diff --git a/build.sh b/build.sh index 3873bd0..f0f94e8 100755 --- a/build.sh +++ b/build.sh @@ -4,9 +4,9 @@ WORLD_ROOT=${PWD} ARCHIE_ROOT="${WORLD_ROOT}/archie" PROSPERO_ROOT="${WORLD_ROOT}/prospero" BERKDB_ROOT="${WORLD_ROOT}/berkdb" -TCL_ROOT="${WORLD_ROOT}/tcl7.3" +TCL_ROOT="${WORLD_ROOT}/tcl7.6" TCLDP_ROOT="${WORLD_ROOT}/tcl-dp/unix" -TK_ROOT="${WORLD_ROOT}/tk3.6" +TK_ROOT="${WORLD_ROOT}/tk4.2" SOLOS=$(uname -s) SOLVER=$(uname -r) SYSTYPE="${SOLOS}-${SOLVER}" @@ -34,18 +34,43 @@ echo " Tk Root : ${TK_ROOT}" echo " System Type : ${SYSTYPE}" echo " Dist Dir : ${DISTDIR}" -cd ${TCL_ROOT} +echo "" +echo "====================================================================" +echo " Building ${TCL_ROOT}/unix" +echo "====================================================================" +echo "" +cd ${TCL_ROOT}/unix ./configure --prefix=${DISTDIR} make install cd ${WORLD_ROOT} -cd ${TK_ROOT} + +echo "" +echo "====================================================================" +echo " Building ${TK_ROOT}/unix" +echo "====================================================================" +echo "" +cd ${TK_ROOT}/unix ./configure --prefix=${DISTDIR} make install cd ${WORLD_ROOT} +echo "" +echo "====================================================================" +echo " Building ${TCLDP_ROOT}" +echo "====================================================================" +echo "" cd ${TCLDP_ROOT} -./configure --prefix=${DISTDIR} +./configure --with-tcl=${TCL_ROOT} --prefix=${DISTDIR} make install cd ${WORLD_ROOT} +echo "" +echo "====================================================================" +echo " Building ${BERKDB_ROOT}/PORT/${SYSTYPE}" +echo "====================================================================" +echo "" +cd ${BERKDB_ROOT}/PORT/${SYSTYPE} +CC=gcc make +cd ${WORLD_ROOT} + diff --git a/tcl7.3/Makefile.in b/tcl7.3/Makefile.in deleted file mode 100755 index afecb78..0000000 --- a/tcl7.3/Makefile.in +++ /dev/null @@ -1,255 +0,0 @@ -# -# This file is a Makefile for Tcl. If it has the name "Makefile.in" -# then it is a template for a Makefile; to generate the actual Makefile, -# run "./configure", which is a configuration script generated by the -# "autoconf" program (constructs like "@foo@" will get replaced in the -# actual Makefile. - -#---------------------------------------------------------------- -# Things you can change to personalize the Makefile for your own -# site (you can make these changes in either Makefile.in or -# Makefile, but changes to Makefile will get lost if you re-run -# the configuration script). -#---------------------------------------------------------------- - -# Default top-level directories in which to install architecture- -# specific files (exec_prefix) and machine-independent files such -# as scripts (prefix). The values specified here may be overridden -# at configure-time with the --exec-prefix and --prefix options -# to the "configure" script. - -exec_prefix = /usr/local -prefix = /usr/local - -# Directory in which to install the library of Tcl scripts (note: -# you can set the TCL_LIBRARY environment variable at run-time to -# override the compiled-in location): -TCL_LIBRARY = $(prefix)/lib/tcl - -# Directory in which to install the archive libtcl.a: -LIB_DIR = $(exec_prefix)/lib - -# Directory in which to install the program tclsh: -BIN_DIR = $(exec_prefix)/bin - -# Directory in which to install the include file tcl.h: -INCLUDE_DIR = $(prefix)/include - -# Top-level directory for manual entries: -MAN_DIR = $(prefix)/man - -# Directory in which to install manual entry for tclsh: -MAN1_DIR = $(MAN_DIR)/man1 - -# Directory in which to install manual entries for Tcl's C library -# procedures: -MAN3_DIR = $(MAN_DIR)/man3 - -# Directory in which to install manual entries for the built-in -# Tcl commands: -MANN_DIR = $(MAN_DIR)/mann - -# To change the compiler switches, for example to change from -O -# to -g, change the following line: -CFLAGS = -O - -# To disable ANSI-C procedure prototypes reverse the comment characters -# on the following lines: -PROTO_FLAGS = -#PROTO_FLAGS = -DNO_PROTOTYPE - -# Mathematical functions like sin and atan2 are enabled for expressions -# by default. To disable them, reverse the comment characters on the -# following pairs of lines: -MATH_FLAGS = -#MATH_FLAGS = -DTCL_NO_MATH -MATH_LIBS = -lm -#MATH_LIBS = - -# To compile for non-UNIX systems (so that only the non-UNIX-specific -# commands are available), reverse the comment characters on the -# following pairs of lines. In addition, you'll have to provide your -# own replacement for the "panic" procedure (see panic.c for what -# the current one does). -GENERIC_FLAGS = -#GENERIC_FLAGS = -DTCL_GENERIC_ONLY -UNIX_OBJS = panic.o tclEnv.o tclGlob.o tclMain.o tclUnixAZ.o \ - tclUnixStr.o tclUnixUtil.o -#UNIX_OBJS = - -# To enable memory debugging reverse the comment characters on the following -# lines. Warning: if you enable memory debugging, you must do it -# *everywhere*, including all the code that calls Tcl, and you must use -# ckalloc and ckfree everywhere instead of malloc and free. -MEM_DEBUG_FLAGS = -#MEM_DEBUG_FLAGS = -DTCL_MEM_DEBUG - -# Some versions of make, like SGI's, use the following variable to -# determine which shell to use for executing commands: -SHELL = /bin/sh - -#---------------------------------------------------------------- -# The information below is modified by the configure script when -# Makefile is generated from Makefile.in. You shouldn't normally -# modify any of this stuff by hand. -#---------------------------------------------------------------- - -COMPAT_OBJS = @LIBOBJS@ -AC_FLAGS = @DEFS@ -INSTALL = @INSTALL@ -INSTALL_PROGRAM = @INSTALL_PROGRAM@ -INSTALL_DATA = @INSTALL_DATA@ -RANLIB = @RANLIB@ -SRC_DIR = @srcdir@ -VPATH = @srcdir@ - -#---------------------------------------------------------------- -# The information below should be usable as is. The configure -# script won't modify it and you shouldn't need to modify it -# either. -#---------------------------------------------------------------- - - -CC = @CC@ -CC_SWITCHES = ${CFLAGS} -I. -I${SRC_DIR} ${AC_FLAGS} ${MATH_FLAGS} \ -${GENERIC_FLAGS} ${PROTO_FLAGS} ${MEM_DEBUG_FLAGS} \ --DTCL_LIBRARY=\"${TCL_LIBRARY}\" - -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 - -OBJS = ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} - -all: libtcl.a tclsh - -libtcl.a: ${OBJS} - rm -f libtcl.a - ar cr libtcl.a ${OBJS} - $(RANLIB) libtcl.a - -tclsh: tclAppInit.o libtcl.a - ${CC} ${CC_SWITCHES} tclAppInit.o libtcl.a ${MATH_LIBS} -o tclsh - -tcltest: tclTest.o libtcl.a - ${CC} ${CC_SWITCHES} tclTest.o libtcl.a ${MATH_LIBS} -o tcltest - -test: tcltest - @cwd=`pwd`; \ - cd $(SRC_DIR); TCL_LIBRARY=`pwd`/library; export TCL_LIBRARY; \ - cd $$cwd; ( echo cd $(SRC_DIR)/tests\; source all ) | ./tcltest - -install: install-binaries install-libraries install-man - -install-binaries: libtcl.a tclsh - @for i in $(LIB_DIR) $(BIN_DIR) ; \ - do \ - if [ ! -d $$i ] ; then \ - echo "Making directory $$i"; \ - mkdir $$i; \ - chmod 755 $$i; \ - else true; \ - fi; \ - done; - @echo "Installing libtcl.a" - @$(INSTALL_DATA) libtcl.a $(LIB_DIR) - @$(RANLIB) $(LIB_DIR)/libtcl.a - @echo "Installing tclsh" - @$(INSTALL_PROGRAM) tclsh $(BIN_DIR) - -install-libraries: - @for i in $(prefix)/lib $(INCLUDE_DIR) $(TCL_LIBRARY) ; \ - do \ - if [ ! -d $$i ] ; then \ - echo "Making directory $$i"; \ - mkdir $$i; \ - chmod 755 $$i; \ - else true; \ - fi; \ - done; - @echo "Installing tcl.h" - @$(INSTALL_DATA) $(SRC_DIR)/tcl.h $(INCLUDE_DIR) - @cd $(SRC_DIR)/library; for i in *.tcl tclIndex; \ - do \ - echo "Installing library/$$i"; \ - $(INSTALL_DATA) $$i $(TCL_LIBRARY); \ - done; - -install-man: - @for i in $(MAN_DIR) $(MAN1_DIR) $(MAN3_DIR) $(MANN_DIR) ; \ - do \ - if [ ! -d $$i ] ; then \ - echo "Making directory $$i"; \ - mkdir $$i; \ - chmod 755 $$i; \ - else true; \ - fi; \ - done; - @cd $(SRC_DIR)/doc; for i in *.1; \ - do \ - echo "Installing doc/$$i"; \ - rm -f $(MAN1_DIR)/$$i; \ - sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \ - $$i > $(MAN1_DIR)/$$i; \ - chmod 444 $(MAN1_DIR)/$$i; \ - done; - @cd $(SRC_DIR)/doc; for i in *.3; \ - do \ - echo "Installing doc/$$i"; \ - rm -f $(MAN3_DIR)/$$i; \ - sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \ - $$i > $(MAN3_DIR)/$$i; \ - chmod 444 $(MAN3_DIR)/$$i; \ - done; - @cd $(SRC_DIR)/doc; for i in *.n; \ - do \ - echo "Installing doc/$$i"; \ - rm -f $(MANN_DIR)/$$i; \ - sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \ - $$i > $(MANN_DIR)/$$i; \ - chmod 444 $(MANN_DIR)/$$i; \ - done; - -Makefile: $(SRC_DIR)/Makefile.in - $(SHELL) config.status - -clean: - rm -f *.a *.o core errs *~ \#* TAGS *.E a.out errors tclsh tcltest - -distclean: clean - rm -f Makefile config.status - -getcwd.o: $(SRC_DIR)/compat/getcwd.c - $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/compat/getcwd.c - -opendir.o: $(SRC_DIR)/compat/opendir.c - $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/compat/opendir.c - -strerror.o: $(SRC_DIR)/compat/strerror.c - $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/compat/strerror.c - -strstr.o: $(SRC_DIR)/compat/strstr.c - $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/compat/strstr.c - -strtod.o: $(SRC_DIR)/compat/strtod.c - $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/compat/strtod.c - -strtol.o: $(SRC_DIR)/compat/strtol.c - $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/compat/strtol.c - -strtoul.o: $(SRC_DIR)/compat/strtoul.c - $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/compat/strtoul.c - -tmpnam.o: $(SRC_DIR)/compat/tmpnam.c - $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/compat/tmpnam.c - -waitpid.o: $(SRC_DIR)/compat/waitpid.c - $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/compat/waitpid.c - -.c.o: - $(CC) -c $(CC_SWITCHES) $< - -${OBJS}: $(SRC_DIR)/tcl.h $(SRC_DIR)/tclInt.h -${UNIX_OBJS}: $(SRC_DIR)/tclUnix.h -tclCmdIL.o: $(SRC_DIR)/patchlevel.h diff --git a/tcl7.3/README b/tcl7.3/README deleted file mode 100644 index 9cb306f..0000000 --- a/tcl7.3/README +++ /dev/null @@ -1,346 +0,0 @@ -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/tcl7.3/changes b/tcl7.3/changes deleted file mode 100644 index d920add..0000000 --- a/tcl7.3/changes +++ /dev/null @@ -1,958 +0,0 @@ -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 !!, !, and -^^ 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 - - \ 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, 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 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/tcl7.3/compat/dirent.h b/tcl7.3/compat/dirent.h deleted file mode 100644 index d6adf95..0000000 --- a/tcl7.3/compat/dirent.h +++ /dev/null @@ -1,37 +0,0 @@ -/* - * dirent.h -- - * - * This file is a replacement for in systems that - * support the old BSD-style 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 - -#define dirent direct - -#endif /* _DIRENT */ diff --git a/tcl7.3/compat/float.h b/tcl7.3/compat/float.h deleted file mode 100644 index e5b0cb0..0000000 --- a/tcl7.3/compat/float.h +++ /dev/null @@ -1,30 +0,0 @@ -/* - * 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/tcl7.3/compat/getcwd.c b/tcl7.3/compat/getcwd.c deleted file mode 100644 index f693a53..0000000 --- a/tcl7.3/compat/getcwd.c +++ /dev/null @@ -1,63 +0,0 @@ -/* - * 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/tcl7.3/compat/limits.h b/tcl7.3/compat/limits.h deleted file mode 100644 index dec6d99..0000000 --- a/tcl7.3/compat/limits.h +++ /dev/null @@ -1,34 +0,0 @@ -/* - * 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/tcl7.3/compat/strerror.c b/tcl7.3/compat/strerror.c deleted file mode 100644 index 773b9d5..0000000 --- a/tcl7.3/compat/strerror.c +++ /dev/null @@ -1,484 +0,0 @@ -/* - * 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/tcl7.3/configure b/tcl7.3/configure deleted file mode 100755 index 61f0a4d..0000000 --- a/tcl7.3/configure +++ /dev/null @@ -1,1015 +0,0 @@ -#!/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 < -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 < -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 < -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 < -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 < -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 < -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 -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 < -#include -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 ' > 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 -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 -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 -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 -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 ' > 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 ' > 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 ' > 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 -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 ' > 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 ' > 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 -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 -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 </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 < -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 </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 < -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 </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 ' > 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 ' > 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 ' > 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 ' > 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 < -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 < 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 < -#include -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 < -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 < config.status </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/tcl7.3/configure.in b/tcl7.3/configure.in deleted file mode 100755 index f1fa256..0000000 --- a/tcl7.3/configure.in +++ /dev/null @@ -1,182 +0,0 @@ -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 -#include ], [ -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 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 -#include ], [ -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 ], [ -struct exception x; -x.type = DOMAIN; -x.type = SING; -], [LIBOBJS="$LIBOBJS tclMtherr.o"; AC_DEFINE(NEED_MATHERR)]) - -AC_OUTPUT(Makefile) diff --git a/tcl7.3/configure.info b/tcl7.3/configure.info deleted file mode 100755 index 1b15d61..0000000 --- a/tcl7.3/configure.info +++ /dev/null @@ -1,81 +0,0 @@ -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/tcl7.3/doc/AppInit.3 b/tcl7.3/doc/AppInit.3 deleted file mode 100644 index e957926..0000000 --- a/tcl7.3/doc/AppInit.3 +++ /dev/null @@ -1,68 +0,0 @@ -'\" -'\" 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 \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/tcl7.3/doc/Backslash.3 b/tcl7.3/doc/Backslash.3 deleted file mode 100644 index e8b0325..0000000 --- a/tcl7.3/doc/Backslash.3 +++ /dev/null @@ -1,58 +0,0 @@ -'\" -'\" 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 \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/tcl7.3/doc/CmdCmplt.3 b/tcl7.3/doc/CmdCmplt.3 deleted file mode 100644 index 968d6df..0000000 --- a/tcl7.3/doc/CmdCmplt.3 +++ /dev/null @@ -1,49 +0,0 @@ -'\" -'\" 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 \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/tcl7.3/doc/CrtInterp.3 b/tcl7.3/doc/CrtInterp.3 deleted file mode 100644 index c987801..0000000 --- a/tcl7.3/doc/CrtInterp.3 +++ /dev/null @@ -1,61 +0,0 @@ -'\" -'\" 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 \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/tcl7.3/doc/CrtPipelin.3 b/tcl7.3/doc/CrtPipelin.3 deleted file mode 100644 index f5064b6..0000000 --- a/tcl7.3/doc/CrtPipelin.3 +++ /dev/null @@ -1,114 +0,0 @@ -'\" -'\" 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 \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/tcl7.3/doc/EnterFile.3 b/tcl7.3/doc/EnterFile.3 deleted file mode 100644 index 12f1529..0000000 --- a/tcl7.3/doc/EnterFile.3 +++ /dev/null @@ -1,98 +0,0 @@ -'\" -'\" 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 \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/tcl7.3/doc/RecordEval.3 b/tcl7.3/doc/RecordEval.3 deleted file mode 100644 index 02e11d8..0000000 --- a/tcl7.3/doc/RecordEval.3 +++ /dev/null @@ -1,60 +0,0 @@ -'\" -'\" 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 \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/tcl7.3/doc/RegExp.3 b/tcl7.3/doc/RegExp.3 deleted file mode 100644 index 13546ee..0000000 --- a/tcl7.3/doc/RegExp.3 +++ /dev/null @@ -1,57 +0,0 @@ -'\" -'\" 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 \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/tcl7.3/doc/StrMatch.3 b/tcl7.3/doc/StrMatch.3 deleted file mode 100644 index d99c648..0000000 --- a/tcl7.3/doc/StrMatch.3 +++ /dev/null @@ -1,52 +0,0 @@ -'\" -'\" 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 \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/tcl7.3/doc/TildeSubst.3 b/tcl7.3/doc/TildeSubst.3 deleted file mode 100644 index 1d1bded..0000000 --- a/tcl7.3/doc/TildeSubst.3 +++ /dev/null @@ -1,85 +0,0 @@ -'\" -'\" 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 \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/tcl7.3/doc/append.n b/tcl7.3/doc/append.n deleted file mode 100644 index 7015d5a..0000000 --- a/tcl7.3/doc/append.n +++ /dev/null @@ -1,45 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/break.n b/tcl7.3/doc/break.n deleted file mode 100644 index ba2f108..0000000 --- a/tcl7.3/doc/break.n +++ /dev/null @@ -1,41 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/catch.n b/tcl7.3/doc/catch.n deleted file mode 100644 index 735aba0..0000000 --- a/tcl7.3/doc/catch.n +++ /dev/null @@ -1,50 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/cd.n b/tcl7.3/doc/cd.n deleted file mode 100644 index cfc4401..0000000 --- a/tcl7.3/doc/cd.n +++ /dev/null @@ -1,43 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/close.n b/tcl7.3/doc/close.n deleted file mode 100644 index dbd0dc0..0000000 --- a/tcl7.3/doc/close.n +++ /dev/null @@ -1,46 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/concat.n b/tcl7.3/doc/concat.n deleted file mode 100644 index 8b50e32..0000000 --- a/tcl7.3/doc/concat.n +++ /dev/null @@ -1,57 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/continue.n b/tcl7.3/doc/continue.n deleted file mode 100644 index 90adf49..0000000 --- a/tcl7.3/doc/continue.n +++ /dev/null @@ -1,43 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/eof.n b/tcl7.3/doc/eof.n deleted file mode 100644 index ef6e766..0000000 --- a/tcl7.3/doc/eof.n +++ /dev/null @@ -1,43 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/eval.n b/tcl7.3/doc/eval.n deleted file mode 100644 index 7c38ab4..0000000 --- a/tcl7.3/doc/eval.n +++ /dev/null @@ -1,43 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/exec.n b/tcl7.3/doc/exec.n deleted file mode 100644 index fa90061..0000000 --- a/tcl7.3/doc/exec.n +++ /dev/null @@ -1,198 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/exit.n b/tcl7.3/doc/exit.n deleted file mode 100644 index d25a524..0000000 --- a/tcl7.3/doc/exit.n +++ /dev/null @@ -1,41 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/file.n b/tcl7.3/doc/file.n deleted file mode 100644 index 2423dae..0000000 --- a/tcl7.3/doc/file.n +++ /dev/null @@ -1,146 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/flush.n b/tcl7.3/doc/flush.n deleted file mode 100644 index bc66834..0000000 --- a/tcl7.3/doc/flush.n +++ /dev/null @@ -1,43 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/foreach.n b/tcl7.3/doc/foreach.n deleted file mode 100644 index 63fe006..0000000 --- a/tcl7.3/doc/foreach.n +++ /dev/null @@ -1,47 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/gets.n b/tcl7.3/doc/gets.n deleted file mode 100644 index da0bd3a..0000000 --- a/tcl7.3/doc/gets.n +++ /dev/null @@ -1,61 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/global.n b/tcl7.3/doc/global.n deleted file mode 100644 index 4f7d7bd..0000000 --- a/tcl7.3/doc/global.n +++ /dev/null @@ -1,43 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/incr.n b/tcl7.3/doc/incr.n deleted file mode 100644 index a534010..0000000 --- a/tcl7.3/doc/incr.n +++ /dev/null @@ -1,44 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/join.n b/tcl7.3/doc/join.n deleted file mode 100644 index d98b0c7..0000000 --- a/tcl7.3/doc/join.n +++ /dev/null @@ -1,42 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/lappend.n b/tcl7.3/doc/lappend.n deleted file mode 100644 index 02c6bcc..0000000 --- a/tcl7.3/doc/lappend.n +++ /dev/null @@ -1,48 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/lindex.n b/tcl7.3/doc/lindex.n deleted file mode 100644 index 60bd0a8..0000000 --- a/tcl7.3/doc/lindex.n +++ /dev/null @@ -1,46 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/linsert.n b/tcl7.3/doc/linsert.n deleted file mode 100644 index 1cb7e5e..0000000 --- a/tcl7.3/doc/linsert.n +++ /dev/null @@ -1,45 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/list.n b/tcl7.3/doc/list.n deleted file mode 100644 index 4099206..0000000 --- a/tcl7.3/doc/list.n +++ /dev/null @@ -1,62 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/llength.n b/tcl7.3/doc/llength.n deleted file mode 100644 index aecba66..0000000 --- a/tcl7.3/doc/llength.n +++ /dev/null @@ -1,39 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/lrange.n b/tcl7.3/doc/lrange.n deleted file mode 100644 index b963906..0000000 --- a/tcl7.3/doc/lrange.n +++ /dev/null @@ -1,51 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/lreplace.n b/tcl7.3/doc/lreplace.n deleted file mode 100644 index c7d96f5..0000000 --- a/tcl7.3/doc/lreplace.n +++ /dev/null @@ -1,55 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/man.macros b/tcl7.3/doc/man.macros deleted file mode 100644 index f45afa8..0000000 --- a/tcl7.3/doc/man.macros +++ /dev/null @@ -1,182 +0,0 @@ -.\" 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/tcl7.3/doc/open.n b/tcl7.3/doc/open.n deleted file mode 100644 index 8bd39ae..0000000 --- a/tcl7.3/doc/open.n +++ /dev/null @@ -1,138 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/pid.n b/tcl7.3/doc/pid.n deleted file mode 100644 index ff671c5..0000000 --- a/tcl7.3/doc/pid.n +++ /dev/null @@ -1,47 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/puts.n b/tcl7.3/doc/puts.n deleted file mode 100644 index 294d417..0000000 --- a/tcl7.3/doc/puts.n +++ /dev/null @@ -1,50 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/pwd.n b/tcl7.3/doc/pwd.n deleted file mode 100644 index b4eb557..0000000 --- a/tcl7.3/doc/pwd.n +++ /dev/null @@ -1,38 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/read.n b/tcl7.3/doc/read.n deleted file mode 100644 index 3507e0e..0000000 --- a/tcl7.3/doc/read.n +++ /dev/null @@ -1,54 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/rename.n b/tcl7.3/doc/rename.n deleted file mode 100644 index 490f52b..0000000 --- a/tcl7.3/doc/rename.n +++ /dev/null @@ -1,41 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/seek.n b/tcl7.3/doc/seek.n deleted file mode 100644 index 832d8a6..0000000 --- a/tcl7.3/doc/seek.n +++ /dev/null @@ -1,64 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/source.n b/tcl7.3/doc/source.n deleted file mode 100644 index 124d804..0000000 --- a/tcl7.3/doc/source.n +++ /dev/null @@ -1,47 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/split.n b/tcl7.3/doc/split.n deleted file mode 100644 index cd1f1dc..0000000 --- a/tcl7.3/doc/split.n +++ /dev/null @@ -1,57 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/tell.n b/tcl7.3/doc/tell.n deleted file mode 100644 index 24c3ff0..0000000 --- a/tcl7.3/doc/tell.n +++ /dev/null @@ -1,43 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/time.n b/tcl7.3/doc/time.n deleted file mode 100644 index dca3c3f..0000000 --- a/tcl7.3/doc/time.n +++ /dev/null @@ -1,46 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/unknown.n b/tcl7.3/doc/unknown.n deleted file mode 100644 index 7c25757..0000000 --- a/tcl7.3/doc/unknown.n +++ /dev/null @@ -1,55 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/unset.n b/tcl7.3/doc/unset.n deleted file mode 100644 index ed27582..0000000 --- a/tcl7.3/doc/unset.n +++ /dev/null @@ -1,47 +0,0 @@ -'\" -'\" 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/tcl7.3/doc/while.n b/tcl7.3/doc/while.n deleted file mode 100644 index f168762..0000000 --- a/tcl7.3/doc/while.n +++ /dev/null @@ -1,50 +0,0 @@ -'\" -'\" 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/tcl7.3/library/init.tcl b/tcl7.3/library/init.tcl deleted file mode 100644 index 6edb37b..0000000 --- a/tcl7.3/library/init.tcl +++ /dev/null @@ -1,259 +0,0 @@ -# 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 !!, !, 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/tcl7.3/library/parray.tcl b/tcl7.3/library/parray.tcl deleted file mode 100644 index b4c9f2d..0000000 --- a/tcl7.3/library/parray.tcl +++ /dev/null @@ -1,43 +0,0 @@ -# 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/tcl7.3/library/tclIndex b/tcl7.3/library/tclIndex deleted file mode 100644 index ad036dc..0000000 --- a/tcl7.3/library/tclIndex +++ /dev/null @@ -1,14 +0,0 @@ -# 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/tcl7.3/panic.c b/tcl7.3/panic.c deleted file mode 100644 index fa99481..0000000 --- a/tcl7.3/panic.c +++ /dev/null @@ -1,69 +0,0 @@ -/* - * 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 -#ifdef NO_STDLIB_H -# include "compat/stdlib.h" -#else -# include -#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/tcl7.3/patchlevel.h b/tcl7.3/patchlevel.h deleted file mode 100644 index 24e4a0a..0000000 --- a/tcl7.3/patchlevel.h +++ /dev/null @@ -1,11 +0,0 @@ -/* - * 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/tcl7.3/tcl.h b/tcl7.3/tcl.h deleted file mode 100644 index 4fdca51..0000000 --- a/tcl7.3/tcl.h +++ /dev/null @@ -1,631 +0,0 @@ -/* - * 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 -#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)); -EXTERN void Tcl_AppendResult _ANSI_ARGS_(VARARGS); -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)); -EXTERN void Tcl_SetErrorCode _ANSI_ARGS_(VARARGS); -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)); -EXTERN int Tcl_VarEval _ANSI_ARGS_(VARARGS); -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/tcl7.3/tclAppInit.c b/tcl7.3/tclAppInit.c deleted file mode 100644 index df7f93c..0000000 --- a/tcl7.3/tclAppInit.c +++ /dev/null @@ -1,95 +0,0 @@ -/* - * 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/tcl7.3/tclCmdAH.c b/tcl7.3/tclCmdAH.c deleted file mode 100644 index 5238804..0000000 --- a/tcl7.3/tclCmdAH.c +++ /dev/null @@ -1,952 +0,0 @@ -/* - * 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/tcl7.3/tclGlob.c b/tcl7.3/tclGlob.c deleted file mode 100644 index a7f29d3..0000000 --- a/tcl7.3/tclGlob.c +++ /dev/null @@ -1,455 +0,0 @@ -/* - * 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 "~/" (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/tcl7.3/tclTest.c b/tcl7.3/tclTest.c deleted file mode 100644 index c3b19f3..0000000 --- a/tcl7.3/tclTest.c +++ /dev/null @@ -1,786 +0,0 @@ -/* - * 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/tcl7.3/tclUnix.h b/tcl7.3/tclUnix.h deleted file mode 100644 index 343b025..0000000 --- a/tcl7.3/tclUnix.h +++ /dev/null @@ -1,285 +0,0 @@ -/* - * 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 -#include -#include -#include -#include -#include -#ifdef USE_DIRENT2_H -# include "compat/dirent2.h" -#else -# ifdef NO_DIRENT_H -# include "compat/dirent.h" -# else -# include -# endif -#endif -#include -#include -#ifndef NO_SYS_TIME_H -# include -#else -# include -#endif -#ifndef NO_SYS_WAIT_H -# include -#endif -#ifdef HAVE_UNISTD_H -# include -#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 -# include -# 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/tcl7.3/tclUnixAZ.c b/tcl7.3/tclUnixAZ.c deleted file mode 100644 index 765b7f0..0000000 --- a/tcl7.3/tclUnixAZ.c +++ /dev/null @@ -1,1998 +0,0 @@ -/* - * 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/tcl7.3/tclUnixUtil.c b/tcl7.3/tclUnixUtil.c deleted file mode 100644 index b7b8e9e..0000000 --- a/tcl7.3/tclUnixUtil.c +++ /dev/null @@ -1,1385 +0,0 @@ -/* - * 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. - */ - - tmpnam(inName); - 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]; - - tmpnam(errName); - *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/tcl7.3/tests/cd.test b/tcl7.3/tests/cd.test deleted file mode 100644 index d1eb335..0000000 --- a/tcl7.3/tests/cd.test +++ /dev/null @@ -1,121 +0,0 @@ -# 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/tcl7.3/tests/concat.test b/tcl7.3/tests/concat.test deleted file mode 100644 index a758765..0000000 --- a/tcl7.3/tests/concat.test +++ /dev/null @@ -1,53 +0,0 @@ -# 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/tcl7.3/tests/dcall.test b/tcl7.3/tests/dcall.test deleted file mode 100644 index a54d719..0000000 --- a/tcl7.3/tests/dcall.test +++ /dev/null @@ -1,54 +0,0 @@ -# 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/tcl7.3/tests/defs b/tcl7.3/tests/defs deleted file mode 100644 index 63f2440..0000000 --- a/tcl7.3/tests/defs +++ /dev/null @@ -1,94 +0,0 @@ -# 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/tcl7.3/tests/file.test b/tcl7.3/tests/file.test deleted file mode 100644 index 8360334..0000000 --- a/tcl7.3/tests/file.test +++ /dev/null @@ -1,326 +0,0 @@ -# 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/tcl7.3/tests/glob.test b/tcl7.3/tests/glob.test deleted file mode 100644 index ba134ed..0000000 --- a/tcl7.3/tests/glob.test +++ /dev/null @@ -1,153 +0,0 @@ -# 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/tcl7.3/tests/join.test b/tcl7.3/tests/join.test deleted file mode 100644 index 0d01d4d..0000000 --- a/tcl7.3/tests/join.test +++ /dev/null @@ -1,52 +0,0 @@ -# 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/tcl7.3/tests/llength.test b/tcl7.3/tests/llength.test deleted file mode 100644 index 371e165..0000000 --- a/tcl7.3/tests/llength.test +++ /dev/null @@ -1,49 +0,0 @@ -# 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/tcl7.3/tests/open.test b/tcl7.3/tests/open.test deleted file mode 100644 index 950873d..0000000 --- a/tcl7.3/tests/open.test +++ /dev/null @@ -1,662 +0,0 @@ -# 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/tcl7.3/tests/pid.test b/tcl7.3/tests/pid.test deleted file mode 100644 index b602387..0000000 --- a/tcl7.3/tests/pid.test +++ /dev/null @@ -1,58 +0,0 @@ -# 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/tcl7.3/tests/rename.test b/tcl7.3/tests/rename.test deleted file mode 100644 index c5c8d92..0000000 --- a/tcl7.3/tests/rename.test +++ /dev/null @@ -1,78 +0,0 @@ -# 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/tcl7.3/tests/source.test b/tcl7.3/tests/source.test deleted file mode 100644 index 4ad049a..0000000 --- a/tcl7.3/tests/source.test +++ /dev/null @@ -1,95 +0,0 @@ -# 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/tcl7.6/README b/tcl7.6/README new file mode 100644 index 0000000..1437005 --- /dev/null +++ b/tcl7.6/README @@ -0,0 +1,248 @@ +Tcl + +SCCS: @(#) README 1.38 96/10/07 11:33:23 + +1. Introduction +--------------- + +This directory and its descendants contain the sources and documentation +for Tcl, an embeddable scripting language. The information here +corresponds to release 7.6. This is a relatively minor release with bug +fixes and a few new features, mostly to improve portability. Tcl 7.6 +should be backwards compatible with Tcl 7.5 scripts, but there are two +incompatible changes, one in the C APIs for custom channel drivers and +the other affecting start-up file names under Windows. See below for +more details. + +2. Documentation +---------------- + +The best way to get started with Tcl is to read one of the introductory +books on Tcl: + + Tcl and the Tk Toolkit, by John Ousterhout, + Addison-Wesley, 1994, ISBN 0-201-63337-X + + Practical Programming in Tcl and Tk, by Brent Welch, + Prentice-Hall, 1995, ISBN 0-13-182007-9 + + Exploring Expect, by Don Libes, + O'Reilly and Associates, 1995, ISBN 1-56592-090-2 + +The "doc" subdirectory in this release contains a complete set of reference +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 + +There is also an official home for Tcl and Tk on the Web: + http://www.sunlabs.com/research/tcl +These Web pages include release updates, reports on bug fixes and porting +issues, HTML versions of the manual pages, and pointers to many other +Tcl/Tk Web pages at other sites. Check them out! + +3. Compiling and installing Tcl +------------------------------- + +This release contains everything you should need to compile and run +Tcl under UNIX, Macintoshes, and PCs (either Windows NT, Windows 95, +or Win 3.1 with Win32s). + +Before trying to compile Tcl you should do the following things: + + (a) Check for a binary release. Pre-compiled binary releases are + available now for PCs, Macintoshes, and several flavors of UNIX. + Binary releases are much easier to install than source releases. + To find out whether a binary release is available for your platform, + check the home page for the Sun Tcl/Tk project + (http://www.sunlabs.com/research/tcl) and also check in the FTP + directory from which you retrieved the base distribution. Some + of the binary releases are available freely, while others are for + sale. + + (b) Make sure you have the most recent patch release. Look in the + FTP directory from which you retrieved this distribution to see + if it has been updated with patches. Patch releases fix bugs + without changing any features, so you should normally use the + latest patch release for the version of Tcl that you want. + Patch releases are available in two forms. A file like + tcl7.6p1.tar.Z is a complete release for patch level 1 of Tcl + version 7.6. If there is a file with a higher patch level than + this release, just fetch the file with the highest patch level + and use it. + + Patches are also available in the form of patch files that just + contain the changes from one patch level to another. These + files will have names like tcl7.6p1.patch, tcl7.6p2.patch, etc. They + may also have .gz or .Z extensions to indicate compression. To + use one of these files, you apply it to an existing release with + the "patch" program. Patches must be applied in order: + tcl7.6p1.patch must be applied to an unpatched Tcl 7.6 release + to produce a Tcl 7.6p1 release; tcl7.6p2.patch can then be + applied to Tcl7.6p1 to produce Tcl 7.6p2, and so on. To apply an + uncompressed patch file such as tcl7.6p1.patch, invoke a shell + command like the following from the directory containing this + file: + patch -p < tcl7.6p1.patch + If the patch file has a .gz extension, invoke a command like the + following: + gunzip -c tcl7.6p1.patch.gz | patch -p + If the patch file has a .Z extension, it was compressed with + compress. To apply it, invoke a command like the following: + zcat tcl7.6p1.patch.Z | patch -p + If you're applying a patch to a release that has already been + compiled, then before applying the patch you should cd to the + "unix" subdirectory and type "make distclean" to restore the + directory to a pristine state. + +Once you've done this, change to the "unix" subdirectory if you're +compiling under UNIX, "win" if you're compiling under Windows, or +"mac" if you're compiling on a Macintosh. Then follow the instructions +in the README file in that directory for compiling Tcl, installing it, +and running the test suite. + +4. Summary of changes in Tcl 7.6 +-------------------------------- + +Here are the most significant changes in Tcl 7.6. In addition to these +changes, there are numerous small bug fixes. See the file "changes" for +a complete list of all changes. + + 1. New file manipulation commands. There are new options to the + "file" command for copying files ("file copy"), deleting files and + directories ("file delete"), creating directories ("file mkdir"), + and renaming files ("file rename"). + + 2. The implementation of "exec" has been improved greatly for Windows + 95 and Windows NT. + + 3. The package loader has been modified to look for packages not only + in the auto_path directories but also in their immediate descendants. + This makes it much easier to install and uninstall packages. There + is now a new variable, tcl_pkgPath, which contains directories in + which packages are normally installed, and these directories are + automatically included in auto_path. + + 4. There is a new memory allocator for the Macintosh version, which + should be more efficient than the old one. + +Tcl 7.6 contains two incompatible changes: + 1. The C interfaces to channel drivers have been revised to eliminate + the use of Tcl_File handles in the interfaces. Instead, there are + new interface procedures channelReadyProc, watchChannelProc, and + getFileProc. This change does not affect Tcl scripts; it will only + affect you if you have written a custom channel driver. + + 2. Under Windows, tclsh now looks for the start-up file "tclshrc.tcl" + instead of "tclsh.rc". This is more consistent with wish and uses + the right extension. + +5. 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. +We read the newsgroup and will attempt to fix bugs and problems reported +to it. + +When using comp.lang.tcl, please be sure that your e-mail return address +is correctly set in your postings. This allows people to respond directly +to you, rather than the entire newsgroup, for answers that are not of +general interest. A bad e-mail return address may prevent you from +getting answers to your questions. You may have to reconfigure your news +reading software to ensure that it is supplying valid e-mail addresses. + +6. Tcl contributed archive +-------------------------- + +Many people have created exciting packages and applications based on Tcl +and/or Tk and made them freely available to the Tcl community. An archive +of these contributions is kept on the machine ftp.neosoft.com. You +can access the archive using anonymous FTP; the Tcl contributed archive is +in the directory "/pub/tcl". The archive also contains several FAQ +("frequently asked questions") documents that provide solutions to problems +that are commonly encountered by TCL newcomers. + +7. Support and bug fixes +------------------------ + +We're very interested in receiving bug reports and suggestions for +improvements. We prefer that you send this information to the +comp.lang.tcl newsgroup rather than to any of us at Sun. We'll see +anything on comp.lang.tcl, and in addition someone else who reads +comp.lang.tcl may be able to offer a solution. The normal turn-around +time for bugs is 3-6 weeks. Enhancements may take longer and may not +happen at all unless there is widespread support for them (we're +trying to slow the rate at which Tcl turns into a kitchen sink). It's +very difficult to make incompatible changes to Tcl at this point, due +to the size of the installed base. + +When reporting bugs, please provide a short tclsh script that we can +use to reproduce the bug. Make sure that the script runs with a +bare-bones tclsh and doesn't depend on any extensions or other +programs, particularly those that exist only at your site. Also, +please include three additional pieces of information with the +script: + (a) how do we use the script to make the problem happen (e.g. + what things do we click on, in what order)? + (b) what happens when you do these things (presumably this is + undesirable)? + (c) what did you expect to happen instead? + +The Tcl community is too large for us to provide much individual +support for users. If you need help we suggest that you post questions +to comp.lang.tcl. We 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 (info@neosoft.com), Computerized Processes Unlimited +(gwl@cpu.com), and Data Kinetics (education@dkl.com). + +8. Tcl version numbers +---------------------- + +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. + +Alpha and beta releases have an additional suffix of the form a2 or b1. +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. An alpha release is like a beta release, +except it's likely to need even more work before it's "ready for prime +time". New releases are normally preceded by one or more alpha and beta +releases. We hope that lots of people will try out the alpha and beta +releases and report problems. We'll make new alpha/beta releases to fix +the problems, until eventually there is a beta release that appears to +be stable. Once this occurs we'll make the final release. + +We can't promise to maintain compatibility among alpha and beta releases. +For example, release 7.1b2 may not be backward compatible with 7.1b1, even +though the final 7.1 release will be backward compatible with 7.0. This +allows us to change new features as we find problems during beta testing. +We'll try to minimize incompatibilities between beta releases, but if +a major problem turns up then we'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. + +Patch releases have a suffix such as p1 or p2. These releases contain +bug fixes only. A patch release (e.g Tcl 7.6p2) should be completely +compatible with the base release from which it is derived (e.g. Tcl +7.6), and you should normally use the highest available patch release. diff --git a/tcl7.6/changes b/tcl7.6/changes new file mode 100644 index 0000000..65396a6 --- /dev/null +++ b/tcl7.6/changes @@ -0,0 +1,2400 @@ +Recent user-visible changes to Tcl: + +SCCS: @(#) changes 1.171 96/10/14 12:59:16 + +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 !!, !, and +^^ 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 + - \ 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, 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 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 ------------------ + +239. 11/6/93 Modified "lindex", "linsert", "lrange", and "lreplace" +so that "end" can be specified as an index. + +240. 11/6/93 Modified "append" and "lappend" to allow only two +words total (i.e., nothing to append) without generating an error. + +241. 12/2/93 Changed to use EAGAIN as the errno for non-blocking +I/O instead of EWOULDBLOCK: this should fix problem where non-blocking +I/O didn't work correctly on System-V systems. + +242. 12/22/93 Fixed bug in expressions where cancelled evaluation +wasn't always working correctly (e.g. "set one 1; eval {1 || 1/$one}" +failed with a divide by zero error). + +243. 1/6/94 Changed TCL_VOLATILE definition from -1 to the address of +a dummy procedure Tcl_Volatile, since -1 causes portability problems on +some machines (e.g., Crays). + +244. 2/4/94 Added support for unary plus. + +245. 2/17/94 Changed Tcl_RecordAndEval and "history" command to +call Tcl_GlobalEval instead of Tcl_Eval. Otherwise, invocation of +these facilities in nested procedures can cause unwanted results. + +246. 2/17/94 Fixed bug in tclExpr.c where an expression such as +"expr {"12398712938788234-1298379" != ""}" triggers an integer +overflow error for the number in quotes, even though it isn't really +a proper integer anyway. + +247. 2/19/94 Added new procedure Tcl_DStringGetResult to move result +from interpreter to a dynamic string. + +248. 2/19/94 Fixed bug in Tcl_DStringResult that caused it to overwrite +the contents of a static result in some situations. This can cause +bizarre errors such as variables suddenly having empty values. + +249. 2/21/94 Fixed bug in Tcl_AppendElement, Tcl_DStringAppendElement, +and the "lappend" command that caused improper omission of a separator +space in some cases. For example, the script + set x "abc{"; lappend x "def" +used to return the result "abc{def" instead of "abc{ def". + +250. 3/3/94 Tcl_ConvertElement was outputting empty elements as \0 if +TCL_DONT_USE_BRACES was set. This depends on old pre-7.0 meaning of +\0, which is no longer in effect, so it didn't really work. Changed +to output empty elements as {} always. + +251. 3/3/94 Renamed Tcl_DStringTrunc to Tcl_DStringSetLength and extended +it so that it can be used to lengthen a string as well as shorten it. +Tcl_DStringTrunc is defined as a macro for backward compatibility, but +it is deprecated. + +252. 3/3/94 Added Tcl_AllowExceptions procedure. + +253. 3/13/94 Fixed bug in Tcl_FormatCmd that could cause "format" +to mis-behave on 64-bit Big-Endian machines. + +254. 3/13/94 Changed to use vfork instead of fork on systems where +vfork exists. + +255. 3/23/94 Fixed bug in expressions where ?: didn't associate +right-to-left as they should. + +256. 4/3/94 Fixed "exec" to flush any files used in >@ or >&@ +redirection in exec, so that data buffered for them is written +before any new data added by the subprocess. + +257. 4/3/94 Added "subst" command. + +258. 5/20/94 The tclsh main program is now called Tcl_Main; tclAppInit.c +has a "main" procedure that calls Tcl_Main. This makes it easier to use +Tcl with C++ programs, which need their own main programs, and it also +allows an application to prefilter the argument list before calling +Tcl_Main. +*** POTENTIAL INCOMPATIBILITY *** + +259. 6/6/94 Fixed bug in procedure returns where the errorInfo variable +could get truncated if an unset trace was invoked as part of returning +from the procedure. + +260. 6/13/94 Added "wordstart" and "wordend" options to "string" command. + +261. 6/27/94 Fixed bug in expressions where they didn't properly cancel +the evaluation of math functions in &&, ||, and ?:. + +262. 7/11/94 Incorrect boolean values, like "ogle", weren't being +handled properly. + +263. 7/15/94 Added Tcl_RegExpCompile, Tcl_RegExpExec, and Tcl_RegExpRange, +which provide lower-level access to regular expression pattern matching. + +264. 7/22/94 Fixed bug in "glob" command where "glob -nocomplain ~bad_user" +would complain about a missing user. Now it doesn't complain anymore. + +265. 8/4/94 Fixed bug with linked variables where they didn't behave +correctly when accessed via upvars. + +266. 8/17/94 Fixed bug in Tcl_EvalFile where it didn't clear interp->result. + +267. 8/31/94 Modified "open" command so that errors in exec-ing +subprocesses are returned by the open immediately, rather than +being delayed until the "close" is executed. + +268. 9/9/94 Modified "expr" command to generate errors for integer +overflow (includes addition, subtraction, negation, multiplication, +division). + +269. 9/23/94 Modified "regsub" to return a count of the number of +matches and replacements, rather than 0/1. + +279. 10/4/94 Added new features to "array" command: + - added "get" and "set" commands for easy conversion between arrays + and lists. + - added "exists" command to see if a variable is an array, changed + "names" and "size" commands to treat a non-existent array (or scalar + variable) just like an empty one. + - added pattern option to "names" command. + +280. 10/6/94 Modified Tcl_SetVar2 so that read traces on variables get +called during append operations. + +281. 10/20/94 Fixed bug in "read" command where reading from stdin +required two control-D's to stop the reading. + +282. 11/3/94 Changed "expr" command to use longs for division just like +all other expr operators; it previously used ints for division. + +283. 11/4/94 Fixed bugs in "unknown" procedure: it wasn't properly +handling exception returns from commands that were executed after +being auto-loaded. + +----------------- Released version 7.4b1, 12/23/94 ------------------ + +284. 12/26/94 Fixed "install" target in Makefile (couldn't always +find install program). + +285. 12/26/94 Added strcncasecmp procedure to compat directory. + +286. 1/3/95 Fixed all procedure calls to explicitly cast arguments: +implicit conversions from prototypes (especially integer->double) +don't work when compiling under non-ANSI compilers. Tcl is now clean +under gcc -Wconversion. + +287. 1/4/95 Fixed problem in Tcl_ArrayCmd where same name was used for +both a label and a variable; caused problems on several older compilers, +making array command misbehave and causing many errors in Tcl test suite. + +----------------- Released version 7.4b2, 1/12/95 ------------------ + +288. 2/9/95 Modified Tcl_CreateCommand to return a token, and added +Tcl_GetCommandName procedure. Together, these procedures make it possible +to track renames of a command. + +289. 2/13/95 Fixed bug in expr where "089" was interpreted as a +floating-point number rather than a bogus octal number. +*** POTENTIAL INCOMPATIBILITY *** + +290. 2/14/95 Added code to Tcl_GetInt and Tcl_GetDouble to check for +overflows when reading in numbers. + +291. 2/18/95 Changed "array set" to stop after first error, rather than +continuing after error. + +292. 2/20/95 Upgraded to use autoconf version 2.2. + +293. 2/20/95 Fixed core dump that could occur in "scan" command if a +close bracket was omitted. + +294. 2/27/95 Changed Makefile to always use install-sh for installations: +there's just too much variation among "install" system programs, which +makes installation flakey. + +----------------- Released version 7.4b3, 3/24/95 ------------------ + +3/25/95 (bug fix) Changed "install" to "./install" in Makefile so that +"make install" will work even when "." isn't in the search path. + +3/29/95 (bug fix) Fixed bug where the auto-loading mechanism wasn't +protecting the values of the errorCode and errorInfo variables. + +3/29/95 (new feature) Added optional pattern argument to "parray" procedure. + +3/29/95 (bug fix) Made the full functionality of + "return -code ... -errorcode ..." +work not just inside procedures, but also in sourced files and at +top level. + +4/6/95 (new feature) Added "pattern" option to "array names" command. + +4/18/95 (bug fix) Fixed bug in parser where it didn't allow backslash-newline +immediately after an argument in braces or quotes. + +4/19/95 (new feature) Added tcl_library variable, which application can +set to override default library directory. + +4/30/95 (bug fix) During trace callbacks for array elements, the variable +name used in the original reference would be temporarily modified to +separate the array name and element name; if the trace callback used +the same name string, it would get the wrong name (the array name without +element). Fixed to restore the variable name before making trace +callbacks. + +4/30/95 (new feature) Added -nobackslashes, -nocommands, and -novariables +switches to "subst" command. + +5/4/95 (new feature) Added TCL_EVAL_GLOBAL flag to Tcl_RecordAndEval. + +5/5/95 (bug fix) Format command would overrun memory when printing +integers with very large precision, as in "format %.1000d 0". + +5/5/95 (portability improvement) Changed to use BSDgettimeofday on +IRIX machines, to avoid compilation problems with the gettimeofday +declaration. + +5/6/95 (bug fix) Changed manual entries to use the standard .TH +macro instead of a custom .HS macro; the .HS macro confuses index +generators like makewhatis. + +5/9/95 (bug fix) Modified configure script to check for Solaris bug +that makes vfork unreliable (core dumps result if vforked child +changes a signal handler); will use fork instead of vfork if the +bug is present. + +6/5/95 (bug fix) Modified "lsort" command to disallow recursive calls +to lsort from a comparison function. This is needed because qsort +is not reentrant. + +6/5/95 (bug fix) Undid change 243 above: changed TCL_VOLATILE and +TCL_DYNAMIC back to integer constants rather than procedure addresses. +This was needed because procedure addresses can have multiple values +under some dynamic loading systems (e.g. SunOS 4.1 and Windows). + +6/8/95 (feature change) Modified interface to Tcl_Main to pass in the +address of the application-specific initialization procedure. +Tcl_AppInit is no longer hardwired into Tcl_Main. This is needed +in order to make Tcl a shared library. + +6/8/95 (feature change) Modified Makefile so that the installed versions +of tclsh and libtcl.a have version number in them (e.g. tclsh7.4 and +libtcl7.4.a) and the library directory name also has an embedded version +number (e.g., /usr/local/lib/tcl7.4). This should make it easier for +Tcl 7.4 to coexist with earlier versions. + +----------------- Released version 7.4b4, 6/16/95 ------------------ + +6/19/95 (bug fix) Fixed bugs in tclCkalloc.c that caused core dumps +if TCL_MEM_DEBUG was enabled on word-addressed machines such as Crays. + +6/21/95 (feature removal) Removed overflow checks for integer arithmetic: +they just cause too much trouble (e.g. for random number generators). + +6/28/95 (new features) Added tcl_patchLevel and tcl_version variables, +for consistency with Tk. + +6/29/95 (bug fix) Fixed problem in Tcl_Eval where it didn't record +the right termination character if a script ended with a comment. This +caused erroneous output for the following command, among others: +puts "[ +expr 1+1 +# duh! +]" + +6/29/95 (message change) Changed the error message for ECHILD slightly +to provide a hint about why the problem is occurring. + +----------------- Released version 7.4, 7/1/95 ------------------ + +7/18/95 (bug fix) Changed "lreplace" so that nothing is deleted if +the last index is less than the first index or if the last index +is < 0. + +7/18/95 (bug fix) Fixed bugs with backslashes in comments: +Tcl_CommandComplete (and "info complete") didn't properly handle +strings ending in backslash-newline, and neither Tcl_CommandComplete +nor the Tcl parser handled other backslash sequences right, such +as two backslashes before a newline. + +7/19/95 (bug fix) Modified Tcl_DeleteCommand to delete the hash table +entry for the command before invoking its callback. This is needed in +order to deal with reentrancy. + +7/22/95 (bug fix) "exec" wasn't reaping processes correctly after +certain errors (e.g. if the name of the executable was bogus, as +in "exec foobar"). + +7/27/95 (bug fix) Makefile.in wasn't using the LIBS variable provided +by the "configure" script. This caused problems on some SCO systems. + +7/27/95 (bug fix) The version of strtod in fixstrtod.c didn't properly +handle the case where endPtr == NULL. + +----------------- Released patch 7.4p1, 7/29/95 ----------------------- + +8/4/95 (bug fix) C-level trace callbacks for variables were sometimes +receiving the PART1_NOT_PARSED flag, which could cause errors in +subsequent Tcl library calls using the flags. (JO) + +8/4/95 (bug fix) Calls to toupper and tolower weren't using the +UCHAR macros, which caused trouble in non-U.S. locales. (JO) + +8/10/95 (new feature) Added the "load" command for dynamic loading of +binary packages, and the Tcl_PackageInitProc prototype for package +initialization procedures. (JO) + +8/23/95 (new features) Added "info sharedlibextension" and +"info nameofexecutable" commands, plus Tcl_FindExtension procedure. (JO) + +8/25/95 (bug fix) If the target of an "upvar" was non-existent but +had traces set, the traces were silently lost. Change to generate +an error instead. (JO) + +8/25/95 (bug fix) Undid change from 7/19, so that commands can stay +around while their deletion callbacks execute. Added lots of code to +handle all of the reentrancy problems that this opens up. (JO) + +8/25/95 (bug fix) Fixed core dump that could occur in TclDeleteVars +if there was an upvar from one entry in the table to the next entry +in the same table. (JO) + +8/28/95 (bug fix) Exec wasn't handling bad user names properly, as +in "exec ~bogus_user/foo". (JO) + +8/29/95 (bug fixes) Changed backslash-newline handling to correct two +problems: + - Only spaces and tabs following the backslash-newline are now + absorbed as part of the backslash-newline. Newlinew are no + longer absorbed (add another backslash if you want to absorb + another newline). + - TclWordEnd returns the character just before the backslash in + the sequence as the end of the sequence; it used to not consider + the backslash-newline as a word separator. (JO) + +8/31/95 (new feature) Changed man page installation (with "mkLinks" +script) to create additional links for manual pages corresponding to +each of the procedure and command names described in the pages. (JO) + +9/10/95 Reorganized Tcl sources for Windows and Mac ports. All sources +are now in subdirectories: "generic" contains sources that work on all +platforms, "windows", "mac", and "unix" directories contain platform- +specific sources. Some UNIX sources are also used on other platforms. (SS) + +9/10/95 (feature change) Eliminated exported global variables (they +don't work with Windows DLLs). Replaced tcl_AsyncReady and +tcl_FileCloseProc with procedures Tcl_AsyncReady() and +Tcl_SetFileCloseProc(). Replaced C variable tcl_RcFileName with +a Tcl variable tcl_rcFileName. (SS) +*** POTENTIAL INCOMPATIBILITY *** + +9/11/95 (new feature) Added procedure Tcl_SetPanicProc to override +the default implementation of "panic". (SS) + +9/11/95 (new feature) Added "interp" command to allow creation of +new interpreters and execution of untrusted scripts. Added many new +procedures, such as Tcl_CreateSlave, Tcl_CreateAlias,and Tcl_MakeSafe, +to provide C-level access to the interpreter facility. This mechanism +now provides almost all of the generic functions of Borenstein's and +Rose's Safe-Tcl (but not any Tk or email-related stuff). (JL) + +9/11/95 (feature change) Changed file management so that files are +no longer shared between interpreters: a file cannot normally be +referenced in one interpreter if it was opened in another. This +feature is needed to support safe interpreters. Added Tcl_ShareHandle() +procedure for allowing files to be shared, and added "interp" argument +to Tcl_FilePermissions procedure. +*** POTENTIAL INCOMPATIBILITY *** + +9/11/95 (new feature) Added "AssocData" mechanism, whereby extensions +can associate their own data with an interpreter and get called back +when the interpreter is deleted. This is visible at C level via the +procedures Tcl_SetAssocData and Tcl_GetAssocData. (JL) + +9/11/95 (new feature) Added Tcl_ErrnoMsg to translate an errno value +into a human-readable string. This is now used instead of calling +strerror because strerror mesages vary dramatically from platform +to platform, which messes up Tcl tests. Tcl_ErrnoMsg uses the standard +POSIX messages for all the common signals, and calls strerror for +signals it doesn't understand. + +----------------- Released patch 7.5p2, 9/15/95 ----------------------- + +----------------- Released 7.5a1, 9/15/95 ----------------------- + +9/22/95 (bug fix) Changed auto_mkindex to create tclIndex files that +handle directories whose paths might contain spaces. (RJ) + +9/27/95 (bug fix) The "format" command didn't check for huge or negative +width specifiers, which could cause core dumps. (JO) + +9/27/95 (bug fix) Core dumps could occur if an interactive command typed +to tclsh returned a very long result for tclsh to print out. The bug is +actually in printf (in Solaris 2.3 and 2.4, at least); switched to use +puts instead. (JO) + +9/28/95 (bug fix) Changed makefile.bc to eliminate a false dependency +for tcl1675.dll on the Borland run time library. (SS) + +9/28/95 (bug fix) Fixed tcl75.dll so it looks for tcl1675.dll instead +of tcl16.dll. (SS) + +9/28/95 (bug fix) Tcl was not correctly detecting the difference +between Win32s and Windows '95. (SS) + +9/28/95 (bug fix) "exec" was not passing environment changes to child +processes under Windows. (SS) + +9/28/95 (bug fix) Changed Tcl to ensure that open files are not passed +to child processes under Windows. (SS) + +9/28/95 (bug fix) Fixed Windows '95 and NT versions of exec so it can +handle both console and windows apps. (SS) + +9/28/95 (bug fix) Fixed Windows version of exec so it no longer leaves +temp files lying around. Also changed it so the temp files are +created in the appropriate system dependent temp directory. (SS) + +9/28/95 (bug fix) Eliminated source dependency on the Win32s Universal +Thunk header file, since it is not bundled with VC++. (SS) + +9/28/95 (bug fix) Under Windows, Tcl now constructs the HOME +environment variable from HOMEPATH and HOMEDRIVE when HOME is not +already set. (SS) + +9/28/95 (bug fix) Added support for "info nameofexecutable" and "info +sharedlibextension" to the Windows version. (SS) + +9/28/95 (bug fix) Changed tclsh to correctly parse command line +arguments so that backslashes are preserved under Windows. (SS) + +9/29/95 (bug fix) Tcl 7.5a1 treated either return or newline as end +of line in "gets", which caused lines ending in CRLF to be treated as +two separate lines. Changed to allow only character as end-of-line: +carriage return on Macs, newline elsewhere. (JO) + +9/29/95 (new feature) Changed to install "configInfo" file in same +directory as library scripts. It didn't used to get installed. (JO) + +9/29/95 (bug fix) Tcl was not converting Win32 errors into POSIX +errors under some circumstances. (SS) + +10/2/95 (bug fix) Safe interpreters no longer get initialized with +a call to Tcl_Init(). (JL) + +10/1/95 (new feature) Added "tcl_platform" global variable to provide +environment information such as the instruction set and operating +system. (JO) + +10/1/95 (bug fix) "exec" command wasn't always generating the +"child process exited abnormally" message when it should have. (JO) + +10/2/95 (bug fix) Changed "mkLinks.tcl" so that the scripts it generates +won't create links that overwrite original manual entries (there was +a problem where pack-old.n was overwriting pack.n). (JO) + +10/2/95 (feature change) Changed to use -ldl for dynamic loading under +Linux if it is available, but fall back to -ldld if it isn't. (JO) + +10/2/95 (bug fix) File sharing was causing refcounts to reach 0 +prematurely for stdin, stdout and stderr, under some circumstances. (JL) + +10/2/95 (platform support) Added support for Visual C++ compiler on +Windows, Windows '95 and Windows NT, code donated by Gordon Chaffee. (JL) + +10/3/95 (bug fix) Tcl now frees any libraries that it loads before it +exits. (SS) + +10/03/95 (bug fix) Fixed bug in Macintosh ls command where the -l +and -C options would fail in anything but the HOME directory. (RJ) + +----------------- Released 7.5a2, 10/6/95 ----------------------- + +10/10/95 (bug fix) "file dirnam /." was returning ":" on UNIX instead +of "/". (JO) + +10/13/95 (bug fix) Eliminated dependency on MKS toolkit for generating +the tcl.def file from Borland object files. (SS) + +10/17/95 (new features) Moved the event loop from Tcl to Tk, made major +revisions along the way: + - New Tcl commands: after, update, vwait (replaces "tkwait variable"). + - "tkerror" is now replaced with "bgerror". + - The following procedures are similar to their old Tk counterparts: + Tcl_DoOneEvent, Tcl_Sleep, Tcl_DoWhenIdle, Tcl_CancelIdleCall, + Tcl_CreateFileHandler, Tcl_DeleteFileHandler, Tcl_CreateTimerHandler, + Tcl_DeleteTimerHandler, Tcl_BackgroundError. + - Revised notifier, add new concept of "event source" with the following + procedures: Tcl_CreateEventSource, Tcl_DeleteEventSource, + Tcl_WatchFile, Tcl_SetMaxBlockTime, Tcl_FileReady, Tcl_QueueEvent, + Tcl_WaitForEvent. (JO) + +10/31/95 (new features) Implemented cross platform file name support to make +it easier to write cross platform scripts. Tcl now understands 4 file naming +conventions: Windows (both DOS and UNC), Mac, Unix, and Network. The network +convention is a new naming mechanism that can be used to paths in a platform +independent fashion. See the "file" command manual page for more details. +The primary interfaces changes are: + - All Tcl commands that expect a file name now accept both network and + native form. + - Two new "file" subcommands, "nativename" and "networkname", provide a + way to convert between network and native form. + - Renamed Tcl_TildeSubst to Tcl_TranslateFileName, and changed it so that + it always returns a filename in native form. Tcl_TildeSubst is defined + as a macro for backward compatibility, but it is deprecated. (SS) + +11/5/95 (new feature) Made "tkerror" and "bgerror" synonyms, so that +either name can be used to manipulate the command (provides temporary +backward compatibility for existing scripts that use tkerror). (JO) + +11/5/95 (new feature) Added exit handlers and new C procedures +Tcl_CreateExitHandler, Tcl_DeleteExitHandler, and Tcl_Exit. (JO) + +11/6/95 (new feature) Added pid command for Macintosh version of +Tcl (it didn't previously exist on the Mac). (RJ) + +11/7/95 (new feature) New generic IO facility and support for IO to +files, pipes and sockets based on a common buffering scheme. Support +for asynchronous (non-blocking) IO and for event driver IO. Support +for automatic (background) asynchronous flushing and asynchronous +closing of channels. (JL) + +11/7/95 (new feature) Added new commands "fconfigure" and "fblocked" +to support new I/O features such as nonblocking I/O. Added "socket" +command for creating TCP client and server sockets. (JL). + +11/7/95 (new feature) Complete set of C APIs to the new generic IO +facility: + - Opening channels: Tcl_OpenFileChannel, Tcl_OpenCommandChannel, + Tcl_OpenTcpClient, Tcl_OpenTcpServer. + - I/O procedures on channels, which roughly mirror the ANSI C stdio + library: Tcl_Read, Tcl_Gets, Tcl_Write, Tcl_Flush, Tcl_Seek, + Tcl_Tell, Tcl_Close, Tcl_Eof, Tcl_InputBlocked, Tcl_GetChannelOption, + Tcl_SetChannelOption. + - Extension mechanism for creating new kinds of channels: + Tcl_CreateChannel, Tcl_GetChannelInstanceData, Tcl_GetChannelType, + Tcl_GetChannelName, Tcl_GetChannelFile, Tcl_RegisterChannel, + Tcl_UnregisterChannel, Tcl_GetChannel. + - Event-driven I/O on channels: Tcl_CreateChannelHandler, + Tcl_DeleteChannelHandler. (JL) + +11/7/95 (new feature) Channel driver interface specification to allow +new types of channels to be added easily to Tcl. Currently being used +in three drivers - for files, pipes and TCP-based sockets. (JL). + +11/7/95 (new feature) interp delete now takes any number of path +names of interpreters to delete, including zero. (JL). + +11/8/95 (new feature) implemented 'info hostname' and Tcl_GetHostName +command to get host name of machine on which the Tcl process is running. (JL) + +11/9/95 (new feature) Implemented file APIs for access to low level files +on each system. The APIs are: Tcl_CloseFile, Tcl_OpenFile, Tcl_ReadFile, +Tcl_WriteFile and Tcl_SeekFile. Also implemented Tcl_WaitPid which waits +in a system dependent manner for a child process. (JL) + +11/9/95 (new feature) Added Tcl_UpdateLinkedVar procedure to force a +Tcl variable to be updated after its C variable changes. (JO) + +11/9/95 (bug fix) The glob command has been totally reimplemented so +that it can support different file name conventions. It now handles +Windows file names (both UNC and drive-relative) properly. It also +supports nested braces correctly now. (SS) + +11/13/95 (bug fix) Fixed Makefile.in so that configure can be run +from a clean directory separate from the Tcl source tree, and compilations +can be performed there. (JO) + +11/14/95 (bug fix) Fixed file sharing between interpreters and file +transferring between interpreters to correctly manage the refcount so that +files are closed when the last reference to them is discarded. (JL) + +11/14/95 (bug fix) Fixed gettimeofday implementation for the +Macintosh. This fixes several timing related bugs. (RJ) + +11/17/95 (new feature) Added missing support for info nameofexecutable +on the Macintosh. (RJ) + +11/17/95 (bug fix) The Tcl variables argc argv and argv0 now return +something reasonable on the Mac. (RJ) + +11/22/95 (new feature) Implemented "auto-detect" mode for end of line +translations. On input, standalone "\r" mean MAC mode, standalone "\n" +mean Unix mode and "\r\n" means Windows mode. On output, the mode is +modified to whatever the platform specific mode for that platform is. (JL) + +11/24/95 (feature change) Replaced "configInfo" file with tclConfig.sh, +which is more complete and uses slightly different names. Also +arranged for tclConfig.sh to be installed in the platform-specific +library directory instead of Tcl's script library directory. (JO) +*** POTENTIAL INCOMPATIBILITY with Tcl 7.5a2, but not with Tcl 7.4 *** + +----------------- Released patch 7.4p3, 11/28/95 ----------------------- + +12/5/95 (new feature) Added Tcl_File facility to support platform- +independent file handles. Changed all interfaces that used Unix- +style integer fd's to use Tcl_File's instead. (SS) +*** POTENTIAL INCOMPATIBILITY *** + +12/5/95 (new feature) Added a new "clock" command to Tcl. The command +allows you to get the current "clicks" or seconds & allows you to +format or scan human readable time/date strings. (RJ) + +12/18/95 (new feature) Moved Tk_Preserve, Tk_Release, and Tk_EventuallyFree +to Tcl, renamed to Tcl_Preserve, Tcl_Release, and Tcl_EventuallyFree. (JO) + +12/18/95 (new feature) Added new "package" command and associated +procedures Tcl_PkgRequire and Tcl_PkgProvide. Also wrote +pkg_mkIndex library procedure to create index files from binaries +and scripts. (JO) + +12/20/95 (new feature) Added Tcl_WaitForFile procedure. (JO) + +12/21/95 (new features) Made package name argument to "load" optional +(Tcl will now attempt to guess the package name if necessary). Also +added Tcl_StaticPackage and support in "load" for statically linked +packages. (JO) + +12/22/95 (new feature) Upgraded the foreach command to accept multiple +loop variables and multiple value lists. This lets you iterate over +multiple lists in parallel, and/or assign multiple loop variables from +one value list during each iteration. The only potential compatibility +problem is with scripts that used loop variables with a name that could be +construed to be a list of variable names (i.e. contained spaces). (BW) + +1/5/96 (new feature) Changed tclsh so it builds as a console mode +application under Windows. Now tclsh can be used from the command +line with pipes or interactively. Note that this only works under +Windows 95 or NT. (SS) + +1/17/96 (new feature) Modified Makefile and configure script to allow +Tcl to be compiled as a shared library: use the --enable-shared option +when configuing. (JO) + +1/17/96 (removed obsolete features) Removed the procedures Tcl_EnterFile +and Tcl_GetOpenFile: these no longer make sense with the new I/O system. (JL) +*** POTENTIAL INCOMPATIBILITY *** + +1/19/96 (bug fixes) Prevented formation of circular aliases, through the +Tcl 'interp alias' command and through the 'rename' command, as well as +through the C API Tcl_CreateAlias. (JL) + +1/19/96 (bug fixes) Fixed several bugs in direct deletion of interpreters +with Tcl_DeleteInterp when the interpreter is a slave; fixes based on a +patch received from Viktor Dukhovni of ESM. (JL) + +1/19/96 (new feature) Implemented on-close handlers for channels; added +the C APIs Tcl_CreateCloseHandler and Tcl_DeleteCloseHandler. (JL) + +1/19/96 (new feature) Implemented portable error reporting mechanism; added +the C APIs Tcl_SetErrno and Tcl_GetErrno. (JL) + +1/24/96 (bug fix) Unknown command processing properly invokes external +commands under Windows NT and Windows '95 now. (SS) + +1/23/96 (bug fix) Eliminated extremely long startup times under Windows '95. +The problem was a result of the option database initialization code that +concatenated $HOME with /.Xdefaults, resulting in a // in the middle of the +file name. Under Windows '95, this is incorrectly interpreted as a UNC +path. They delays came from the network timeouts needed to determine that +the file name was invalid. Tcl_TranslateFileName now suppresses duplicate +slashes that aren't at the beginning of the file name. (SS) + +1/25/96 (bug fix) Changed exec and open to create children so they are +attached to the application's console if it exists. (SS) + +1/31/96 (bug fix) Fixed command line parsing to handle embedded +spaces under Windows. (SS) + +----------------- Released 7.5b1, 2/1/96 ----------------------- + +2/7/96 (bug fix) Fixed off by one error in argument parsing code under +Windows. (SS) + +2/7/96 (bug fix) Fixed bugs in VC++ makefile that improperly +initialized the tcl75.dll. Fixed bugs in Borland makefile that caused +build failures under Windows NT. (SS) + +2/9/96 (bug fix) Fixed deadlock problem in AUTO end of line translation +mode which would cause a socket server with several concurrent clients +writing in CRLF mode to hang. (JL) + +2/9/96 (API change) Replaced -linemode option to fconfigure with a +new -buffering option, added "none" setting to enable immediate write. (JL) +*** INCOMPATIBILITY with b1 *** + +2/9/96 (new feature) Added C API Tcl_InputBuffered which returns the count +of bytes currently buffered in the input buffer of a channel, and o for +output only channels. (JL) + +2/9/96 (new feature) Implemented asynchronous connect for sockets. (JL) + +2/9/96 (new feature) Added C API Tcl_SetDefaultTranslation to set (per +channel) the default end of line translation mode. This is the mode that +will be installed if an output operation is done on the channel while it is +still in AUTO mode. (JL) + +2/9/96 (bug fix) Changed Tcl_OpenCommandChannel interface to properly +handle all of the combinations of stdio inheritance in background +pipelines. See the Tcl_OpenFileChannel(3) man page for more +info. This change fixes the bug where exec of a background pipeline +was not getting passed the stdio handles properly. (SS) + +2/9/96 (bug fix) Removed the new Tcl_CreatePipeline interface, and +restored the old version for Unix platforms only. All new code should +use Tcl_CreateCommandChannel instead. (SS) + +2/9/96 (bug fix) Changed Makefile.in to use -L and -ltcl7.5 for Tcl +library so that shared libraries are more likely to be found correctly +on more platforms. (JO) + +2/13/96 (new feature) Added C API Tcl_SetNotifierData and +Tcl_GetNotifierData to allow notifier and channel driver writers to +associate data with a Tcl_File. The result of this change is that +Tcl_GetFileInfo now always returns an OS file handle, and Tcl_GetFile +can be used to construct a Tcl_File for an externally constructed OS +handle. (SS) + +2/13/96 (bug fix) Changed Windows socket implementation so it doesn't +set SO_REUSEADDR on server sockets. Now attempts to create a server +socket on a port that is already in use will be properly identified +and an error will be generated. (SS) + +2/13/96 (bug fix) Fixed problems with DLL initialization under Visual +C++ that left the C run time library uninitialized. (SS) + +2/13/96 (bug fix) Fixed Windows socket initialization so it loads +winsock the first time it is used, rather than at the time tcl75.dll +is loaded. This should fix the bug where the modem immediately starts +trying to connect to a service provider when wish or tclsh are +started. (SS) + +2/13/96 (new feature) Added C APIs Tcl_MakeFileChannel and +Tcl_MakeTcpClientChannel to wrap up existing fds and sockets into +channels. Provided implementations on Unix and Windows. (JL) + +2/13/96 (bug fix) Fixed bug with seek leaving EOF and BLOCKING set. (JL) + +2/14/96 (bug fix) Fixed reentrancy problem in fileevent handling +and made it more robust in the face of errors. (JL) + +2/14/96 (feature change) Made generic IO level emulate blocking mode if the +channel driver is unable to provide it, e.g. if the low level device is +always nonblocking. Thus, now blocking behavior is an advisory setting for +channel drivers and can be ignored safely if the channel driver is unable +to provide it. (JL) + +2/15/96 (new feature) Added "binary" end of line translation mode, which is +a synonym of "lf" mode. (JL) + +2/15/96 (bug fix) Fixed reentrancy problem in fileevent handling vs +deletion of channel event handlers. (JL) + +2/15/96 (bug fix) Fixed bug in event handling which would cause a +nonblocking channel to not see further readable events after the first +readable event that had insufficient input. (JL) + +2/17/96 (bug fix) "info complete" didn't properly handle comments +in nested commands. (JO) + +2/21/96 (bug fix) "exec" under Windows NT/95 did not properly handle +very long command lines (>200 chars). (SS) + +2/21/96 (bug fix) Sockets could get into an infinite loop if a read +event arrived after all of the available data had been read. (SS) + +2/22/96 (bug fix) Added cast of st_size elements to (long) before +sprintf-ing in "file size" command. This is needed to handle systems +like NetBSD with 64-bit file offsets. (JO) + +----------------- Released 7.5b2, 2/23/96 ----------------------- + +2/23/96 (bug fix) TCL_VARARGS macro in tcl.h wasn't defined properly +when compiling with C++. (JO) + +2/24/96 (bug fix) Removed dependencies on Makefile in the UNIX Makefile: +this caused problems on some platforms (like Linux?). (JO) + +2/24/96 (bug fix) Fixed configuration bug that made Tcl not compile +correctly on Linux machines with neither -ldl or -ldld. (JO) + +2/24/96 (new feature) Added a block of comments and definitions to +Makefile.in to make it easier to have Tcl's TclSetEnv etc. replace +the library procedures setenv etc, so that calls to setenv etc. in +the application automatically update the Tcl "env" variable. (JO) + +2/27/96 (feature change) Added optional Tcl_Interp * argument (may be NULL) +to C API Tcl_Close and simplified closing of command channels. (JL) +*** INCOMPATIBILITY with Tcl 7.5b2, but not with Tcl 7.4 *** + +2/27/96 (feature change) Added optional Tcl_Interp * argument (may be NULL) +to C type definition Tcl_DriverCloseProc; modified all channel drivers to +implement close procedures that accept the additional argument. (JL) +*** INCOMPATIBILITY with Tcl 7.5b2, but not with Tcl 7.4 *** + +2/28/96 (bug fix) Fixed memory leak that could occur if an upvar +referred to an element of an array in the same stack frame as the +upvar. (JO) + +2/29/96 (feature change) Modified both Tcl_DoOneEvent and Tcl_WaitForEvent +so that they return immediately in cases where they would otherwise +block forever (e.g. if there are no event handlers of any sort). (JO) + +2/29/96 (new feature) Added C APIs Tcl_GetChannelBufferSize and +Tcl_SetChannelBufferSize to set and retrieve the size, in bytes, for +buffers allocated to store input or output in a channel. (JL) + +2/29/96 (new feature) Added option -buffersize to Tcl fconfigure command +to allow Tcl scripts to query and set the size of channel buffers. (JL) + +2/29/96 (feature removed) Removed channel driver function to specify +the buffer size to use when allocating a buffer. Removed the C typedef +for Tcl_DriverBufferSizeProc. Channels are now created with a default +buffer size of 4K. (JL) +*** INCOMPATIBILITY with Tcl 7.5b2, but not with Tcl 7.4 *** + +2/29/96 (feature change) The channel driver function for setting blocking +mode on the device may now be NULL. If the generic code detects that the +function is NULL, operations that set the blocking mode on the channel +simply succeed. (JL) + +3/2/96 (bug fix) Fixed core dump that could occur if a syntax error +(such as missing close paren) occurred in an array reference with a +very long array name. (JO) + +3/4/96 (bug fix) Removed code in the "auto_load" procedure that deletes +all existing auto-load information whenever the "auto_path" variable +is changed. Instead, new information adds to what was already there. +Otherwise, changing the "auto_path" variable causes all package- +related information to be lost. If you really want to get rid of +existing auto-load information, use auto_reset before setting auto_path. (JO) + +3/5/96 (new feature) Added version suffix to shared library names so that +Tcl will compile under NetBSD and FreeBSD (I hope). (JO) + +3/6/96 (bug fix) Cleaned up error messages in new I/O system to correspond +more closely to old I/O system. (JO) + +3/6/96 (new feature) Added -myaddr and -myport options to the socket +command, removed -tcp and -- options. This lets clients and servers +choose a particular interface. Also changed the default server address +from the hostname to INADDR_ANY. The server accept callback now gets +passed the client's port as well as IP address. The C interfaces for +Tcl_OpenTcpClient and Tcl_OpenTcpServer have changed to support the +above changes. (BW) +*** POTENTIAL INCOMPATIBILITY with Tcl 7.5b2, but not with Tcl 7.4 *** + +3/6/96 (changed feature) The library function auto_mkindex will now +default to using the pattern "*.tcl" if no pattern is given. (RJ) + +3/6/96 (bug fix) The socket channel code for the Macintosh has been +rewritten to use native MacTcp. (RJ) + +3/7/96 (new feature) Added Tcl_SetStdChannel and Tcl_GetStdChannel +interfaces to allow applications to explicitly set and get the global +standard channels. (SS) + +3/7/96 (bug fix) Tcl did close not the file descriptors associated +with "stdout", etc. when the corresponding channels were closed. (SS) + +3/7/96 (bug fix) Reworked shared library and dynamic loading stuff to +try to get it working under AIX. Added new @SHLIB_LD_LIBS@ autoconf +symbol as part of this. AIX probably doesn't work yet, but it should +be a lot closer. (JO) + +3/7/96 (feature change) Added Tcl_ChannelProc typedef and changed the +signature of Tcl_CreateChannelHandler and Tcl_DeleteChannelHandler to take +Tcl_ChannelProc arguments instead of Tcl_FileProc arguments. This change +should not affect any code outside Tcl because the signatures of +Tcl_ChannelProc and Tcl_FileProc are compatible. (JL) + +3/7/96 (API change) Modified signature of Tcl_GetChannelOption to return +an int instead of char *, and to take a Tcl_DString * argument. Modified +the implementation so that the option name can be NULL, to mean that the +call should retrieve a list of alternating option names and values. (JL) +*** INCOMPATIBILITY with Tcl 7.5b2, but not with Tcl 7.4 *** + +3/7/96 (API change) Added Tcl_DriverSetOptionProc, Tcl_DriverGetOptionProc +typedefs, added two slots setOptionProc and getOptionProc to the channel +type structure. These may be NULL to indicate that the channel type does +not support any options. (JL) +*** INCOMPATIBILITY with Tcl 7.5b2, but not with Tcl 7.4 *** + +3/7/96 (feature change) stdin, stdout and stderr can now be put into +nonblocking mode. (JL) + +3/8/96 (feature change) Eliminated dependence on the registry for +finding the Tcl library files. (SS) + +----------------- Released 7.5b3, 3/8/96 ----------------------- + +3/12/96 (feature improvement) Modified startup script to look in several +different places for the Tcl library directory. This should allow Tcl +to find the libraries under all but the weirdest conditions, even without +the TCL_LIBRARY environment variable being set. (JO) + +3/13/96 (bug fix) Eliminated use of the "linger" option from the Windows +socket implementation. (JL) + +3/13/96 (new feature) Added -peername and -sockname options for fconfigure +for socket channels. Code contributed by John Haxby of HP. (JL) + +3/13/96 (bug fix) Fixed panic and core dump that would occur if the accept +callback script on a server socket encountered an error. (JL) + +3/13/96 (feature change) Added -async option to the Tcl socket command. +If the command is creating a client socket and the flag is present, the +client is connected asynchronously. If the option is absent (the default), +the client socket is connected synchronously, and the command returns only +when the connection has been completed or failed. This change was suggested +by Mark Diekhans. (JL) + +3/13/96 (feature change) Modified the signature of Tcl_OpenTcpClient to +take an additional int argument, async. If nonzero, the client is connected +to the server asynchronously. If the value is zero, the connection is made +synchronously, and the call to Tcl_OpenTcpClient returns only when the +connection fails or succeeds. This change was suggested by Mark Diekhans. (JL) +*** INCOMPATIBILITY with Tcl 7.5b3, but not with Tcl 7.4 *** + +3/14/96 (bug fix) "tclsh bogus_file_name" didn't print an error message. (JO) + +3/14/96 (bug fix) Added new procedures to tclCkalloc.c so that libraries +and applications can be compiled with TCL_MEM_DEBUG even if Tcl isn't +(however, the converse is still not true). Patches provided by Jan +Nijtmans. (JO) + +3/15/96 (bug fix) Marked standard IO handles of a process as close-on-exec +to fix bug in Ultrix where exec was not sharing standard IO handles with +subprocesses. Fix suggested by Mark Diekhans. (JL) + +3/15/96 (bug fix) Fixed asynchronous close mechanism so that it closes the +channel instead of leaking system resources. The manifestation was that Tcl +would eventually run out of file descriptors if it was handling a large +number of nonblocking sockets or pipes with high congestion. (JL) + +3/15/96 (bug fix) Fixed tests so that they no longer leak file descriptors. +The manifestation was that Tcl would eventually run out of file descriptors +if the tests were rerun many times (> a hundred times on Solaris). (JL) + +3/15/96 (bug fix) Fixed channel creation code so that it never creates +unnamed channels. This would cause a panic and core dump when the channel +was closed. (JL) + +3/16/96 (bug fixes) Made lots of changes in configuration stuff to get +Tcl working under AIX (finally). Tcl should now support the "load" +command under AIX and should work either with or without shared +libraries for Tcl and Tk. (JO) + +3/21/96 (configuration improvement) Changed configure script so it +doesn't use version numbers (as in -ltcl7.5 and libtcl7.5.so) under +SunOS 4.1, where they don't work anyway. (JO) + +3/22/96 (new feature) Added C API Tcl_InterpDeleted that allows extension +writers to discover when an interpreter is being deleted. (JL) + +3/22/96 (bug fix) The standard IO channels are now added to each +trusted interpreter as soon as the interpreter is created. This ensures +against the bug where a child would do IO before the master had done any, +and then the child is destroyed - the standard IO channels would be then +closed and the master would be unable to do any IO. (JL) + +3/22/96 (bug fix) Made Tcl more robust against interpreter deletion, by +using Tcl_Preserve, Tcl_Release and Tcl_EventuallyFree to split the process +of interpreter deletion into two distinct phases. Also went through all of +Tcl and added calls to Tcl_Preserve and Tcl_Delete where needed. (JL) + +3/22/96 (bug fix) Fixed several places where C code was reading and writing +into freed memory, especially during interpreter deletion. (JL) + +3/22/96 (bug fix) Fixed very deep bug in Tcl_Release that caused memory to +be freed twice if the release callback did Tcl_Preserve and Tcl_Release on +the same memory as the chunk currently being freed. (JL) + +3/22/96 (bug fix) Removed several memory leaks that would cause memory +buildup on half-K chunks in the generic IO level. (JL) + +3/22/96 (bug fix) Fixed several core dumps which occurred when new +AssocData was being created during the cleanups in interpreter deletion. +The solution implemented now is to loop repeatedly over the AssocData until +none is left to clean up. (JL) + +3/22/96 (bug fix) Fixed a bug in event handling which caused an infinite +loop if there were no files being watched and no timer. Fix suggested by +Jan Nijtmans. (JL) + +3/22/96 (bug fix) Fixed Tcl_CreateCommand, Tcl_DeleteCommand to be more +robust if the interpreter is being deleted. Also fixed several order +dependency bugs in Tcl_DeleteCommand which kicked in when an interpreter +was being deleted. (JL) + +3/26/96 (bug fix) Upon a "short read", the generic code no longer calls +the driver for more input. Doing this caused blocking on some platforms +even on nonblocking channels. Bug and fix courtesy Mark Roseman. (JL) + +3/26/96 (new feature) Added 'package Tcltest' which is present only in +test versions of Tcl; this allows the testing commands to be loaded into +new interpreters besides the main one. (JL) + +3/26/96 (restored feature) Recreated the Tcl_GetOpenFile C API. You can +now get a FILE * from a registered channel; Unix only. (JL) + +3/27/96 (bug fix) The regular expression code did not support more +than 9 subexpressions. It now supports up to 20. (SS) + +4/1/96 (bug fixes) The CHANNEL_BLOCKED bit was being left on on a short +read, so that fileevents wouldn't fire correctly. Bug reported by Mark +Roseman.(JL, RJ) + +4/1/96 (bug fix) Moved Tcl_Release to match Tcl_Preserve exactly, in +tclInterp.c; previously interpreters were being freed only conditionally +and sometimes not at all. (JL) + +4/1/96 (bug fix) Fixed error reporting in slave interpreters when the +error message was being generated directly by C code. Fix suggested by +Viktor Dukhovni of ESM. (JL) + +4/2/96 (bug fixes) Fixed a series of bugs in Windows sockets that caused +events to variously get lost, to get sent multiple times, or to be ignored +by the driver. The manifestation was blocking if the channel is blocking, +and either getting EAGAIN or infinite loops if the channel is nonblocking. +This series of bugs was found by Ian Wallis of Cisco. Now all tests (also +those that were previously commented out) in socket.test pass. (JL, SS) + +4/2/96 (feature change/bug fix) Eliminated network name support in +favor of better native name support. Added "file split", "file join", +and "file pathtype" commands. See the "file" man page for more +details. (SS) +*** INCOMPATIBILITY with Tcl 7.5b3, but not with Tcl 7.4 *** + +4/2/96 (bug fix) Changed implementation of auto_mkindex so tclIndex +files will properly handle path names in a cross platform context. (SS) + +4/5/96 (bug fix) Fixed Tcl_ReadCmd to use the channel buffer size as the +chunk size it reads, instead of a fixed 4K size. Thus, on large reads, the +user can set the channel buffer size to a large size and the read will +occur orders of magnitude faster. For example, on a 2MB file, reading in 4K +chunks took 34 seconds, while reading in 1MB chunks took 1.5 seconds (on a +SS-20). Problem identified and fix suggested by John Haxby of HP. (JL) + +4/5/96 (bug fix) Fixed socket creation code to invoke gethostbyname only if +inet_addr failed (very unlikely). Before this change the order was reversed +and this made things much slower than they needed to be (gethostbyname +generally requires an RPC, which is slow). Problem identified and fix +suggested by John Loverso of OSF. (JL) + +4/9/96 (feature change) Modified "auto" translation mode so that it +recognizes any of "\n", "\r" and "\r\n" in input as end of line, so +that a file can have mixed end-of-line sequences. It now outputs +the platform specific end of line sequence on each platform for files and +pipes, and for sockets it produces crlf in output on all platforms. (JL) +*** INCOMPATIBILITY with Tcl 7.5b3, but not with Tcl 7.4 *** + +4/11/96 (new feature) Added -eofchar option to Tcl_SetChannelOption to allow +setting of an end of file character for input and output. If an input eof +char is set, it is recognized as EOF and further input from the channel is +not presented to the caller. If an output eof char is set, on output, that +byte is appended to the channel when it is closed. On Unix and Macintosh, +all channels start with no eof char set for input or output. On Windows, +files and pipes start with input and output eof chars set to Crlt-Z (ascii +26), and sockets start with no input or output eof char. (JL) +*** INCOMPATIBILITY with Tcl 7.5b3, but not with Tcl 7.4 *** + +4/17/96 (bug fix) Fixed series of bugs with handling of crlf sequence split +across buffer boundaries in input, in AUTO mode. (JL, BW) + +4/17/96 (test suite improvement) Fixed test suite so that tests that +depend on the availability of Unix commands such as echo, cat and others +are not run if these commands are not present. (JL) + +4/17/96 (test suite improvement) The socket test now automatically starts, +on platformst that support exec, a separate process for remote testsing. (JL) + +----------------- Released 7.5, 4/21/96 ----------------------- + +5/1/96 (bug fix) "file tail ~" did not correctly return the tail +portion of the user's home directory. (SS) + +5/1/96 (bug fix) Fixed bug in TclGetEnv where it didn't lookup environment +variables correctly: could confuse "H" and "HOME", for example. (JO) + +5/1/96 (bug fix) Changed to install tclConfig.sh under "make install-binaries", +not "make install-libraries". (JO) + +5/2/96 (bug fix) Changed pkg_mkIndex not to attempt to "load" a file unless +it has the standard shared library extension. On SunOS, attempts to load +Tcl scripts cause the whole application to be aborted (there's no way to +get the error back into Tcl). (JO) + +5/7/96 (bug fix) Moved initScript in tclUnixInit.c to writable memory to +avoid potential core dumps. (JO) + +5/7/96 (bug fix) Auto_reset procedure was removing procedure from init.tcl, +such as pkg_mkIndex. (JO) + +5/7/96 (bug fix) Fixed cast on socket address resolution code that +would cause a failure to connect on Dec Alphas. (JL) + +5/7/96 (bug fix) Added "time", "subst" and "fileevent" commands to set of +commands available in a safe interpreter. (JL) + +5/13/96 (bug fix) Preventing OS level handles for stdin, stdout and stderr +from being implicitly closed when the last reference to the standard +channel containing that handle is discarded when an interpreter is deleted. +Explicitly closing standard channels by using "close" still works. (JL) + +5/21/96 (bug fix) Do not create channels for stdin, stdout and stderr on +Unix if the devices are closed. This prevents a duplicate channel name +panic later on when the fd is used to open a channel and the channel is +registered in an interpreter. (JL) + +5/23/96 (bug fix) Fixed bug that prevented the use of standard channels in +interpreters created after the last interpreter was destroyed. In the sequence + + interp = Tcl_CreateInterp(); + Tcl_DeleteInterp(interp); + interp = Tcl_CreateInterp(); + +channels for stdio would not be available in the second interpreter. (JL) + +5/23/96 (bug fix) Fixed bug that allowed Tcl_MakeFileChannel to create new +channels with Tcl_Files in them that are already used by another channel. +This would cause core dumps when the Tcl_Files were being freed twice. (JL) + +5/23/96 (bug fix) Fixed a logical timing bug that caused a standard channel +to be removed from the standard channel table too early when the channel +was being closed. If the channel was being flushed asynchronously, it could +get recreated before being actually destroyed, and the recreated channel +would contain the same Tcl_File as the one being closed, leading to +dangling pointers and core dumps. (JL) + +5/27/96 (bug fix) Fixed a bug in Tcl_GetChannelOption which caused it to +always return a list of one element, a list of the settings, for +-translation and -eofchar options. Now correctly returns the value +described by the documentation (Mark Diekhans found this, thanks!). (JL) + +5/30/96 (bug fix) Fixed a couple of syntax errors in io.test. (JL) + +5/30/96 (bug fix) If a fileevent scripts gets an error, delete it before +causing a background error. This is to allow the error handler to reinstall +the fileevent and to prevent infinite loops if the event loop is reentered +in the error handler. (JL) + +5/31/96 (bug fix) Channels now will get properly flushed on exit. (JL) + +6/5/96 (bug fix) Changed Tcl_Ckalloc, Tcl_Ckfree, and Tcl_Ckrealloc to +Tcl_Alloc, Tcl_Free, and Tcl_Realloc. Added documentation for these +routines now that they are officially supported. Extension writers +should use these routines instead of free() and malloc(). (SS) + +6/10/96 (bug fix) Changes the Tcl close command so that it no longer +waits on nonblocking pipes for the piped processes to exit; instead it +reaps them in the background. (JL) + +6/11/96 (bug fix) Increased the length of the listen queue for server +sockets on Unix from 5 to 100. Some OSes will disregard this and reset it +to 5, but we should try to get as long a queue as we can, for performance +reasons. (JL) + +6/11/96 (bug fix) Fixed windows sockets bug that caused a cascade of events +if the fileevent script read less than was available. Now reading less than +is available does not cause a flood of Tcl events. (JL, SS) + +6/11/96 (bug fix) Fixed bug in background flushing on closed channels that +would prevent the last buffer from getting flushed. (JL) + +6/13/96 (bug fix) Fixed bug in Windows sockets that caused a core dump if +a DLL linked with tcl.dll and referred to e.g. ntohs() without opening a +Tcl socket. The problem was that the indirection table was not being +initialized. (JL) + +6/13/96 (bug fix) Fixed OS level resource leak that would occur when a +Tcl channel was still registered in some interpreter when the process +exits. Previously the channel was not being closed and the OS level handles +were not being released; the output was being flushed but the device was +not being closed. Now the device is properly closed. This was only a +problem on Win3.1 and MacOS. (JL, SS) + +6/28/96 (bug fix) Fixed bug where transient errors were leaving an error +code around, so that it would erroneously get reported later. This bug was +exercised intermittently by closing a channel to a file on a very loaded +NFS server, or to a socket whose other end blocked. (JL, BW) + +7/3/96 (bug fix) Fileevents declared in an interpreter are now deleted +when the channel is closed in that interpreter. Before this fix, the +fileevent would hang around until the channel is completely closed, and +would cause errors if events happened before the channel was closed. This +could happen in two cases: first if the channel is shared between several +interpreters, and second if an async flush is in progress that prevents the +channel from being closed until the flush finishes. (JL) + +7/10/96 (bug fix) Fixed bugs in both "lrange" and "lreplace" commands +where too much white space was being removed. For example, the command + lreplace {\}\ hello} end end +was returning "\}\", losing the significant space in the first list +element and corrupting the list. (JO) + +7/20/96 (bug fix) The procedure pkg_mkIndex didn't work properly for +extensions that depend on Tk, because it didn't load Tk into the child +interpreter before loading the extension. Now it loads Tk if Tk is +present in the parent. (JO) + +7/23/96 (bug fix) Added compat version of strftime to fix crashes +resulting from bad implementations under Windows. (SS) + +7/23/96 (bug fix) Standard implementations of gmtime() and localtime() +under Windows did not handle dates before 1970, so they were replaced +with a revised implementation. (SS) + +7/23/96 (bug fix) Tcl would crash on exit under Borland 5.0 because +the global environ pointer was left pointing to freed memory. (SS) + +7/29/96 (bug fix) Fixed memory leak in Tcl_LoadCmd that could occur if +a package's AppInit procedure called Tcl_StaticPackage to register +static packages. (JO) + +8/1/96 (bug fix) Fixed a series of bugs in Windows sockets so that async +writebehind in the presence of read event handlers now works, and so that +async writebehind also works on sockets for which a read event handler was +declared and whose channels were then closed before the async write +finished. The bug was reported by John Loverso and Steven Wahl, +independently, test case supplied by John Loverso. (JL) + +----------------- Released patch 7.5p1, 8/2/96 ----------------------- + +5/8/96 (API changes) Revised C APIs for channel drivers: + - Removed all Tcl_Files from channel driver interface; you can now have + channels that are not based on Tcl_Files. + - Added channelReadyProc and watchChannelProc procedures to interface; + these are used to implement event notification for channels. + - Added getFileProc to channel driver, to allow the generic IO code + to retrieve a Tcl_File from a channel (presumably if the channel + uses Tcl_Files they will be stored inside its instanceData). (JL) +*** INCOMPATIBILITY with Tcl 7.5 *** + +5/8/96 (API change) The Tcl_CreateChannel C API was modified to not take +Tcl_File arguments, and instead to take a mask specifying whether the +channel is readable and/or writable. (JL) +*** INCOMPATIBILITY with Tcl 7.5 *** + +5/8/96 (new feature) Added Tcl_Ungets C API for putting a sequence of bytes +into a channel's input buffer. This can be used for "push" model channels +where the input is obtained via callbacks instead of by request of the +generic IO code. (JL) + +5/8/96 (new feature) Added Tcl_GetChannelMode C API for retrieving whether +a channel is open for reading and writing. (JL) + +6/3/96 (bug fix) Made Tcl_SetVar2 robust against the case where the value +of the variable is a NULL pointer instead of "". (JL) + +6/17/96 (bug fix) Fixed "reading uninitialized memory" error reported by +Purify, in Tcl_Preserve/Tcl_Release. (JL) + +8/9/96 (bug fix) Fixed bug in init.tcl that caused incorrect error message +if the act of autoloading a procedure caused the procedure to be invoked +again. (JO) + +8/9/96 (bug fix) Configure script produced bad library names and extensions +under SunOS and a few other platforms if the --disable-load switch was used. +(JO) + +8/9/96 (bug fix) Tcl_UpdateLinkedVar generated an error if the variable +being updated was read-only. (JO) + +8/14/96 (bug fix) The macintosh now supports synchronous socket +connections. Other minor bugs were also fixed. (RJ) + +8/15/96 (configuration improvement) Changed the file patchlevel.h +to be tclPatch.h. This avoids conflict with the Tk file and is now +in 8.3 format on the Windows platform. (RJ) + +8/20/96 (bug fix) Fixed core dump in interp alias command for interpreters +created with Tcl_CreateInterp (as opposed to with Tcl_CreateSlave). (JL) + +8/20/96 (bug fix) No longer masking ECONNRESET on Windows sockets so +that the higher level of the IO mechanism sees the error instead of +entering an infinite loop. (JL) + +8/20/96 (bug fix) Destroying the last interpreter no longer closes the +standard channels. (JL) + +8/20/96 (bug fix) Closing one of the stdin, stdout or stderr channels and +then opening a new channel now correctly assigns the new channel as the +standard channel that was closed. (JL) + +8/20/96 (bug fix) Added code to unix/tclUnixChan.c for using ioctl with +FIONBIO instead of fcntl with O_NONBLOCK, for those versions of Unix where +either O_NONBLOCK is not supported or implemented incorrectly. (JL) + +8/21/96 (bug fix) Fixed "file extension" so it correctly returns the +extension on files like "foo..c" as "..c" instead of ".c". (SS) + +8/22/96 (bug fix) If environ[] contains static strings, Tcl would core +dump in TclSetupEnv because it was trying to write NULLs into the actual +data in environ[]. Now we instead copy as appropriate. (JL) + +8/22/96 (added impl) Added missing implementation of Tcl_MakeTcpClientChannel +for Windows platform. Code contributed by Mark Diekhans. (JL) + +8/22/96 (new feature) Added a new memory allocator for the Macintosh +version of Tcl. It's quite a bit faster than MetroWerk's version. (RJ) + +8/26/96 (documentation update) Removed old change bars (for all changes +in Tcl 7.5 and earlier releases) from manual entries. (JO) + +8/27/96 (enhancement) The exec and open commands behave better and work in +more situations under Windows NT and Windows 95. Documentation describes +what is still lacking. (CS) + +8/27/96 (enhancement) The Windows makefiles will now compile even if the +compiler is not in the path and/or the compiler's environment variables +have not been set up. (CS) + +8/27/96 (configuration improvement) The Windows resource files are +automatically updated when the version/patch level changes. The header file +now has a comment that reminds the user which other files must be manually +updated when the version/patch level changes. (CS) + +8/28/96 (new feature) Added file manipulation features (copy, rename, delete, +mkdir) that are supported on all platforms. They are implemented as +subcommands to the "file" command. See the documentation for the "file" +command for more information. (JH) + +----------------- Released 7.6b1, 8/30/96 ----------------------- + +9/3/96 (bug fix) Simplified code so that standard channels are created +lazily, they are added to an interpreter lazily, and they are never added +to a safe interpreter. (JL) + +9/3/96 (bug fix) Closing a channel after closing a standard channel, e.g. +stdout, would cause the implicit recreation of that standard channel. (JL) + +9/3/96 (new feature) Now calling Tcl_RegisterChannel with a NULL +interpreter increments the refcount so that code outside any interpreter +can use channels that are also registered in interpreters, without worrying +that the channel may turn into a dangling pointer at any time. Calling +Tcl_UnregisterChannel with a NULL interpreter only decrements the recount +so that code outside any interpreter can safely declare it is no longer +interested in a channel. (JL) + +9/4/96 (new features) Two changes to dynamic loading: + - If the file name is empty in the "load" command and there is no + statically loaded version of the package, a dynamically loaded + version will be used if there is one. + - Tcl_StaticPackage ignores redundant calls for the same package. (JO) + +9/6/96 (bug fix) Platform specific procedures for manipulating files are +no longer macros and have been prefixed with "Tclp", such as TclpRenameFile. +Unix file code now handles symbolic links and other special files correctly. +The semantics of file copy and file rename has been changed so that if +a target directory exists, the source files will NOT be merged with the +existing files. (JH) + +9/6/96 (bug fix) If standard channel is NULL, because Tcl cannot connect +to the standard channel, do not increment the refcount. The channel can +be NULL if there is for example no standard input. (JL) + +9/6/96 (portability improvement) Changed parsing of backslash sequences +like \n to translate directly to absolute values like 0xa instead of +letting the compiler do the translation. This guarantees that the +translation is done the same everywhere. (JO) + +9/9/96 (bug fix) If channel is opened and not associated with any +interpreter, but Tcl decides to use it as one of the standard channels, it +became impossible to close the channel with Tcl_Close -- instead you had +to call Tcl_UnregisterChannel. Fixed now so that it's safe to call +Tcl_Close even when Tcl is using the channel as one of the standard ones. (JL) + +9/11/96 (feature change) The Tcl library is now placed in the Tcl +shared libraries resource. You no longer need to place the Tcl files +in your applications explicitly. (RJ) + +9/11/96 (feature change) Extensions no longer automatically have the +resource fork of the extension opened for it. Instead you need to +use the tclMacLibrary.c file in your extension. (RJ) +*** POTENTIAL INCOMPATIBILITY *** + +9/12/96 (bug fix) The extension loading mechanism on the Macintosh now +looks at the 'cfrg' resource to determine where to load the code +fragment from. This means FAT fragments should now work. (RJ) + +9/18/96 (enhancement) The exec and open commands behave better and work in +more situations under Windows 3.X. Documentation describes what is still +lacking. (CS) + +9/19/96 (bug fix) Fixed a panic which would occur if you delete a +non-existent alias before any aliases are created. Now instead correctly +returns an error that the alias is not found. (JL) + +9/19/96 (bug fix) Slave interpreters could rename aliases and they would +not get deleted when the alias was being redefined. This led to dangling +pointers etc. (JL) + +9/19/96 (bug fix) Fixed a panic where a hash table entry was being deleted +twice during alias management operations. (JL) + +9/19/96 (bug fix) Fixed bug in event loop that could cause the input focus +in Tk to get confused during menu traversal, among other problems. The +problem was related to handling of the "marker" when its event was +deleted. (JO) + +9/26/96 (bug fix) Windows was losing EOF on a socket if the FD_CLOSE event +happened to precede any left over FD_READ events. Now correctly remembers +seeing FD_CLOSE, so that trailing FD_READ events are not discarded if they +do not contain any data. This allows Tcl to correctly get a zero read and +notice EOF. (JL) + +9/26/96 (bug fix) Was not resetting READABLE state properly on sockets +under Windows if the driver discarded an FD_READ event because no data was +present. Now correctly resets the state. (JL) + +9/30/96 (bug fix) Made EOF sticky on Windows sockets, so that fileevent +readable will fire repeatedly until the socket is closed. Previously the +fileevent fired only once. This could lead to never-closed connections if +the Tcl script in the fileevent wasn't closing the socket immediately. (JL) + +10/2/96 (new feature) Improved the package loader: + - Added new variable tcl_pkgPath, which holds the default + directories under which packages are normally installed (each + package goes in a separate subdirectory of a directory in + $tcl_pkgPath). These directories are included in auto_path by + default. + - Changed the package auto-loader to look for pkgIndex.tcl files + not only in the auto_path directories but also in their immediate + children. This should make it easier to install and uninstall + packages (don't have to change auto_path or merge pkgIndex.tcl + files). (JO) + +10/3/96 (bug fix) Changed tclsh to look for tclshrc.tcl instead of +tclsh.rc on startup under Windows. This is more consistent with wish and +uses the right extension. (SS) +*** POTENTIAL INCOMPATIBILITY *** + +10/8/96 (bug fix) Convertclock does not parse 24-hour times of the +form "hhmm" correctly when hour = 00. In the parse code, hour must be +>= 100 for minutes to be non-zero. Thanks to Lint LaCour for this +bug fix. (RJ) + +10/11/96 (bug fix) Under Windows, the pid command returned the process +handle instead of the process id. (SS) + +----------------- Released 7.6, 10/16/96 ----------------------- diff --git a/tcl7.3/compat/README b/tcl7.6/compat/README similarity index 88% rename from tcl7.3/compat/README rename to tcl7.6/compat/README index 9af4285..4ed8e54 100644 --- a/tcl7.3/compat/README +++ b/tcl7.6/compat/README @@ -4,3 +4,5 @@ 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. + +sccsid = SCCS: @(#) README 1.3 96/02/16 08:56:51 diff --git a/tcl7.6/compat/dirent.h b/tcl7.6/compat/dirent.h new file mode 100644 index 0000000..081376b --- /dev/null +++ b/tcl7.6/compat/dirent.h @@ -0,0 +1,23 @@ +/* + * dirent.h -- + * + * This file is a replacement for in systems that + * support the old BSD-style with a "struct direct". + * + * Copyright (c) 1991 The Regents of the University of California. + * Copyright (c) 1994 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) dirent.h 1.4 96/02/15 14:43:50 + */ + +#ifndef _DIRENT +#define _DIRENT + +#include + +#define dirent direct + +#endif /* _DIRENT */ diff --git a/tcl7.3/compat/dirent2.h b/tcl7.6/compat/dirent2.h similarity index 51% rename from tcl7.3/compat/dirent2.h rename to tcl7.6/compat/dirent2.h index 2f61c35..585a7e8 100644 --- a/tcl7.3/compat/dirent2.h +++ b/tcl7.6/compat/dirent2.h @@ -5,26 +5,12 @@ * in the POSIX style ("struct dirent"). * * Copyright (c) 1991 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1994 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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) + * SCCS: @(#) dirent2.h 1.4 96/02/15 14:43:51 */ #ifndef _DIRENT diff --git a/tcl7.6/compat/dlfcn.h b/tcl7.6/compat/dlfcn.h new file mode 100644 index 0000000..cf02fb9 --- /dev/null +++ b/tcl7.6/compat/dlfcn.h @@ -0,0 +1,65 @@ +/* + * dlfcn.h -- + * + * This file provides a replacement for the header file "dlfcn.h" + * on systems where dlfcn.h is missing. It's primary use is for + * AIX, where Tcl emulates the dl library. + * + * This file is subject to the following copyright notice, which is + * different from the notice used elsewhere in Tcl but rougly + * equivalent in meaning. + * + * Copyright (c) 1992,1993,1995,1996, Jens-Uwe Mager, Helios Software GmbH + * Not derived from licensed software. + * + * Permission is granted to freely use, copy, modify, and redistribute + * this software, provided that the author is not construed to be liable + * for any results of using the software, alterations are clearly marked + * as such, and this notice is not modified. + * + * SCCS: @(#) dlfcn.h 1.4 96/09/17 09:05:59 + */ + +/* + * @(#)dlfcn.h 1.4 revision of 95/04/25 09:36:52 + * This is an unpublished work copyright (c) 1992 HELIOS Software GmbH + * 30159 Hannover, Germany + */ + +#ifndef __dlfcn_h__ +#define __dlfcn_h__ + +#ifndef _TCL +#include +#endif + +#ifdef __cplusplus +extern "C" { +#endif + +/* + * Mode flags for the dlopen routine. + */ +#define RTLD_LAZY 1 /* lazy function call binding */ +#define RTLD_NOW 2 /* immediate function call binding */ +#define RTLD_GLOBAL 0x100 /* allow symbols to be global */ + +/* + * To be able to intialize, a library may provide a dl_info structure + * that contains functions to be called to initialize and terminate. + */ +struct dl_info { + void (*init) _ANSI_ARGS_((void)); + void (*fini) _ANSI_ARGS_((void)); +}; + +VOID *dlopen _ANSI_ARGS_((const char *path, int mode)); +VOID *dlsym _ANSI_ARGS_((void *handle, const char *symbol)); +char *dlerror _ANSI_ARGS_((void)); +int dlclose _ANSI_ARGS_((void *handle)); + +#ifdef __cplusplus +} +#endif + +#endif /* __dlfcn_h__ */ diff --git a/tcl7.6/compat/fixstrtod.c b/tcl7.6/compat/fixstrtod.c new file mode 100644 index 0000000..2655767 --- /dev/null +++ b/tcl7.6/compat/fixstrtod.c @@ -0,0 +1,38 @@ +/* + * fixstrtod.c -- + * + * Source code for the "fixstrtod" procedure. This procedure is + * used in place of strtod under Solaris 2.4, in order to fix + * a bug where the "end" pointer gets set incorrectly. + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) fixstrtod.c 1.5 96/02/15 12:08:21 + */ + +#include + +#undef strtod + +/* + * Declare strtod explicitly rather than including stdlib.h, since in + * somes systems (e.g. SunOS 4.1.4) stdlib.h doesn't declare strtod. + */ + +extern double strtod(); + +double +fixstrtod(string, endPtr) + char *string; + char **endPtr; +{ + double d; + d = strtod(string, endPtr); + if ((endPtr != NULL) && (*endPtr != string) && ((*endPtr)[-1] == 0)) { + *endPtr -= 1; + } + return d; +} diff --git a/tcl7.6/compat/float.h b/tcl7.6/compat/float.h new file mode 100644 index 0000000..06db4fd --- /dev/null +++ b/tcl7.6/compat/float.h @@ -0,0 +1,16 @@ +/* + * 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. + * Copyright (c) 1994 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) float.h 1.3 96/02/15 14:43:52 + */ diff --git a/tcl7.6/compat/getcwd.c b/tcl7.6/compat/getcwd.c new file mode 100644 index 0000000..e4340c1 --- /dev/null +++ b/tcl7.6/compat/getcwd.c @@ -0,0 +1,47 @@ +/* + * 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. + * Copyright (c) 1994 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) getcwd.c 1.5 96/02/15 12:08:20 + */ + +#include "tclInt.h" +#include "tclPort.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/tcl7.6/compat/gettod.c b/tcl7.6/compat/gettod.c new file mode 100644 index 0000000..4110262 --- /dev/null +++ b/tcl7.6/compat/gettod.c @@ -0,0 +1,32 @@ +/* + * gettod.c -- + * + * This file provides the gettimeofday function on systems + * that only have the System V ftime function. + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) gettod.c 1.2 96/02/15 12:08:26 + */ + +#include "tcl.h" +#include "tclPort.h" +#include + +#undef timezone + +int +gettimeofday(tp, tz) +struct timeval *tp; +struct timezone *tz; +{ + struct timeb t; + ftime(&t); + tp->tv_sec = t.time; + tp->tv_usec = t. millitm * 1000; + return 0; +} + diff --git a/tcl7.6/compat/license.terms b/tcl7.6/compat/license.terms new file mode 100644 index 0000000..96ad966 --- /dev/null +++ b/tcl7.6/compat/license.terms @@ -0,0 +1,39 @@ +This software is copyrighted by the Regents of the University of +California, Sun Microsystems, Inc., and other parties. The following +terms apply to all files associated with the software unless explicitly +disclaimed in individual files. + +The authors hereby grant permission to use, copy, modify, distribute, +and license this software and its documentation for any purpose, provided +that existing copyright notices are retained in all copies and that this +notice is included verbatim in any distributions. No written agreement, +license, or royalty fee is required for any of the authorized uses. +Modifications to this software may be copyrighted by their authors +and need not follow the licensing terms described here, provided that +the new terms are clearly indicated on the first page of each file where +they apply. + +IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY +FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES +ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY +DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + +THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE +IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE +NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR +MODIFICATIONS. + +GOVERNMENT USE: If you are acquiring this software on behalf of the +U.S. government, the Government shall have only "Restricted Rights" +in the software and related documentation as defined in the Federal +Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you +are acquiring the software on behalf of the Department of Defense, the +software shall be classified as "Commercial Computer Software" and the +Government shall have only "Restricted Rights" as defined in Clause +252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the +authors grant the U.S. Government and others acting in its behalf +permission to use and distribute the software in accordance with the +terms specified in this license. diff --git a/tcl7.6/compat/limits.h b/tcl7.6/compat/limits.h new file mode 100644 index 0000000..66eb542 --- /dev/null +++ b/tcl7.6/compat/limits.h @@ -0,0 +1,22 @@ +/* + * 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 tclPort.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. + * Copyright (c) 1994 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) limits.h 1.7 96/02/15 14:43:55 + */ + +#define LONG_MIN 0x80000000 +#define LONG_MAX 0x7fffffff +#define INT_MIN 0x80000000 +#define INT_MAX 0x7fffffff diff --git a/tcl7.3/compat/opendir.c b/tcl7.6/compat/opendir.c similarity index 96% rename from tcl7.3/compat/opendir.c rename to tcl7.6/compat/opendir.c index 5602350..b1a47ff 100644 --- a/tcl7.3/compat/opendir.c +++ b/tcl7.6/compat/opendir.c @@ -6,10 +6,12 @@ * origin of this code is unclear, but it seems to have come * originally from Larry Wall. * + * + * SCCS: @(#) opendir.c 1.3 96/02/15 12:08:21 */ #include "tclInt.h" -#include "tclUnix.h" +#include "tclPort.h" #undef DIRSIZ #define DIRSIZ(dp) \ diff --git a/tcl7.3/compat/stdlib.h b/tcl7.6/compat/stdlib.h similarity index 56% rename from tcl7.3/compat/stdlib.h rename to tcl7.6/compat/stdlib.h index 9aec51a..059ea29 100644 --- a/tcl7.3/compat/stdlib.h +++ b/tcl7.6/compat/stdlib.h @@ -9,26 +9,12 @@ * declare all the procedures needed here (such as strtod). * * Copyright (c) 1991 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1994 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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) + * SCCS: @(#) stdlib.h 1.10 96/02/15 14:43:54 */ #ifndef _STDLIB diff --git a/tcl7.6/compat/strftime.c b/tcl7.6/compat/strftime.c new file mode 100644 index 0000000..9b51e96 --- /dev/null +++ b/tcl7.6/compat/strftime.c @@ -0,0 +1,382 @@ +/* + * strftime.c -- + * + * This file contains a modified version of the BSD 4.4 strftime + * function. + * + * This file is a modified version of the strftime.c file from the BSD 4.4 + * source. See the copyright notice below for details on redistribution + * restrictions. The "license.terms" file does not apply to this file. + * + * SCCS: @(#) strftime.c 1.3 96/09/12 14:52:02 + */ + +/* + * Copyright (c) 1989 The Regents of the University of California. + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * 3. All advertising materials mentioning features or use of this software + * must display the following acknowledgement: + * This product includes software developed by the University of + * California, Berkeley and its contributors. + * 4. Neither the name of the University nor the names of its contributors + * may be used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE + * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + * SUCH DAMAGE. + */ + +#if defined(LIBC_SCCS) && !defined(lint) +/*static char *sccsid = "from: @(#)strftime.c 5.11 (Berkeley) 2/24/91";*/ +static char *rcsid = "$Id: strftime.c,v 1.10.4.1 1996/06/01 22:00:41 jtc Exp $"; +#endif /* LIBC_SCCS and not lint */ + +#include +#include +#include +#include "tclInt.h" + +#define TM_YEAR_BASE 1900 + +typedef struct { + const char *abday[7]; + const char *day[7]; + const char *abmon[12]; + const char *mon[12]; + const char *am_pm[2]; + const char *d_t_fmt; + const char *d_fmt; + const char *t_fmt; + const char *t_fmt_ampm; +} _TimeLocale; + +static const _TimeLocale _DefaultTimeLocale = +{ + { + "Sun","Mon","Tue","Wed","Thu","Fri","Sat", + }, + { + "Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", + "Friday", "Saturday" + }, + { + "Jan", "Feb", "Mar", "Apr", "May", "Jun", + "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" + }, + { + "January", "February", "March", "April", "May", "June", "July", + "August", "September", "October", "November", "December" + }, + { + "AM", "PM" + }, + "%a %b %d %H:%M:%S %Y", + "%m/%d/%y", + "%H:%M:%S", + "%I:%M:%S %p" +}; + +static const _TimeLocale *_CurrentTimeLocale = &_DefaultTimeLocale; + +static size_t gsize; +static char *pt; +static int _add _ANSI_ARGS_((const char* str)); +static int _conv _ANSI_ARGS_((int n, int digits, int pad)); +static int _secs _ANSI_ARGS_((const struct tm *t)); +static size_t _fmt _ANSI_ARGS_((const char *format, + const struct tm *t)); + +size_t +TclStrftime(s, maxsize, format, t) + char *s; + size_t maxsize; + const char *format; + const struct tm *t; +{ + tzset(); + + pt = s; + if ((gsize = maxsize) < 1) + return(0); + if (_fmt(format, t)) { + *pt = '\0'; + return(maxsize - gsize); + } + return(0); +} + +#define SUN_WEEK(t) (((t)->tm_yday + 7 - \ + ((t)->tm_wday)) / 7) +#define MON_WEEK(t) (((t)->tm_yday + 7 - \ + ((t)->tm_wday ? (t)->tm_wday - 1 : 6)) / 7) + +static size_t +_fmt(format, t) + const char *format; + const struct tm *t; +{ + for (; *format; ++format) { + if (*format == '%') { + ++format; + if (*format == 'E') { + /* Alternate Era */ + ++format; + } else if (*format == 'O') { + /* Alternate numeric symbols */ + ++format; + } + switch(*format) { + case '\0': + --format; + break; + case 'A': + if (t->tm_wday < 0 || t->tm_wday > 6) + return(0); + if (!_add(_CurrentTimeLocale->day[t->tm_wday])) + return(0); + continue; + case 'a': + if (t->tm_wday < 0 || t->tm_wday > 6) + return(0); + if (!_add(_CurrentTimeLocale->abday[t->tm_wday])) + return(0); + continue; + case 'B': + if (t->tm_mon < 0 || t->tm_mon > 11) + return(0); + if (!_add(_CurrentTimeLocale->mon[t->tm_mon])) + return(0); + continue; + case 'b': + case 'h': + if (t->tm_mon < 0 || t->tm_mon > 11) + return(0); + if (!_add(_CurrentTimeLocale->abmon[t->tm_mon])) + return(0); + continue; + case 'C': + if (!_conv((t->tm_year + TM_YEAR_BASE) / 100, + 2, '0')) + return(0); + continue; + case 'c': + if (!_fmt(_CurrentTimeLocale->d_t_fmt, t)) + return(0); + continue; + case 'D': + if (!_fmt("%m/%d/%y", t)) + return(0); + continue; + case 'd': + if (!_conv(t->tm_mday, 2, '0')) + return(0); + continue; + case 'e': + if (!_conv(t->tm_mday, 2, ' ')) + return(0); + continue; + case 'H': + if (!_conv(t->tm_hour, 2, '0')) + return(0); + continue; + case 'I': + if (!_conv(t->tm_hour % 12 ? + t->tm_hour % 12 : 12, 2, '0')) + return(0); + continue; + case 'j': + if (!_conv(t->tm_yday + 1, 3, '0')) + return(0); + continue; + case 'k': + if (!_conv(t->tm_hour, 2, ' ')) + return(0); + continue; + case 'l': + if (!_conv(t->tm_hour % 12 ? + t->tm_hour % 12: 12, 2, ' ')) + return(0); + continue; + case 'M': + if (!_conv(t->tm_min, 2, '0')) + return(0); + continue; + case 'm': + if (!_conv(t->tm_mon + 1, 2, '0')) + return(0); + continue; + case 'n': + if (!_add("\n")) + return(0); + continue; + case 'p': + if (!_add(_CurrentTimeLocale->am_pm[t->tm_hour >= 12])) + return(0); + continue; + case 'R': + if (!_fmt("%H:%M", t)) + return(0); + continue; + case 'r': + if (!_fmt(_CurrentTimeLocale->t_fmt_ampm, t)) + return(0); + continue; + case 'S': + if (!_conv(t->tm_sec, 2, '0')) + return(0); + continue; + case 's': + if (!_secs(t)) + return(0); + continue; + case 'T': + if (!_fmt("%H:%M:%S", t)) + return(0); + continue; + case 't': + if (!_add("\t")) + return(0); + continue; + case 'U': + if (!_conv(SUN_WEEK(t), 2, '0')) + return(0); + continue; + case 'u': + if (!_conv(t->tm_wday ? t->tm_wday : 7, 1, '0')) + return(0); + continue; + case 'V': + { + /* ISO 8601 Week Of Year: + If the week (Monday - Sunday) containing + January 1 has four or more days in the new + year, then it is week 1; otherwise it is + week 53 of the previous year and the next + week is week one. */ + + int week = MON_WEEK(t); + + int days = (((t)->tm_yday + 7 - \ + ((t)->tm_wday ? (t)->tm_wday - 1 : 6)) % 7); + + + if (days >= 4) { + week++; + } else if (week == 0) { + week = 53; + } + + if (!_conv(week, 2, '0')) + return(0); + continue; + } + case 'W': + if (!_conv(MON_WEEK(t), 2, '0')) + return(0); + continue; + case 'w': + if (!_conv(t->tm_wday, 1, '0')) + return(0); + continue; + case 'x': + if (!_fmt(_CurrentTimeLocale->d_fmt, t)) + return(0); + continue; + case 'X': + if (!_fmt(_CurrentTimeLocale->t_fmt, t)) + return(0); + continue; + case 'y': + if (!_conv((t->tm_year + TM_YEAR_BASE) % 100, + 2, '0')) + return(0); + continue; + case 'Y': + if (!_conv((t->tm_year + TM_YEAR_BASE), 4, '0')) + return(0); + continue; + case 'Z': { + char *name = TclpGetTZName(); + if (name && !_add(name)) { + return 0; + } + continue; + } + case '%': + /* + * X311J/88-090 (4.12.3.5): if conversion char is + * undefined, behavior is undefined. Print out the + * character itself as printf(3) does. + */ + default: + break; + } + } + if (!gsize--) + return(0); + *pt++ = *format; + } + return(gsize); +} + +static int +_secs(t) + const struct tm *t; +{ + static char buf[15]; + register time_t s; + register char *p; + struct tm tmp; + + /* Make a copy, mktime(3) modifies the tm struct. */ + tmp = *t; + s = mktime(&tmp); + for (p = buf + sizeof(buf) - 2; s > 0 && p > buf; s /= 10) + *p-- = (char)(s % 10 + '0'); + return(_add(++p)); +} + +static int +_conv(n, digits, pad) + int n, digits; + int pad; +{ + static char buf[10]; + register char *p; + + for (p = buf + sizeof(buf) - 2; n > 0 && p > buf; n /= 10, --digits) + *p-- = (char)(n % 10 + '0'); + while (p > buf && digits-- > 0) + *p-- = (char) pad; + return(_add(++p)); +} + +static int +_add(str) + const char *str; +{ + for (;; ++pt, --gsize) { + if (!gsize) + return(0); + if (!(*pt = *str++)) + return(1); + } +} diff --git a/tcl7.3/compat/string.h b/tcl7.6/compat/string.h similarity index 66% rename from tcl7.3/compat/string.h rename to tcl7.6/compat/string.h index 863961f..541e159 100644 --- a/tcl7.3/compat/string.h +++ b/tcl7.6/compat/string.h @@ -4,26 +4,12 @@ * Declarations of ANSI C library procedures for string handling. * * Copyright (c) 1991-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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) + * SCCS: @(#) string.h 1.13 96/04/09 22:14:53 */ #ifndef _STRING @@ -38,7 +24,9 @@ * it exists everywhere) */ +#ifndef MAC_TCL #include +#endif extern char * memchr _ANSI_ARGS_((CONST VOID *s, int c, size_t n)); extern int memcmp _ANSI_ARGS_((CONST VOID *s1, CONST VOID *s2, diff --git a/tcl7.6/compat/strncasecmp.c b/tcl7.6/compat/strncasecmp.c new file mode 100644 index 0000000..9750d02 --- /dev/null +++ b/tcl7.6/compat/strncasecmp.c @@ -0,0 +1,142 @@ +/* + * strncasecmp.c -- + * + * Source code for the "strncasecmp" library routine. + * + * Copyright (c) 1988-1993 The Regents of the University of California. + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) strncasecmp.c 1.6 96/09/13 15:21:37 + */ + +#include "tclPort.h" + +/* + * This array is designed for mapping upper and lower case letter + * together for a case independent comparison. The mappings are + * based upon ASCII character sequences. + */ + +static unsigned char charmap[] = { + 0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, + 0x08, 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f, + 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, + 0x18, 0x19, 0x1a, 0x1b, 0x1c, 0x1d, 0x1e, 0x1f, + 0x20, 0x21, 0x22, 0x23, 0x24, 0x25, 0x26, 0x27, + 0x28, 0x29, 0x2a, 0x2b, 0x2c, 0x2d, 0x2e, 0x2f, + 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, + 0x38, 0x39, 0x3a, 0x3b, 0x3c, 0x3d, 0x3e, 0x3f, + 0x40, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, + 0x68, 0x69, 0x6a, 0x6b, 0x6c, 0x6d, 0x6e, 0x6f, + 0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77, + 0x78, 0x79, 0x7a, 0x5b, 0x5c, 0x5d, 0x5e, 0x5f, + 0x60, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, + 0x68, 0x69, 0x6a, 0x6b, 0x6c, 0x6d, 0x6e, 0x6f, + 0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77, + 0x78, 0x79, 0x7a, 0x7b, 0x7c, 0x7d, 0x7e, 0x7f, + 0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87, + 0x88, 0x89, 0x8a, 0x8b, 0x8c, 0x8d, 0x8e, 0x8f, + 0x90, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96, 0x97, + 0x98, 0x99, 0x9a, 0x9b, 0x9c, 0x9d, 0x9e, 0x9f, + 0xa0, 0xa1, 0xa2, 0xa3, 0xa4, 0xa5, 0xa6, 0xa7, + 0xa8, 0xa9, 0xaa, 0xab, 0xac, 0xad, 0xae, 0xaf, + 0xb0, 0xb1, 0xb2, 0xb3, 0xb4, 0xb5, 0xb6, 0xb7, + 0xb8, 0xb9, 0xba, 0xbb, 0xbc, 0xbd, 0xbe, 0xbf, + 0xc0, 0xe1, 0xe2, 0xe3, 0xe4, 0xc5, 0xe6, 0xe7, + 0xe8, 0xe9, 0xea, 0xeb, 0xec, 0xed, 0xee, 0xef, + 0xf0, 0xf1, 0xf2, 0xf3, 0xf4, 0xf5, 0xf6, 0xf7, + 0xf8, 0xf9, 0xfa, 0xdb, 0xdc, 0xdd, 0xde, 0xdf, + 0xe0, 0xe1, 0xe2, 0xe3, 0xe4, 0xe5, 0xe6, 0xe7, + 0xe8, 0xe9, 0xea, 0xeb, 0xec, 0xed, 0xee, 0xef, + 0xf0, 0xf1, 0xf2, 0xf3, 0xf4, 0xf5, 0xf6, 0xf7, + 0xf8, 0xf9, 0xfa, 0xfb, 0xfc, 0xfd, 0xfe, 0xff, +}; + +/* + * Here are the prototypes just in case they are not included + * in tclPort.h. + */ +int strncasecmp _ANSI_ARGS_((CONST char *s1, + CONST char *s2, size_t n)); + +int strcasecmp _ANSI_ARGS_((CONST char *s1, + CONST char *s2, size_t n)); + +/* + *---------------------------------------------------------------------- + * + * strcasecmp -- + * + * Compares two strings, ignoring case differences. + * + * Results: + * Compares two null-terminated strings s1 and s2, returning -1, 0, + * or 1 if s1 is lexicographically less than, equal to, or greater + * than s2. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +strcasecmp(s1, s2) + CONST char *s1; /* First string. */ + CONST char *s2; /* Second string. */ +{ + unsigned char u1, u2; + + for ( ; ; s1++, s2++) { + u1 = (unsigned char) *s1; + u2 = (unsigned char) *s2; + if ((u1 == '\0') || (charmap[u1] != charmap[u2])) { + break; + } + } + return charmap[u1] - charmap[u2]; +} + +/* + *---------------------------------------------------------------------- + * + * strncasecmp -- + * + * Compares two strings, ignoring case differences. + * + * Results: + * Compares up to length chars of s1 and s2, returning -1, 0, or 1 + * if s1 is lexicographically less than, equal to, or greater + * than s2 over those characters. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +strncasecmp(s1, s2, length) + CONST char *s1; /* First string. */ + CONST char *s2; /* Second string. */ + size_t length; /* Maximum number of characters to compare + * (stop earlier if the end of either string + * is reached). */ +{ + unsigned char u1, u2; + + for (; length != 0; length--, s1++, s2++) { + u1 = (unsigned char) *s1; + u2 = (unsigned char) *s2; + if (charmap[u1] != charmap[u2]) { + return charmap[u1] - charmap[u2]; + } + if (u1 == '\0') { + return 0; + } + } + return 0; +} diff --git a/tcl7.3/compat/strstr.c b/tcl7.6/compat/strstr.c similarity index 53% rename from tcl7.3/compat/strstr.c rename to tcl7.6/compat/strstr.c index 4fd5e1b..59296db 100644 --- a/tcl7.3/compat/strstr.c +++ b/tcl7.6/compat/strstr.c @@ -4,30 +4,14 @@ * Source code for the "strstr" library routine. * * Copyright (c) 1988-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1994 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) strstr.c 1.4 96/02/15 12:08:22 */ -#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 */ - /* *---------------------------------------------------------------------- * diff --git a/tcl7.3/compat/strtod.c b/tcl7.6/compat/strtod.c similarity index 82% rename from tcl7.3/compat/strtod.c rename to tcl7.6/compat/strtod.c index eb4b323..3766639 100644 --- a/tcl7.3/compat/strtod.c +++ b/tcl7.6/compat/strtod.c @@ -4,30 +4,14 @@ * Source code for the "strtod" library procedure. * * Copyright (c) 1988-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1994 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) strtod.c 1.8 96/02/15 12:08:23 */ -#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" diff --git a/tcl7.3/compat/strtol.c b/tcl7.6/compat/strtol.c similarity index 59% rename from tcl7.3/compat/strtol.c rename to tcl7.6/compat/strtol.c index b5341a7..c781bd6 100644 --- a/tcl7.3/compat/strtol.c +++ b/tcl7.6/compat/strtol.c @@ -4,30 +4,14 @@ * Source code for the "strtol" library procedure. * * Copyright (c) 1988 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1994 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) strtol.c 1.4 96/02/15 12:08:23 */ -#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 diff --git a/tcl7.3/compat/strtoul.c b/tcl7.6/compat/strtoul.c similarity index 76% rename from tcl7.3/compat/strtoul.c rename to tcl7.6/compat/strtoul.c index 8981e2c..37fe490 100644 --- a/tcl7.3/compat/strtoul.c +++ b/tcl7.6/compat/strtoul.c @@ -4,30 +4,14 @@ * Source code for the "strtoul" library procedure. * * Copyright (c) 1988 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1994 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) strtoul.c 1.5 96/02/15 12:08:24 */ -#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 /* diff --git a/tcl7.6/compat/tclErrno.h b/tcl7.6/compat/tclErrno.h new file mode 100644 index 0000000..bc45481 --- /dev/null +++ b/tcl7.6/compat/tclErrno.h @@ -0,0 +1,100 @@ +/* + * tclErrno.h -- + * + * This header file contains the various POSIX errno definitions that + * are used by Tcl. This file is derived from the spec POSIX 2.4 and + * previous implementations for Berkeley UNIX. + * + * Copyright (c) 1982, 1986, 1989 Regents of the University of California. + * Copyright (c) 1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclErrno.h 1.1 96/04/29 15:25:31 + */ + +extern int errno; /* global error number */ + +#define EPERM 1 /* Operation not permitted */ +#define ENOENT 2 /* No such file or directory */ +#define ESRCH 3 /* No such process */ +#define EINTR 4 /* Interrupted system call */ +#define EIO 5 /* Input/output error */ +#define ENXIO 6 /* Device not configured */ +#define E2BIG 7 /* Argument list too long */ +#define ENOEXEC 8 /* Exec format error */ +#define EBADF 9 /* Bad file descriptor */ +#define ECHILD 10 /* No child processes */ +#define EDEADLK 11 /* Resource deadlock avoided */ + /* 11 was EAGAIN */ +#define ENOMEM 12 /* Cannot allocate memory */ +#define EACCES 13 /* Permission denied */ +#define EFAULT 14 /* Bad address */ +#define ENOTBLK 15 /* Block device required */ +#define EBUSY 16 /* Device busy */ +#define EEXIST 17 /* File exists */ +#define EXDEV 18 /* Cross-device link */ +#define ENODEV 19 /* Operation not supported by device */ +#define ENOTDIR 20 /* Not a directory */ +#define EISDIR 21 /* Is a directory */ +#define EINVAL 22 /* Invalid argument */ +#define ENFILE 23 /* Too many open files in system */ +#define EMFILE 24 /* Too many open files */ +#define ENOTTY 25 /* Inappropriate ioctl for device */ +#define ETXTBSY 26 /* Text file busy */ +#define EFBIG 27 /* File too large */ +#define ENOSPC 28 /* No space left on device */ +#define ESPIPE 29 /* Illegal seek */ +#define EROFS 30 /* Read-only file system */ +#define EMLINK 31 /* Too many links */ +#define EPIPE 32 /* Broken pipe */ +#define EDOM 33 /* Numerical argument out of domain */ +#define ERANGE 34 /* Result too large */ +#define EAGAIN 35 /* Resource temporarily unavailable */ +#define EWOULDBLOCK EAGAIN /* Operation would block */ +#define EINPROGRESS 36 /* Operation now in progress */ +#define EALREADY 37 /* Operation already in progress */ +#define ENOTSOCK 38 /* Socket operation on non-socket */ +#define EDESTADDRREQ 39 /* Destination address required */ +#define EMSGSIZE 40 /* Message too long */ +#define EPROTOTYPE 41 /* Protocol wrong type for socket */ +#define ENOPROTOOPT 42 /* Protocol not available */ +#define EPROTONOSUPPORT 43 /* Protocol not supported */ +#define ESOCKTNOSUPPORT 44 /* Socket type not supported */ +#define EOPNOTSUPP 45 /* Operation not supported on socket */ +#define EPFNOSUPPORT 46 /* Protocol family not supported */ +#define EAFNOSUPPORT 47 /* Address family not supported by protocol family */ +#define EADDRINUSE 48 /* Address already in use */ +#define EADDRNOTAVAIL 49 /* Can't assign requested address */ +#define ENETDOWN 50 /* Network is down */ +#define ENETUNREACH 51 /* Network is unreachable */ +#define ENETRESET 52 /* Network dropped connection on reset */ +#define ECONNABORTED 53 /* Software caused connection abort */ +#define ECONNRESET 54 /* Connection reset by peer */ +#define ENOBUFS 55 /* No buffer space available */ +#define EISCONN 56 /* Socket is already connected */ +#define ENOTCONN 57 /* Socket is not connected */ +#define ESHUTDOWN 58 /* Can't send after socket shutdown */ +#define ETOOMANYREFS 59 /* Too many references: can't splice */ +#define ETIMEDOUT 60 /* Connection timed out */ +#define ECONNREFUSED 61 /* Connection refused */ +#define ELOOP 62 /* Too many levels of symbolic links */ +#define ENAMETOOLONG 63 /* File name too long */ +#define EHOSTDOWN 64 /* Host is down */ +#define EHOSTUNREACH 65 /* No route to host */ +#define ENOTEMPTY 66 /* Directory not empty */ +#define EPROCLIM 67 /* Too many processes */ +#define EUSERS 68 /* Too many users */ +#define EDQUOT 69 /* Disc quota exceeded */ +#define ESTALE 70 /* Stale NFS file handle */ +#define EREMOTE 71 /* Too many levels of remote in path */ +#define EBADRPC 72 /* RPC struct is bad */ +#define ERPCMISMATCH 73 /* RPC version wrong */ +#define EPROGUNAVAIL 74 /* RPC prog. not avail */ +#define EPROGMISMATCH 75 /* Program version wrong */ +#define EPROCUNAVAIL 76 /* Bad procedure for program */ +#define ENOLCK 77 /* No locks available */ +#define ENOSYS 78 /* Function not implemented */ +#define EFTYPE 79 /* Inappropriate file type or format */ + diff --git a/tcl7.3/compat/tmpnam.c b/tcl7.6/compat/tmpnam.c similarity index 87% rename from tcl7.3/compat/tmpnam.c rename to tcl7.6/compat/tmpnam.c index 4807471..c29a1e3 100644 --- a/tcl7.3/compat/tmpnam.c +++ b/tcl7.6/compat/tmpnam.c @@ -8,12 +8,10 @@ * 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. + * + * SCCS: @(#) tmpnam.c 1.3 96/02/15 12:08:25 */ -#if defined(LIBC_SCCS) && !defined(lint) -static char sccsid[] = "@(#)tmpnam.c 4.4 (Berkeley) 6/8/88"; -#endif /* LIBC_SCCS and not lint */ - #include #include #include @@ -25,6 +23,9 @@ static char sccsid[] = "@(#)tmpnam.c 4.4 (Berkeley) 6/8/88"; * buffer overflows. */ +#ifdef P_tmpdir +# undef P_tmpdir +#endif #define P_tmpdir "/tmp" char * diff --git a/tcl7.3/compat/unistd.h b/tcl7.6/compat/unistd.h similarity index 96% rename from tcl7.3/compat/unistd.h rename to tcl7.6/compat/unistd.h index 0158c7a..3af430c 100644 --- a/tcl7.3/compat/unistd.h +++ b/tcl7.6/compat/unistd.h @@ -12,7 +12,7 @@ * 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 $ + * SCCS: @(#) unistd.h 1.7 96/02/15 14:43:57 */ #ifndef _UNISTD @@ -69,6 +69,7 @@ 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 ioctl _ANSI_ARGS_((int fd, int request, ...)); 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)); diff --git a/tcl7.3/compat/waitpid.c b/tcl7.6/compat/waitpid.c similarity index 78% rename from tcl7.3/compat/waitpid.c rename to tcl7.6/compat/waitpid.c index dd9713f..179d5de 100644 --- a/tcl7.3/compat/waitpid.c +++ b/tcl7.6/compat/waitpid.c @@ -7,32 +7,16 @@ * Mark Diekhans and Karl Lehenbauer. * * Copyright (c) 1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1994 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) waitpid.c 1.9 96/02/15 12:08:26 */ -#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" +#include "tclPort.h" /* * A linked list of the following structures is used to keep track diff --git a/tcl7.3/doc/AddErrInfo.3 b/tcl7.6/doc/AddErrInfo.3 similarity index 77% rename from tcl7.3/doc/AddErrInfo.3 rename to tcl7.6/doc/AddErrInfo.3 index 0ed3da3..8c01bae 100644 --- a/tcl7.3/doc/AddErrInfo.3 +++ b/tcl7.6/doc/AddErrInfo.3 @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/AddErrInfo.3,v 1.15 93/04/08 13:54:29 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) AddErrInfo.3 1.22 96/08/26 12:59:39 '\" .so man.macros -.HS Tcl_AddErrorInfo tclc +.TH Tcl_AddErrorInfo 3 7.5 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_AddErrorInfo, Tcl_SetErrorCode, Tcl_PosixError \- record information about errors @@ -48,7 +35,7 @@ Last \fIelement\fR argument must be NULL. .SH DESCRIPTION .PP -These procedures are used to manipulate two global variables +These procedures are used to manipulate two Tcl 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 @@ -56,9 +43,7 @@ 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 @@ -103,13 +88,16 @@ 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 +\fBTcl_SetErrorCode\fR to set \fBerrorCode\fR in the \fBPOSIX\fR format. +The caller must previously have called \fBTcl_SetErrno\fR to set +\fBerrno\fR; this is necessary on some platforms (e.g. Windows) where Tcl +is linked into an application as a shared library, or when the error +occurs in a dynamically loaded extension. See the manual entry for +\fBTcl_SetErrno\fR for more information. +.PP +\fBTcl_PosixError\fR returns a human-readable 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 @@ -137,7 +125,7 @@ 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 +Tcl_Interp, Tcl_ResetResult, Tcl_SetErrno .SH KEYWORDS error, stack, trace, variable diff --git a/tcl7.6/doc/Alloc.3 b/tcl7.6/doc/Alloc.3 new file mode 100644 index 0000000..2f1fd5a --- /dev/null +++ b/tcl7.6/doc/Alloc.3 @@ -0,0 +1,52 @@ +'\" +'\" Copyright (c) 1995-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) Alloc.3 1.2 96/06/05 18:00:19 +'\" +.so man.macros +.TH Tcl_Alloc 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_Alloc, Tcl_Free, Tcl_Realloc \- allocate or free heap memory +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +char * +\fBTcl_Alloc\fR(\fIsize\fR) +.sp +\fBTcl_Free\fR(\fIptr\fR) +.sp +char * +\fBTcl_Realloc\fR(\fIptr, size\fR) +.SH ARGUMENTS +.AS char *size +.AP int size in +Size in bytes of the memory block to allocate. +.AP char *ptr in +Pointer to memory block to free or realloc. +.BE + +.SH DESCRIPTION +.PP +These procedures provide a platform and compiler independent interface +for memory allocation. Programs that need to transfer ownership of +memory blocks between Tcl and other modules should use these routines +rather than the native \fBmalloc()\fR and \fBfree()\fR routines +provided by the C run-time library. +.PP +\fBTcl_Alloc\fR returns a pointer to a block of at least \fIsize\fR +bytes suitably aligned for any use. +.PP +\fBTcl_Free\fR makes the space referred to by \fIptr\fR available for +further allocation. +.PP +\fBTcl_Realloc\fR changes the size of the block pointed to by +\fIptr\fR to \fIsize\fR bytes and returns a pointer to the new block. +The contents will be unchanged up to the lesser of the new and old +sizes. The returned location may be different from \fIptr\fR. +.SH KEYWORDS +alloc, allocation, free, malloc, memory, realloc diff --git a/tcl7.6/doc/AllowExc.3 b/tcl7.6/doc/AllowExc.3 new file mode 100644 index 0000000..b5b4b5c --- /dev/null +++ b/tcl7.6/doc/AllowExc.3 @@ -0,0 +1,42 @@ +'\" +'\" Copyright (c) 1989-1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) AllowExc.3 1.5 96/03/25 19:55:47 +'\" +.so man.macros +.TH Tcl_AllowExceptions 3 7.4 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_AllowExceptions \- allow all exceptions in next script evaluation +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +\fBTcl_AllowExceptions\fR(\fIinterp\fR) +.SH ARGUMENTS +.AS Tcl_Interp *doublePtr +.AP Tcl_Interp *interp in +Interpreter in which script will be evaluated. +.BE + +.SH DESCRIPTION +.PP +If a script is evaluated at top-level (i.e. no other scripts are +pending evaluation when the script is invoked), and if the script +terminates with a completion code other than TCL_OK, TCL_CONTINUE +or TCL_RETURN, then Tcl normally converts this into a TCL_ERROR +return with an appropriate message. +.PP +However, if \fBTcl_AllowExceptions\fR is invoked immediately before +calling a procedure such as \fBTcl_Eval\fR, then arbitrary completion +codes are permitted from the script, and they are returned without +modification. +This is useful in cases where the caller can deal with exceptions +such as TCL_BREAK or TCL_CONTINUE in a meaningful way. + +.SH KEYWORDS +continue, break, exception, interpreter diff --git a/tcl7.6/doc/AppInit.3 b/tcl7.6/doc/AppInit.3 new file mode 100644 index 0000000..ca78003 --- /dev/null +++ b/tcl7.6/doc/AppInit.3 @@ -0,0 +1,73 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) AppInit.3 1.10 96/08/26 12:59:40 +'\" +.so man.macros +.TH Tcl_AppInit 3 7.0 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_AppInit \- perform application-specific initialization +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +int +\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 ``hook'' 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 the main programs provided as part of Tcl and Tk. +To create a new application you 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. +.PP +\fBTcl_AppInit\fR is invoked after by \fBTcl_Main\fR and \fBTk_Main\fR +after their own initialization 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. +.LP +\fBTcl_AppInit\fR returns TCL_OK or TCL_ERROR. +If it returns TCL_ERROR then it must leave an error message in +\fIinterp->result\fR; otherwise the result is ignored. +.PP +In addition to \fBTcl_AppInit\fR, your application should also contain +a procedure \fBmain\fR that calls \fBTcl_Main\fR as follows: +.CS +Tcl_Main(argc, argv, Tcl_AppInit); +.CE +The third argument to \fBTcl_Main\fR gives the address of the +application-specific initialization procedure to invoke. +This means that you don't have to use the name \fBTcl_AppInit\fR +for the procedure, but in practice the name is nearly always +\fBTcl_AppInit\fR (in versions before Tcl 7.4 the name \fBTcl_AppInit\fR +was implicit; there was no way to specify the procedure explicitly). +The best way to get started is to make a copy of the file +\fBtclAppInit.c\fR from the Tcl library or source directory. +It already contains a \fBmain\fR procedure and a template for +\fBTcl_AppInit\fR that you can modify for your application. + +.SH KEYWORDS +application, argument, command, initialization, interpreter diff --git a/tcl7.6/doc/AssocData.3 b/tcl7.6/doc/AssocData.3 new file mode 100644 index 0000000..aef7a67 --- /dev/null +++ b/tcl7.6/doc/AssocData.3 @@ -0,0 +1,89 @@ +'\" +'\" Copyright (c) 1995-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" +'\" SCCS: @(#) AssocData.3 1.8 96/03/25 19:56:17 +.so man.macros +.TH Tcl_SetAssocData 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_GetAssocData, Tcl_SetAssocData, Tcl_DeleteAssocData \- manage +associations of string keys and user specified data with Tcl +interpreters. +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +ClientData +\fBTcl_GetAssocData\fR(\fIinterp, key, delProcPtr\fR) +.sp +\fBTcl_SetAssocData\fR(\fIinterp, key, delProc, clientData\fR) +.sp +\fBTcl_DeleteAssocData\fR(\fIinterp, key\fR) +.SH ARGUMENTS +.AS Tcl_InterpDeleteProc *delProcPtr +.AP Tcl_Interp *interp in +Interpreter in which to execute the specified command. +.AP char *key in +Key for association with which to store data or from which to delete or +retrieve data. Typically the module prefix for a package. +.AP Tcl_InterpDeleteProc *delProc in +Procedure to call when \fIinterp\fR is deleted. +.AP Tcl_InterpDeleteProc **delProcPtr in +Pointer to location in which to store address of current deletion procedure +for association. Ignored if NULL. +.AP ClientData clientData in +Arbitrary one-word value associated with the given key in this +interpreter. This data is owned by the caller. +.BE + +.SH DESCRIPTION +.PP +These procedures allow extensions to associate their own data with +a Tcl interpreter. +An association consists of a string key, typically the name of +the extension, and a one-word value, which is typically a pointer +to a data structure holding data specific to the extension. +Tcl makes no interpretation of either the key or the value for +an association. +.PP +Storage management is facilitated by storing with each association a +procedure to call when the interpreter is deleted. This +procedure can dispose of the storage occupied by the client's data in any +way it sees fit. +.PP +\fBTcl_SetAssocData\fR creates an association between a string +key and a user specified datum in the given interpreter. +If there is already an association with the given \fIkey\fR, +\fBTcl_SetAssocData\fR overwrites it with the new information. +It is up to callers to organize their use of names to avoid conflicts, +for example, by using package names as the keys. +If the \fIdeleteProc\fR argument is non-NULL it specifies the address of a +procedure to invoke if the interpreter is deleted before the association +is deleted. \fIDeleteProc\fR should have arguments and result that match +the type \fBTcl_InterpDeleteProc\fR: +.CS +typedef void Tcl_InterpDeleteProc( + ClientData \fIclientData\fR, + Tcl_Interp *\fIinterp\fR); +.CE +When \fIdeleteProc\fR is invoked the \fIclientData\fR and \fIinterp\fR +arguments will be the same as the corresponding arguments passed to +\fBTcl_SetAssocData\fR. +The deletion procedure will \fInot\fR be invoked if the association +is deleted before the interpreter is deleted. +.PP +\fBTcl_GetAssocData\fR returns the datum stored in the association with the +specified key in the given interpreter, and if the \fIdelProcPtr\fR field +is non-\fBNULL\fR, the address indicated by it gets the address of the +delete procedure stored with this association. If no association with the +specified key exists in the given interpreter \fBTcl_GetAssocData\fR +returns \fBNULL\fR. +.PP +\fBTcl_DeleteAssocData\fR deletes an association with a specified key in +the given interpreter. It does not call the deletion procedure. +.SH KEYWORDS +association, data, deletion procedure, interpreter, key diff --git a/tcl7.3/doc/Async.3 b/tcl7.6/doc/Async.3 similarity index 78% rename from tcl7.3/doc/Async.3 rename to tcl7.6/doc/Async.3 index 730284d..9a58b09 100644 --- a/tcl7.3/doc/Async.3 +++ b/tcl7.6/doc/Async.3 @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/Async.3,v 1.5 93/09/17 15:21:50 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) Async.3 1.14 96/08/26 12:59:41 '\" .so man.macros -.HS Tcl_AsyncCreate tclc 7.0 +.TH Tcl_AsyncCreate 3 7.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_AsyncCreate, Tcl_AsyncMark, Tcl_AsyncInvoke, Tcl_AsyncDelete \- handle asynchronous events @@ -29,8 +16,6 @@ Tcl_AsyncCreate, Tcl_AsyncMark, Tcl_AsyncInvoke, Tcl_AsyncDelete \- handle async .nf \fB#include \fR .sp -extern int \fBtcl_AsyncReady\fR; -.sp Tcl_AsyncHandler \fBTcl_AsyncCreate\fR(\fIproc, clientData\fR) .sp @@ -40,6 +25,9 @@ int \fBTcl_AsyncInvoke\fR(\fIinterp, code\fR) .sp \fBTcl_AsyncDelete\fR(\fIasync\fR) +.sp +int +\fBTcl_AsyncReady\fR() .SH ARGUMENTS .AS Tcl_AsyncHandler clientData .AP Tcl_AsyncProc *proc in @@ -65,7 +53,7 @@ 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; +interpreter 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 @@ -88,16 +76,12 @@ 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 +.CS typedef int Tcl_AsyncProc( -.RS -ClientData \fIclientData\fR, -Tcl_Interp *\fIinterp\fR, -int \fIcode\fR); -.RE -.RE -.fi + ClientData \fIclientData\fR, + Tcl_Interp *\fIinterp\fR, + int \fIcode\fR); +.CE The \fIclientData\fR will be the same as the \fIclientData\fR argument passed to \fBTcl_AsyncCreate\fR when the handler was created. @@ -121,18 +105,18 @@ In this case \fIinterp\fR will be NULL and \fIcode\fR will be .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 +The procedure \fBTcl_AsyncReady\fR will return 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 +Tcl calls \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 +For example, Tcl's event handler calls \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 +interpreter, if any, and the completion code from the command that just completed. .PP \fBTcl_AsyncDelete\fR removes an asynchronous handler so that diff --git a/tcl7.6/doc/BackgdErr.3 b/tcl7.6/doc/BackgdErr.3 new file mode 100644 index 0000000..005f5b6 --- /dev/null +++ b/tcl7.6/doc/BackgdErr.3 @@ -0,0 +1,58 @@ +'\" +'\" Copyright (c) 1992-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) BackgdErr.3 1.3 96/03/25 19:56:51 +'\" +.so man.macros +.TH Tcl_BackgroundError 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_BackgroundError \- report Tcl error that occurred in background processing +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +\fBTcl_BackgroundError\fR(\fIinterp\fR) +.SH ARGUMENTS +.AS Tcl_Interp *interp +.AP Tcl_Interp *interp in +Interpreter in which the error occurred. +.BE + +.SH DESCRIPTION +.PP +This procedure is typically invoked when a Tcl error occurs during +``background processing'' such as executing an event handler. +When such an error occurs, the error condition is reported to Tcl +or to a widget or some other C code, and there is not usually any +obvious way for that code to report the error to the user. +In these cases the code calls \fBTcl_BackgroundError\fR with an +\fIinterp\fR argument identifying the interpreter in which the +error occurred. At the time \fBTcl_BackgroundError\fR is invoked, +\fIinterp->result\fR is expected to contain an error message. +\fBTcl_BackgroundError\fR will invoke the \fBbgerror\fR +Tcl command to report the error in an application-specific fashion. +If no \fBbgerror\fR command exists, or if it returns with an error condition, +then \fBTcl_BackgroundError\fR reports the error itself by printing +a message on the standard error file. +.PP +\fBTcl_BackgroundError\fR does not invoke \fBbgerror\fR immediately +because this could potentially interfere with scripts that are in process +at the time the error occurred. +Instead, it invokes \fBbgerror\fR later as an idle callback. +\fBTcl_BackgroundError\fR saves the values of the \fBerrorInfo\fR and +\fBerrorCode\fR variables and restores these values just before +invoking \fBbgerror\fR. +.PP +It is possible for many background errors to accumulate before +\fBbgerror\fR is invoked. When this happens, each of the errors +is processed in order. However, if \fBbgerror\fR returns a +break exception, then all remaining error reports for the +interpreter are skipped. + +.SH KEYWORDS +background, bgerror, error diff --git a/tcl7.6/doc/Backslash.3 b/tcl7.6/doc/Backslash.3 new file mode 100644 index 0000000..e7ac1f7 --- /dev/null +++ b/tcl7.6/doc/Backslash.3 @@ -0,0 +1,45 @@ +'\" +'\" Copyright (c) 1989-1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) Backslash.3 1.16 96/03/25 19:57:09 +'\" +.so man.macros +.TH Tcl_Backslash 3 "" Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_Backslash \- parse a backslash sequence +.SH SYNOPSIS +.nf +\fB#include \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/tcl7.3/doc/CallDel.3 b/tcl7.6/doc/CallDel.3 similarity index 55% rename from tcl7.3/doc/CallDel.3 rename to tcl7.6/doc/CallDel.3 index 1454ca3..544afdf 100644 --- a/tcl7.3/doc/CallDel.3 +++ b/tcl7.6/doc/CallDel.3 @@ -1,32 +1,17 @@ '\" '\" Copyright (c) 1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/CallDel.3,v 1.3 93/09/09 16:49:23 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) CallDel.3 1.11 96/03/25 19:57:25 '\" .so man.macros -.HS Tcl_CallWhenDeleted tclc 7.0 +.TH Tcl_CallWhenDeleted 3 7.0 Tcl "Tcl Library Procedures" .BS .SH NAME -.na Tcl_CallWhenDeleted, Tcl_DontCallWhenDeleted \- Arrange for callback when interpreter is deleted -.ad .SH SYNOPSIS .nf \fB#include \fR @@ -53,17 +38,13 @@ 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 +.CS +typedef void Tcl_InterpDeleteProc( + ClientData \fIclientData\fR, + Tcl_Interp *\fIinterp\fR); +.CE +The \fIclientData\fR and \fIinterp\fR parameters are +copies of the \fIclientData\fR 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 diff --git a/tcl7.6/doc/CmdCmplt.3 b/tcl7.6/doc/CmdCmplt.3 new file mode 100644 index 0000000..b700343 --- /dev/null +++ b/tcl7.6/doc/CmdCmplt.3 @@ -0,0 +1,36 @@ +'\" +'\" Copyright (c) 1989-1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) CmdCmplt.3 1.6 96/03/25 19:57:46 +'\" +.so man.macros +.TH Tcl_CommandComplete 3 "" Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_CommandComplete \- Check for unmatched braces in a Tcl command +.SH SYNOPSIS +.nf +\fB#include \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/tcl7.3/doc/Concat.3 b/tcl7.6/doc/Concat.3 similarity index 52% rename from tcl7.3/doc/Concat.3 rename to tcl7.6/doc/Concat.3 index 8509601..807fcad 100644 --- a/tcl7.3/doc/Concat.3 +++ b/tcl7.6/doc/Concat.3 @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/Concat.3,v 1.6 93/04/01 09:25:23 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) Concat.3 1.11 96/06/05 18:00:12 '\" .so man.macros -.HS Tcl_Concat tclc +.TH Tcl_Concat 3 7.5 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_Concat \- concatenate a collection of strings @@ -56,9 +43,11 @@ copies strings from \fBargv\fR to the result. If an element of is ignored entirely. This white-space removal was added to make the output of the \fBconcat\fR command cleaner-looking. .PP +.VS The result string is dynamically allocated -using \fBmalloc()\fR; the caller must eventually release the space -by calling \fBfree()\fR. +using \fBTcl_Alloc\fR; the caller must eventually release the space +by calling \fBTcl_Free\fR. +.VE .SH KEYWORDS concatenate, strings diff --git a/tcl7.6/doc/CrtChannel.3 b/tcl7.6/doc/CrtChannel.3 new file mode 100644 index 0000000..67b4dbb --- /dev/null +++ b/tcl7.6/doc/CrtChannel.3 @@ -0,0 +1,498 @@ +'\" +'\" Copyright (c) 1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) CrtChannel.3 1.24 96/05/08 18:10:56 +.so man.macros +.TH Tcl_CreateChannel 3 7.5 Tcl "Tcl Library Procedures" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +Tcl_CreateChannel, Tcl_GetChannelInstanceData, Tcl_GetChannelType, Tcl_GetChannelName, Tcl_GetChannelFile, Tcl_GetChannelMode, Tcl_GetChannelBufferSize, Tcl_SetDefaultTranslation, Tcl_SetChannelBufferSize \- procedures for creating and manipulating channels +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +Tcl_Channel +\fBTcl_CreateChannel\fR(\fItypePtr, channelName, instanceData, mask\fR) +.sp +ClientData +\fBTcl_GetChannelInstanceData\fR(\fIchannel\fR) +.sp +Tcl_ChannelType * +\fBTcl_GetChannelType\fR(\fIchannel\fR) +.sp +char * +\fBTcl_GetChannelName\fR(\fIchannel\fR) +.sp +Tcl_File +\fBTcl_GetChannelFile\fR(\fIchannel, direction\fR) +.sp +int +\fBTcl_GetChannelFlags\fR(\fIchannel\fR) +.sp +void +\fBTcl_SetDefaultTranslation\fR(\fIchannel, transMode\fR) +.sp +int +\fBTcl_GetChannelBufferSize\fR(\fIchannel\fR) +.sp +void +\fBTcl_SetChannelBufferSize\fR(\fIchannel, size\fR) +.sp +.SH ARGUMENTS +.AS Tcl_FileHandle pipelineSpec in +.AP Tcl_ChannelType *typePtr in +Points to a structure containing the addresses of procedures that +can be called to perform I/O and other functions on the channel. +.AP char *channelName in +The name of this channel, such as \fBfile3\fR; must not be in use +by any other channel. Can be NULL, in which case the channel is +created without a name. +.AP ClientData instanceData in +Arbitrary one-word value to be associated with this channel. This +value is passed to procedures in \fItypePtr\fR when they are invoked. +.AP int mask in +OR-ed combination of \fBTCL_READABLE\fR and \fBTCL_WRITABLE\fR to indicate +whether a channel is readable and writable. +.AP Tcl_Channel channel in +The channel to operate on. +.AP int direction in +\fBTCL_READABLE\fR means the input file is wanted; \fBTCL_WRITABLE\fR +means the output file is wanted. +.AP Tcl_EolTranslation transMode in +The translation mode; one of the constants \fBTCL_TRANSLATE_AUTO\fR, +\fBTCL_TRANSLATE_CR\fR, \fBTCL_TRANSLATE_LF\fR and \fBTCL_TRANSLATE_CRLF\fR. +.AP int size in +The size, in bytes, of buffers to allocate in this channel. +.BE + +.SH DESCRIPTION +.PP +Tcl uses a two-layered channel architecture. It provides a generic upper +layer to enable C and Tcl programs to perform input and output using the +same APIs for a variety of files, devices, sockets etc. The generic C APIs +are described in the manual entry for \fBTcl_OpenFileChannel\fR. +.PP +The lower layer provides type-specific channel drivers for each type of +file, socket and device supported on each platform. +This manual entry describes the C APIs +used by the generic layer to communicate with type-specific channel drivers +to perform the input and output operations. It also explains how new types +of channels can be added by providing new channel drivers. +.PP +Channel drivers consist of a number of components: First, each channel +driver provides a \fBTcl_ChannelType\fR structure containing pointers to +functions implementing the various operations used by the generic layer to +communicate with the channel driver. The \fBTcl_ChannelType\fR structure +and the functions referenced by it are described in the section +TCL_CHANNELTYPE, below. +.PP +Second, channel drivers usually provide a Tcl command to create instances +of that type of channel. For example, the Tcl \fBopen\fR command creates +channels that use the \fBfile\fR and \fBcommand\fR channel drivers, and +the Tcl \fBsocket\fR command creates channels that use TCP sockets for +network communication. +.PP +Third, a channel driver optionally provides a C function to open channel +instances of that type. For example, \fBTcl_OpenFileChannel\fR opens a +channel that uses the \fBfile\fR channel driver, and +\fBTcl_OpenTcpClient\fR opens a channel that uses the TCP network protocol. +These creation functions typically use +\fBTcl_CreateChannel\fR internally to open the channel. +.PP +To add a new type of channel you must implement a C API or a Tcl command +that opens a channel by invoking \fBTcl_CreateChannel\fR. +When your driver calls \fBTcl_CreateChannel\fR it passes in +a \fBTcl_ChannelType\fR structure describing the driver's I/O +procedures. +The generic layer will then invoke the functions referenced in that +structure to perform operations on the channel. +.PP +\fBTcl_CreateChannel\fR opens a new channel and associates the supplied +\fItypePtr\fR and \fIinstanceData\fR with it. The channel is opened in the +mode indicated by \fImask\fR. +For a discussion of channel drivers, their operations and the +\fBTcl_ChannelType\fR structure, see the section TCL_CHANNELTYPE, below. +.PP +\fBTcl_GetChannelInstanceData\fR returns the instance data associated with +the channel in \fIchannel\fR. This is the same as the \fIinstanceData\fR +argument in the call to \fBTcl_CreateChannel\fR that created this channel. +.PP +\fBTcl_GetChannelType\fR returns a pointer to the \fBTcl_ChannelType\fR +structure used by the channel in the \fIchannel\fR argument. This is +the same as the \fItypePtr\fR argument in the call to +\fBTcl_CreateChannel\fR that created this channel. +.PP +\fBTcl_GetChannelName\fR returns a string containing the name associated +with the channel, or NULL if the \fIchannelName\fR argument to +\fBTcl_CreateChannel\fR was NULL. +.PP +\fBTcl_GetChannelFile\fR returns the \fIinFile\fR associated with +\fIchannel\fR if \fIdirection\fR is \fBTCL_READABLE\fR, or the +\fIoutFile\fR if \fIdirection\fR is \fBTCL_WRITABLE\fR. The operation +returns NULL if the channel is not based on \fBTcl_File\fRs or if the +channel is not open for the specified direction. +.PP +\fBTcl_GetChannelMode\fR returns an OR-ed combination of \fBTCL_READABLE\fR +and \fBTCL_WRITABLE\fR, indicating whether the channel is open for input +and output. +.PP +\fBTcl_SetDefaultTranslation\fR sets the default end of line translation +mode. This mode will be installed as the translation mode for the channel +if an attempt is made to output on the channel while it is still in +\fBTCL_TRANSLATE_AUTO\fR mode. For a description of end of line translation +modes, see the manual entry for \fBfconfigure\fR. +.PP +\fBTcl_GetChannelBufferSize\fR returns the size, in bytes, of buffers +allocated to store input or output in \fIchan\fR. If the value was not set +by a previous call to \fBTcl_SetChannelBufferSize\fR, described below, then +the default value of 4096 is returned. +.PP +\fBTcl_SetChannelBufferSize\fR sets the size, in bytes, of buffers that +will be allocated in subsequent operations on the channel to store input or +output. The \fIsize\fR argument should be between ten and one million, +allowing buffers of ten bytes to one million bytes. If \fIsize\fR is +outside this range, \fBTcl_SetChannelBufferSize\fR sets the buffer size to +4096. + +.SH TCL_CHANNELTYPE +.PP +A channel driver provides a \fBTcl_ChannelType\fR structure that contains +pointers to functions that implement the various operations on a channel; +these operations are invoked as needed by the generic layer. The +\fBTcl_ChannelType\fR structure contains the following fields: +.PP +.CS +typedef struct Tcl_ChannelType { + char *\fItypeName\fR; + Tcl_DriverBlockModeProc *\fIblockModeProc\fR; + Tcl_DriverCloseProc *\fIcloseProc\fR; + Tcl_DriverInputProc *\fIinputProc\fR; + Tcl_DriverOutputProc *\fIoutputProc\fR; + Tcl_DriverSeekProc *\fIseekProc\fR; + Tcl_DriverSetOptionProc *\fIsetOptionProc\fR; + Tcl_DriverGetOptionProc *\fIgetOptionProc\fR; + Tcl_DriverWatchChannelProc *\fIwatchChannelProc\fR; + Tcl_DriverChannelReadyProc *\fIchannelReadyProc\fR; + Tcl_DriverGetFileProc *\fIgetFileProc\fR; +} Tcl_ChannelType; +.CE +.PP +The driver must provide implementations for all functions except +\fIblockModeProc\fR, \fIseekProc\fR, \fIsetOptionProc\fR, and +\fIgetOptionProc\fR, which may be specified as NULL to indicate that the +channel does not support seeking. Other functions that can not be +implemented for this type of device should return \fBEINVAL\fR when invoked +to indicate that they are not implemented. + +.SH TYPENAME +.PP +The \fItypeName\fR field contains a null-terminated string that +identifies the type of the device implemented by this driver, e.g. +\fBfile\fR or \fBsocket\fR. + +.SH BLOCKMODEPROC +.PP +The \fIblockModeProc\fR field contains the address of a function called by +the generic layer to set blocking and nonblocking mode on the device. +\fIBlockModeProc\fR should match the following prototype: +.PP +.CS +typedef int Tcl_DriverBlockModeProc( + ClientData \fIinstanceData\fR, + int \fImode\fR); +.CE +.PP +The \fIinstanceData\fR is the same as the value passed to +\fBTcl_CreateChannel\fR when this channel was created. The \fImode\fR +argument is either \fBTCL_MODE_BLOCKING\fR or \fBTCL_MODE_NONBLOCKING\fR to +set the device into blocking or nonblocking mode. The function should +return zero if the operation was successful, or a nonzero POSIX error code +if the operation failed. +.PP +If the operation is successful, the function can modify the supplied +\fIinstanceData\fR to record that the channel entered blocking or +nonblocking mode and to implement the blocking or nonblocking behavior. +For some device types, the blocking and nonblocking behavior can be +implemented by the underlying operating system; for other device types, the +behavior must be emulated in the channel driver. + +.SH CLOSEPROC +.PP +The \fIcloseProc\fR field contains the address of a function called by the +generic layer to clean up driver-related information when the channel is +closed. \fICloseProc\fR must match the following prototype: +.PP +.CS +typedef int Tcl_DriverCloseProc( + ClientData \fIinstanceData\fR, + Tcl_Interp *\fIinterp\fR); +.CE +.PP +The \fIinstanceData\fR argument is the same as the value provided to +\fBTcl_CreateChannel\fR when the channel was created. The function should +release any storage maintained by the channel driver for this channel, and +close the input and output devices encapsulated by this channel. All queued +output will have been flushed to the device before this function is called, +and no further driver operations will be invoked on this instance after +calling the \fIcloseProc\fR. If the close operation is successful, the +procedure should return zero; otherwise it should return a nonzero POSIX +error code. In addition, if an error occurs and \fIinterp\fR is not NULL, +the procedure should store an error message in \fIinterp->result\fR. + +.SH INPUTPROC +.PP +The \fIinputProc\fR field contains the address of a function called by the +generic layer to read data from the file or device and store it in an +internal buffer. \fIInputProc\fR must match the following prototype: +.PP +.CS +typedef int Tcl_DriverInputProc( + ClientData \fIinstanceData\fR, + char *\fIbuf\fR, + int \fIbufSize\fR, + int *\fIerrorCodePtr\fR); +.CE +.PP +\fIInstanceData\fR is the same as the value passed to +\fBTcl_CreateChannel\fR when the channel was created. The \fIbuf\fR +argument points to an array of bytes in which to store input from the +device, and the \fIbufSize\fR argument indicates how many bytes are +available at \fIbuf\fR. +.PP +The \fIerrorCodePtr\fR argument points to an integer variable provided by +the generic layer. If an error occurs, the function should set the variable +to a POSIX error code that identifies the error that occurred. +.PP +The function should read data from the input device encapsulated by the +channel and store it at \fIbuf\fR. On success, the function should return +a nonnegative integer indicating how many bytes were read from the input +device and stored at \fIbuf\fR. On error, the function should return -1. If +an error occurs after some data has been read from the device, that data is +lost. +.PP +If \fIinputProc\fR can determine that the input device has some data +available but less than requested by the \fIbufSize\fR argument, the +function should only attempt to read as much data as is available and +return without blocking. If the input device has no data available +whatsoever and the channel is in nonblocking mode, the function should +return an \fBEAGAIN\fR error. If the input device has no data available +whatsoever and the channel is in blocking mode, the function should block +for the shortest possible time until at least one byte of data can be read +from the device; then, it should return as much data as it can read without +blocking. + +.SH OUTPUTPROC +.PP +The \fIoutputProc\fR field contains the address of a function called by the +generic layer to transfer data from an internal buffer to the output device. +\fIOutputProc\fR must match the following prototype: +.PP +.CS +typedef int Tcl_DriverOutputProc( + ClientData \fIinstanceData\fR, + char *\fIbuf\fR, + int \fItoWrite\fR, + int *\fIerrorCodePtr\fR); +.CE +.PP +\fIInstanceData\fR is the same as the value passed to +\fBTcl_CreateChannel\fR when the channel was created. The \fIbuf\fR +argument contains an array of bytes to be written to the device, and the +\fItoWrite\fR argument indicates how many bytes are to be written from the +\fIbuf\fR argument. +.PP +The \fIerrorCodePtr\fR argument points to an integer variable provided by +the generic layer. If an error occurs, the function should set this +variable to a POSIX error code that identifies the error. +.PP +The function should write the data at \fIbuf\fR to the output device +encapsulated by the channel. On success, the function should return a +nonnegative integer indicating how many bytes were written to the output +device. The return value is normally the same as \fItoWrite\fR, but may be +less in some cases such as if the output operation is interrupted by a +signal. If an error occurs the function should return -1. In case of +error, some data may have been written to the device. +.PP +If the channel is nonblocking and the output device is unable to absorb any +data whatsoever, the function should return -1 with an \fBEAGAIN\fR error +without writing any data. + +.SH SEEKPROC +.PP +The \fIseekProc\fR field contains the address of a function called by the +generic layer to move the access point at which subsequent input or output +operations will be applied. \fISeekProc\fR must match the following +prototype: +.PP +.CS +typedef int Tcl_DriverSeekProc( + ClientData \fIinstanceData\fR, + long \fIoffset\fR, + int \fIseekMode\fR, + int *\fIerrorCodePtr\fR); +.CE +.PP +The \fIinstanceData\fR argument is the same as the value given to +\fBTcl_CreateChannel\fR when this channel was created. \fIOffset\fR and +\fIseekMode\fR have the same meaning as for the \fBTcl_SeekChannel\fR +procedure (described in the manual entry for \fBTcl_OpenFileChannel\fR). +.PP +The \fIerrorCodePtr\fR argument points to an integer variable provided by +the generic layer for returning \fBerrno\fR values from the function. The +function should set this variable to a POSIX error code if an error occurs. +The function should store an \fBEINVAL\fR error code if the channel type +does not implement seeking. +.PP +The return value is the new access point or -1 in case of error. If an +error occurred, the function should not move the access point. + +.SH SETOPTIONPROC +.PP +The \fIsetOptionProc\fR field contains the address of a function called by +the generic layer to set a channel type specific option on a channel. +\fIsetOptionProc\fR must match the following prototype: +.PP +.CS +typedef int Tcl_DriverSetOptionProc( + ClientData \fIinstanceData\fR, + Tcl_Interp *\fIinterp\fR, + char *\fIoptionName\fR, + char *\fIoptionValue\fR); +.CE +.PP +\fIoptionName\fR is the name of an option to set, and \fIoptionValue\fR is +the new value for that option, as a string. The \fIinstanceData\fR is the +same as the value given to \fBTcl_CreateChannel\fR when this channel was +created. The function should do whatever channel type specific action is +required to implement the new value of the option. +.PP +Some options are handled by the generic code and this function is never +called to set them, e.g. \fB-blockmode\fR. Other options are specific to +each channel type and the \fIsetOptionProc\fR procedure of the channel +driver will get called to implement them. The \fIsetOptionProc\fR field can +be NULL, which indicates that this channel type supports no type specific +options. +.PP +If the option value is successfully modified to the new value, the function +returns \fBTCL_OK\fR. It returns \fBTCL_ERROR\fR if the \fIoptionName\fR is +unrecognized or if \fIoptionValue\fR specifies a value for the option that +is not supported. In this case, the function leaves an error message in the +\fIresult\fR field of \fIinterp\fR if \fIinterp\fR is not NULL. The +function should also call \fBTcl_SetErrno\fR to store an appropriate POSIX +error code. + +.SH GETOPTIONPROC +.PP +The \fIgetOptionProc\fR field contains the address of a function called by +the generic layer to get the value of a channel type specific option on a +channel. \fIgetOptionProc\fR must match the following prototype: +.PP +.CS +typedef int Tcl_DriverGetOptionProc( + ClientData \fIinstanceData\fR, + char *\fIoptionName\fR, + Tcl_DString *\fIdsPtr\fR); +.CE +.PP +\fIOptionName\fR is the name of an option supported by this type of +channel. If the option name is not NULL, the function stores its current +value, as a string, in the Tcl dynamic string \fIdsPtr\fR. +If \fIoptionName\fR is NULL, the function stores in \fIdsPtr\fR an +alternating list of all supported options and their current values. +On success, the function returns \fBTCL_OK\fR. If an error occurs, the +function returns \fBTCL_ERROR\fR and calls \fBTcl_SetErrno\fR to store an +appropriate POSIX error code. +.PP +Some options are handled by the generic code and this function is never +called to retrieve their value, e.g. \fB-blockmode\fR. Other options are +specific to each channel type and the \fIgetOptionProc\fR procedure of the +channel driver will get called to implement them. The \fIgetOptionProc\fR +field can be NULL, which indicates that this channel type supports no type +specific options. + +.SH WATCHCHANNELPROC +.PP +The \fIwatchChannelProc\fR field contains the address of a function called +by the generic layer to initialize the event notification mechanism to +notice events of interest on this channel. +\fIWatchChannelProc\fR should match the following prototype: +.PP +.CS +typeded void Tcl_DriverWatchChannelProc( + ClientData \fIinstanceData\fR, + int \fImask\fR); +.CE +.PP +The \fIinstanceData\fR is the same as the value passed to +\fBTcl_CreateChannel\fR when this channel was created. The \fImask\fR +argument is an OR-ed combination of \fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR +and \fBTCL_EXCEPTION\fR; it indicates events the caller is interested in +noticing on this channel. +.PP +The function should initialize device type specific mechanisms to notice +when an event of interest is present on the channel. It may invoke +\fITcl_SetMaxBlockTime\fR to specify an upper limit on the length of time +to wait for an event, and it may invoke \fITcl_WatchFile\fR if the channel +implementation is based on \fBTcl_File\fRs. + +.SH CHANNELREADYPROC +.PP +The \fIchannelReadyProc\fR field contains the address of a function called +by the generic layer to sense whether events of interest have occurred for +this channel. +\fIChannelReadyProc\fR should match the following prototype: +.PP +.CS +typedef int Tcl_DriverChannelReadyProc( + ClientData \fIinstanceData\fR, + int \fImask\fR); +.CE +.PP +\fIInstanceData\fR is the same as the value passed to +\fBTcl_CreateChannel\fR when this channel was created. The \fImask\fR +argument is an OR-ed combination of \fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR +and \fBTCL_EXCEPTION\fR indicating what events are of interest. The +function returns a mask containing an OR-ed combination of a subset of the +flags in \fImask\fR to indicate what events have actually occurred on the +channel. +.PP +The function should use a device type dependent mechanism to detect whether +events of interest have occurred on the channel. It may invoke +\fBTcl_FileReady\fR if the channel implementation is based on +\fBTcl_File\fRs. + +.SH GETFILEPROC +.PP +The \fIgetFileProc\fR field contains the address of a function called by +the generic layer to retrieve a \fBTcl_File\fR from the channel. +\fIGetFileProc\fR should match the following prototype: +.PP +.CS +typedef Tcl_File Tcl_DriverGetFileProc( + ClientData \fIinstanceData\fR, + int \fIdirection\fR); +.CE +.PP +\fIInstanceData is the same as the value passed to +\fBTcl_CreateChannel\fR when this channel was created. The \fIdirection\fR +argument is either \fBTCL_READABLE\fR to retrieve the \fBTcl_File\fR used +for input, or \fBTCL_WRITABLE\fR to retrieve the \fBTcl_File\fR used for +output. +.PP +If the channel implementation is based on \fBTcl_File\fRs, the function +should retrieve the appropriate \fBTcl_File\fR associated with the channel, +according the \fIdirection\fR argument; it can return NULL if the channel +is not open for that direction. If the channel implementation does not use +\fBTcl_File\fRs, the function should always return NULL. + +.SH "SEE ALSO" +Tcl_Close(3), Tcl_OpenFileChannel(3), Tcl_SetErrno(3), +Tcl_SetMaxBlockTime(3), Tcl_WatchFile(3), Tcl_FileReady(3) + + +.SH KEYWORDS +blocking, channel driver, channel registration, channel type, nonblocking diff --git a/tcl7.6/doc/CrtChnlHdlr.3 b/tcl7.6/doc/CrtChnlHdlr.3 new file mode 100644 index 0000000..388f01f --- /dev/null +++ b/tcl7.6/doc/CrtChnlHdlr.3 @@ -0,0 +1,92 @@ +'\" +'\" Copyright (c) 1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) CrtChnlHdlr.3 1.10 96/03/14 10:54:43 +.so man.macros +.TH Tcl_CreateChannelHandler 3 7.5 Tcl "Tcl Library Procedures" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +Tcl_CreateChannelHandler, Tcl_DeleteChannelHandler \- call a procedure when a channel becomes readable or writable +.SH SYNOPSIS +.nf +.nf +\fB#include \fR +.sp +void +\fBTcl_CreateChannelHandler\fR(\fIchannel, mask, proc, clientData\fR) +.sp +void +\fBTcl_DeleteChannelHandler\fR(\fIchannel, proc, clientData\fR) +.sp +.SH ARGUMENTS +.AS Tcl_ChannelProc clientData +.AP Tcl_Channel channel in +Tcl channel such as returned by \fBTcl_CreateChannel\fR. +.AP int mask in +Conditions under which \fIproc\fR should be called: OR-ed combination of +\fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR and \fBTCL_EXCEPTION\fR. Specify +a zero value to temporarily disable an existing handler. +.AP Tcl_FileProc *proc in +Procedure to invoke whenever the channel indicated by \fIchannel\fR meets +the conditions specified by \fImask\fR. +.AP ClientData clientData in +Arbitrary one-word value to pass to \fIproc\fR. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_CreateChannelHandler\fR arranges for \fIproc\fR to be called in the +future whenever input or output becomes possible on the channel identified +by \fIchannel\fR, or whenever an exceptional condition exists for +\fIchannel\fR. The conditions of interest under which \fIproc\fR will be +invoked are specified by the \fImask\fR argument. +See the manual entry for \fBfileevent\fR for a precise description of +what it means for a channel to be readable or writable. +\fIProc\fR must conform to the following prototype: +.CS +typedef void Tcl_ChannelProc( + ClientData \fIclientData\fR, + int \fImask\fR); +.CE +.PP +The \fIclientData\fR argument is the same as the value passed to +\fBTcl_CreateChannelHandler\fR when the handler was created. Typically, +\fIclientData\fR points to a data structure containing application-specific +information about the channel. \fIMask\fR is an integer mask indicating +which of the requested conditions actually exists for the channel; it will +contain a subset of the bits from the \fImask\fR argument to +\fBTcl_CreateChannelHandler\fR when the handler was created. +.PP +Each channel handler is identified by a unique combination of \fIchannel\fR, +\fIproc\fR and \fIclientData\fR. +There may be many handlers for a given channel as long as they don't +have the same \fIchannel\fR, \fIproc\fR, and \fIclientData\fR. +If \fBTcl_CreateChannelHandler\fR is invoked when there is already a handler +for \fIchannel\fR, \fIproc\fR, and \fIclientData\fR, then no new +handler is created; instead, the \fImask\fR is changed for the +existing handler. +.PP +\fBTcl_DeleteChannelHandler\fR deletes a channel handler identified by +\fIchannel\fR, \fIproc\fR and \fIclientData\fR; if no such handler exists, +the call has no effect. +.PP +Channel handlers are invoked via the Tcl event mechanism, so they +are only useful in applications that are event-driven. +Note also that the conditions specified in the \fImask\fR argument +to \fIproc\fR may no longer exist when \fIproc\fR is invoked: for +example, if there are two handlers for \fBTCL_READABLE\fR on the same +channel, the first handler could consume all of the available input +so that the channel is no longer readable when the second handler +is invoked. +For this reason it may be useful to use nonblocking I/O on channels +for which there are event handlers. + +.SH "SEE ALSO" +Notifier(3), Tcl_CreateChannel(3), Tcl_OpenFileChannel(3), vwait(n). + +.SH KEYWORDS +blocking, callback, channel, events, handler, nonblocking. diff --git a/tcl7.6/doc/CrtCloseHdlr.3 b/tcl7.6/doc/CrtCloseHdlr.3 new file mode 100644 index 0000000..3ceff18 --- /dev/null +++ b/tcl7.6/doc/CrtCloseHdlr.3 @@ -0,0 +1,59 @@ +'\" +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) CrtCloseHdlr.3 1.7 96/04/15 13:08:19 +.so man.macros +.TH Tcl_CreateCloseHandler 3 7.5 Tcl "Tcl Library Procedures" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +Tcl_CreateCloseHandler, Tcl_DeleteCloseHandler \- arrange for callbacks when channels are closed +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +void +\fBTcl_CreateCloseHandler\fR(\fIchannel, proc, clientData\fR) +.sp +void +\fBTcl_DeleteCloseHandler\fR(\fIchannel, proc, clientData\fR) +.sp +.SH ARGUMENTS +.AS Tcl_CloseProc callbackData in +.AP Tcl_Channel channel in +The channel for which to create or delete a close callback. +.AP Tcl_CloseProc *proc in +The procedure to call as the callback. +.AP ClientData clientData in +Arbitrary one-word value to pass to \fIproc\fR. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_CreateCloseHandler\fR arranges for \fIproc\fR to be called when +\fIchannel\fR is closed with \fBTcl_Close\fR or +\fBTcl_UnregisterChannel\fR, or using the Tcl \fBclose\fR command. +\fIProc\fR should match the following prototype: +.PP +.CS +typedef void Tcl_CloseProc( + ClientData \fIclientData\fR); +.CE +.PP +The \fIclientData\fR is the same as the value provided in the call to +\fBTcl_CreateCloseHandler\fR. +.PP +\fBTcl_DeleteCloseHandler\fR removes a close callback for \fIchannel\fR. +The \fIproc\fR and \fIclientData\fR identify which close callback to +remove; \fBTcl_DeleteCloseHandler\fR does nothing if its \fIproc\fR and +\fIclientData\fR arguments do not match the \fIproc\fR and \fIclientData\fR +for a close handler for \fIchannel\fR. + +.SH "SEE ALSO" +close(n), Tcl_Close(3), Tcl_UnregisterChannel(3) + +.SH KEYWORDS +callback, channel closing diff --git a/tcl7.3/doc/CrtCommand.3 b/tcl7.6/doc/CrtCommand.3 similarity index 74% rename from tcl7.3/doc/CrtCommand.3 rename to tcl7.6/doc/CrtCommand.3 index 9f61f49..12814dc 100644 --- a/tcl7.3/doc/CrtCommand.3 +++ b/tcl7.6/doc/CrtCommand.3 @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/CrtCommand.3,v 1.12 93/10/29 15:52:29 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) CrtCommand.3 1.23 96/08/26 12:59:42 '\" .so man.macros -.HS Tcl_CreateCommand tclc +.TH Tcl_CreateCommand 3 "" Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_CreateCommand, Tcl_DeleteCommand, Tcl_GetCommandInfo, Tcl_SetCommandInfo \- implement new commands in C @@ -29,18 +16,20 @@ Tcl_CreateCommand, Tcl_DeleteCommand, Tcl_GetCommandInfo, Tcl_SetCommandInfo \- .nf \fB#include \fR .sp +Tcl_Command \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 +.sp +char * +\fBTcl_GetCommandName\fR(\fIinterp, token\fR) .SH ARGUMENTS .AS Tcl_CmdDeleteProc **deleteProcPtr .AP Tcl_Interp *interp in @@ -57,10 +46,11 @@ 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 +.AP Tcl_Command token in +Token for command, returned by previous call to \fBTcl_CreateCommand\fR. +The command must not have been deleted. .BE .SH DESCRIPTION @@ -70,21 +60,23 @@ 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 +associated with the interpreter, it is deleted. +\fBTcl_CreateCommand\fR returns a token that may be used to refer +to the command in subsequent calls to \fBTcl_GetCommandName\fR. +If \fBTcl_CreateCommand\fR is called for an interpreter that is in +the process of being deleted, then it does not create a new command +and it returns NULL. +\fIProc\fR should have arguments and result that match the type +\fBTcl_CmdProc\fR: +.CS 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 + ClientData \fIclientData\fR, + Tcl_Interp *\fIinterp\fR, + int \fIargc\fR, + char *\fIargv\fR[]); +.CE +When \fIproc\fR is invoked the \fIclientData\fR and \fIinterp\fR +parameters will be copies of the \fIclientData\fR 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 @@ -109,14 +101,12 @@ 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, @@ -125,13 +115,9 @@ or by replacing \fIcmdName\fR in another call to \fBTcl_CreateCommand\fR. 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 +.CS typedef void Tcl_CmdDeleteProc(ClientData \fIclientData\fR); -.sp -.RE -.fi +.CE The \fIclientData\fR argument will be the same as the \fIclientData\fR argument passed to \fBTcl_CreateCommand\fR. .PP @@ -144,7 +130,6 @@ 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 @@ -160,13 +145,23 @@ to pass to \fIdeleteProc\fR; it is normally the same as \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. +If this command does not exist 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 +.PP +\fBTcl_GetCommandName\fR provides a mechanism for tracking commands +that have been renamed. Given a token returned by \fBTcl_CreateCommand\fR +when the command was created, \fBTcl_GetCommandName\fR returns the +string name of the command. If the command has been renamed since it +was created, then \fBTcl_GetCommandName\fR returns the current name. +The command corresponding to \fItoken\fR must not have been deleted. +The string returned by \fBTcl_GetCommandName\fR is in dynamic memory +owned by Tcl and is only guaranteed to retain its value as long as the +command isn't deleted or renamed; callers should copy the string if +they need to keep it for a long time. .SH KEYWORDS bind, command, create, delete, interpreter diff --git a/tcl7.6/doc/CrtFileHdlr.3 b/tcl7.6/doc/CrtFileHdlr.3 new file mode 100644 index 0000000..31a5466 --- /dev/null +++ b/tcl7.6/doc/CrtFileHdlr.3 @@ -0,0 +1,90 @@ +'\" +'\" Copyright (c) 1990-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) CrtFileHdlr.3 1.6 96/03/25 19:59:08 +'\" +.so man.macros +.TH Tcl_CreateFileHandler 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_CreateFileHandler, Tcl_DeleteFileHandler \- associate procedure callbacks with files or devices +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +\fBTcl_CreateFileHandler\fR(\fIfile, mask, proc, clientData\fR) +.sp +\fBTcl_DeleteFileHandler\fR(\fIfile\fR) +.SH ARGUMENTS +.AS Tcl_FileProc clientData +.AP Tcl_File file in +Generic file handle for an open file or device (such as returned by +\fBTcl_GetFile\fR call). +.AP int mask in +Conditions under which \fIproc\fR should be called: +OR-ed combination of \fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR, +and \fBTCL_EXCEPTION\fR. May be set to 0 to temporarily disable +a handler. +.AP Tcl_FileProc *proc in +Procedure to invoke whenever the file or device indicated +by \fIfile\fR meets the conditions specified by \fImask\fR. +.AP ClientData clientData in +Arbitrary one-word value to pass to \fIproc\fR. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_CreateFileHandler\fR arranges for \fIproc\fR to be +invoked in the future whenever I/O becomes possible on a file +or an exceptional condition exists for the file. The file +is indicated by \fIfile\fR, and the conditions of interest +are indicated by \fImask\fR. For example, if \fImask\fR +is \fBTCL_READABLE\fR, \fIproc\fR will be called when +the file is readable. +The callback to \fIproc\fR is made by \fBTcl_DoOneEvent\fR, so +\fBTcl_CreateFileHandler\fR is only useful in programs that dispatch +events through \fBTcl_DoOneEvent\fR or through Tcl commands such +as \fBvwait\fR. +.PP +\fIProc\fR should have arguments and result that match the +type \fBTcl_FileProc\fR: +.CS +typedef void Tcl_FileProc( + ClientData \fIclientData\fR, + int \fImask\fR); +.CE +The \fIclientData\fR parameter to \fIproc\fR is a copy +of the \fIclientData\fR +argument given to \fBTcl_CreateFileHandler\fR when the callback +was created. Typically, \fIclientData\fR points to a data +structure containing application-specific information about +the file. \fIMask\fR is an integer mask indicating which +of the requested conditions actually exists for the file; it +will contain a subset of the bits in the \fImask\fR argument +to \fBTcl_CreateFileHandler\fR. +.PP +.PP +There may exist only one handler for a given file at a given time. +If \fBTcl_CreateFileHandler\fR is called when a handler already +exists for \fIfile\fR, then the new callback replaces the information +that was previously recorded. +.PP +\fBTcl_DeleteFileHandler\fR may be called to delete the +file handler for \fIfile\fR; if no handler exists for the +file given by \fIfile\fR then the procedure has no effect. +.PP +The purpose of file handlers is to enable an application to respond to +events while waiting for files to become ready for I/O. For this to work +correctly, the application may need to use non-blocking I/O operations on +the files for which handlers are declared. Otherwise the application may +block if it reads or writes too much data; while waiting for the I/O to +complete the application won't be able to service other events. Use +\fBTcl_SetChannelOption\fR with \fB\-blocking\fR to set the channel into +blocking or nonblocking mode as required. + +.SH KEYWORDS +callback, file, handler diff --git a/tcl7.6/doc/CrtInterp.3 b/tcl7.6/doc/CrtInterp.3 new file mode 100644 index 0000000..b50d34e --- /dev/null +++ b/tcl7.6/doc/CrtInterp.3 @@ -0,0 +1,131 @@ +'\" +'\" Copyright (c) 1989-1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) CrtInterp.3 1.14 96/03/26 15:14:45 +'\" +.so man.macros +.TH Tcl_CreateInterp 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_CreateInterp, Tcl_DeleteInterp, Tcl_InterpDeleted \- create and delete Tcl command interpreters +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +Tcl_Interp * +\fBTcl_CreateInterp\fR() +.sp +\fBTcl_DeleteInterp\fR(\fIinterp\fR) +.sp +int +\fBTcl_InterpDeleted\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 marks an interpreter as deleted; the interpreter +will eventually be deleted when all calls to \fBTcl_Preserve\fR for it have +been matched by calls to \fBTcl_Release\fR. At that time, all of the +resources associated with it, including variables, procedures, and +application-specific command bindings, will be deleted. After +\fBTcl_DeleteInterp\fR returns any attempt to use \fBTcl_Eval\fR on the +interpreter will fail and return \fBTCL_ERROR\fR. After the call to +\fBTcl_DeleteInterp\fR it is safe to examine \fIinterp->result\fR, query or +set the values of variables, define, undefine or retrieve procedures, and +examine the runtime evaluation stack. See below, in the section +\fBINTERPRETERS AND MEMORY MANAGEMENT\fR for details. +.PP +\fBTcl_InterpDeleted\fR returns nonzero if \fBTcl_DeleteInterp\fR was +called with \fIinterp\fR as its argument; this indicates that the +interpreter will eventually be deleted, when the last call to +\fBTcl_Preserve\fR for it is matched by a call to \fBTcl_Release\fR. If +nonzero is returned, further calls to \fBTcl_Eval\fR in this interpreter +will return \fBTCL_ERROR\fR. +.PP +\fBTcl_InterpDeleted\fR is useful in deletion callbacks to distinguish +between when only the memory the callback is responsible for is being +deleted and when the whole interpreter is being deleted. In the former case +the callback may recreate the data being deleted, but this would lead to an +infinite loop if the interpreter were being deleted. + +.SH "INTERPRETERS AND MEMORY MANAGEMENT" +.PP +\fBTcl_DeleteInterp\fR can be called at any time on an interpreter that may +be used by nested evaluations and C code in various extensions. Tcl +implements a simple mechanism that allows callers to use interpreters +without worrying about the interpreter being deleted in a nested call, and +without requiring special code to protect the interpreter, in most cases. +This mechanism ensures that nested uses of an interpreter can safely +continue using it even after \fBTcl_DeleteInterp\fR is called. +.PP +The mechanism relies on matching up calls to \fBTcl_Preserve\fR with calls +to \fBTcl_Release\fR. If \fBTcl_DeleteInterp\fR has been called, only when +the last call to \fBTcl_Preserve\fR is matched by a call to +\fBTcl_Release\fR, will the interpreter be freed. See the manual entry for +\fBTcl_Preserve\fR for a description of these functions. +.PP +The rules for when the user of an interpreter must call \fBTcl_Preserve\fR +and \fBTcl_Release\fR are simple: +.TP +Interpreters Passed As Arguments +Functions that are passed an interpreter as an argument can safely use the +interpreter without any special protection. Thus, when you write an +extension consisting of new Tcl commands, no special code is needed to +protect interpreters received as arguments. This covers the majority of all +uses. +.TP +Interpreter Creation And Deletion +When a new interpreter is created and used in a call to \fBTcl_Eval\fR, +\fBTcl_VarEval\fR, \fBTcl_GlobalEval\fR, \fBTcl_SetVar\fR, or +\fBTcl_GetVar\fR, a pair of calls to \fBTcl_Preserve\fR and +\fBTcl_Release\fR should be wrapped around all uses of the interpreter. +Remember that it is unsafe to use the interpreter once \fBTcl_Release\fR +has been called. To ensure that the interpreter is properly deleted when +it is no longer needed, call \fBTcl_InterpDeleted\fB to test if some other +code already called \fBTcl_DeleteInterp\fB; if not, call +\fBTcl_DeleteInterp\fR before calling \fBTcl_Release\fB in your own code. +Do not call \fBTcl_DeleteInterp\fR on an interpreter for which +\fBTcl_InterpDeleted\fR returns nonzero. +.TP +Retrieving An Interpreter From A Data Structure +When an interpreter is retrieved from a data structure (e.g. the client +data of a callback) for use in \fBTcl_Eval\fR, \fBTcl_VarEval\fR, +\fBTcl_GlobalEval\fR, \fBTcl_SetVar\fR, or \fBTcl_GetVar\fR, a pair of +calls to \fBTcl_Preserve\fR and \fBTcl_Release\fR should be wrapped around +all uses of the interpreter; it is unsafe to reuse the interpreter once +\fBTcl_Release\fR has been called. If an interpreter is stored inside a +callback data structure, an appropriate deletion cleanup mechanism should +be set up by the code that creates the data structure so that the +interpreter is removed from the data structure (e.g. by setting the field +to NULL) when the interpreter is deleted. Otherwise, you may be using an +interpreter that has been freed and whose memory may already have been +reused. +.PP +All uses of interpreters in Tcl and Tk have already been protected. +Extension writers should ensure that their code also properly protects any +additional interpreters used, as described above. + +.SH KEYWORDS +command, create, delete, interpreter + +.SH "SEE ALSO" +Tcl_Preserve(3), Tcl_Release(3) diff --git a/tcl7.3/doc/CrtMathFnc.3 b/tcl7.6/doc/CrtMathFnc.3 similarity index 69% rename from tcl7.3/doc/CrtMathFnc.3 rename to tcl7.6/doc/CrtMathFnc.3 index 1a48b6c..907df03 100644 --- a/tcl7.3/doc/CrtMathFnc.3 +++ b/tcl7.6/doc/CrtMathFnc.3 @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/CrtMathFnc.3,v 1.1 93/04/14 16:35:59 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) CrtMathFnc.3 1.9 96/08/26 12:59:43 '\" .so man.macros -.HS Tcl_CreateMathFunc tclc 7.0 +.TH Tcl_CreateMathFunc 3 7.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_CreateMathFunc \- Define a new math function for expressions @@ -64,33 +51,25 @@ integer, a double-precision floating value, or either, respectively. 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 +.CS typedef int Tcl_MathProc( -.RS -ClientData \fIclientData\fR, -Tcl_Interp *\fIinterp\fR, -Tcl_Value *\fIargs\fR, -Tcl_Value *resultPtr\fR); -.RE -.RE -.fi + ClientData \fIclientData\fR, + Tcl_Interp *\fIinterp\fR, + Tcl_Value *\fIargs\fR, + Tcl_Value *\fIresultPtr\fR); +.CE .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 +.CS typedef struct Tcl_Value { -.RS -Tcl_ValueType \fItype\fR; -int \fIintValue\fR; -double \fIdoubleValue\fR; -.RE + Tcl_ValueType \fItype\fR; + long \fIintValue\fR; + double \fIdoubleValue\fR; } Tcl_Value; -.RE -.fi +.CE .PP The \fItype\fR field indicates the type of the argument and is either TCL_INT or TCL_DOUBLE. diff --git a/tcl7.6/doc/CrtModalTmt.3 b/tcl7.6/doc/CrtModalTmt.3 new file mode 100644 index 0000000..85f079f --- /dev/null +++ b/tcl7.6/doc/CrtModalTmt.3 @@ -0,0 +1,71 @@ +'\" +'\" Copyright (c) 1995-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) CrtModalTmt.3 1.3 96/03/25 20:00:19 +'\" +.so man.macros +.TH Tcl_CreateModalTimeout 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_CreateModalTimeout, Tcl_DeleteModalTimeout \- special timer for modal operations +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +\fBTcl_CreateModalTimeout\fR(\fImilliseconds, proc, clientData\fR) +.sp +\fBTcl_DeleteModalTimeout\fR(\fIproc, clientData\fR) +.SH ARGUMENTS +.AS Tcl_TimerToken milliseconds +.AP int milliseconds in +How many milliseconds to wait before invoking \fIproc\fR. +.AP Tcl_TimerProc *proc in +Procedure to invoke after \fImilliseconds\fR have elapsed. +.AP ClientData clientData in +Arbitrary one-word value to pass to \fIproc\fR. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_CreateModalTimeout\fR provides an alternate form of timer +from those provided by \fBTcl_CreateTimerHandler\fR. +These timers are called ``modal'' because they are typically +used in situations where a particular operation must be completed +before the application does anything else. +If such an operation needs a timeout, it cannot use normal timer +events: if normal timer events were processed, arbitrary Tcl scripts +might be invoked via other event handlers, which could interfere with +the completion of the modal operation. +The purpose of modal timers is to allow a single timeout to occur +without allowing any normal timer events to occur. +.PP +\fBTcl_CreateModalTimeout\fR behaves just like \fBTcl_CreateTimerHandler\fR +except that it creates a modal timeout. +Its arguments have the same meaning as for \fBTcl_CreateTimerHandler\fR +and \fIproc\fR is invoked just as for \fBTcl_CreateTimerHandler\fR. +\fBTcl_DeleteModalTimeout\fR deletes the most recently created +modal timeout; its arguments must match the corresponding arguments +to the most recent call to \fBTcl_CreateModalTimeout\fR. +.PP +Modal timeouts differ from a normal timers in three ways. First, +they will trigger regardless of whether the TCL_TIMER_EVENTS flag +has been passed to \fBTcl_DoOneEvent\fR. +Typically modal timers are used with the TCL_TIMER_EVENTS flag +off so that normal timers don't fire but modal ones do. +Second, if several modal timers have been created they stack: +only the top timer on the stack (the most recently created one) +is active at any point in time. +Modal timeouts must be deleted in inverse order from their creation. +Third, modal timeouts are not deleted when they fire: once a modal +timeout has fired, it will continue firing every time \fBTcl_DoOneEvent\fR +is called, until the timeout is deleted by calling +\fBTcl_DeleteModalTimeout\fR. +.PP +Modal timeouts are only needed in a few special situations, and they +should be used with caution. + +.SH KEYWORDS +callback, clock, handler, modal timeout diff --git a/tcl7.6/doc/CrtSlave.3 b/tcl7.6/doc/CrtSlave.3 new file mode 100644 index 0000000..7979bbb --- /dev/null +++ b/tcl7.6/doc/CrtSlave.3 @@ -0,0 +1,142 @@ +'\" +'\" Copyright (c) 1995-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) CrtSlave.3 1.13 96/03/25 20:00:42 +'\" +.so man.macros +.TH Tcl_CreateSlave 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_IsSafe, Tcl_MakeSafe, Tcl_CreateSlave, Tcl_GetSlave, Tcl_GetSlaves, Tcl_GetMaster, Tcl_CreateAlias, Tcl_GetAlias, Tcl_GetAliases \- manage +multiple Tcl interpreters and aliases. +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +int +\fBTcl_IsSafe\fR(\fIinterp\fR) +.sp +int +\fBTcl_MakeSafe\fR(\fIinterp\fR) +.sp +Tcl_Interp * +\fBTcl_CreateSlave\fR(\fIinterp, slaveName, isSafe\fR) +.sp +Tcl_Interp * +\fBTcl_GetSlave\fR(\fIinterp, slaveName\fR) +.sp +Tcl_Interp * +\fBTcl_GetMaster\fR(\fIinterp\fR) +.sp +int +\fBTcl_GetInterpPath\fR(\fIaskingInterp, slaveInterp\fR) +.sp +int +\fBTcl_CreateAlias\fR(\fIslaveInterp, srcCmd, targetInterp, targetCmd, argc, argv\fR) +.sp +int +\fBTcl_GetAlias\fR(\fIinterp, srcCmd, targetInterpPtr, targetCmdPtr, argcPtr, argvPtr\fR) +.SH ARGUMENTS +.AS Tcl_InterpDeleteProc **delProcPtr +.AP Tcl_Interp *interp in +Interpreter in which to execute the specified command. +.AP char *slaveName in +Name of slave interpreter to create or manipulate. +.AP int isSafe in +Zero means the interpreter may have all Tcl functions. Non-zero means the +new interpreter's functionality should be limited to make it safe. +.AP Tcl_Interp *slaveInterp in +Interpreter to use for creating the source command for an alias (see +below). +.AP char *srcCmd in +Name of source command for alias. +.AP Tcl_Interp *targetInterp in +Interpreter that contains the target command for an alias. +.AP char *targetCmd in +Name of target command for alias in \fItargetInterp\fR. +.AP int argc in +Count of additional arguments to pass to the alias command. +.AP char **argv in +Vector of strings, the additional arguments to pass to the alias command. +This storage is owned by the caller. +.AP Tcl_Interp **targetInterpPtr in +Pointer to location to store the address of the interpreter where a target +command is defined for an alias. +.AP char **targetCmdPtr out +Pointer to location to store the address of the name of the target command +for an alias. +.AP int *argcPtr out +Pointer to location to store count of additional arguments to be passed to +the alias. The location is in storage owned by the caller. +.AP char ***argvPtr out +Pointer to location to store a vector of strings, the additional arguments +to pass to an alias. The location is in storage owned by the caller, the +vector of strings is owned by the called function. +.BE + +.SH DESCRIPTION +.PP +These procedures are intended for access to the multiple interpreter +facility from inside C programs. They enable managing multiple interpreters +in a hierarchical relationship, and the management of aliases, commands +that when invoked in one interpreter execute a command in another +interpreter. The return value for those procedures that return an \fBint\fR +is either \fBTCL_OK\fR or \fBTCL_ERROR\fR. If \fBTCL_ERROR\fR is returned +then the \fBresult\fR field of the interpreter contains an error message. +.PP +\fBTcl_CreateSlave\fR creates a new interpreter as a slave of the given +interpreter. It also creates a slave command in the given interpreter which +allows the master interpreter to manipulate the slave. The slave +interpreter and the slave command have the specified name. If \fIisSafe\fR +is \fB1\fR, the new slave interpreter is made ``safe'' by removing all +unsafe functionality. If the creation failed, \fBNULL\fR is returned. +.PP +\fBTcl_IsSafe\fR returns \fB1\fR if the given interpreter is ``safe'', +\fB0\fR otherwise. +.PP +\fBTcl_MakeSafe\fR makes the given interpreter ``safe'' by removing all +non-core and core unsafe functionality. Note that if you call this after +adding some extension to an interpreter, all traces of that extension will +be removed from the interpreter. This operation always succeeds and returns +\fBTCL_OK\fR. +.PP +\fBTcl_GetSlave\fR returns a pointer to a slave interpreter of the given +interpreter. The slave interpreter is identified by the name specified. +If no such slave interpreter exists, \fBNULL\fR is returned. +.PP +\fBTcl_GetMaster\fR returns a pointer to the master interpreter of the +given interpreter. If the given interpreter has no master (it is a +top-level interpreter) then \fBNULL\fR is returned. +.PP +\fBTcl_GetInterpPath\fR sets the \fIresult\fR field in \fIaskingInterp\fR +to the relative path between \fIaskingInterp\fR and \fIslaveInterp\fR; +\fIslaveInterp\fR must be a slave of \fIaskingInterp\fR. If the computation +of the relative path succeeds, \fBTCL_OK\fR is returned, else +\fBTCL_ERROR\fR is returned and the \fIresult\fR field in +\fIaskingInterp\fR contains the error message. +.PP +\fBTcl_GetAlias\fR returns information about an alias of a specified name +in a given interpreter. Any of the result fields can be \fBNULL\fR, in +which case the corresponding datum is not returned. If a result field is +non\-\fBNULL\fR, the address indicated is set to the corresponding datum. +For example, if \fItargetNamePtr\fR is non\-\fBNULL\fR it is set to a +pointer to the string containing the name of the target command. +.PP +In order to map over all slave interpreters, use \fBTcl_Eval\fR with the +command \fBinterp slaves\fR and use the value (a Tcl list) deposited in the +\fBresult\fR field of the interpreter. Similarly, to map over all aliases +whose source commands are defined in an interpreter, use \fBTcl_Eval\fR +with the command \fBinterp aliases\fR and use the value (a Tcl list) +deposited in the \fBresult\fR field. Note that the storage of this list +belongs to Tcl, so you should copy it before invoking any other Tcl +commands in that interpreter. +.SH "SEE ALSO" +For a description of the Tcl interface to multiple interpreters, see +\fIinterp(n)\fR. + +.SH KEYWORDS +alias, command, interpreter, master, slave + diff --git a/tcl7.6/doc/CrtTimerHdlr.3 b/tcl7.6/doc/CrtTimerHdlr.3 new file mode 100644 index 0000000..14f48a4 --- /dev/null +++ b/tcl7.6/doc/CrtTimerHdlr.3 @@ -0,0 +1,76 @@ +'\" +'\" Copyright (c) 1990 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) CrtTimerHdlr.3 1.4 96/09/17 10:54:58 +'\" +.so man.macros +.TH Tcl_CreateTimerHandler 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_CreateTimerHandler, Tcl_DeleteTimerHandler \- call a procedure at a +given time +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +Tcl_TimerToken +\fBTcl_CreateTimerHandler\fR(\fImilliseconds, proc, clientData\fR) +.sp +\fBTcl_DeleteTimerHandler\fR(\fItoken\fR) +.SH ARGUMENTS +.AS Tcl_TimerToken milliseconds +.AP int milliseconds in +How many milliseconds to wait before invoking \fIproc\fR. +.AP Tcl_TimerProc *proc in +Procedure to invoke after \fImilliseconds\fR have elapsed. +.AP ClientData clientData in +Arbitrary one-word value to pass to \fIproc\fR. +.AP Tcl_TimerToken token in +Token for previously-created timer handler (the return value +from some previous call to \fBTcl_CreateTimerHandler\fR). +.BE + +.SH DESCRIPTION +.PP +\fBTcl_CreateTimerHandler\fR arranges for \fIproc\fR to be +invoked at a time \fImilliseconds\fR milliseconds in the +future. +The callback to \fIproc\fR will be made by \fBTcl_DoOneEvent\fR, +so \fBTcl_CreateTimerHandler\fR is only useful in programs that +dispatch events through \fBTcl_DoOneEvent\fR or through Tcl commands +such as \fBvwait\fR. +The call to \fIproc\fR may not be made at the exact time given by +\fImilliseconds\fR: it will be made at the next opportunity +after that time. For example, if \fBTcl_DoOneEvent\fR isn't +called until long after the time has elapsed, or if there +are other pending events to process before the call to +\fIproc\fR, then the call to \fIproc\fR will be delayed. +.PP +\fIProc\fR should have arguments and return value that match +the type \fBTcl_TimerProc\fR: +.CS +typedef void Tcl_TimerProc(ClientData \fIclientData\fR); +.CE +The \fIclientData\fR parameter to \fIproc\fR is a +copy of the \fIclientData\fR argument given to +\fBTcl_CreateTimerHandler\fR when the callback +was created. Typically, \fIclientData\fR points to a data +structure containing application-specific information about +what to do in \fIproc\fR. +.PP +\fBTcl_DeleteTimerHandler\fR may be called to delete a +previously-created timer handler. It deletes the handler +indicated by \fItoken\fR so that no call to \fIproc\fR +will be made; if that handler no longer exists +(e.g. because the time period has already elapsed and \fIproc\fR +has been invoked then \fBTcl_DeleteTimerHandler\fR does nothing. +The tokens returned by \fBTcl_CreateTimerHandler\fR never have +a value of NULL, so if NULL is passed to \fBTcl_DeleteTimerHandler\fR +then the procedure does nothing. + +.SH KEYWORDS +callback, clock, handler, timer diff --git a/tcl7.3/doc/CrtTrace.3 b/tcl7.6/doc/CrtTrace.3 similarity index 74% rename from tcl7.3/doc/CrtTrace.3 rename to tcl7.6/doc/CrtTrace.3 index 796346d..e9f3bb3 100644 --- a/tcl7.3/doc/CrtTrace.3 +++ b/tcl7.6/doc/CrtTrace.3 @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/CrtTrace.3,v 1.8 93/04/01 09:25:26 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) CrtTrace.3 1.14 96/03/25 20:01:10 '\" .so man.macros -.HS Tcl_CreateTrace tclc +.TH Tcl_CreateTrace 3 "" Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_CreateTrace, Tcl_DeleteTrace \- arrange for command execution to be traced @@ -63,24 +50,18 @@ 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 +.CS 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 + 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[]); +.CE +The \fIclientData\fR and \fIinterp\fR 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 diff --git a/tcl7.3/doc/DString.3 b/tcl7.6/doc/DString.3 similarity index 72% rename from tcl7.3/doc/DString.3 rename to tcl7.6/doc/DString.3 index 9d72b42..e6ea142 100644 --- a/tcl7.3/doc/DString.3 +++ b/tcl7.6/doc/DString.3 @@ -1,32 +1,17 @@ '\" '\" Copyright (c) 1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/DString.3,v 1.10 93/08/16 13:24:52 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) DString.3 1.20 96/08/26 12:59:44 '\" .so man.macros -.HS Tcl_DStringInit tclc 7.0 +.TH Tcl_DString 3 7.4 Tcl "Tcl Library Procedures" .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 +Tcl_DStringInit, Tcl_DStringAppend, Tcl_DStringAppendElement, Tcl_DStringStartSublist, Tcl_DStringEndSublist, Tcl_DStringLength, Tcl_DStringValue, Tcl_DStringSetLength, Tcl_DStringFree, Tcl_DStringResult, Tcl_DStringGetResult \- manipulate dynamic strings .SH SYNOPSIS .nf \fB#include \fR @@ -49,11 +34,13 @@ int char * \fBTcl_DStringValue\fR(\fIdsPtr\fR) .sp -\fBTcl_DStringTrunc\fR(\fIdsPtr, newLength\fR) +\fBTcl_DStringSetLength\fR(\fIdsPtr, newLength\fR) .sp \fBTcl_DStringFree\fR(\fIdsPtr\fR) .sp \fBTcl_DStringResult\fR(\fIinterp, dsPtr\fR) +.sp +\fBTcl_DStringGetResult\fR(\fIinterp, dsPtr\fR) .SH ARGUMENTS .AS Tcl_DString newLength .AP Tcl_DString *dsPtr in/out @@ -66,6 +53,9 @@ add all characters up to null terminating character. .AP int newLength in New length for dynamic string, not including null terminating character. +.AP Tcl_Interp *interp in/out +Interpreter whose result is to be set from or moved to the +dynamic string. .BE .SH DESCRIPTION @@ -111,7 +101,7 @@ 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 +followed by an open brace; \fBTcl_DStringEndSublist\fR appends a close brace. Lists can be nested to any depth. .PP @@ -120,10 +110,18 @@ 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 +.PP +\fBTcl_DStringSetLength\fR changes the length of a dynamic string. +If \fInewLength\fR is less than the string's current length, then +the string is truncated. +If \fInewLength\fR is greater than the string's current length, +then the string will become longer and new space will be allocated +for the string if needed. +However, \fBTcl_DStringSetLength\fR will not initialize the new +space except to provide a terminating null character; it is up to the +caller to fill in the new space. +\fBTcl_DStringSetLength\fR 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 @@ -136,6 +134,12 @@ 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. +.PP +\fBTcl_DStringGetResult\fR does the opposite of \fBTcl_DStringResult\fR. +It sets the value of \fIdsPtr\fR to the result of \fIinterp\fR and +it clears \fIinterp\fR's result. +If possible it does this by moving a pointer rather than by copying +the string. .SH KEYWORDS append, dynamic string, free, result diff --git a/tcl7.3/doc/DetachPids.3 b/tcl7.6/doc/DetachPids.3 similarity index 66% rename from tcl7.3/doc/DetachPids.3 rename to tcl7.6/doc/DetachPids.3 index 4862d92..153649b 100644 --- a/tcl7.3/doc/DetachPids.3 +++ b/tcl7.6/doc/DetachPids.3 @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/DetachPids.3,v 1.10 93/09/09 10:53:24 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) DetachPids.3 1.15 96/08/26 12:59:44 '\" .so man.macros -.HS Tcl_DetachPids tclc +.TH Tcl_DetachPids 3 "" Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_DetachPids, Tcl_ReapDetachedProcs \- manage child processes in background @@ -31,9 +18,7 @@ Tcl_DetachPids, Tcl_ReapDetachedProcs \- manage child processes in background .sp \fBTcl_DetachPids\fR(\fInumPids, pidPtr\fR) .sp -.VS \fBTcl_ReapDetachedProcs\fR() -.VE .SH ARGUMENTS .AS int *statusPtr .AP int numPids in @@ -44,7 +29,6 @@ Address of array containing \fInumPids\fR process ids. .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 @@ -73,7 +57,6 @@ 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/tcl7.6/doc/DoOneEvent.3 b/tcl7.6/doc/DoOneEvent.3 new file mode 100644 index 0000000..a9e0bc9 --- /dev/null +++ b/tcl7.6/doc/DoOneEvent.3 @@ -0,0 +1,108 @@ +'\" +'\" Copyright (c) 1990-1992 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) DoOneEvent.3 1.5 96/03/25 20:02:05 +'\" +.so man.macros +.TH Tcl_DoOneEvent 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_DoOneEvent \- wait for events and invoke event handlers +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +int +\fBTcl_DoOneEvent\fR(\fIflags\fR) +.SH ARGUMENTS +.AS int flags +.AP int flags in +This parameter is normally zero. It may be an OR-ed combination +of any of the following flag bits: +TCL_WINDOW_EVENTS, +TCL_FILE_EVENTS, TCL_TIMER_EVENTS, TCL_IDLE_EVENTS, TCL_ALL_EVENTS, or +TCL_DONT_WAIT. +.BE + +.SH DESCRIPTION +.PP +This procedure is the entry point to Tcl's event loop; it is responsible for +waiting for events and dispatching event handlers created with +procedures such as \fBTk_CreateEventHandler\fR, \fBTcl_CreateFileHandler\fR, +\fBTcl_CreateTimerHandler\fR, and \fBTcl_DoWhenIdle\fR. +\fBTcl_DoOneEvent\fR checks to see if +events are already present on the Tcl event queue; if so, +it calls the handler(s) for the first (oldest) event, removes it from +the queue, and returns. +If there are no events ready to be handled, then \fBTcl_DoOneEvent\fR +checks for new events from all possible sources. +If any are found, it puts all of them on Tcl's event queue, calls +handlers for the first event on the queue, and returns. +If no events are found, \fBTcl_DoOneEvent\fR checks for \fBTcl_DoWhenIdle\fR +callbacks; if any are found, it invokes all of them and returns. +Finally, if no events or idle callbacks have been found, then +\fBTcl_DoOneEvent\fR sleeps until an event occurs; then it adds any +ew events to the Tcl event queue, calls handlers for the first event, +and returns. +The normal return value is 1 to signify that some event +was processed (see below for other alternatives). +.PP +If the \fIflags\fR argument to \fBTcl_DoOneEvent\fR is non-zero, +it restricts the kinds of events that will be processed by +\fBTcl_DoOneEvent\fR. +\fIFlags\fR may be an OR-ed combination of any of the following bits: +.TP 27 +\fBTCL_WINDOW_EVENTS\fR \- +Process window system events. +.TP 27 +\fBTCL_FILE_EVENTS\fR \- +Process file events. +.TP 27 +\fBTCL_TIMER_EVENTS\fR \- +Process timer events. +.TP 27 +\fBTCL_IDLE_EVENTS\fR \- +Process idle callbacks. +.TP 27 +\fBTCL_ALL_EVENTS\fR \- +Process all kinds of events: equivalent to OR-ing together all of the +above flags or specifying none of them. +.TP 27 +\fBTCL_DONT_WAIT\fR \- +Don't sleep: process only events that are ready at the time of the +call. +.LP +If any of the flags \fBTCL_WINDOW_EVENTS\fR, \fBTCL_FILE_EVENTS\fR, +\fBTCL_TIMER_EVENTS\fR, or \fBTCL_IDLE_EVENTS\fR is set, then the only +events that will be considered are those for which flags are set. +Setting none of these flags is equivalent to the value +\fBTCL_ALL_EVENTS\fR, which causes all event types to be processed. +If an application has defined additional event sources with +\fBTcl_CreateEventSource\fR, then additional \fIflag\fR values +may also be valid, depending on those event sources. +.PP +The \fBTCL_DONT_WAIT\fR flag causes \fBTcl_DoOneEvent\fR not to put +the process to sleep: it will check for events but if none are found +then it returns immediately with a return value of 0 to indicate +that no work was done. +\fBTcl_DoOneEvent\fR will also return 0 without doing anything if +the only alternative is to block forever (this can happen, for example, +if \fIflags\fR is \fBTCL_IDLE_EVENTS\fR and there are no +\fBTcl_DoWhenIdle\fR callbacks pending, or if no event handlers or +timer handlers exist). +.PP +\fBTcl_DoOneEvent\fR may be invoked recursively. For example, +it is possible to invoke \fBTcl_DoOneEvent\fR recursively +from a handler called by \fBTcl_DoOneEvent\fR. This sort +of operation is useful in some modal situations, such +as when a +notification dialog has been popped up and an application wishes to +wait for the user to click a button in the dialog before +doing anything else. + +.SH KEYWORDS +callback, event, handler, idle, timer diff --git a/tcl7.6/doc/DoWhenIdle.3 b/tcl7.6/doc/DoWhenIdle.3 new file mode 100644 index 0000000..2b43b05 --- /dev/null +++ b/tcl7.6/doc/DoWhenIdle.3 @@ -0,0 +1,87 @@ +'\" +'\" Copyright (c) 1990 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) DoWhenIdle.3 1.4 96/03/25 20:02:20 +'\" +.so man.macros +.TH Tcl_DoWhenIdle 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_DoWhenIdle, Tcl_CancelIdleCall \- invoke a procedure when there are no pending events +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +\fBTcl_DoWhenIdle\fR(\fIproc, clientData\fR) +.sp +\fBTcl_CancelIdleCall\fR(\fIproc, clientData\fR) +.SH ARGUMENTS +.AS Tcl_IdleProc clientData +.AP Tcl_IdleProc *proc in +Procedure to invoke. +.AP ClientData clientData in +Arbitrary one-word value to pass to \fIproc\fR. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_DoWhenIdle\fR arranges for \fIproc\fR to be invoked +when the application becomes idle. The application is +considered to be idle when \fBTcl_DoOneEvent\fR has been +called, couldn't find any events to handle, and is about +to go to sleep waiting for an event to occur. At this +point all pending \fBTcl_DoWhenIdle\fR handlers are +invoked. For each call to \fBTcl_DoWhenIdle\fR there will +be a single call to \fIproc\fR; after \fIproc\fR is +invoked the handler is automatically removed. +\fBTcl_DoWhenIdle\fR is only usable in programs that +use \fBTcl_DoOneEvent\fR to dispatch events. +.PP +\fIProc\fR should have arguments and result that match the +type \fBTcl_IdleProc\fR: +.CS +typedef void Tcl_IdleProc(ClientData \fIclientData\fR); +.CE +The \fIclientData\fR parameter to \fIproc\fR is a copy of the \fIclientData\fR +argument given to \fBTcl_DoWhenIdle\fR. Typically, \fIclientData\fR +points to a data structure containing application-specific information about +what \fIproc\fR should do. +.PP +\fBTcl_CancelIdleCall\fR +may be used to cancel one or more previous +calls to \fBTcl_DoWhenIdle\fR: if there is a \fBTcl_DoWhenIdle\fR +handler registered for \fIproc\fR and \fIclientData\fR, then it +is removed without invoking it. If there is more than one +handler on the idle list that refers to \fIproc\fR and \fIclientData\fR, +all of the handlers are removed. If no existing handlers match +\fIproc\fR and \fIclientData\fR then nothing happens. +.PP +\fBTcl_DoWhenIdle\fR is most useful in situations where +(a) a piece of work will have to be done but (b) it's +possible that something will happen in the near future +that will change what has to be done or require something +different to be done. \fBTcl_DoWhenIdle\fR allows the +actual work to be deferred until all pending events have +been processed. At this point the exact work to be done +will presumably be known and it can be done exactly once. +.PP +For example, \fBTcl_DoWhenIdle\fR might be used by an editor +to defer display updates until all pending commands have +been processed. Without this feature, redundant redisplays +might occur in some situations, such as the processing of +a command file. + +.SH BUGS +.PP +At present it is not safe for an idle callback to reschedule itself +continuously. This will interact badly with certain features of Tk +that attempt to wait for all idle callbacks to complete. If you would +like for an idle callback to reschedule itself continuously, it is +better to use a timer handler with a zero timeout period. + +.SH KEYWORDS +callback, defer, idle callback diff --git a/tcl7.3/doc/Eval.3 b/tcl7.6/doc/Eval.3 similarity index 77% rename from tcl7.3/doc/Eval.3 rename to tcl7.6/doc/Eval.3 index db2cbf4..adea029 100644 --- a/tcl7.3/doc/Eval.3 +++ b/tcl7.6/doc/Eval.3 @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/Eval.3,v 1.13 93/04/03 16:40:04 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) Eval.3 1.18 96/08/26 12:59:45 '\" .so man.macros -.HS Tcl_Eval tclc 7.0 +.TH Tcl_Eval 3 7.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_Eval, Tcl_VarEval, Tcl_EvalFile, Tcl_GlobalEval \- execute Tcl commands @@ -30,9 +17,7 @@ Tcl_Eval, Tcl_VarEval, Tcl_EvalFile, Tcl_GlobalEval \- execute Tcl commands \fB#include \fR .sp int -.VS \fBTcl_Eval\fR(\fIinterp, cmd\fR) -.VE .sp int \fBTcl_VarEval\fR(\fIinterp, string, string, ... \fB(char *) NULL\fR) @@ -61,9 +46,7 @@ Name of file containing Tcl command string. 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 diff --git a/tcl7.6/doc/Exit.3 b/tcl7.6/doc/Exit.3 new file mode 100644 index 0000000..dc370bd --- /dev/null +++ b/tcl7.6/doc/Exit.3 @@ -0,0 +1,66 @@ +'\" +'\" Copyright (c) 1995-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) Exit.3 1.4 96/03/25 20:02:50 +'\" +.so man.macros +.TH Tcl_Exit 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_Exit, Tcl_CreateExitHandler, Tcl_DeleteExitHandler \- end the application (and invoke exit handlers) +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +\fBTcl_Exit\fR(\fIstatus\fR) +.sp +\fBTcl_CreateExitHandler\fR(\fIproc, clientData\fR) +.sp +\fBTcl_DeleteExitHandler\fR(\fIproc, clientData\fR) +.SH ARGUMENTS +.AS Tcl_ExitProc clientData +.AP int status in +Provides information about why application exited. Exact meaning may +be platform-specific. 0 usually means a normal exit, 1 means that an +error occurred. +.AP Tcl_ExitProc *proc in +Procedure to invoke before exiting application. +.AP ClientData clientData in +Arbitrary one-word value to pass to \fIproc\fR. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_Exit\fR is the procedure that is invoked to end a Tcl application. +It is invoked by the \fBexit\fR command, as well as anyplace else that +terminates the application. +No-one should ever invoke the \fBexit\fR procedure directly; always +invoke \fBTcl_Exit\fR instead, so that it can invoke exit handlers. +.PP +\fBTcl_CreateExitHandler\fR arranges for \fIproc\fR to be invoked +by \fBTcl_Exit\fR before it terminates the application. +This provides a hook for cleanup operations such as flushing buffers +and freeing global memory. +\fIProc\fR should have arguments and return value that match +the type \fBTcl_ExitProc\fR: +.CS +typedef void Tcl_ExitProc(ClientData \fIclientData\fR); +.CE +The \fIclientData\fR parameter to \fIproc\fR is a +copy of the \fIclientData\fR argument given to +\fBTcl_CreateExitHandler\fR when the callback +was created. Typically, \fIclientData\fR points to a data +structure containing application-specific information about +what to do in \fIproc\fR. +.PP +\fBTcl_DeleteExitHandler\fR may be called to delete a +previously-created exit handler. It removes the handler +indicated by \fIproc\fR and \fIclientData\fR so that no call +to \fIproc\fR will be made. If no such handler exists then +\fBTcl_DeleteExitHandler\fR does nothing. + +.SH KEYWORDS +callback, end application, exit diff --git a/tcl7.3/doc/ExprLong.3 b/tcl7.6/doc/ExprLong.3 similarity index 72% rename from tcl7.3/doc/ExprLong.3 rename to tcl7.6/doc/ExprLong.3 index a043347..dfe2ecc 100644 --- a/tcl7.3/doc/ExprLong.3 +++ b/tcl7.6/doc/ExprLong.3 @@ -1,30 +1,17 @@ '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/ExprLong.3,v 1.11 93/04/17 15:31:16 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) ExprLong.3 1.18 96/08/26 12:59:46 '\" .so man.macros -.HS Tcl_ExprLong tclc 7.0 +.TH Tcl_ExprLong 3 7.0 Tcl "Tcl Library Procedures" .BS .SH NAME -Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBool, Tcl_ExprString \- evaluate an expression +Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean, Tcl_ExprString \- evaluate an expression .SH SYNOPSIS .nf \fB#include \fR @@ -72,7 +59,7 @@ 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 +Tcl result: \fBTCL_OK\fR means the expression was successfully 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. @@ -98,22 +85,18 @@ an error is returned. 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/tcl7.6/doc/FindExec.3 b/tcl7.6/doc/FindExec.3 new file mode 100644 index 0000000..b48b225 --- /dev/null +++ b/tcl7.6/doc/FindExec.3 @@ -0,0 +1,46 @@ +'\" +'\" Copyright (c) 1995-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) FindExec.3 1.4 96/10/09 08:29:29 +'\" +.so man.macros +.TH Tcl_FindExecutable 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_FindExecutable \- identify the binary file containing the application +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +char * +\fBTcl_FindExecutable\fR(\fIargv0\fR) +.SH ARGUMENTS +.AS char *argv0 in +.AP char *argv0 in +The first command-line argument to the program, which gives the +application's name. +.BE + +.SH DESCRIPTION +.PP +This procedure computes the full path name of the executable file +from which the application was invoked and saves it for Tcl's +internal use. +The executable's path name is needed for several purposes in +Tcl. For example, it is needed on some platforms in the +implementation of the \fBload\fR command. +It is also returned by the \fBinfo nameofexecutable\fR command. +.PP +On UNIX platforms this procedure is typically invoked as the very +first thing in the application's main program; it must be passed +\fIargv[0]\fR as its argument. \fBTcl_FindExecutable\fR uses \fIargv0\fR +along with the \fBPATH\fR environment variable to find the +application's executable, if possible. If it fails to find +the binary, then future calls to \fBinfo nameofexecutable\fR +will return an empty string. + +.SH KEYWORDS +binary, executable file diff --git a/tcl7.6/doc/GetFile.3 b/tcl7.6/doc/GetFile.3 new file mode 100644 index 0000000..68ffd21 --- /dev/null +++ b/tcl7.6/doc/GetFile.3 @@ -0,0 +1,130 @@ +'\" +'\" Copyright (c) 1995-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) GetFile.3 1.8 96/03/25 20:03:31 +'\" +.so man.macros +.TH Tcl_GetFile 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_GetFile, Tcl_FreeFile, Tcl_GetFileInfo \- procedures to manipulate generic file handles +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +Tcl_File +\fBTcl_GetFile\fR(\fIosHandle, type\fR) +.sp +\fBTcl_FreeFile\fR(\fIhandle\fR) +.sp +ClientData +\fBTcl_GetFileInfo\fR(\fIhandle, typePtr\fR) +.sp +ClientData +\fBTcl_GetNotifierData\fR(\fIhandle, freeProcPtr\fR) +.sp +\fBTcl_SetNotifierData\fR(\fIhandle, freeProc, clientData\fR) +.SH ARGUMENTS +.AS Tcl_FileFreeProc **freeProcPtr +.AP ClientData osHandle in +Platform-specific file handle to be associated with the generic file handle. +.AP int type in +The type of platform-specific file handle associated with the generic file +handle. See below for a list of valid types. +.AP Tcl_File handle in +Generic file handle associated with platform-specific file information. +.AP int *typePtr in/out +If \fI*typePtr\fR is not NULL, then the specified word is set to +contain the type associated with \fIhandle\fR. +.AP Tcl_FileFreeProc *freeProc in +Procedure to call when \fIhandle\fR is deleted. +.AP Tcl_FileFreeProc **freeProcPtr in/out +Pointer to location in which to store address of current free procedure +for file handle. Ignored if NULL. +.AP ClientData clientData in +Arbitrary one-word value associated with the given file handle. This +data is owned by the caller. +.BE + +.SH DESCRIPTION +.PP +A \fBTcl_File\fR is an opaque handle used to refer to files in a +platform independent way in Tcl routines like +\fBTcl_CreateFileHandler\fR. A file handle has an associated +platform-dependent \fIosHandle\fR, a \fItype\fR and additional private +data used by the notifier to generate events for the file. The type +is an integer that determines how the platform-specific drivers will +interpret the \fIosHandle\fR. The types that are defined by the core +are: +.TP 22 +\fBTCL_UNIX_FD\fR +The \fIosHandle\fR is a Unix file descriptor. +.TP 22 +\fBTCL_MAC_FILE\fR +The file is a Macintosh file handle. +.TP 22 +\fBTCL_WIN_FILE\fR +The \fIosHandle\fR is a Windows normal file \fBHANDLE\fR. +.TP 22 +\fBTCL_WIN_PIPE\fR +The \fIosHandle\fR is a Windows anonymous pipe \fBHANDLE\fR. +.TP 22 +\fBTCL_WIN_SOCKET\fR +The \fIosHandle\fR is a Windows \fBSOCKET\fR. +.TP 22 +\fBTCL_WIN_CONSOLE\fR +The \fIosHandle\fR is a Windows console buffer \fBHANDLE\fR. +.PP +\fBTcl_GetFile\fR locates the file handle corresponding to a particular +\fIosHandle\fR and a \fItype\fR. If a file handle already existed for the +given file, then that handle will be returned. If this is the first time that +the file handle for a particular file is being retrieved, then a new file +handle will be allocated and returned. +.PP +When a file handle is no longer in use, it should be deallocated with +a call to \fBTcl_FreeFile\fR. A call to this function will invoke the +notifier free procedure \fIproc\fR, if there is one. After the +notifier has cleaned up, any resources used by the file handle will be +deallocated. \fBTcl_FreeFile\fR will not close the platform-specific +\fIosHandle\fR. +.PP +\fBTcl_GetFileInfo\fR may be used to retrieve the platform-specific +\fIosHandle\fR and type associated with a file handle. If +\fItypePtr\fR is not NULL, then the word at \fI*typePtr\fR is set to +the type of the file handle. The return value of the function is the +associated platform-specific \fIosHandle\fR. Note that this function +may be used to extract the platform-specific file handle from a +\fBTcl_File\fR so that it may be used in external interfaces. +However, programs written using this interface will be +platform-specific. +.PP +The \fBTcl_SetNotifierData\fR and \fBTcl_GetNotifierData\fR procedures are +intended to be used only by notifier writers. See the +\fITcl_CreateEventSource(3)\fR manual entry for more information on +the notifier. +.PP +\fBTcl_SetNotifierData\fR may be used by notifier writers to associate +notifier-specific information with a \fBTcl_File\fR. The \fIdata\fR +argument specifies a word that may be retrieved with a later call to +\fBTcl_GetNotifierData\fR. If the \fIfreeProc\fR argument is non-NULL +it specifies the address of a procedure to invoke when the +\fBTcl_File\fR is deleted. \fIfreeProc\fR should have arguments and +result that match the type \fBTcl_FileFreeProc\fR: +.CS +typedef void Tcl_FileFreeProc( + ClientData \fIclientData\fR); +.CE +When \fIfreeProc\fR is invoked the \fIclientData\fR argument will be +the same as the corresponding argument passed to +\fBTcl_SetNotifierData\fR. +.PP +\fBTcl_GetNotifierData\fR returns the \fIclientData\fR associated with +the given \fBTcl_File\fR, and if the \fIfreeProcPtr\fR field is +non-\fBNULL\fR, the address indicated by it gets the address of the +free procedure stored with this file. + +.SH KEYWORDS +generic file handle, file type, file descriptor, notifier diff --git a/tcl7.3/doc/GetInt.3 b/tcl7.6/doc/GetInt.3 similarity index 72% rename from tcl7.3/doc/GetInt.3 rename to tcl7.6/doc/GetInt.3 index b3cf91d..8f1da08 100644 --- a/tcl7.3/doc/GetInt.3 +++ b/tcl7.6/doc/GetInt.3 @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/GetInt.3,v 1.8 93/04/01 09:25:29 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) GetInt.3 1.12 96/03/25 20:03:44 '\" .so man.macros -.HS Tcl_GetInt tclc +.TH Tcl_GetInt 3 "" Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_GetInt, Tcl_GetDouble, Tcl_GetBoolean \- convert from string to integer, double, or boolean diff --git a/tcl7.6/doc/GetOpnFl.3 b/tcl7.6/doc/GetOpnFl.3 new file mode 100644 index 0000000..8f37d11 --- /dev/null +++ b/tcl7.6/doc/GetOpnFl.3 @@ -0,0 +1,57 @@ +'\" +'\" Copyright (c) 1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) GetOpnFl.3 1.2 96/03/26 13:40:26 +.so man.macros +.TH Tcl_GetOpenFile 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_GetOpenFile \- Get a standard IO File * handle from a channel. +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +int +\fBTcl_GetOpenFile\fR(\fIinterp, string, write, checkUsage, filePtr\fR) +.sp +.SH ARGUMENTS +.AS Tcl_Interp checkUsage +.AP Tcl_Interp *interp in +Tcl interpreter from which file handle is to be obtained. +.AP char *string in +String identifying channel, 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 ClientData *filePtr out +Points to word in which to store pointer to FILE structure for +the file given by \fIstring\fR. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_GetOpenFile\fR takes as argument a file identifier of the form +returned by the \fBopen\fR command 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 channel 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. +In the current implementation \fIcheckUsage\fR is ignored and consistency +checks are always performed. + +.SH KEYWORDS +channel, file handle, permissions, pipeline, read, write diff --git a/tcl7.6/doc/GetStdChan.3 b/tcl7.6/doc/GetStdChan.3 new file mode 100644 index 0000000..bc81e4c --- /dev/null +++ b/tcl7.6/doc/GetStdChan.3 @@ -0,0 +1,73 @@ +'\" +'\" Copyright (c) 1996 by Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" @(#) GetStdChan.3 1.2 96/03/08 13:59:57 +'\" +.so man.macros +.TH Tcl_GetStdChannel 3 7.5 Tcl "Tcl Library Procedures" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +Tcl_GetStdChannel, Tcl_SetStdChannel \- procedures for retrieving and replacing the standard channels +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +Tcl_Channel +\fBTcl_GetStdChannel\fR(\fItype\fR) +.sp +\fBTcl_SetStdChannel\fR(\fIchannel, type\fR) +.sp +.SH ARGUMENTS +.AS Tcl_Channel channel in +.AP int type in +The identifier for the standard channel to retrieve or modify. Must be one of +\fBTCL_STDIN\fR, \fBTCL_STDOUT\fR, or \fBTCL_STDERR\fR. +.AP Tcl_Channel channel in +The channel to use as the new value for the specified standard channel. +.BE + +.SH DESCRIPTION +.PP +Tcl defines three special channels that are used by various I/O related +commands if no other channels are specified. The standard input channel +has a channel name of \fBstdin\fR and is used by \fBread\fR and \fBgets\fR. +The standard output channel is named \fBstdout\fR and is used by +\fBputs\fR. The standard error channel is named \fBstderr\fR and is used for +reporting errors. In addition, the standard channels are inherited by any +child processes created using \fBexec\fR or \fBopen\fR in the absence of any +other redirections. +.PP +The standard channels are actually aliases for other normal channels. The +current channel associated with a standard channel can be retrieved by calling +\fBTcl_GetStdChannel\fR with one of +\fBTCL_STDIN\fR, \fBTCL_STDOUT\fR, or \fBTCL_STDERR\fR as the \fItype\fR. The +return value will be a valid channel, or NULL. +.PP +A new channel can be set for the standard channel specified by \fItype\fR +by calling \fBTcl_SetStdChannel\fR with a new channel or NULL in the +\fIchannel\fR argument. If the specified channel is closed by a later call to +\fBTcl_Close\fR, then the corresponding standard channel will automatically be +set to NULL. +.PP +If \fBTcl_GetStdChannel\fR is called before \fBTcl_SetStdChannel\fR, Tcl will +construct a new channel to wrap the appropriate platform-specific standard +file handle. If \fBTcl_SetStdChannel\fR is called before +\fBTcl_GetStdChannel\fR, then the default channel will not be created. +.PP +If one of the standard channels is set to NULL, either by calling +\fBTcl_SetStdChannel\fR with a null \fIchannel\fR argument, or by calling +\fBTcl_Close\fR on the channel, then the next call to \fBTcl_CreateChannel\fR +will automatically set the standard channel with the newly created channel. If +more than one standard channel is NULL, then the standard channels will be +assigned starting with standard input, followed by standard output, with +standard error being last. + +.SH "SEE ALSO" +Tcl_Close(3), Tcl_CreateChannel(3) + +.SH KEYWORDS +standard channel, standard input, standard output, standard error diff --git a/tcl7.3/doc/Hash.3 b/tcl7.6/doc/Hash.3 similarity index 87% rename from tcl7.3/doc/Hash.3 rename to tcl7.6/doc/Hash.3 index fec8903..48835a3 100644 --- a/tcl7.3/doc/Hash.3 +++ b/tcl7.6/doc/Hash.3 @@ -1,30 +1,16 @@ '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/Hash.3,v 1.9 93/07/23 08:30:53 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) Hash.3 1.15 96/03/25 20:04:01 '\" .so man.macros -.HS Tcl_Hash tclc +.TH Tcl_Hash 3 "" Tcl "Tcl Library Procedures" .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 @@ -192,7 +178,7 @@ 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 +Each subsequent 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 diff --git a/tcl7.3/doc/Interp.3 b/tcl7.6/doc/Interp.3 similarity index 79% rename from tcl7.3/doc/Interp.3 rename to tcl7.6/doc/Interp.3 index a93cfcc..5610246 100644 --- a/tcl7.3/doc/Interp.3 +++ b/tcl7.6/doc/Interp.3 @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/Interp.3,v 1.10 93/04/01 09:25:32 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) Interp.3 1.16 96/06/06 13:48:02 '\" .so man.macros -.HS Tcl_Interp tclc +.TH Tcl_Interp 3 7.5 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_Interp \- client-visible fields of interpreter structures @@ -70,12 +57,16 @@ 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. +.VS 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) +allocate its return value (e.g. using \fBTcl_Alloc\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). +to the address of a procedure that can free the value, or \fBTCL_DYNAMIC\fR +if the storage was allocated directly by Tcl or by a call to +\fBTcl_Alloc\fR. +.VE 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. @@ -87,8 +78,10 @@ macro should be used for this purpose). \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 +.VS +In most applications \fBTCL_DYNAMIC\fR is the only non-zero value ever used for \fIfreeProc\fR. +.VE 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. diff --git a/tcl7.3/doc/LinkVar.3 b/tcl7.6/doc/LinkVar.3 similarity index 68% rename from tcl7.3/doc/LinkVar.3 rename to tcl7.6/doc/LinkVar.3 index f44c96c..a7a5355 100644 --- a/tcl7.3/doc/LinkVar.3 +++ b/tcl7.6/doc/LinkVar.3 @@ -1,32 +1,17 @@ '\" '\" Copyright (c) 1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/LinkVar.3,v 1.4 93/07/28 15:18:56 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) LinkVar.3 1.15 96/09/05 17:16:57 '\" .so man.macros -.HS Tcl_LinkVar tclc 7.0 +.TH Tcl_LinkVar 3 7.5 Tcl "Tcl Library Procedures" .BS .SH NAME -.na -Tcl_LinkVar, Tcl_UnlinkVar \- link Tcl variable to C variable -.ad +Tcl_LinkVar, Tcl_UnlinkVar, Tcl_UpdateLinkedVar \- link Tcl variable to C variable .SH SYNOPSIS .nf \fB#include \fR @@ -35,21 +20,22 @@ int \fBTcl_LinkVar\fR(\fIinterp, varName, addr, type\fR) .sp \fBTcl_UnlinkVar\fR(\fIinterp, varName\fR) +.sp +\fBTcl_UpdateLinkedVar\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. +Name of global variable. Must be in writable memory: Tcl may make +temporary modifications to it while parsing the variable name. .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 @@ -87,7 +73,7 @@ Tcl errors. 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 +Whenever \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 @@ -96,8 +82,10 @@ Tcl errors. .TP \fBTCL_LINK_STRING\fR The C variable is of type \fBchar *\fR. +.VS If its value is not null then it must be a pointer to a string -allocated with \fBmalloc\fR. +allocated with \fBTcl_Alloc\fR. +.VE 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. @@ -108,6 +96,20 @@ 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. +.PP +\fBTcl_UnlinkVar\fR removes the link previously set up for the +variable given by \fIvarName\fR. If there does not exist a link +for \fIvarName\fR then the procedure has no effect. +.PP +\fBTcl_UpdateLinkedVar\fR may be invoked after the C variable has +changed to force the Tcl variable to be updated immediately. +In many cases this procedure is not needed, since any attempt to +read the Tcl variable will return the latest value of the C variable. +However, if a trace has been set on the Tcl variable (such as a +Tk widget that wishes to display the value of the variable), the +trace will not trigger when the C variable has changed. +\fBTcl_UpdateLinkedVar\fR ensures that any traces on the Tcl +variable are invoked. .SH KEYWORDS -boolean, integer, link, read-only, real, string, variable +boolean, integer, link, read-only, real, string, traces, variable diff --git a/tcl7.6/doc/Notifier.3 b/tcl7.6/doc/Notifier.3 new file mode 100644 index 0000000..0d3ff93 --- /dev/null +++ b/tcl7.6/doc/Notifier.3 @@ -0,0 +1,370 @@ +'\" +'\" Copyright (c) 1995-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) Notifier.3 1.11 96/06/05 18:00:17 +'\" +.so man.macros +.TH Tcl_CreateEventSource 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_CreateEventSource, Tcl_DeleteEventSource, Tcl_WatchFile, Tcl_FileReady, Tcl_SetMaxBlockTime, Tcl_QueueEvent, Tcl_WaitForEvent \- Event sources, the event notifier, and the event queue +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +\fBTcl_CreateEventSource(\fIsetupProc, checkProc, clientData\fB)\fR +.sp +\fBTcl_DeleteEventSource(\fIsetupProc, checkProc, clientData\fB)\fR +.sp +\fBTcl_WatchFile(\fIfile, mask\fB)\fR +.sp +\fBTcl_SetMaxBlockTime(\fItimePtr\fB)\fR +.sp +int +\fBTcl_FileReady(\fIfile, mask\fB)\fR +.sp +\fBTcl_QueueEvent(\fIevPtr, position\fB)\fR +.sp +int +\fBTcl_WaitForEvent(\fItimePtr\fB)\fR +.SH ARGUMENTS +.AS Tcl_EventSetupProc *setupProc +.AP Tcl_EventSetupProc *setupProc in +Procedure to invoke to prepare for event wait in \fBTcl_DoWhenIdle\fR. +.AP Tcl_EventCheckProc *checkProc in +Procedure for \fBTcl_DoWhenIdle\fR to invoke after waiting for +events. Checks to see if any events have occurred and, if so, +queues them. +.AP ClientData clientData in +Arbitrary one-word value to pass to \fIsetupProc\fR and \fIcheckProc\fR. +.AP Tcl_File file in +Generic file handle as returned by \fBTcl_GetFile\fR. +.AP int mask in +Indicates the events of interest on \fIfile\fR: an OR'ed combination +of \fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR, and \fBTCL_EXCEPTION\fR. +.AP Tcl_Time *timePtr in +Indicates the maximum amount of time to wait for an event. This +is specified as an interval (how long to wait), not an absolute +time (when to wakeup). If the pointer passed to \fBTcl_WaitForEvent\fR +is NULL, it means there is no maximum wait time: wait forever if +necessary. +.AP Tcl_Event *evPtr in +An event to add to the event queue. The storage for the event must +.VS +have been allocated by the caller using \fBTcl_Alloc\fR or \fBckalloc\fR. +.VE +.AP Tcl_QueuePosition position in +Where to add the new event in the queue: \fBTCL_QUEUE_TAIL\fR, +\fBTCL_QUEUE_HEAD\fR, or \fBTCL_QUEUE_MARK\fR. +.AP int flags in +A copy of the \fIflags\fR argument passed to \fBTcl_DoOneEvent\fR. +.BE + +.SH INTRODUCTION +.PP +The procedures described here are the building blocks out of which +the Tcl event notifier is constructed. The event notifier is the +lowest layer in the Tcl event mechanism. It consists of three +things: +.IP [1] +Event sources: these represent the ways in which events can be +generated. For example, there is a timer event source that implements +the \fBTcl_CreateTimerHandler\fR procedure and the \fBafter\fR command, +and there is a file event source that implements the +\fBTcl_CreateFileHandler\fR procedure. An event source must work +with the notifier to detect events at the right times, record them +on the event queue, and eventually notify higher-level software that +they have occurred. +.IP [2] +The event queue: there is a single queue for the whole application, +containing events that have been detected but not yet serviced. +The event queue guarantees a fair discipline of event handling, so +that no event source can starve the others. It also allows events +to be saved for servicing at a future time. +.IP [3] +The procedure \fBTcl_DoOneEvent\fR: this is procedure that is invoked +by the application to service events. It works with the event sources +and the event queue to detect and handle events, and calls +\fBTcl_WaitForEvent\fR to actually wait for an event to occur. +.PP +The easiest way to understand how the notifier works is to consider +what happens when \fBTcl_DoOneEvent\fR is called. +\fBTcl_DoOneEvent\fR is passed a \fIflags\fR +argument that indicates what sort of events it is OK to process and +also whether or not to block if no events are ready. +\fBTcl_DoOneEvent\fR does the following things: +.IP [1] +Check the event queue to see if it contains any events that can +be serviced. If so, service the first possible event, remove it +from the queue, and return. +.IP [2] +Prepare to block for an event. To do this, \fBTcl_DoOneEvent\fR +invokes a \fIsetup procedure\fR in each event source. +The event source will call procedures like \fBTcl_WatchFile\fR and +\fBTcl_SetMaxBlockTime\fR to indicate what low-level events to look +for in \fBTcl_WaitForEvent\fR. +.IP [3] +Call \fBTcl_WaitForEvent\fR. This procedure is implemented differently +on different platforms; it waits for an event to occur, based on the +information provided by the event sources. +It may cause the application to block if \fItimePtr\fR specifies +an interval other than 0. +\fBTcl_WaitForEvent\fR returns when something has happened, +such as a file becoming readable or the interval given by \fItimePtr\fR +expiring. If there are no events for \fBTcl_WaitForEvent\fR to +wait for, so that it would block forever, then it returns immediately +and \fBTcl_DoOneEvent\fR returns 0. +.IP [4] +Call a \fIcheck procedure\fR in each event source. The check +procedure determines whether any events of interest to this source +occurred (e.g. by calling \fBTcl_FileReady\fR). If so, +the events are added to the event queue. +.IP [5] +Check the event queue to see if it contains any events that can +be serviced. If so, service the first possible event, remove it +from the queue, and return. +.IP [6] +See if there are idle callbacks pending. +If so, invoke all of them and return. +.IP [7] +Either return 0 to indicate that no events were ready, or go back to +step [2] if blocking was requested by the caller. +.PP +The procedures in this file allow you to do two things. First, they +allow you to create new event sources, such as one for UNIX signals +or one to notify when subprocesses have exited. Second, the procedures +can be used to build a new version of \fBTcl_DoOneEvent\fR. This +might be necessary to support a new operating system with different +low-level event reporting mechanisms, or it might be necessary to +merge Tcl's event loop with that of some other toolkit like Xt. + +.SH "CREATING A NEW EVENT SOURCE" +.PP +An event source consists of three procedures invoked by the notifier, +plus additional C procedures that are invoked by higher-level code +to arrange for event-driven callbacks. The three procedures called +by the notifier consist of the setup and check procedures described +above, plus an additional procedure that is invoked when an event +is removed from the event queue for servicing. +.PP +The procedure \fBTcl_CreateEventSource\fR creates a new event source. +Its arguments specify the setup procedure and check procedure for +the event source. +\fISetupProc\fR should match the following prototype: +.CS +typedef void Tcl_EventSetupProc( + ClientData \fIclientData\fR, + int \fIflags\fR); +.CE +The \fIclientData\fR argument will be the same as the \fIclientData\fR +argument to \fBTcl_CreateEventSource\fR; it is typically used to +point to private information managed by the event source. +The \fIflags\fR argument will be the same as the \fIflags\fR +argument passed to \fBTcl_DoOneEvent\fR except that it will never +by 0 (\fBTcl_DoOneEvent\fR replaces 0 with \fBTCL_ALL_EVENTS\fR). +\fIFlags\fR indicates what kinds of events should be considered; +if the bit corresponding to this event source isn't set, the event +source should return immediately without doing anything. For +example, the file event source checks for the \fBTCL_FILE_EVENTS\fR +bit. +.PP +\fISetupProc\fR's job is to provide information to +\fBTcl_WaitForEvent\fR about how to wait for events. +It usually does this by calling \fBTcl_WatchFile\fR or +\fBTcl_SetMaxBlockTime\fR. +For example, \fIsetupProc\fR can call \fBTcl_WatchFile\fR to indicate +that \fBTcl_WaitForEvent\fR should return when the conditions +given by the \fImask\fR argument become true for the file given +by \fIfile\fR. +The UNIX version of \fBTcl_WaitForEvent\fR uses the +information passed to \fBTcl_WatchFile\fR to set the file masks +for \fBselect\fR, which it uses to wait for events. +If \fBTcl_WatchFile\fR isn't called by any event sources then +\fBTcl_WaitForEvent\fR will ignore files while waiting. +.PP +\fISetupProc\fR can also invoke \fBTcl_SetMaxBlockTime\fR to set an +upper bound on how long \fBTcl_WaitForEvent\fR will block. +If no event source calls \fBTcl_SetMaxBlockTime\fR then +\fBTcl_WaitForEvent\fR will wait as long as necessary for an event +to occur; otherwise, it will only wait as long as the shortest +interval passed to \fBTcl_SetMaxBlockTime\fR by one of the event +sources. +For example, the timer event source uses this procedure to limit the +wait time to the interval before the next timer event is ready. +If an event source knows that it already has events ready to report, +it can request a zero maximum block time. +The \fItimePtr\fR argument to \fBTcl_WaitForEvent\fR points to +a structure that describes a time interval in seconds and +microseconds: +.CS +typedef struct Tcl_Time { + long \fIsec\fR; + long \fIusec\fR; +} Tcl_Time; +.CE +The \fIusec\fR field should be less than 1000000. +.PP +Information provided to \fBTcl_WatchFile\fR and \fBTcl_SetMaxBlockTime\fR +is only used for the next call to \fBTcl_WaitForEvent\fR; it is +discarded after \fBTcl_WaitForEvent\fR returns. +The next time an event wait is done each of the event sources' +setup procedures will be called again, and they can specify new +information for that event wait. +.PP +In addition to the generic procedures \fBTcl_WatchFile\fR and +\fBTcl_SetMaxBlockTime\fR, other platform-specific procedures may +also be available for \fIsetupProc\fR, if there is additional +information needed by \fBTcl_WaitForEvent\fR on that platform. +.PP +The second procedure provided by each event source is its check +procedure, indicated by the \fIcheckProc\fR argument to +\fBTcl_CreateEventSource\fR. \fICheckProc\fR must match the +following prototype: +.CS +typedef void Tcl_EventCheckProc( + ClientData \fIclientData\fR, + int \fIflags\fR); +.CE +The arguments to this procedure are the same as those for \fIsetupProc\fR. +\fBCheckProc\fR is invoked by \fBTcl_DoOneEvent\fR after it has waited +for events. Presumably at least one event source is now prepared to +queue an event. \fBTcl_DoOneEvent\fR calls each of the event sources +in turn, so they all have a chance to queue any events that are ready. +The check procedure does two things. First, it must see if any events +have triggered. Different event sources do this in different ways, +but the procedure \fBTcl_FileReady\fR may be useful for some event +sources. It takes as arguments a file identifier \fIfile\fR and +a mask of interesting conditions; it returns another mask indicating +which of those conditions were found to be present on the file during +the most recent call to \fBTcl_WaitForEvent\fR. +\fBTcl_WaitForEvent\fR only checks a file if \fBTcl_WatchFile\fR was +called by at least one event source, so it is possible for +\fBTcl_FileReady\fR to return 0 even if the file is ready. +.PP +If an event source's check procedure detects that an interesting +event has occurred, then it must add the event to Tcl's event queue. +To do this, the event source calls \fBTcl_QueueEvent\fR. +The \fIevPtr\fR argument is a pointer to a dynamically allocated +structure containing the event (see below for more information +on memory management issues). +Each event source can define its own event structure with +whatever information is relevant to that event source. +However, the first element of the structure must be a structure +of type \fBTcl_Event\fR, and the address of this structure is used when +communicating between the event source and the rest of the notifier. +A \fBTcl_Event\fR has the following definition: +.CS +typedef struct Tcl_Event { + Tcl_EventProc *\fIproc\fR; + struct Tcl_Event *\fInextPtr\fR; +}; +.CE +The event source must fill in the \fIproc\fR field of +the event before calling \fBTcl_QueueEvent\fR. +The \fInextPtr\fR is used to link together the events in the queue +and should not be modified by the event source. +.PP +An event may be added to the queue at any of three positions, depending +on the \fIposition\fR argument to \fBTcl_QueueEvent\fR: +.IP \fBTCL_QUEUE_TAIL\fR 24 +Add the event at the back of the queue, so that all other pending +events will be serviced first. This is almost always the right +place for new events. +.IP \fBTCL_QUEUE_HEAD\fR 24 +Add the event at the front of the queue, so that it will be serviced +before all other queued events. +.IP \fBTCL_QUEUE_MARK\fR 24 +Add the event at the front of the queue, unless there are other +events at the front whose position is \fBTCL_QUEUE_MARK\fR; if so, +add the new event just after all other \fBTCL_QUEUE_MARK\fR events. +This value of \fIposition\fR is used to insert an ordered sequence of +events at the front of the queue, such as a series of +Enter and Leave events synthesized during a grab or ungrab operation +in Tk. +.PP +When it is time to handle an event from the queue (steps 1 and 5 +above) \fBTcl_DoOneEvent\fR will invoke the \fIproc\fR specified +in the first queued \fBTcl_Event\fR structure. +\fIProc\fR must match the following prototype: +.CS +typedef int Tcl_EventProc( + Tcl_Event *\fIevPtr\fR, + int \fIflags\fR); +.CE +The first argument to \fIproc\fR is a pointer to the event, which will +be the same as the first argument to the \fBTcl_QueueEvent\fR call that +added the event to the queue. +The second argument to \fIproc\fR is the \fIflags\fR argument for the +current call to \fBTcl_DoOneEvent\fR; this is used by the event source +to return immediately if its events are not relevant. +.PP +It is up to \fIproc\fR to handle the event, typically by invoking +one or more Tcl commands or C-level callbacks. +Once the event source has finished handling the event it returns 1 +to indicate that the event can be removed from the queue. +If for some reason the event source decides that the event cannot +be handled at this time, it may return 0 to indicate that the event +should be deferred for processing later; in this case \fBTcl_DoOneEvent\fR +will go on to the next event in the queue and attempt to service it. +There are several reasons why an event source might defer an event. +One possibility is that events of this type are excluded by the +\fIflags\fR argument. +For example, the file event source will always return 0 if the +\fBTCL_FILE_EVENTS\fR bit isn't set in \fIflags\fR. +Another example of deferring events happens in Tk if +\fBTk_RestrictEvents\fR has been invoked to defer certain kinds +of window events. +.PP +When \fIproc\fR returns 1, \fBTcl_DoOneEvent\fR will remove the +event from the event queue and free its storage. +Note that the storage for an event must be allocated by +.VS +the event source (using \fBTcl_Alloc\fR or the Tcl macro \fBckalloc\fR) +.VE +before calling \fBTcl_QueueEvent\fR, but it +will be freed by \fBTcl_DoOneEvent\fR, not by the event source. + +.SH "CREATING A NEW NOTIFIER" +.PP +The notifier consists of all the procedures described in this +manual entry, plus \fBTcl_DoOneEvent\fR and \fBTcl_Sleep\fR. +Most of these procedures are generic, in that they are the +same for all platforms. However, four of the procedures are +platform-dependent: \fBTcl_WatchFile\fR, +\fBTcl_FileReady\fR, \fBTcl_WaitForEvent\fR, and \fBTcl_Sleep\fR. +To support a new platform, you must write new versions of these +procedures. +\fBTcl_WatchFile\fR and \fBTcl_FileReady\fR have already been +described previously in this document, and \fBTcl_Sleep\fR +is described in its own manual entry. +.PP +\fBTcl_WaitForEvent\fR is the lowest-level procedure in the +notifier; it is responsible for waiting for an ``interesting'' +event to occur or for a given time to elapse. +Before \fBTcl_WaitForEvent\fR is invoked, each of the event +sources' setup procedure will have been invoked; the setup +procedures will have provided information about what to wait +for by invoking procedures like \fBTcl_WatchFile\fR. +The \fItimePtr\fR argument to \fBTcl_WaitForEvent\fR gives +the maximum time to block for an event, based on calls to +\fBTcl_SetMaxBlockTime\fR made by setup procedures and +on other information (such as the \fBTCL_DONT_WAIT\fR bit in \fIflags\fR). +\fBTcl_WaitForEvent\fR uses information saved by \fBTcl_WatchFile\fR, +plus the \fItimePtr\fR argument to decide what to wait for +and how long to block. +It returns TCL_OK as soon as one of the specified events has occurred +or the given amount of time has elapsed. +However, if there are no event handlers (neither \fBTcl_WatchFile\fR nor +\fBTcl_SetMaxBlockTime\fR has been called since the last call to +\fBTcl_WaitForEvent\fR), so that the procedure would block forever, +then it returns immediately with a result of TCL_ERROR. +.PP +The easiest way to create a new notifier is to look at the code +for an existing notifier, such as the files \fBgeneric/tclNotify.c\fR +and \fBunix/tclUnixNotfy.c\fR. + +.SH KEYWORDS +block time, event notifier, event queue, event sources, file events diff --git a/tcl7.6/doc/OpenFileChnl.3 b/tcl7.6/doc/OpenFileChnl.3 new file mode 100644 index 0000000..1910c60 --- /dev/null +++ b/tcl7.6/doc/OpenFileChnl.3 @@ -0,0 +1,472 @@ +'\" +'\" Copyright (c) 1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) OpenFileChnl.3 1.27 96/03/22 14:55:07 +.so man.macros +.TH Tcl_OpenFileChannel 3 7.5 Tcl "Tcl Library Procedures" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +Tcl_OpenFileChannel, Tcl_OpenCommandChannel, Tcl_Close, Tcl_Read, Tcl_Gets, Tcl_Write, Tcl_Flush, Tcl_Seek, Tcl_Tell, Tcl_Eof, Tcl_InputBlocked, Tcl_GetChannelOption, Tcl_SetChannelOption \- buffered I/O facilities using channels +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +typedef ... Tcl_Channel; +.sp +Tcl_Channel +\fBTcl_OpenFileChannel\fR(\fIinterp, fileName, mode, permissions\fR) +.sp +Tcl_Channel +\fBTcl_OpenCommandChannel\fR(\fIinterp, argc, argv, flags\fR) +.sp +Tcl_Channel +\fBTcl_MakeFileChannel\fR(\fIinOsFile, outOsFile, readOrWrite\fR) +.sp +Tcl_Channel +\fBTcl_GetChannel\fR(\fIinterp, channelName, modePtr\fR) +.sp +void +\fBTcl_RegisterChannel\fR(\fIinterp, channel\fR) +.sp +int +\fBTcl_UnregisterChannel\fR(\fIinterp, channel\fR) +.sp +int +\fBTcl_Close\fR(\fIinterp, channel\fR) +.sp +int +\fBTcl_Read\fR(\fIchannel, buf, toRead\fR) +.sp +int +\fBTcl_Gets\fR(\fIchannel, lineRead\fR) +.sp +int +\fBTcl_Write\fR(\fIchannel, buf, toWrite\fR) +.sp +int +\fBTcl_Flush\fR(\fIchannel\fR) +.sp +int +\fBTcl_Seek\fR(\fIchannel, offset, seekMode\fR) +.sp +int +\fBTcl_Tell\fR(\fIchannel\fR) +.sp +int +\fBTcl_GetChannelOption\fR(\fIchannel, optionName, optionValue\fR) +.sp +int +\fBTcl_SetChannelOption\fR(\fIinterp, channel, optionName, newValue\fR) +.sp +int +\fBTcl_Eof\fR(\fIchannel\fR) +.sp +int +\fBTcl_InputBlocked\fR(\fIchannel\fR) +.sp +int +\fBTcl_InputBuffered\fR(\fIchannel\fR) +.sp +.SH ARGUMENTS +.AS Tcl_ChannelType newClientProcPtr in +.AP Tcl_Interp *interp in +Used for error reporting and to look up a channel registered in it. +.AP char *fileName in +The name of a local or network file. +.AP char *mode in +Specifies how the file is to be accessed. May have any of the +values allowed for the \fImode\fR argument to the Tcl +\fBopen\fR command. +For \fBTcl_OpenCommandChannel\fR, may be NULL. +.AP int permissions in +POSIX-style permission flags such as 0644. +If a new file is created, these permissions will be set on the +created file. +.AP int argc in +The number of elements in \fIargv\fR. +.AP char **argv in +Arguments for constructing a command pipeline. +These values have the same meaning as the non-switch arguments +to the Tcl \fBexec\fR command. +.AP int flags in +Specifies the disposition of the stdio handles in pipeline: OR-ed +combination of \fBTCL_STDIN\fR, \fBTCL_STDOUT\fR, \fBTCL_STDERR\fR, +and \fBTCL_ENFORCE_MODE\fR. If \fBTCL_STDIN\fR is set, stdin for +the first child in the pipe is the pipe channel, otherwise it is the same +as the standard input of the invoking process; likewise for +\fBTCL_STDOUT\fR and \fBTCL_STDERR\fR. If \fBTCL_ENFORCE_MODE\fR is not set, +then the pipe can redirect stdio handles to override the stdio handles for +which \fBTCL_STDIN\fR, \fBTCL_STDOUT\fR and \fBTCL_STDERR\fR have been set. +If it is set, then such redirections cause an error. +.AP ClientData inOsFile in +Operating system specific handle for input from a file. For Unix this is a +file descriptor, for Windows it is a HANDLE, etc. +.AP ClientData outOsFile in +Operating system specific handle for output to a file. +.AP int readOrWrite in +OR-ed combination of \fBTCL_READABLE\fR and \fBTCL_WRITABLE\fR to indicate +which of \fIinOsFile\fR and \fIoutOsFile\fR contains a valid value. +.AP int *modePtr out +Points at an integer variable that will receive an OR-ed combination of +\fBTCL_READABLE\fR and \fBTCL_WRITABLE\fR denoting whether the channel is +open for reading and writing. +.AP Tcl_Channel channel in +A Tcl channel for input or output. Must have been the return value +from a procedure such as \fBTcl_OpenFileChannel\fR. +.AP char *buf in +An array of bytes in which to store channel input, or from which +to read channel output. +.AP int len in +The length of the input or output. +.AP int atEnd in +If nonzero, store the input at the end of the input queue, otherwise store +it at the head of the input queue. +.AP int toRead in +The number of bytes to read from the channel. +.AP Tcl_DString *lineRead in +A pointer to a Tcl dynamic string in which to store the line read from the +channel. Must have been initialized by the caller. +.AP int toWrite in +The number of bytes to read from \fIbuf\fR and output to the channel. +.AP int offset in +How far to move the access point in the channel at which the next input or +output operation will be applied, measured in bytes from the position +given by \fIseekMode\fR. May be either positive or negative. +.AP int seekMode in +Relative to which point to seek; used with \fIoffset\fR to calculate the new +access point for the channel. Legal values are \fBSEEK_SET\fR, +\fBSEEK_CUR\fR, and \fBSEEK_END\fR. +.AP char *optionName in +The name of an option applicable to this channel, such as \fB\-blocking\fR. +May have any of the values accepted by the \fBfconfigure\fR command. +.AP Tcl_DString *optionValue in +Where to store the value of an option or a list of all options and their +values. Must have been initialized by the caller. +.AP char *newValue in +New value for the option given by \fIoptionName\fR. +.BE + +.SH DESCRIPTION +.PP +The Tcl channel mechanism provides a device-independent and +platform-independent mechanism for performing buffered input +and output operations on a variety of file, socket, and device +types. +The channel mechanism is extensible to new channel types, by +providing a low level channel driver for the new type; the channel driver +interface is described in the manual entry for \fBTcl_CreateChannel\fR. The +channel mechanism provides a buffering scheme modelled after +Unix's standard I/O, and it also allows for nonblocking I/O on +channels. +.PP +The procedures described in this manual entry comprise the C APIs of the +generic layer of the channel architecture. For a description of the channel +driver architecture and how to implement channel drivers for new types of +channels, see the manual entry for \fBTcl_CreateChannel\fR. + +.SH TCL_OPENFILECHANNEL +.PP +\fBTcl_OpenFileChannel\fR opens a file specified by \fIfileName\fR and +returns a channel handle that can be used to perform input and output on +the file. This API is modelled after the \fBfopen\fR procedure of +the Unix standard I/O library. +The syntax and meaning of all arguments is similar to those +given in the Tcl \fBopen\fR command when opening a file. +If an error occurs while opening the channel, \fBTcl_OpenFileChannel\fR +returns NULL and records a POSIX error code that can be +retrieved with \fBTcl_GetErrno\fR. +In addition, if \fIinterp\fR is non-NULL, \fBTcl_OpenFileChannel\fR +leaves an error message in \fIinterp->result\fR after any error. +.PP +The newly created channel is not registered in the supplied interpreter; to +register it, use \fBTcl_RegisterChannel\fR, described below. +If one of the standard channels, \fBstdin, stdout\fR or \fBstderr\fR was +previously closed, the act of creating the new channel also assigns it as a +replacement for the standard channel. + +.SH TCL_OPENCOMMANDCHANNEL +.PP +\fBTcl_OpenCommandChannel\fR provides a C-level interface to the +functions of the \fBexec\fR and \fBopen\fR commands. +It creates a sequence of subprocesses specified +by the \fIargv\fR and \fIargc\fR arguments and returns a channel that can +be used to communicate with these subprocesses. +The \fIflags\fR argument indicates what sort of communication will +exist with the command pipeline. +.PP +If the \fBTCL_STDIN\fR flag is set then the standard input for the +first subprocess will be tied to the channel: writing to the channel +will provide input to the subprocess. If \fBTCL_STDIN\fR is not set, +then standard input for the first subprocess will be the same as this +application's standard input. If \fBTCL_STDOUT\fR is set then +standard output from the last subprocess can be read from the channel; +otherwise it goes to this application's standard output. If +\fBTCL_STDERR\fR is set, standard error output for all subprocesses is +returned to the channel and results in an error when the channel is +closed; otherwise it goes to this application's standard error. If +\fBTCL_ENFORCE_MODE\fR is not set, then \fIargc\fR and \fIargv\fR can +redirect the stdio handles to override \fBTCL_STDIN\fR, +\fBTCL_STDOUT\fR, and \fBTCL_STDERR\fR; if it is set, then it is an +error for argc and argv to override stdio channels for which +\fBTCL_STDIN\fR, \fBTCL_STDOUT\fR, and \fBTCL_STDERR\fR have been set. +.PP +If an error occurs while opening the channel, \fBTcl_OpenCommandChannel\fR +returns NULL and records a POSIX error code that can be retrieved with +\fBTcl_GetErrno\fR. +In addition, \fBTcl_OpenCommandChannel\fR leaves an error message in +\fIinterp->result\fR if \fIinterp\fR is not NULL. +.PP +The newly created channel is not registered in the supplied interpreter; to +register it, use \fBTcl_RegisterChannel\fR, described below. +If one of the standard channels, \fBstdin, stdout\fR or \fBstderr\fR was +previously closed, the act of creating the new channel also assigns it as a +replacement for the standard channel. + +.SH TCL_MAKEFILECHANNEL +.PP +\fBTcl_MakeFileChannel\fR makes a \fBTcl_Channel\fR from an existing, +platform-specific, file handle. +The newly created channel is not registered in the supplied interpreter; to +register it, use \fBTcl_RegisterChannel\fR, described below. +If one of the standard channels, \fBstdin, stdout\fR or \fBstderr\fR was +previously closed, the act of creating the new channel also assigns it as a +replacement for the standard channel. + +.SH TCL_GETCHANNEL +.PP +\fBTcl_GetChannel\fR returns a channel given the \fIchannelName\fR used to +create it with \fBTcl_CreateChannel\fR and a pointer to a Tcl interpreter in +\fIinterp\fR. If a channel by that name is not registered in that interpreter, +the procedure returns NULL. If the \fImode\fR argument is not NULL, it +points at an integer variable that will receive an OR-ed combination of +\fBTCL_READABLE\fR and \fBTCL_WRITABLE\fR describing whether the channel is +open for reading and writing. + +.SH TCL_REGISTERCHANNEL +.PP +\fBTcl_RegisterChannel\fR adds a channel to the set of channels accessible +in \fIinterp\fR. After this call, Tcl programs executing in that +interpreter can refer to the channel in input or output operations using +the name given in the call to \fBTcl_CreateChannel\fR. After this call, +the channel becomes the property of the interpreter, and the caller should +not call \fBTcl_Close\fR for the channel; the channel will be closed +automatically when it is unregistered from the interpreter. +.PP +Code executing outside of any Tcl interpreter can call +\fBTcl_RegisterChannel\fR with \fIinterp\fR as NULL, to indicate that it +wishes to hold a reference to this channel. Subsequently, the channel can +be registered in a Tcl interpreter and it will only be closed when the +matching number of calls to \fBTcl_UnregisterChannel\fR have been made. +This allows code executing outside of any interpreter to safely hold a +reference to a channel that is also registered in a Tcl interpreter. + +.SH TCL_UNREGISTERCHANNEL +.PP +\fBTcl_UnregisterChannel\fR removes a channel from the set of channels +accessible in \fIinterp\fR. After this call, Tcl programs will no longer be +able to use the channel's name to refer to the channel in that interpreter. +If this operation removed the last registration of the channel in any +interpreter, the channel is also closed and destroyed. +.PP +Code not associated with a Tcl interpreter can call +\fBTcl_UnregisterChannel\fR with \fIinterp\fR as NULL, to indicate to Tcl +that it no longer holds a reference to that channel. If this is the last +reference to the channel, it will now be closed. + +.SH TCL_CLOSE +.PP +\fBTcl_Close\fR destroys the channel \fIchannel\fR, which must denote a +currently open channel. The channel should not be registered in any +interpreter when \fBTcl_Close\fR is called. Buffered output is flushed to +the channel's output device prior to destroying the channel, and any +buffered input is discarded. If this is a blocking channel, the call does +not return until all buffered data is successfully sent to the channel's +output device. If this is a nonblocking channel and there is buffered +output that cannot be written without blocking, the call returns +immediately; output is flushed in the background and the channel will be +closed once all of the buffered data has been output. In this case errors +during flushing are not reported. +.PP +If the channel was closed successfully, \fBTcl_Close\fR returns \fBTCL_OK\fR. +If an error occurs, \fBTcl_Close\fR returns \fBTCL_ERROR\fR and records a +POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. +If the channel is being closed synchronously and an error occurs during +closing of the channel and \fIinterp\fR is not NULL, an error message is +left in \fIinterp->result\fR. +.PP +Note: it is not safe to call \fBTcl_Close\fR on a channel that has been +registered using \fBTcl_RegisterChannel\fR; see the documentation for +\fBTcl_RegisterChannel\fR, above, for details. If the channel has ever been +given as the \fBchan\fR argument in a call to \fBTcl_RegisterChannel\fR, +you should instead use \fBTcl_UnregisterChannel\fR, which will internally +call \fBTcl_Close\fR when all calls to \fBTcl_RegisterChannel\fR have been +matched by corresponding calls to \fBTcl_UnregisterChannel\fR. + +.SH TCL_READ +.PP +\fBTcl_Read\fR consumes up to \fItoRead\fR bytes of data from +\fIchannel\fR and stores it at \fIbuf\fR. +The return value of \fBTcl_Read\fR is the number of characters written +at \fIbuf\fR. +The buffer produced by \fBTcl_Read\fR is not NULL terminated. Its contents +are valid from the zeroth position up to and excluding the position +indicated by the return value. +If an error occurs, the return value is -1 and \fBTcl_Read\fR records +a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. +.PP +The return value may be smaller than the value of \fItoRead\fR, indicating +that less data than requested was available, also called a \fIshort +read\fR. +In blocking mode, this can only happen on an end-of-file. +In nonblocking mode, a short read can also occur if there is not +enough input currently available: \fBTcl_Read\fR returns a short +count rather than waiting for more data. +.PP +If the channel is in blocking mode, a return value of zero indicates an end +of file condition. If the channel is in nonblocking mode, a return value of +zero indicates either that no input is currently available or an end of +file condition. Use \fBTcl_Eof\fR and \fBTcl_InputBlocked\fR +to tell which of these conditions actually occurred. +.PP +\fBTcl_Read\fR translates platform-specific end-of-line representations +into the canonical \fB\en\fR internal representation according to the +current end-of-line recognition mode. End-of-line recognition and the +various platform-specific modes are described in the manual entry for the +Tcl \fBfconfigure\fR command. + +.SH TCL_GETS +.PP +\fBTcl_Gets\fR reads a line of input from a channel and appends all of +the characters of the line except for the terminating end-of-line character(s) +to the dynamic string given by \fIdsPtr\fR. +The end-of-line character(s) are read and discarded. +.PP +If a line was successfully read, the return value is greater than or +equal to zero, and it indicates the number of characters stored +in the dynamic string. +If an error occurs, \fBTcl_Gets\fR returns -1 and records a POSIX error +code that can be retrieved with \fBTcl_GetErrno\fR. +\fBTcl_Gets\fR also returns -1 if the end of the file is reached; +the \fBTcl_Eof\fR procedure can be used to distinguish an error +from an end-of-file condition. +.PP +If the channel is in nonblocking mode, the return value can also +be -1 if no data was available or the data that was available +did not contain an end-of-line character. +When -1 is returned, the \fBTcl_InputBlocked\fR procedure may be +invoked to determine if the channel is blocked because of input +unavailability. + +.SH TCL_WRITE +.PP +\fBTcl_Write\fR accepts \fItoWrite\fR bytes of data at \fIbuf\fR for output +on \fIchannel\fR. This data may not appear on the output device +immediately. If the data should appear immediately, call \fBTcl_Flush\fR +after the call to \fBTcl_Write\fR, or set the \fB-buffering\fR option on +the channel to \fBnone\fR. If you wish the data to appear as soon as an end +of line is accepted for output, set the \fB\-buffering\fR option on the +channel to \fBline\fR mode. +.PP +The \fItoWrite\fR argument specifies how many bytes of data are provided in +the \fIbuf\fR argument. If it is negative, \fBTcl_Write\fR expects the data +to be NULL terminated and it outputs everything up to the NULL. +.PP +The return value of \fBTcl_Write\fR is a count of how many +characters were accepted for output to the channel. This is either equal to +\fItoWrite\fR or -1 to indicate that an error occurred. +If an error occurs, \fBTcl_Write\fR also records a POSIX error code +that may be retrieved with \fBTcl_GetErrno\fR. +.PP +Newline characters in the output data are translated to platform-specific +end-of-line sequences according to the \fB\-translation\fR option for +the channel. + +.SH TCL_FLUSH +.PP +\fBTcl_Flush\fR causes all of the buffered output data for \fIchannel\fR +to be written to its underlying file or device as soon as possible. +If the channel is in blocking mode, the call does not return until +all the buffered data has been sent to the channel or some error occurred. +The call returns immediately if the channel is nonblocking; it starts +a background flush that will write the buffered data to the channel +eventually, as fast as the channel is able to absorb it. +.PP +The return value is normally \fBTCL_OK\fR. +If an error occurs, \fBTcl_Flush\fR returns \fBTCL_ERROR\fR and +records a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. + +.SH TCL_SEEK +.PP +\fBTcl_Seek\fR moves the access point in \fIchannel\fR where subsequent +data will be read or written. Buffered output is flushed to the channel and +buffered input is discarded, prior to the seek operation. +.PP +\fBTcl_Seek\fR normally returns the new access point. +If an error occurs, \fBTcl_Seek\fR returns -1 and records a POSIX error +code that can be retrieved with \fBTcl_GetErrno\fR. +After an error, the access point may or may not have been moved. + +.SH TCL_TELL +.PP +\fBTcl_Tell\fR returns the current access point for a channel. The returned +value is -1 if the channel does not support seeking. + +.SH TCL_GETCHANNELOPTION +.PP +\fBTcl_GetChannelOption\fR retrieves, in \fIdsPtr\fR, the value of one of +the options currently in effect for a channel, or a list of all options and +their values. The \fIchannel\fR argument identifies the channel for which +to query an option or retrieve all options and their values. +If \fIoptionName\fR is not NULL, it is the name of the +option to query; the option's value is copied to the Tcl dynamic string +denoted by \fIoptionValue\fR. If +\fIoptionName\fR is NULL, the function stores an alternating list of option +names and their values in \fIoptionValue\fR, using a series of calls to +\fBTcl_DStringAppendElement\fR. The various preexisting options and +their possible values are described in the manual entry for the Tcl +\fBfconfigure\fR command. Other options can be added by each channel type. +These channel type specific options are described in the manual entry for +the Tcl command that creates a channel of that type; for example, the +additional options for TCP based channels are described in the manual entry +for the Tcl \fBsocket\fR command. +The procedure normally returns \fBTCL_OK\fR. If an error occurs, it returns +\fBTCL_ERROR\fR and calls \fBTcl_SetErrno\fR to store an appropriate POSIX +error code. + +.SH TCL_SETCHANNELOPTION +.PP +\fBTcl_SetChannelOption\fR sets a new value for an option on \fIchannel\fR. +\fIOptionName\fR is the option to set and \fInewValue\fR is the value to +set. +The procedure normally returns \fBTCL_OK\fR. If an error occurs, +it returns \fBTCL_ERROR\fR; in addition, if \fIinterp\fR is non-NULL, +\fBTcl_SetChannelOption\fR leaves an error message in \fIinterp->result\fR. + +.SH TCL_EOF +.PP +\fBTcl_Eof\fR returns a nonzero value if \fIchannel\fR encountered +an end of file during the last input operation. + +.SH TCL_INPUTBLOCKED +.PP +\fBTcl_InputBlocked\fR returns a nonzero value if \fIchannel\fR is in +nonblocking mode and the last input operation returned less data than +requested because there was insufficient data available. +The call always returns zero if the channel is in blocking mode. + +.SH TCL_INPUTBUFFERED +.PP +\fBTcl_InputBuffered\fR returns the number of bytes of input currently +buffered in the internal buffers for a channel. If the channel is not open +for reading, this function always returns zero. + +.SH "SEE ALSO" +DString(3), fconfigure(n), filename(n), fopen(2), Tcl_CreateChannel(3) + +.SH KEYWORDS +access point, blocking, buffered I/O, channel, channel driver, end of file, +flush, input, nonblocking, output, read, seek, write diff --git a/tcl7.6/doc/OpenTcp.3 b/tcl7.6/doc/OpenTcp.3 new file mode 100644 index 0000000..0f05fcb --- /dev/null +++ b/tcl7.6/doc/OpenTcp.3 @@ -0,0 +1,170 @@ +'\" +'\" Copyright (c) 1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) OpenTcp.3 1.17 96/09/09 10:07:12 +.so man.macros +.TH Tcl_OpenTcpClient 3 7.5 Tcl "Tcl Library Procedures" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +Tcl_OpenTcpClient, Tcl_OpenTcpServer \- procedures to open channels using TCP sockets +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +Tcl_Channel +\fBTcl_OpenTcpClient\fR(\fIinterp, port, host, myaddr, myport, async\fR) +.sp +Tcl_Channel +\fBTcl_MakeTcpClientChannel\fR(\fIsock\fR) +.sp +Tcl_Channel +\fBTcl_OpenTcpServer\fR(\fIinterp, port, myaddr, proc, clientData\fR) +.sp +.SH ARGUMENTS +.AS Tcl_ChannelType newClientProcPtr in +.AP Tcl_Interp *interp in +Tcl interpreter to use for error reporting. If non-NULL and an +error occurs, an error message is left in \fIinterp->result\fR. +.AP int port in +A port number to connect to as a client or to listen on as a server. +.AP char *host in +A string specifying a host name or address for the remote end of the connection. +.AP int myport in +A port number for the client's end of the socket. If 0, a port number +is allocated at random. +.AP char *myaddr in +A string specifying the host name or address for network interface to use +for the local end of the connection. If NULL, a default interface is +chosen. +.AP int async in +If nonzero, the client socket is connected asynchronously to the server. +.AP ClientData sock in +Platform-specific handle for client TCP socket. +.AP Tcl_TcpAcceptProc *proc in +Pointer to a procedure to invoke each time a new connection is +accepted via the socket. +.AP ClientData clientData in +Arbitrary one-word value to pass to \fIproc\fR. +.BE + +.SH DESCRIPTION +.PP +These functions are convenience procedures for creating +channels that communicate over TCP sockets. +The operations on a channel +are described in the manual entry for \fBTcl_OpenFileChannel\fR. + +.SH TCL_OPENTCPCLIENT +.PP +\fBTcl_OpenTcpClient\fR opens a client TCP socket connected to a \fIport\fR +on a specific \fIhost\fR, and returns a channel that can be used to +communicate with the server. The host to connect to can be specified either +as a domain name style name (e.g. \fBwww.sunlabs.com\fR), or as a string +containing the alphanumeric representation of its four-byte address (e.g. +\fB127.0.0.1\fR). Use the string \fBlocalhost\fR to connect to a TCP socket on +the host on which the function is invoked. +.PP +The \fImyaddr\fR and \fImyport\fR arguments allow a client to specify an +address for the local end of the connection. If \fImyaddr\fR is NULL, then +an interface is chosen automatically by the operating system. +If \fImyport\fR is 0, then a port number is chosen at random by +the operating system. +.PP +If \fIasync\fR is zero, the call to \fBTcl_OpenTcpClient\fR returns only +after the client socket has either successfully connected to the server, or +the attempted connection has failed. +If \fIasync\fR is nonzero the socket is connected asynchronously and the +returned channel may not yet be connected to the server when the call to +\fBTcl_OpenTcpClient\fR returns. If the channel is in blocking mode and an +input or output operation is done on the channel before the connection is +completed or fails, that operation will wait until the connection either +completes successfully or fails. If the channel is in nonblocking mode, the +input or output operation will return immediately and a subsequent call to +\fBTcl_InputBlocked\fR on the channel will return nonzero. +.PP +The returned channel is opened for reading and writing. +If an error occurs in opening the socket, \fBTcl_OpenTcpClient\fR returns +NULL and records a POSIX error code that can be retrieved +with \fBTcl_GetErrno\fR. +In addition, if \fIinterp\fR is non-NULL, an error message +is left in \fIinterp->result\fR. +.PP +The newly created channel is not registered in the supplied interpreter; to +register it, use \fBTcl_RegisterChannel\fR. +If one of the standard channels, \fBstdin, stdout\fR or \fBstderr\fR was +previously closed, the act of creating the new channel also assigns it as a +replacement for the standard channel. + +.SH TCL_MAKETCPCLIENTCHANNEL +.PP +\fBTcl_MakeTcpClientChannel\fR creates a \fBTcl_Channel\fR around an +existing, platform specific, handle for a client TCP socket. +.PP +The newly created channel is not registered in the supplied interpreter; to +register it, use \fBTcl_RegisterChannel\fR. +If one of the standard channels, \fBstdin, stdout\fR or \fBstderr\fR was +previously closed, the act of creating the new channel also assigns it as a +replacement for the standard channel. + +.SH TCL_OPENTCPSERVER +.PP +\fBTcl_OpenTcpServer\fR opens a TCP socket on the local host on a specified +\fIport\fR and uses the Tcl event mechanism to accept requests from clients +to connect to it. The \fImyaddr\fP argument specifies the network interface. +If \fImyaddr\fP is NULL the special address INADDR_ANY should be used to +allow connections from any network interface. +Each time a client connects to this socket, Tcl creates a channel +for the new connection and invokes \fIproc\fR with information about +the channel. \fIProc\fR must match the following prototype: +.CS +typedef void Tcl_TcpAcceptProc( + ClientData \fIclientData\fR, + Tcl_Channel \fIchannel\fR, + char *\fIhostName\fR, + int \fIport\fP); +.CE +.PP +The \fIclientData\fR argument will be the same as the \fIclientData\fR +argument to \fBTcl_OpenTcpServer\fR, \fIchannel\fR will be the handle +for the new channel, \fIhostName\fR points to a string containing +the name of the client host making the connection, and \fIport\fP +will contain the client's port number. +The new channel +is opened for both input and output. +If \fIproc\fR raises an error, the connection is closed automatically. +\fIProc\fR has no return value, but if it wishes to reject the +connection it can close \fIchannel\fR. +.PP +\fBTcl_OpenTcpServer\fR normally returns a pointer to a channel +representing the server socket. +If an error occurs, \fBTcl_OpenTcpServer\fR returns NULL and +records a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. +In addition, if \fIinterp->result\fR is non-NULL, an error message +is left in \fIinterp->result\fR. +.PP +The channel returned by \fBTcl_OpenTcpServer\fR cannot be used for +either input or output. +It is simply a handle for the socket used to accept connections. +The caller can close the channel to shut down the server and disallow +further connections from new clients. +.PP +TCP server channels operate correctly only in applications that dispatch +events through \fBTcl_DoOneEvent\fR or through Tcl commands such as +\fBvwait\fR; otherwise Tcl will never notice that a connection request from +a remote client is pending. +.PP +The newly created channel is not registered in the supplied interpreter; to +register it, use \fBTcl_RegisterChannel\fR. +If one of the standard channels, \fBstdin, stdout\fR or \fBstderr\fR was +previously closed, the act of creating the new channel also assigns it as a +replacement for the standard channel. + +.SH "SEE ALSO" +Tcl_OpenFileChannel(3), Tcl_RegisterChannel(3), vwait(n) + +.SH KEYWORDS +client, server, TCP diff --git a/tcl7.6/doc/PkgRequire.3 b/tcl7.6/doc/PkgRequire.3 new file mode 100644 index 0000000..62e2cd0 --- /dev/null +++ b/tcl7.6/doc/PkgRequire.3 @@ -0,0 +1,59 @@ +'\" +'\" Copyright (c) 1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) PkgRequire.3 1.4 96/02/15 20:03:16 +'\" +.so man.macros +.TH Tcl_PkgRequire 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_PkgRequire, Tcl_PkgProvide \- package version control +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +char * +\fBTcl_PkgRequire\fR(\fIinterp, name, version, exact\fR) +.sp +int +\fBTcl_PkgProvide\fR(\fIinterp, name, version\fR) +.SH ARGUMENTS +.AS Tcl_FreeProc clientData +.AP Tcl_Interp *interp in +Interpreter where package is needed or available. +.AP char *name in +Name of package. +.AP char *version in +A version string consisting of one or more decimal numbers +separated by dots. +.AP int exact in +Non-zero means that only the particular version specified by +\fIversion\fR is acceptable. +Zero means that newer versions than \fIversion\fR are also +acceptable as long as they have the same major version number +as \fIversion\fR. +.BE + +.SH DESCRIPTION +.PP +These procedures provide C-level interfaces to Tcl's package and +version management facilities. +\fBTcl_PkgRequire\fR is equivalent to the \fBpackage require\fR +command, and \fBTcl_PkgProvide\fR is equivalent to the +\fBpackage provide\fR command. +See the documentation for the Tcl commands for details on what these +procedures do. +If \fBTcl_PkgRequire\fR completes successfully it returns a pointer +to the version string for the version of the package that is provided +in the interpreter (which may be different than \fIversion\fR); if +an error occurs it returns NULL and leaves an error message in +\fIinterp->result\fR. +\fBTcl_PkgProvide\fR returns TCL_OK if it completes successfully; +if an error occurs it returns TCL_ERROR and leaves an error message +in \fIinterp->result\fR. + +.SH KEYWORDS +package, provide, require, version diff --git a/tk3.6/doc/Preserve.3 b/tcl7.6/doc/Preserve.3 similarity index 50% rename from tk3.6/doc/Preserve.3 rename to tcl7.6/doc/Preserve.3 index 2d26717..a2c7d28 100644 --- a/tk3.6/doc/Preserve.3 +++ b/tcl7.6/doc/Preserve.3 @@ -1,45 +1,32 @@ '\" '\" Copyright (c) 1990 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/wish/man/RCS/Preserve.3,v 1.5 93/04/01 09:41:54 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) Preserve.3 1.13 96/05/28 09:26:12 '\" .so man.macros -.HS Tk_Preserve tkc +.TH Tcl_Preserve 3 7.5 Tcl "Tcl Library Procedures" .BS .SH NAME -Tk_Preserve, Tk_Release, Tk_EventuallyFree \- avoid freeing storage while it's being used +Tcl_Preserve, Tcl_Release, Tcl_EventuallyFree \- avoid freeing storage while it's being used .SH SYNOPSIS .nf -\fB#include \fR +\fB#include \fR .sp -\fBTk_Preserve\fR(\fIclientData\fR) +\fBTcl_Preserve\fR(\fIclientData\fR) .sp -\fBTk_Release\fR(\fIclientData\fR) +\fBTcl_Release\fR(\fIclientData\fR) .sp -\fBTk_EventuallyFree\fR(\fIclientData, freeProc\fR) +\fBTcl_EventuallyFree\fR(\fIclientData, freeProc\fR) .SH ARGUMENTS -.AS Tk_FreeProc clientData +.AS Tcl_FreeProc clientData .AP ClientData clientData in Token describing structure to be freed or reallocated. Usually a pointer to memory for structure. -.AP Tk_FreeProc *freeProc in +.AP Tcl_FreeProc *freeProc in Procedure to invoke to free \fIclientData\fR. .BE @@ -47,7 +34,8 @@ Procedure to invoke to free \fIclientData\fR. .PP These three procedures help implement a simple reference count mechanism for managing storage. They are designed to solve a problem -having to do with widget deletion. When a widget is deleted, its +having to do with widget deletion, but are also useful in many other +situations. When a widget is deleted, its widget record (the structure holding information specific to the widget) must be returned to the storage allocator. However, it's possible that the widget record is in active use @@ -67,41 +55,42 @@ finished with it. In other situations where the widget is deleted, it may be possible to free the widget record immediately. .PP -\fBTk_Preserve\fR and \fBTk_Release\fR +\fBTcl_Preserve\fR and \fBTcl_Release\fR implement short-term reference counts for their \fIclientData\fR argument. The \fIclientData\fR argument identifies an object and usually consists of the address of a structure. The reference counts guarantee that an object will not be freed -until each call to \fBTk_Preserve\fR for the object has been -matched by calls to \fBTk_Release\fR. -There may be any number of unmatched \fBTk_Preserve\fR calls +until each call to \fBTcl_Preserve\fR for the object has been +matched by calls to \fBTcl_Release\fR. +There may be any number of unmatched \fBTcl_Preserve\fR calls in effect at once. .PP -\fBTk_EventuallyFree\fR is invoked to free up its \fIclientData\fR +\fBTcl_EventuallyFree\fR is invoked to free up its \fIclientData\fR argument. -It checks to see if there are unmatched \fBTk_Preserve\fR calls +It checks to see if there are unmatched \fBTcl_Preserve\fR calls for the object. -If not, then \fBTk_EventuallyFree\fR calls \fIfreeProc\fR immediately. -Otherwise \fBTk_EventuallyFree\fR records the fact that \fIclientData\fR +If not, then \fBTcl_EventuallyFree\fR calls \fIfreeProc\fR immediately. +Otherwise \fBTcl_EventuallyFree\fR records the fact that \fIclientData\fR needs eventually to be freed. -When all calls to \fBTk_Preserve\fR have been matched with -calls to \fBTk_Release\fR then \fIfreeProc\fR will be called by -\fBTk_Release\fR to do the cleanup. +When all calls to \fBTcl_Preserve\fR have been matched with +calls to \fBTcl_Release\fR then \fIfreeProc\fR will be called by +\fBTcl_Release\fR to do the cleanup. .PP All the work of freeing the object is carried out by \fIfreeProc\fR. \fIFreeProc\fR must have arguments and result that match the -type \fBTk_FreeProc\fR: -.nf -.RS -typedef void Tk_FreeProc(ClientData \fIclientData\fR); -.RE -.fi -The \fIclientData\fR argument to \fIfreeProc\fR will be the -same as the \fIclientData\fR argument to \fBTk_EventuallyFree\fR. +type \fBTcl_FreeProc\fR: +.CS +typedef void Tcl_FreeProc(char *\fIblockPtr\fR); +.CE +The \fIblockPtr\fR argument to \fIfreeProc\fR will be the +same as the \fIclientData\fR argument to \fBTcl_EventuallyFree\fR. +The type of \fIblockPtr\fR (\fBchar *\fR) is different than the type of the +\fIclientData\fR argument to \fBTcl_EventuallyFree\fR for historical +reasons, but the value is the same. .PP This mechanism can be used to solve the problem described above -by placing \fBTk_Preserve\fR and \fBTk_Release\fR calls around +by placing \fBTcl_Preserve\fR and \fBTcl_Release\fR calls around actions that may cause undesired storage re-allocation. The mechanism is intended only for short-term use (i.e. while procedures are pending on the stack); it will not work efficiently as a diff --git a/tcl7.3/doc/PrintDbl.3 b/tcl7.6/doc/PrintDbl.3 similarity index 53% rename from tcl7.3/doc/PrintDbl.3 rename to tcl7.6/doc/PrintDbl.3 index 51d7f88..413e2b7 100644 --- a/tcl7.3/doc/PrintDbl.3 +++ b/tcl7.6/doc/PrintDbl.3 @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/PrintDbl.3,v 1.2 93/06/05 15:32:01 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) PrintDbl.3 1.6 96/03/25 20:05:45 '\" .so man.macros -.HS Tcl_PrintDouble tclc 7.0 +.TH Tcl_PrintDouble 3 7.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_PrintDouble \- Convert floating value to string diff --git a/tcl7.6/doc/RecordEval.3 b/tcl7.6/doc/RecordEval.3 new file mode 100644 index 0000000..6e6fb27 --- /dev/null +++ b/tcl7.6/doc/RecordEval.3 @@ -0,0 +1,49 @@ +'\" +'\" Copyright (c) 1989-1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) RecordEval.3 1.17 96/08/26 12:59:47 +'\" +.so man.macros +.TH Tcl_RecordAndEval 3 7.4 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_RecordAndEval \- save command on history list before evaluating +.SH SYNOPSIS +.nf +\fB#include \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 flags in +An OR'ed combination of flag bits. TCL_NO_EVAL means record the +command but don't evaluate it. TCL_EVAL_GLOBAL means evaluate +the command at global level instead of the current stack level. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_RecordAndEval\fR is invoked to record a command as an event +on the history list and then execute it using \fBTcl_Eval\fR +(or \fBTcl_GlobalEval\fR if the TCL_EVAL_GLOBAL bit is set in \fIflags\fR). +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 \fIflags\fR argument contains the TCL_NO_EVAL bit then +the command is recorded without being evaluated. + +.SH KEYWORDS +command, event, execute, history, interpreter, record diff --git a/tcl7.6/doc/RegExp.3 b/tcl7.6/doc/RegExp.3 new file mode 100644 index 0000000..fef9245 --- /dev/null +++ b/tcl7.6/doc/RegExp.3 @@ -0,0 +1,116 @@ +'\" +'\" Copyright (c) 1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) RegExp.3 1.9 96/08/26 12:59:48 +'\" +.so man.macros +.TH Tcl_RegExpMatch 3 7.4 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_RegExpMatch, Tcl_RegExpCompile, Tcl_RegExpExec, Tcl_RegExpRange \- Pattern matching with regular expressions +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +int +\fBTcl_RegExpMatch\fR(\fIinterp\fR, \fIstring\fR, \fIpattern\fR) +.sp +Tcl_RegExp +\fBTcl_RegExpCompile\fR(\fIinterp\fR, \fIpattern\fR) +.sp +int +\fBTcl_RegExpExec\fR(\fIinterp\fR, \fIregexp\fR, \fIstring\fR, \fIstart\fR) +.sp +\fBTcl_RegExpRange\fR(\fIregexp\fR, \fIindex\fR, \fIstartPtr\fR, \fIendPtr\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 check for a match with a regular expression. +.AP char *pattern in +String in the form of a regular expression pattern. +.AP Tcl_RegExp regexp in +Compiled regular expression. Must have been returned previously +by \fBTcl_RegExpCompile\fR. +.AP char *start in +If \fIstring\fR is just a portion of some other string, this argument +identifies the beginning of the larger string. +If it isn't the same as \fIstring\fR, then no \fB^\fR matches +will be allowed. +.AP int index in +Specifies which range is desired: 0 means the range of the entire +match, 1 or greater means the range that matched a parenthesized +sub-expression. +.AP char **startPtr out +The address of the first character in the range is stored here, or +NULL if there is no such range. +.AP char **endPtr out +The address of the character just after the last one in the range +is stored here, or NULL if there is no such range. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_RegExpMatch\fR determines whether its \fIpattern\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. \fIpattern\fR +is not a valid regular expression) then \fBTcl_RegExpMatch\fR +returns \-1 and leaves an error message in \fIinterp->result\fR. +.PP +\fBTcl_RegExpCompile\fR, \fBTcl_RegExpExec\fR, and \fBTcl_RegExpRange\fR +provide lower-level access to the regular expression pattern matcher. +\fBTcl_RegExpCompile\fR compiles a regular expression string into +the internal form used for efficient pattern matching. +The return value is a token for this compiled form, which can be +used in subsequent calls to \fBTcl_RegExpExec\fR or \fBTcl_RegExpRange\fR. +If an error occurs while compiling the regular expression then +\fBTcl_RegExpCompile\fR returns NULL and leaves an error message +in \fIinterp->result\fR. +Note: the return value from \fBTcl_RegExpCompile\fR is only valid +up to the next call to \fBTcl_RegExpCompile\fR; it is not safe to +retain these values for long periods of time. +.PP +\fBTcl_RegExpExec\fR executes the regular expression pattern matcher. +It returns 1 if \fIstring\fR contains a range of characters that +match \fIregexp\fR, 0 if no match is found, and +\-1 if an error occurs. +In the case of an error, \fBTcl_RegExpExec\fR leaves an error +message in \fIinterp->result\fR. +When searching a string for multiple matches of a pattern, +it is important to distinguish between the start of the original +string and the start of the current search. +For example, when searching for the second occurrence of a +match, the \fIstring\fR argument might point to the character +just after the first match; however, it is important for the +pattern matcher to know that this is not the start of the entire string, +so that it doesn't allow \fB^\fR atoms in the pattern to match. +The \fIstart\fR argument provides this information by pointing +to the start of the overall string containing \fIstring\fR. +\fIStart\fR will be less than or equal to \fIstring\fR; if it +is less than \fIstring\fR then no \fB^\fR matches will be allowed. +.PP +\fBTcl_RegExpRange\fR may be invoked after \fBTcl_RegExpExec\fR +returns; it provides detailed information about what ranges of +the string matched what parts of the pattern. +\fBTcl_RegExpRange\fR returns a pair of pointers in \fI*startPtr\fR +and \fI*endPtr\fR that identify a range of characters in +the source string for the most recent call to \fBTcl_RegExpExec\fR. +\fIIndex\fR indicates which of several ranges is desired: +if \fIindex\fR is 0, information is returned about the overall range +of characters that matched the entire pattern; otherwise, +information is returned about the range of characters that matched the +\fIindex\fR'th parenthesized subexpression within the pattern. +If there is no range corresponding to \fIindex\fR then NULL +is stored in \fI*firstPtr\fR and \fI*lastPtr\fR. + +.SH KEYWORDS +match, pattern, regular expression, string, subexpression diff --git a/tcl7.6/doc/SetErrno.3 b/tcl7.6/doc/SetErrno.3 new file mode 100644 index 0000000..b3c6277 --- /dev/null +++ b/tcl7.6/doc/SetErrno.3 @@ -0,0 +1,48 @@ +'\" +'\" Copyright (c) 1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) SetErrno.3 1.5 96/02/15 20:01:31 +.so man.macros +.TH Tcl_SetErrno 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_SetErrno, Tcl_GetErrno \- manipulate errno to store and retrieve error codes +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +void +\fBTcl_SetErrno\fR(\fIerrorCode\fR) +.sp +int +\fBTcl_GetErrno\fR() +.sp +.SH ARGUMENTS +.AS Tcl_Interp *errorCode in +.AP int errorCode in +A POSIX error code such as \fBENOENT\fR. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_SetErrno\fR and \fBTcl_GetErrno\fR provide portable access +to the \fBerrno\fR variable, which is used to record a POSIX error +code after system calls and other operations such as \fBTcl_Gets\fR. +These procedures are necessary because global variable accesses cannot +be made across module boundaries on some platforms. +.PP +\fBTcl_SetErrno\fR sets the \fBerrno\fR variable to the value of the +\fIerrorCode\fR argument +C procedures that wish to return error information to their callers +via \fBerrno\fR should call \fBTcl_SetErrno\fR rather than setting +\fBerrno\fR directly. +.PP +\fBTcl_GetErrno\fR returns the current value of \fBerrno\fR. +Procedures wishing to access \fBerrno\fR should call this procedure +instead of accessing \fBerrno\fR directly. + +.SH KEYWORDS +errno, error code, global variables diff --git a/tcl7.3/doc/SetRecLmt.3 b/tcl7.6/doc/SetRecLmt.3 similarity index 51% rename from tcl7.3/doc/SetRecLmt.3 rename to tcl7.6/doc/SetRecLmt.3 index 3010a86..3a07481 100644 --- a/tcl7.3/doc/SetRecLmt.3 +++ b/tcl7.6/doc/SetRecLmt.3 @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/SetRecLmt.3,v 1.1 93/07/07 16:35:18 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) SetRecLmt.3 1.6 96/03/25 20:06:36 '\" .so man.macros -.HS Tcl_SetRecursionLimit tclc 7.0 +.TH Tcl_SetRecursionLimit 3 7.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_SetRecursionLimit \- set maximum allowable nesting depth in interpreter @@ -55,6 +42,14 @@ 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. +.PP +The \fBTcl_SetRecursionLimit\fR only sets the size of the Tcl +call stack: it cannot by itself prevent stack overflows on the +C stack being used by the application. If your machine has a +limit on the size of the C stack, you may get stack overflows +before reaching the limit set by \fBTcl_SetRecursionLimit\fR. +If this happens, see if there is a mechanism in your system for +increasing the maximum size of the C stack. .SH KEYWORDS nesting depth, recursion diff --git a/tcl7.3/doc/SetResult.3 b/tcl7.6/doc/SetResult.3 similarity index 81% rename from tcl7.3/doc/SetResult.3 rename to tcl7.6/doc/SetResult.3 index 94835ac..609793b 100644 --- a/tcl7.3/doc/SetResult.3 +++ b/tcl7.6/doc/SetResult.3 @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/SetResult.3,v 1.12 93/04/03 15:05:59 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) SetResult.3 1.20 96/08/26 12:59:49 '\" .so man.macros -.HS Tcl_SetResult tclc 7.0 +.TH Tcl_SetResult 3 7.5 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_SetResult, Tcl_AppendResult, Tcl_AppendElement, Tcl_ResetResult \- manipulate Tcl result string @@ -33,9 +20,7 @@ Tcl_SetResult, Tcl_AppendResult, Tcl_AppendElement, Tcl_ResetResult \- manipulat .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 @@ -47,7 +32,7 @@ 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 +.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. @@ -64,11 +49,13 @@ 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. +.VS 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. +to \fBTcl_Alloc\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. +released by calling \fBTcl_Free\fR when it is no longer needed. +.VE 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). @@ -83,13 +70,9 @@ 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 - +.CS typedef void Tcl_FreeProc(char *\fIblockPtr\fR); - -.RE -.fi +.CE When \fIfreeProc\fR is called, its \fIblockPtr\fR will be set to the value of \fIstring\fR passed to \fBTcl_SetResult\fR. .PP @@ -130,12 +113,10 @@ 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 diff --git a/tcl7.3/doc/SetVar.3 b/tcl7.6/doc/SetVar.3 similarity index 81% rename from tcl7.3/doc/SetVar.3 rename to tcl7.6/doc/SetVar.3 index 087ebf8..c9f7048 100644 --- a/tcl7.3/doc/SetVar.3 +++ b/tcl7.6/doc/SetVar.3 @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/SetVar.3,v 1.15 93/06/05 15:40:17 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) SetVar.3 1.23 96/08/26 12:59:49 '\" .so man.macros -.HS Tcl_SetVar tclc 7.0 +.TH Tcl_SetVar 3 7.4 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_SetVar, Tcl_SetVar2, Tcl_GetVar, Tcl_GetVar2, Tcl_UnsetVar, Tcl_UnsetVar2 \- manipulate Tcl variables @@ -53,6 +40,9 @@ Interpreter containing variable. .AP char *varName in Name of variable. May refer to a scalar variable or an element of an array variable. +If the name references an element of an array, then it +must be in writable memory: Tcl will make temporary modifications +to it while looking up the name. .AP char *newValue in New value for variable. .AP int flags in @@ -102,31 +92,33 @@ 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 +.TP +\fBTCL_GLOBAL_ONLY\fR 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 +.TP +\fBTCL_LEAVE_ERR_MSG\fR 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 +.TP +\fBTCL_APPEND_VALUE\fR 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 +.TP +\fBTCL_LIST_ELEMENT\fR 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. @@ -149,11 +141,9 @@ 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 diff --git a/tcl7.6/doc/Sleep.3 b/tcl7.6/doc/Sleep.3 new file mode 100644 index 0000000..0c7956a --- /dev/null +++ b/tcl7.6/doc/Sleep.3 @@ -0,0 +1,37 @@ +'\" +'\" Copyright (c) 1990 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) Sleep.3 1.3 96/03/25 20:07:21 +'\" +.so man.macros +.TH Tcl_Sleep 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_Sleep \- delay execution for a given number of milliseconds +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +\fBTcl_Sleep\fR(\fIms\fR) +.SH ARGUMENTS +.AP int ms in +Number of milliseconds to sleep. +.BE + +.SH DESCRIPTION +.PP +This procedure delays the calling process by the number of +milliseconds given by the \fIms\fR parameter and returns +after that time has elapsed. It is typically used for things +like flashing a button, where the delay is short and the +application needn't do anything while it waits. For longer +delays where the application needs to respond to other events +during the delay, the procedure \fBTcl_CreateTimerHandler\fR +should be used instead of \fBTcl_Sleep\fR. + +.SH KEYWORDS +sleep, time, wait diff --git a/tcl7.3/doc/SplitList.3 b/tcl7.6/doc/SplitList.3 similarity index 80% rename from tcl7.3/doc/SplitList.3 rename to tcl7.6/doc/SplitList.3 index c596489..a136450 100644 --- a/tcl7.3/doc/SplitList.3 +++ b/tcl7.6/doc/SplitList.3 @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/SplitList.3,v 1.11 93/04/01 09:25:34 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) SplitList.3 1.20 96/06/05 18:00:16 '\" .so man.macros -.HS Tcl_SplitList tclc +.TH Tcl_SplitList 3 7.5 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_SplitList, Tcl_Merge, Tcl_ScanElement, Tcl_ConvertElement \- manipulate Tcl lists @@ -43,7 +30,10 @@ int .SH ARGUMENTS .AS Tcl_Interp ***argvPtr .AP Tcl_Interp *interp out -Interpreter to use for error reporting. +.VS +Interpreter to use for error reporting. If NULL, then no error message +is left. +.VE .AP char *list in Pointer to a string with proper list structure. .AP int *argcPtr out @@ -83,17 +73,31 @@ 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. +responsibility to free up all of this storage. +For example, suppose that you have called \fBTcl_SplitList\fR with +the following code: +.CS +int argc, code; +char *string; +char **argv; +\&... +code = Tcl_SplitList(interp, string, &argc, &argv); +.CE +Then you should eventually free the storage with a call like the +following: +.VS +.CS +Tcl_Free((char *) argv); +.CE +.VE .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. +.VS +problem (if \fIinterp\fR was not NULL). +.VE If \fBTCL_ERROR\fR is returned then no memory is allocated and \fI*argvPtr\fR is not modified. .PP @@ -108,9 +112,11 @@ 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. +.VS The result string is dynamically allocated -using \fBmalloc()\fR; the caller must eventually release the space -using \fBfree()\fR. +using \fBTcl_Alloc\fR; the caller must eventually release the space +using \fBTcl_Free\fR. +.VE .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 diff --git a/tcl7.6/doc/SplitPath.3 b/tcl7.6/doc/SplitPath.3 new file mode 100644 index 0000000..f98a78b --- /dev/null +++ b/tcl7.6/doc/SplitPath.3 @@ -0,0 +1,93 @@ +'\" +'\" Copyright (c) 1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) SplitPath.3 1.4 96/08/19 14:59:35 +'\" +.so man.macros +.TH Tcl_SplitPath 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_SplitPath, Tcl_JoinPath, Tcl_GetPathType \- manipulate platform-dependent file paths +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +\fBTcl_SplitPath\fR(\fIpath, argcPtr, argvPtr\fR) +.sp +char * +\fBTcl_JoinPath\fR(\fIargc, argv, resultPtr\fR) +.sp +Tcl_PathType +\fBTcl_GetPathType\fR(\fIpath\fR) +.SH ARGUMENTS +.AS Tcl_DString ***argvPtr +.AP char *path in +File path in a form appropriate for the current platform (see the +\fBfilename\fR manual entry for acceptable forms for path names). +.AP int *argcPtr out +Filled in with number of path elements in \fIpath\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 \fIpath\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 path elements to merge together into a single path. +.AP Tcl_DString *resultPtr in/out +A pointer to an initialized \fBTcl_DString\fR to which the result of +\fBTcl_JoinPath\fR will be appended. +.BE + +.SH DESCRIPTION +.PP +These procedures may be used to disassemble and reassemble file +paths in a platform independent manner: they provide C-level access to +the same functionality as the \fBfile split\fR, \fBfile join\fR, and +\fBfile pathtype\fR commands. +.PP +\fBTcl_SplitPath\fR breaks a path into its constituent elements, +returning an array of pointers to the elements using \fIargcPtr\fR and +\fIargvPtr\fR. 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 path elements. It is the caller's +responsibility to free all of this storage. +For example, suppose that you have called \fBTcl_SplitPath\fR with the +following code: +.CS +int argc; +char *path; +char **argv; +\&... +Tcl_SplitPath(string, &argc, &argv); +.CE +Then you should eventually free the storage with a call like the +following: +.CS +Tcl_Free((char *) argv); +.CE +.PP +\fBTcl_JoinPath\fR is the inverse of \fBTcl_SplitPath\fR: it takes a +collection of path elements given by \fIargc\fR and \fIargv\fR and +generates a result string that is a properly constructed path. The +result string is appended to \fIresultPtr\fR. \fIResultPtr\fR must +refer to an initialized \fBTcl_DString\fR. +.PP +If the result of \fBTcl_SplitPath\fR is passed to \fBTcl_JoinPath\fR, +the result will refer to the same location, but may not be in the same +form. This is because \fBTcl_SplitPath\fR and \fBTcl_JoinPath\fR +eliminate duplicate path separators and return a normalized form for +each platform. +.PP +\fBTcl_GetPathType\fR returns the type of the specified \fIpath\fR, +where \fBTcl_PathType\fR is one of \fBTCL_PATH_ABSOLUTE\fR, +\fBTCL_PATH_RELATIVE\fR, or \fBTCL_PATH_VOLUME_RELATIVE\fR. See the +\fBfilename\fR manual entry for a description of the path types for +each platform. + +.SH KEYWORDS +file, filename, join, path, split, type diff --git a/tcl7.6/doc/StaticPkg.3 b/tcl7.6/doc/StaticPkg.3 new file mode 100644 index 0000000..ccb1a69 --- /dev/null +++ b/tcl7.6/doc/StaticPkg.3 @@ -0,0 +1,70 @@ +'\" +'\" Copyright (c) 1995-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) StaticPkg.3 1.4 96/09/04 11:21:26 +'\" +.so man.macros +.TH Tcl_StaticPackage 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_StaticPackage \- make a statically linked package available via the \fBload\fR command +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +\fBTcl_StaticPackage\fR(\fIinterp, pkgName, initProc, safeInitProc\fR) +.SH ARGUMENTS +.AS Tcl_PackageInitProc *safeInitProc +.AP Tcl_Interp *interp in +If not NULL, points to an interpreter into which the package has +already been loaded (i.e., the caller has already invoked the +appropriate initialization procedure). NULL means the package +hasn't yet been incorporated into any interpreter. +.AP char *pkgName in +Name of the package; should be properly capitalized (first letter +upper-case, all others lower-case). +.AP Tcl_PackageInitProc *initProc in +Procedure to invoke to incorporate this package into a trusted +interpreter. +.AP Tcl_PackageInitProc *safeInitProc in +Procedure to call to incorporate this package into a safe interpreter +(one that will execute untrusted scripts). NULL means the package +can't be used in safe interpreters. +.BE + +.SH DESCRIPTION +.PP +This procedure may be invoked to announce that a package has been +linked statically with a Tcl application and, optionally, that it +has already been loaded into an interpreter. +Once \fBTcl_StaticPackage\fR has been invoked for a package, it +may be loaded into interpreters using the \fBload\fR command. +\fBTcl_StaticPackage\fR is normally invoked only by the \fBTcl_AppInit\fR +procedure for the application, not by packages for themselves +(\fBTcl_StaticPackage\fR should only be invoked for statically +loaded packages, and code in the package itself should not need +to know whether the package is dynamically or statically loaded). +.PP +When the \fBload\fR command is used later to load the package into +an interpreter, one of \fIinitProc\fR and \fIsafeInitProc\fR will +be invoked, depending on whether the target interpreter is safe +or not. +\fIinitProc\fR and \fIsafeInitProc\fR must both match the +following prototype: +.CS +typedef int Tcl_PackageInitProc(Tcl_Interp *\fIinterp\fR); +.CE +The \fIinterp\fR argument identifies the interpreter in which the +package is to be loaded. The initialization procedure must return +\fBTCL_OK\fR or \fBTCL_ERROR\fR to indicate whether or not it completed +successfully; in the event of an error it should set \fIinterp->result\fR +to point to an error message. +The result or error from the initialization procedure will be returned +as the result of the \fBload\fR command that caused the +initialization procedure to be invoked. + +.SH KEYWORDS +initialization procedure, package, static linking diff --git a/tcl7.6/doc/StrMatch.3 b/tcl7.6/doc/StrMatch.3 new file mode 100644 index 0000000..354193b --- /dev/null +++ b/tcl7.6/doc/StrMatch.3 @@ -0,0 +1,39 @@ +'\" +'\" Copyright (c) 1989-1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) StrMatch.3 1.11 96/03/25 20:08:06 +'\" +.so man.macros +.TH Tcl_StringMatch 3 "" Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_StringMatch \- test whether a string matches a pattern +.SH SYNOPSIS +.nf +\fB#include \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/tcl7.3/doc/Tcl.n b/tcl7.6/doc/Tcl.n similarity index 81% rename from tcl7.3/doc/Tcl.n rename to tcl7.6/doc/Tcl.n index e6d8573..610fe1b 100644 --- a/tcl7.3/doc/Tcl.n +++ b/tcl7.6/doc/Tcl.n @@ -1,37 +1,21 @@ '\" '\" Copyright (c) 1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/Tcl.n,v 1.118 93/07/28 14:13:25 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) Tcl.n 1.128 96/08/26 12:59:50 ' .so man.macros -.de UL -\\$1\l'|0\(ul'\\$2 -.. -.HS Tcl tcl +.TH Tcl n "" Tcl "Tcl Built-In Commands" .BS .SH NAME Tcl \- Summary of Tcl language syntax. .BE .SH DESCRIPTION -.LP +.PP 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. @@ -94,7 +78,7 @@ Command substitution is not performed on words enclosed in braces. 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: +Variable substitution may take any of the following forms: .RS .TP 15 \fB$\fIname\fR @@ -111,29 +95,25 @@ substitutions are performed on the characters of \fIindex\fR. \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. +.RE .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). @@ -153,16 +133,14 @@ Tab (0x9). \e\fBv\fR Vertical tab (0xb). .TP 6 -\e\fB\fIwhiteSpace\fR\fR -.VS +\e\fB\fIwhiteSpace\fR A single space character replaces the backslash, newline, and all -white space after the newline. +spaces and tabs 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''). @@ -172,14 +150,12 @@ 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. +.RE .IP [9] If a hash character (``#'') appears at a point where Tcl is expecting the first character of the first word of a command, @@ -190,12 +166,12 @@ 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 +For example, if variable substitution occurs then no further +substitutions 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 +no substitutions are performed before making the recursive call and no additional substitutions are performed on the result of the nested script. .IP [11] diff --git a/tcl7.6/doc/Tcl_Main.3 b/tcl7.6/doc/Tcl_Main.3 new file mode 100644 index 0000000..15c0f3e --- /dev/null +++ b/tcl7.6/doc/Tcl_Main.3 @@ -0,0 +1,61 @@ +'\" +'\" Copyright (c) 1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) Tcl_Main.3 1.8 96/03/25 20:08:33 +'\" +.so man.macros +.TH Tcl_Main 3 7.4 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_Main \- main program for Tcl-based applications +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +\fBTcl_Main\fR(\fIargc, argv, appInitProc\fR) +.SH ARGUMENTS +.AS Tcl_AppInitProc *appInitProc +.AP int argc in +Number of elements in \fIargv\fR. +.AP char *argv[] in +Array of strings containing command-line arguments. +.AP Tcl_AppInitProc *appInitProc in +Address of an application-specific initialization procedure. +The value for this argument is usually \fBTcl_AppInit\fR. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_Main\fR acts as the main program for most Tcl-based applications. +Starting with Tcl 7.4 it is not called \fBmain\fR anymore because it +is part of the Tcl library and having a function \fBmain\fR +in a library (particularly a shared library) causes problems on many +systems. +Having \fBmain\fR in the Tcl library would also make it hard to use +Tcl in C++ programs, since C++ programs must have special C++ +\fBmain\fR functions. +.PP +Normally each application contains a small \fBmain\fR function that does +nothing but invoke \fBTcl_Main\fR. +\fBTcl_Main\fR then does all the work of creating and running a +\fBtclsh\fR-like application. +.PP +When it is has finished its own initialization, but before +it processes commands, \fBTcl_Main\fR calls the procedure given by +the \fIappInitProc\fR argument. This procedure provides a ``hook'' +for the application to perform its own initialization, such as defining +application-specific commands. The procedure must have an interface +that matches the type \fBTcl_AppInitProc\fR: +.CS +typedef int Tcl_AppInitProc(Tcl_Interp *\fIinterp\fR); +.CE +\fIAppInitProc\fR is almost always a pointer to \fBTcl_AppInit\fR; +for more details on this procedure, see the documentation +for \fBTcl_AppInit\fR. + +.SH KEYWORDS +application-specific initialization, command-line arguments, main program diff --git a/tcl7.3/doc/TraceVar.3 b/tcl7.6/doc/TraceVar.3 similarity index 89% rename from tcl7.3/doc/TraceVar.3 rename to tcl7.6/doc/TraceVar.3 index 3ddfecf..665a3a7 100644 --- a/tcl7.3/doc/TraceVar.3 +++ b/tcl7.6/doc/TraceVar.3 @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/TraceVar.3,v 1.14 93/05/03 15:53:18 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) TraceVar.3 1.26 96/08/26 12:59:52 '\" .so man.macros -.HS Tcl_TraceVar tclc +.TH Tcl_TraceVar 3 7.4 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_TraceVar, Tcl_TraceVar2, Tcl_UntraceVar, Tcl_UntraceVar2, Tcl_VarTraceInfo, Tcl_VarTraceInfo2 \- monitor accesses to a variable @@ -52,6 +39,9 @@ Interpreter containing variable. 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. +If the name references an element of an array, then it +must be in writable memory: Tcl will make temporary modifications +to it while looking up the name. .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 @@ -110,19 +100,15 @@ 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 +.CS 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 + ClientData \fIclientData\fR, + Tcl_Interp *\fIinterp\fR, + char *\fIname1\fR, + char *\fIname2\fR, + int \fIflags\fR); +.CE +The \fIclientData\fR and \fIinterp\fR 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 @@ -158,7 +144,7 @@ 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. +The same bits are valid for \fIflags\fR as for calls to \fBTcl_TraceVar\fR. .PP \fBTcl_VarTraceInfo\fR may be used to retrieve information about traces set on a given variable. @@ -207,10 +193,8 @@ for the variable, so that calls to \fBTcl_GetVar2\fR and 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. @@ -234,14 +218,12 @@ and \fBTcl_GetVar2\fR procedures. 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, +is modified. This includes \fBset\fR commands, 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). @@ -251,10 +233,8 @@ 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. @@ -282,11 +262,9 @@ 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 @@ -313,7 +291,7 @@ 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 +is a partially-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 @@ -328,13 +306,13 @@ 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" +.SH "TCL_TRACE_DESTROYED FLAG" .PP -In an unset callback to \fIproc\fR, the TCL_TRACE_DELETED bit +In an unset callback to \fIproc\fR, the TCL_TRACE_DESTROYED 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 +is deleted; the only time TCL_TRACE_DESTROYED isn't set is for a whole-array trace invoked when only a single element of an array is unset. diff --git a/tcl7.6/doc/Translate.3 b/tcl7.6/doc/Translate.3 new file mode 100644 index 0000000..6330ee9 --- /dev/null +++ b/tcl7.6/doc/Translate.3 @@ -0,0 +1,66 @@ +'\" +'\" Copyright (c) 1989-1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) Translate.3 1.22 96/08/26 12:59:51 +'\" +.so man.macros +.TH Tcl_TranslateFileName 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_TranslateFileName \- convert file name to native form and replace tilde with home directory +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +char * +\fBTcl_TranslateFileName\fR(\fIinterp\fR, \fIname\fR, \fIbufferPtr\fR) +.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 in/out +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. +.BE + +.SH DESCRIPTION +.PP +This utility procedure translates a file name to a form suitable for +passing to the local operating system. It converts network names into +native form and does tilde substitution. +.PP +If +\fBTcl_TranslateFileName\fR has to do tilde substitution or translate +the name then it uses +the dynamic string at \fI*bufferPtr\fR to hold the new string it +generates. +After \fBTcl_TranslateFileName\fR returns a non-NULL result, the caller must +eventually invoke \fBTcl_DStringFree\fR to free any information +placed in \fI*bufferPtr\fR. The caller need not know whether or +not \fBTcl_TranslateFileName\fR actually used the string; \fBTcl_TranslateFileName\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. +.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. +When an error occurs, \fBTcl_TranslateFileName\fR +frees the dynamic string itself so that the caller need not call +\fBTcl_DStringFree\fR. +.PP +The caller is responsible for making sure that \fIinterp->result\fR +has its default empty value when \fBTcl_TranslateFileName\fR is invoked. + +.SH "SEE ALSO" +filename + +.SH KEYWORDS +file name, home directory, tilde, translate, user diff --git a/tcl7.6/doc/UpVar.3 b/tcl7.6/doc/UpVar.3 new file mode 100644 index 0000000..ca0cc74 --- /dev/null +++ b/tcl7.6/doc/UpVar.3 @@ -0,0 +1,76 @@ +'\" +'\" Copyright (c) 1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) UpVar.3 1.6 96/03/25 20:09:19 +'\" +.so man.macros +.TH Tcl_UpVar 3 7.4 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_UpVar, Tcl_UpVar2 \- link one variable to another +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +int +\fBTcl_UpVar(\fIinterp, frameName, sourceName, destName, flags\fB)\fR +.sp +int +\fBTcl_UpVar2(\fIinterp, frameName, name1, name2, destName, flags\fB)\fR +.SH ARGUMENTS +.AS Tcl_VarTraceProc prevClientData +.AP Tcl_Interp *interp in +Interpreter containing variables; also used for error reporting. +.AP char *frameName in +Identifies the stack frame containing source variable. +May have any of the forms accepted by +the \fBupvar\fR command, such as \fB#0\fR or \fB1\fR. +.AP char *sourceName in +Name of source variable, in the frame given by \fIframeName\fR. +May refer to a scalar variable or to an array variable with a +parenthesized index. +.AP char *destName in +Name of destination variable, which is to be linked to source +variable so that references to \fIdestName\fR +refer to the other variable. Must not currently exist except as +an upvar-ed variable. +.AP int flags in +Either TCL_GLOBAL_ONLY or 0; if non-zero, then \fIdestName\fR is +a global variable; otherwise it is a local to the current procedure +(or global if no procedure is active). +.AP char *name1 in +First part of source variable's name (scalar name, or name of array +without array index). +.AP char *name2 in +If source variable is an element of an array, gives the index of the element. +For scalar source variables, is NULL. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_UpVar\fR and \fBTcl_UpVar2\fR provide the same functionality +as the \fBupvar\fR command: they make a link from a source variable +to a destination variable, so that references to the destination are +passed transparently through to the source. +The name of the source variable may be specified either as a single +string such as \fBxyx\fR or \fBa(24)\fR (by calling \fBTcl_UpVar\fR) +or in two parts where the array name has been separated from the +element name (by calling \fBTcl_UpVar2\fR). +The destination variable name is specified in a single string; it +may not be an array element. +.PP +Both procedures return either TCL_OK or TCL_ERROR, and they +leave an error message in \fIinterp->result\fR if an error +occurs. +.PP +As with the \fBupvar\fR command, the source variable need not exist; +if it does exist, unsetting it later does not destroy the link. The +destination variable may exist at the time of the call, but if so +it must exist as a linked variable. + +.SH KEYWORDS +linked variable, upvar, variable diff --git a/tcl7.6/doc/after.n b/tcl7.6/doc/after.n new file mode 100644 index 0000000..cf4aaeb --- /dev/null +++ b/tcl7.6/doc/after.n @@ -0,0 +1,109 @@ +'\" +'\" Copyright (c) 1990-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) after.n 1.4 96/03/25 20:09:33 +'\" +.so man.macros +.TH after n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +after \- Execute a command after a time delay +.SH SYNOPSIS +\fBafter \fIms\fR +.sp +\fBafter \fIms \fR?\fIscript script script ...\fR? +.sp +\fBafter cancel \fIid\fR +.sp +\fBafter cancel \fIscript script script ...\fR +.sp +\fBafter idle \fR?\fIscript script script ...\fR? +.sp +\fBafter info \fR?\fIid\fR? +.BE + +.SH DESCRIPTION +.PP +This command is used to delay execution of the program or to execute +a command in background sometime in the future. It has several forms, +depending on the first argument to the command: +.TP +\fBafter \fIms\fR +\fIMs\fR must be an integer giving a time in milliseconds. +The command sleeps for \fIms\fR milliseconds and then returns. +While the command is sleeping the application does not respond to +events. +.TP +\fBafter \fIms \fR?\fIscript script script ...\fR? +In this form the command returns immediately, but it arranges +for a Tcl command to be executed \fIms\fR milliseconds later as an +event handler. +The command will be executed exactly once, at the given time. +The delayed command is formed by concatenating all the \fIscript\fR +arguments in the same fashion as the \fBconcat\fR command. +The command will be executed at global level (outside the context +of any Tcl procedure). +If an error occurs while executing the delayed command then the +\fBbgerror\fR mechanism is used to report the error. +The \fBafter\fR command returns an identifier that can be used +to cancel the delayed command using \fBafter cancel\fR. +.TP +\fBafter cancel \fIid\fR +Cancels the execution of a delayed command that +was previously scheduled. +\fIId\fR indicates which command should be canceled; it must have +been the return value from a previous \fBafter\fR command. +If the command given by \fIid\fR has already been executed then +the \fBafter cancel\fR command has no effect. +.TP +\fBafter cancel \fIscript script ...\fR +This command also cancels the execution of a delayed command. +The \fIscript\fR arguments are concatenated together with space +separators (just as in the \fBconcat\fR command). +If there is a pending command that matches the string, it is +cancelled and will never be executed; if no such command is +currently pending then the \fBafter cancel\fR command has no effect. +.TP +\fBafter idle \fIscript \fR?\fIscript script ...\fR? +Concatenates the \fIscript\fR arguments together with space +separators (just as in the \fBconcat\fR command), and arranges +for the resulting script to be evaluated later as an idle callback. +The script will be run exactly once, the next time the event +loop is entered and there are no events to process. +The command returns an identifier that can be used +to cancel the delayed command using \fBafter cancel\fR. +If an error occurs while executing the script then the +\fBbgerror\fR mechanism is used to report the error. +.TP +\fBafter info \fR?\fIid\fR? +This command returns information about existing event handlers. +If no \fIid\fR argument is supplied, the command returns +a list of the identifiers for all existing +event handlers created by the \fBafter\fR command for this +interpreter. +If \fIid\fR is supplied, it specifies an existing handler; +\fIid\fR must have been the return value from some previous call +to \fBafter\fR and it must not have triggered yet or been cancelled. +In this case the command returns a list with two elements. +The first element of the list is the script associated +with \fIid\fR, and the second element is either +\fBidle\fR or \fBtimer\fR to indicate what kind of event +handler it is. +.LP +The \fBafter \fIms\fR and \fBafter idle\fR forms of the command +assume that the application is event driven: the delayed commands +will not be executed unless the application enters the event loop. +In applications that are not normally event-driven, such as +\fBtclsh\fR, the event loop can be entered with the \fBvwait\fR +and \fBupdate\fR commands. + +.SH "SEE ALSO" +bgerror + +.SH KEYWORDS +cancel, delay, idle callback, sleep, time diff --git a/tcl7.6/doc/append.n b/tcl7.6/doc/append.n new file mode 100644 index 0000000..9d2ba34 --- /dev/null +++ b/tcl7.6/doc/append.n @@ -0,0 +1,32 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) append.n 1.6 96/03/25 20:09:44 +'\" +.so man.macros +.TH append n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +append \- Append to variable +.SH SYNOPSIS +\fBappend \fIvarName \fR?\fIvalue value 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/tcl7.3/doc/array.n b/tcl7.6/doc/array.n similarity index 55% rename from tcl7.3/doc/array.n rename to tcl7.6/doc/array.n index 553a1cc..a6e8817 100644 --- a/tcl7.3/doc/array.n +++ b/tcl7.6/doc/array.n @@ -1,27 +1,14 @@ '\" -'\" Copyright (c) 1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1993-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/array.n,v 1.1 93/04/14 16:52:55 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) array.n 1.8 96/08/26 12:59:53 '\" .so man.macros -.HS array tcl +.TH array n 7.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -34,7 +21,8 @@ array \- Manipulate array variables .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. +Unless otherwise specified for individual commands below, +\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: @@ -58,10 +46,31 @@ 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 +\fBarray exists \fIarrayName\fR +Returns 1 if \fIarrayName\fR is an array variable, 0 if there +is no variable by that name or if it is a scalar variable. +.TP +\fBarray get \fIarrayName\fR ?\fIpattern\fR? +Returns a list containing pairs of elements. The first +element in each pair is the name of an element in \fIarrayName\fR +and the second element of each pair is the value of the +array element. The order of the pairs is undefined. +If \fIpattern\fR is not specified, then all of the elements of the +array are included in the result. +If \fIpattern\fR is specified, then only those elements whose names +match \fIpattern\fR (using the glob-style matching rules of +\fBstring match\fR) are included. +If \fIarrayName\fR isn't the name of an array variable, or if +the array contains no elements, then an empty list is returned. +.TP +\fBarray names \fIarrayName\fR ?\fIpattern\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 +the array that match \fIpattern\fR (using the glob-style matching +rules of \fBstring match\fR). +If \fIpattern\fR is omitted then the command returns all of +the element names in the array. +If there are no (matching) elements in the array, or if \fIarrayName\fR +isn't the name of an array variable, then an empty string is returned. .TP \fBarray nextelement \fIarrayName searchId\fR @@ -75,9 +84,18 @@ 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 set \fIarrayName list\fR +Sets the values of one or more elements in \fIarrayName\fR. +\fIlist\fR must have a form like that returned by \fBarray get\fR, +consisting of an even number of elements. +Each odd-numbered element in \fIlist\fR is treated as an element +name within \fIarrayName\fR, and the following element in \fIlist\fR +is used as a new value for that array element. +.TP \fBarray size \fIarrayName\fR Returns a decimal string giving the number of elements in the array. +If \fIarrayName\fR isn't the name of an array then 0 is returned. .TP \fBarray startsearch \fIarrayName\fR This command initializes an element-by-element search through the diff --git a/tcl7.6/doc/bgerror.n b/tcl7.6/doc/bgerror.n new file mode 100644 index 0000000..6875bcf --- /dev/null +++ b/tcl7.6/doc/bgerror.n @@ -0,0 +1,67 @@ +'\" +'\" Copyright (c) 1990-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) bgerror.n 1.3 96/03/25 20:10:12 +'\" +.so man.macros +.TH bgerror n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +bgerror \- Command invoked to process background errors +.SH SYNOPSIS +\fBbgerror \fImessage\fR +.BE + +.SH DESCRIPTION +.PP +The \fBbgerror\fR command doesn't exist as built-in part of Tcl. Instead, +individual applications or users can define a \fBbgerror\fR +command (e.g. as a Tcl procedure) if they wish to handle background +errors. +.PP +A background error is one that occurs in an event handler or some +other command that didn't originate with the application. +For example, if an error occurs while executing a command specified +with the \fBafter\fR command, then it is a background error. +For a non-background error, the error can simply be returned up +through nested Tcl command evaluations until it reaches the top-level +code in the application; then the application can report the error +in whatever way it wishes. +When a background error occurs, the unwinding ends in +the Tcl library and there is no obvious way for Tcl to report +the error. +.PP +When Tcl detects a background error, it saves information about the +error and invokes the \fBbgerror\fR command later as an idle event handler. +Before invoking \fBbgerror\fR, Tcl restores the \fBerrorInfo\fR +and \fBerrorCode\fR variables to their values at the time the +error occurred, then it invokes \fBbgerror\fR with +the error message as its only argument. +Tcl assumes that the application has implemented the \fBbgerror\fR +command, and that the command will report the error in a way that +makes sense for the application. Tcl will ignore any result returned +by the \fBbgerror\fR command as long as no error is generated. +.PP +If another Tcl error occurs within the \fBbgerror\fR command +(for example, because no \fBbgerror\fR command has been defined) +then Tcl reports the error itself by writing a message to stderr. +.PP +If several background errors accumulate before \fBbgerror\fR +is invoked to process them, \fBbgerror\fR will be invoked once +for each error, in the order they occurred. +However, if \fBbgerror\fR returns with a break exception, then +any remaining errors are skipped without calling \fBbgerror\fR. +.PP +Tcl has no default implementation for \fBbgerror\fR. +However, in applications using Tk there will be a default +\fBbgerror\fR procedure that posts a dialog box containing +the error message and offers the user a chance to see a stack +trace showing where the error occurred. + +.SH KEYWORDS +background error, reporting diff --git a/tcl7.6/doc/break.n b/tcl7.6/doc/break.n new file mode 100644 index 0000000..391ba91 --- /dev/null +++ b/tcl7.6/doc/break.n @@ -0,0 +1,34 @@ +'\" +'\" Copyright (c) 1993-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) break.n 1.7 96/10/09 08:29:26 +'\" +.so man.macros +.TH break n "" Tcl "Tcl Built-In Commands" +.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 is typically invoked inside the body of a looping command +such as \fBfor\fR or \fBforeach\fR or \fBwhile\fR. +It returns a TCL_BREAK code, which causes a break exception +to occur. +The exception causes the current script to be aborted +out to the innermost containing loop command, which then +aborts its execution and returns normally. +Break exceptions are also handled in a few other situations, such +as the \fBcatch\fR command, Tk event bindings, and the outermost +scripts of procedure bodies. + +.SH KEYWORDS +abort, break, loop diff --git a/tcl7.3/doc/case.n b/tcl7.6/doc/case.n similarity index 67% rename from tcl7.3/doc/case.n rename to tcl7.6/doc/case.n index 7911434..d375288 100644 --- a/tcl7.3/doc/case.n +++ b/tcl7.6/doc/case.n @@ -1,34 +1,21 @@ '\" '\" Copyright (c) 1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/case.n,v 1.3 93/06/17 11:29:59 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) case.n 1.8 96/03/25 20:10:49 '\" .so man.macros -.HS case tcl 7.0 +.TH case n 7.0 Tcl "Tcl Built-In Commands" .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 +.sp \fBcase\fI string \fR?\fBin\fR? {\fIpatList body \fR?\fIpatList body \fR...?} .BE diff --git a/tcl7.6/doc/catch.n b/tcl7.6/doc/catch.n new file mode 100644 index 0000000..8aff166 --- /dev/null +++ b/tcl7.6/doc/catch.n @@ -0,0 +1,40 @@ +'\" +'\" Copyright (c) 1993-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) catch.n 1.6 96/03/25 20:11:08 +'\" +.so man.macros +.TH catch n "" Tcl "Tcl Built-In Commands" +.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). +.PP +Note that \fBcatch\fR catches all exceptions, including those +generated by \fBbreak\fR and \fBcontinue\fR as well as errors. + +.SH KEYWORDS +catch, error diff --git a/tcl7.6/doc/cd.n b/tcl7.6/doc/cd.n new file mode 100644 index 0000000..6925a87 --- /dev/null +++ b/tcl7.6/doc/cd.n @@ -0,0 +1,28 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) cd.n 1.6 96/03/28 08:40:52 +'\" +.so man.macros +.TH cd n "" Tcl "Tcl Built-In Commands" +.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. +Returns an empty string. + +.SH KEYWORDS +working directory diff --git a/tcl7.6/doc/clock.n b/tcl7.6/doc/clock.n new file mode 100644 index 0000000..548ffc0 --- /dev/null +++ b/tcl7.6/doc/clock.n @@ -0,0 +1,183 @@ +'\" +'\" Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans. +'\" Copyright (c) 1995-1996 Sun Microsystems, Inc. +'\" +'\" This documentation is derived from the time and date facilities of +'\" TclX, by Mark Diekhans and Karl Lehenbauer. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) clock.n 1.13 96/05/03 14:40:37 +'\" +.so man.macros +.TH clock n 7.4 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +clock \- Obtain and manipulate time +.SH SYNOPSIS +\fBclock \fIoption\fR ?\fIarg arg ...\fR? +.BE + +.SH DESCRIPTION +.PP +This command performs one of several operations that may obtain +or manipulate strings or values that represent some notion of +time. The \fIoption\fR argument determines what action is carried +out by the command. The legal \fIoptions\fR (which may be +abbreviated) are: +.TP +\fBclock clicks\fR +Return a high-resolution time value as a system-dependent integer +value. The unit of the value is system-dependent but should be the +highest resolution clock available on the system such as a CPU cycle +counter. This value should only be used for the relative measurement +of elapsed time. +.TP +\fBclock format \fIclockValue\fR ?\fB\-format \fIstring\fR? ?\fB\-gmt \fIboolean\fR? +Converts an integer time value, typically returned by +\fBclock seconds\fR, \fBclock scan\fR, or the \fBatime\fR, \fBmtime\fR, +or \fBctime\fR options of the \fBfile\fR command, to human-readable +form. If the \fB\-format\fR argument is present the next argument is a +string that describes how the date and time are to be formatted. +Field descriptors consist of a \fB%\fR followed by a field +descriptor character. All other characters are copied into the result. +Valid field descriptors are: +.RS +.IP \fB%%\fR +Insert a %. +.IP \fB%a\fR +Abbreviated weekday name (Mon, Tue, etc.). +.IP \fB%A\fR +Full weekday name (Monday, Tuesday, etc.). +.IP \fB%b\fR +Abbreviated month name (Jan, Feb, etc.). +.IP \fB%B\fR +Full month name. +.IP \fB%c\fR +Locale specific date and time. +.IP \fB%d\fR +Day of month (01 - 31). +.IP \fB%H\fR +Hour in 24-hour format (00 - 23). +.IP \fB%I\fR +Hour in 12-hour format (00 - 12). +.IP \fB%j\fR +Day of year (001 - 366). +.IP \fB%m\fR +Month number (01 - 12). +.IP \fB%M\fR +Minute (00 - 59). +.IP \fB%p\fR +AM/PM indicator. +.IP \fB%S\fR +Seconds (00 - 59). +.IP \fB%U\fR +Week of year (01 - 52), Sunday is the first day of the week. +.IP \fB%w\fR +Weekday number (Sunday = 0). +.IP \fB%W\fR +Week of year (01 - 52), Monday is the first day of the week. +.IP \fB%x\fR +Locale specific date format. +.IP \fB%X\fR +Locale specific time format. +.IP \fB%y\fR +Year without century (00 - 99). +.IP \fB%Y\fR +Year with century (e.g. 1990) +.IP \fB%Z\fR +Time zone name. +.RE +.sp +.RS +In addition, the following field descriptors may be supported on some +systems (e.g. Unix but not Windows): +.IP \fB%D\fR +Date as %m/%d/%y. +.IP \fB%e\fR +Day of month (1 - 31), no leading zeros. +.IP \fB%h\fR +Abbreviated month name. +.IP \fB%n\fR +Insert a newline. +.IP \fB%r\fR +Time as %I:%M:%S %p. +.IP \fB%R\fR +Time as %H:%M. +.IP \fB%t\fR +Insert a tab. +.IP \fB%T\fR +Time as %H:%M:%S. +.RE +.sp +.RS +If the \fB\-format\fR argument is not specified, the format string +"\fB%a %b %d %H:%M:%S %Z %Y\fR" is used. If the \fB\-gmt\fR argument +is present the next argument must be a boolean which if true specifies +that the time will be formatted as Greenwich Mean Time. If false +then the local timezone will be used as defined by the operating +environment. +.RE +.TP +\fBclock scan \fIdateString\fR ?\fB\-base \fIclockVal\fR? ?\fB\-gmt \fIboolean\fR? +Convert \fIdateString\fR to an integer clock value (see \fBclock seconds\fR). +This command can parse and convert virtually any standard date and/or time +string, which can include standard time zone mnemonics. If only a time is +specified, the current date is assumed. If the string does not contain a +time zone mnemonic, the local time zone is assumed, unless the \fB\-gmt\fR +argument is true, in which case the clock value is calculated assuming +that the specified time is relative to Greenwich Mean Time. +.sp +If the \fB\-base\fR flag is specified, the next argument should contain +an integer clock value. Only the date in this value is used, not the +time. This is useful for determining the time on a specific day or +doing other date-relative conversions. +.sp +The \fIdateString\fR consists of zero or more specifications of the +following form: +.RS +.TP +\fItime\fR +A time of day, which is of the form: \fIhh\fR?\fI:mm\fR?\fI:ss\fR?? +?\fImeridian\fR? ?\fIzone\fR? or \fIhhmm \fR?\fImeridian\fR? +?\fIzone\fR?. If no meridian is specified, \fIhh\fR is interpreted on +a 24-hour clock. +.TP +\fIdate\fR +A specific month and day with optional year. The +acceptable formats are \fImm/dd\fR?\fI/yy\fR?, \fImonthname dd\fR +?, \fIyy\fR?, \fIdd monthname \fR?\fIyy\fR? and \fIday, dd monthname +yy\fR. The default year is the current year. If the year is less +then 100, then 1900 is added to it. +.TP +\fIrelative time\fR +A specification relative to the current time. The format is \fInumber +unit\fR acceptable units are \fByear\fR, \fBfortnight\fR, \fBmonth\fR, \fBweek\fR, \fBday\fR, +\fBhour\fR, \fBminute\fR (or \fBmin\fR), and \fBsecond\fR (or \fBsec\fR). The +unit can be specified as a singular or plural, as in \fB3 weeks\fR. +These modifiers may also be specified: +\fBtomorrow\fR, \fByesterday\fR, \fBtoday\fR, \fBnow\fR, +\fBlast\fR, \fBthis\fR, \fBnext\fR, \fBago\fR. +.RE +.sp +.RS +The actual date is calculated according to the following steps. +First, any absolute date and/or time is processed and converted. +Using that time as the base, day-of-week specifications are added. +Next, relative specifications are used. If a date or day is +specified, and no absolute or relative time is given, midnight is +used. Finally, a correction is applied so that the correct hour of +the day is produced after allowing for daylight savings time +differences. +.RE +.TP +\fBclock seconds\fR +Return the current date and time as a system-dependent integer value. The +unit of the value is seconds, allowing it to be used for relative time +calculations. The value is usually defined as total elapsed time from +an ``epoch''. You shouldn't assume the value of the epoch. + +.SH KEYWORDS +clock, date, time diff --git a/tcl7.6/doc/close.n b/tcl7.6/doc/close.n new file mode 100644 index 0000000..0ed5a1f --- /dev/null +++ b/tcl7.6/doc/close.n @@ -0,0 +1,59 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) close.n 1.10 96/02/15 20:01:34 +'\" +.so man.macros +.TH close n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +close \- Close an open channel. +.SH SYNOPSIS +\fBclose \fIchannelId\fR +.BE + +.SH DESCRIPTION +.PP +Closes the channel given by \fIchannelId\fR. \fIChannelId\fR must be a +channel identifier such as the return value from a previous \fBopen\fR +or \fBsocket\fR command. +All buffered output is flushed to the channel's output device, +any buffered input is discarded, the underlying file or device is closed, +and \fIchannelId\fR becomes unavailable for use. +.VS br +.PP +If the channel is blocking, the command does not return until all output +is flushed. +If the channel is nonblocking and there is unflushed output, the +channel remains open and the command +returns immediately; output will be flushed in the background and the +channel will be closed when all the flushing is complete. +.VE +.PP +If \fIchannelId\fR is a blocking channel for a command pipeline then +\fBclose\fR waits for the child processes to complete. +.VS br +.PP +If the channel is shared between interpreters, then \fBclose\fR +makes \fIchannelId\fR unavailable in the invoking interpreter but has no +other effect until all of the sharing interpreters have closed the +channel. +When the last interpreter in which the channel is registered invokes +\fBclose\fR, the cleanup actions described above occur. See the +\fBinterp\fR command for a description of channel sharing. +.PP +Channels are automatically closed when an interpreter is destroyed and +when the process exits. Channels are switched to blocking mode, to ensure +that all output is correctly flushed before the process exits. +.VE +.PP +The command returns an empty string, and may generate an error if +an error occurs while flushing output. + +.SH KEYWORDS +blocking, channel, close, nonblocking diff --git a/tcl7.6/doc/concat.n b/tcl7.6/doc/concat.n new file mode 100644 index 0000000..3a1e7a4 --- /dev/null +++ b/tcl7.6/doc/concat.n @@ -0,0 +1,40 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) concat.n 1.8 96/08/26 12:59:54 +'\" +.so man.macros +.TH concat n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +concat \- Join lists together +.SH SYNOPSIS +\fBconcat\fI \fR?\fIarg arg ...\fR? +.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 +.CS +\fBconcat a b {c d e} {f {g h}}\fR +.CE +will return +.CS +\fBa b c d e f {g h}\fR +.CE +as its result. +.PP +If no \fIarg\fRs are supplied, the result is an empty string. + +.SH KEYWORDS +concatenate, join, lists diff --git a/tcl7.6/doc/continue.n b/tcl7.6/doc/continue.n new file mode 100644 index 0000000..104b89d --- /dev/null +++ b/tcl7.6/doc/continue.n @@ -0,0 +1,34 @@ +'\" +'\" Copyright (c) 1993-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) continue.n 1.7 96/10/09 08:29:27 +'\" +.so man.macros +.TH continue n "" Tcl "Tcl Built-In Commands" +.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 is typically invoked inside the body of a looping command +such as \fBfor\fR or \fBforeach\fR or \fBwhile\fR. +It returns a TCL_CONTINUE code, which causes a continue exception +to occur. +The exception causes the current script to be aborted +out to the innermost containing loop command, which then +continues with the next iteration of the loop. +Catch exceptions are also handled in a few other situations, such +as the \fBcatch\fR command and the outermost scripts of procedure +bodies. + +.SH KEYWORDS +continue, iteration, loop diff --git a/tcl7.6/doc/eof.n b/tcl7.6/doc/eof.n new file mode 100644 index 0000000..71de06a --- /dev/null +++ b/tcl7.6/doc/eof.n @@ -0,0 +1,27 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) eof.n 1.8 96/02/15 20:01:59 +'\" +.so man.macros +.TH eof n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +eof \- Check for end of file condition on channel +.SH SYNOPSIS +\fBeof \fIchannelId\fR +.BE + +.SH DESCRIPTION +.PP +Returns 1 if an end of file condition occurred during the most +recent input operation on \fIchannelId\fR (such as \fBgets\fR), +0 otherwise. + +.SH KEYWORDS +channel, end of file diff --git a/tcl7.3/doc/error.n b/tcl7.6/doc/error.n similarity index 59% rename from tcl7.3/doc/error.n rename to tcl7.6/doc/error.n index 0c90115..6be285b 100644 --- a/tcl7.3/doc/error.n +++ b/tcl7.6/doc/error.n @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/error.n,v 1.1 93/04/16 17:23:32 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) error.n 1.7 96/03/25 20:12:35 '\" .so man.macros -.HS error tcl +.TH error n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -50,18 +37,18 @@ 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 +.CS \fBcatch {...} errMsg set savedInfo $errorInfo \&... error $errMsg $savedInfo\fR -.DE +.CE .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. +such information is available; see the \fBtclvars\fR manual +page 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 diff --git a/tcl7.6/doc/eval.n b/tcl7.6/doc/eval.n new file mode 100644 index 0000000..8ea7ae3 --- /dev/null +++ b/tcl7.6/doc/eval.n @@ -0,0 +1,30 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) eval.n 1.5 96/03/25 20:12:53 +'\" +.so man.macros +.TH eval n "" Tcl "Tcl Built-In Commands" +.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/tcl7.6/doc/exec.n b/tcl7.6/doc/exec.n new file mode 100644 index 0000000..22caf80 --- /dev/null +++ b/tcl7.6/doc/exec.n @@ -0,0 +1,357 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) exec.n 1.17 96/09/18 15:21:17 +'\" +.so man.macros +.TH exec n 7.6 Tcl "Tcl Built-In Commands" +.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 +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\fR +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\-\fR. +.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 +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''). +.TP 15 +| +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 +|& +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 +\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. +.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 +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. +.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 +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. +.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. +However, if \fB\-keepnewline\fR is specified then the trailing +newline is retained. +.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. +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. +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. + +.VS +.SH "PORTABILITY ISSUES" +.TP +\fBWindows\fR (all versions) +. +Reading from or writing to a socket, using the ``\fB@\0\fIfileId\fR'' +notation, does not work. When reading from a socket, a 16-bit DOS +application will hang and a 32-bit application will return immediately with +end-of-file. When either type of application writes to a socket, the +information is instead sent to the console, if one is present, or is +discarded. +.sp +The Tk console text widget does not provide real standard IO capabilities. +Under Tk, when redirecting from standard input, all applications will see an +immediate end-of-file; information redirected to standard output or standard +error will be discarded. +.sp +Either forward or backward slashes are accepted as path separators for +arguments to Tcl commands. When executing an application, the path name +specified for the application may also contain forward or backward slashes +as path separators. Bear in mind, however, that most Windows applications +accept arguments with forward slashes only as option delimiters and +backslashes only in paths. Any arguments to an application that specify a +path name with forward slashes will not automatically be converted to use +the backslash character. If an argument contains forward slashes as the +path separator, it may or may not be recognized as a path name, depending on +the program. +.sp +Additionally, when calling a 16-bit DOS or Windows 3.X application, all path +names must use the short, cryptic, path format (e.g., using ``applba~1.def'' +instead of ``applbakery.default''). +.sp +Two or more forward or backward slashes in a row in a path refer to a +network path. For example, a simple concatenation of the root directory +\fBc:/\fR with a subdirectory \fB/windows/system\fR will yield +\fBc://windows/system\fR (two slashes together), which refers to the +directory \fB/system\fR on the machine \fBwindows\fR (and the \fBc:/\fR is +ignored), and is not equivalent to \fBc:/windows/system\fR, which describes +a directory on the current computer. +.TP +\fBWindows NT\fR +. +When attempting to execute an application, \fBexec\fR first searches for the +name as it was specified. Then, in order, \fB.com\fR, \fB.exe\fR, and \fB.bat\fR +are appended to the end of the specified name and it searches for +the longer name. If a directory name was not specified as part of the +application name, the following directories are automatically searched in +order when attempting to locate the application: +.sp +.RS +.RS +The directory from which the Tcl executable was loaded. +.br +The current directory. +.br +The Windows NT 32-bit system directory. +.br +The Windows NT 16-bit system directory. +.br +The Windows NT home directory. +.br +The directories listed in the path. +.RE +.sp +In order to execute the shell builtin commands like \fBdir\fR and \fBcopy\fR, +the caller must prepend ``\fBcmd.exe /c\0\fR'' to the desired command. +.sp +.RE +.TP +\fBWindows 95\fR +. +When attempting to execute an application, \fBexec\fR first searches for the +name as it was specified. Then, in order, \fB.com\fR, \fB.exe\fR, and \fB.bat\fR +are appended to the end of the specified name and it searches for +the longer name. If a directory name was not specified as part of the +application name, the following directories are automatically searched in +order when attempting to locate the application: +.sp +.RS +.RS +The directory from which the Tcl executable was loaded. +.br +The current directory. +.br +The Windows 95 system directory. +.br +The Windows 95 home directory. +.br +The directories listed in the path. +.RE +.sp +In order to execute the shell builtin commands like \fBdir\fR and \fBcopy\fR, +the caller must prepend ``\fBcommand.com /c\0\fR'' to the desired command. +.sp +Once a 16-bit DOS application has read standard input from a console and +then quit, all subsequently run 16-bit DOS applications will see the +standard input as already closed. 32-bit applications do not have this +problem and will run correctly even after a 16-bit DOS application thinks +that standard input is closed. There is no known workaround for this bug +at this time. +.sp +Redirection between the \fBNUL:\fR device and a 16-bit application does not +always work. When redirecting from \fBNUL:\fR, some applications may hang, +others will get an infinite stream of ``0x01'' bytes, and some will actually +correctly get an immediate end-of-file; the behavior seems to depend upon +something compiled into the application itself. When redirecting greater than +4K or so to \fBNUL:\fR, some applications will hang. The above problems do not +happen with 32-bit applications. +.sp +All DOS 16-bit applications are run synchronously. All standard input from +a pipe to a 16-bit DOS application is collected into a temporary file; the +other end of the pipe must be closed before the 16-bit DOS application +begins executing. All standard output or error from a 16-bit DOS +application to a pipe is collected into temporary files; the application +must terminate before the temporary files are redirected to the next stage +of the pipeline. This is due to a workaround for a Windows 95 bug in the +implementation of pipes, and is how the Windows 95 command line interpreter +handles pipes itself. +.sp +Certain applications, such as \fBcommand.com\fR, should not be executed +interactively. Applications which directly access the console window, +rather than reading from their standard input and writing to their standard +output may fail, hang Tcl, or even hang the system if their own private +console window is not available to them. +.RE +.TP +\fBWindows 3.X\fR +. +When attempting to execute an application, \fBexec\fR first searches for the +name as it was specified. Then, in order, \fB.com\fR, \fB.exe\fR, and \fB.bat\fR +are appended to the end of the specified name and it searches for +the longer name. If a directory name was not specified as part of the +application name, the following directories are automatically searched in +order when attempting to locate the application: +.sp +.RS +.RS +The directory from which the Tcl executable was loaded. +.br +The current directory. +.br +The Windows 3.X system directory. +.br +The Windows 3.X home directory. +.br +The directories listed in the path. +.RE +.sp +In order to execute the shell builtin commands like \fBdir\fR and \fBcopy\fR, +the caller must prepend ``\fBcommand.com /c\0\fR'' to the desired command. +.sp +16-bit and 32-bit DOS and Windows applications may be executed. However, +redirection and piping of standard IO only works with 16-bit DOS +applications. 32-bit applications always see standard input as already +closed, and any standard output or error is discarded, no matter where in the +pipeline the application occurs or what redirection symbols are used by the +caller. Additionally, for 16-bit applications, standard error is always +sent to the same place as standard output; it cannot be redirected to a +separate location. In order to achieve pseudo-redirection for 32-bit +applications, the 32-bit application must instead be written to take command +line arguments that specify the files that it should read from and write to +and open those files itself. +.sp +All applications, both 16-bit and 32-bit, run synchronously; each application +runs to completion before the next one in the pipeline starts. Temporary files +are used to simulate piping between applications. The \fBexec\fR +command cannot be used to start an application in the background. +.sp +When standard input is redirected from an open file using the +``\fB@\0\fIfileId\fR'' notation, the open file is completely read up to its +end. This is slightly different than under Windows 95 or NT, where the child +application consumes from the open file only as much as it wants. +Redirecting to an open file is supported as normal. +.RE +.TP +\fBMacintosh\fR +The \fBexec\fR command is not implemented and does not exist under Macintosh. +.TP +\fBUnix\fR\0\0\0\0\0\0\0 +The \fBexec\fR command is fully functional and works as described. + +.SH "SEE ALSO" +open(n) +.VE + +.SH KEYWORDS +execute, pipeline, redirection, subprocess + diff --git a/tcl7.6/doc/exit.n b/tcl7.6/doc/exit.n new file mode 100644 index 0000000..2dfffb4 --- /dev/null +++ b/tcl7.6/doc/exit.n @@ -0,0 +1,28 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) exit.n 1.6 96/03/25 20:13:32 +'\" +.so man.macros +.TH exit n "" Tcl "Tcl Built-In Commands" +.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/tcl7.3/doc/expr.n b/tcl7.6/doc/expr.n similarity index 84% rename from tcl7.3/doc/expr.n rename to tcl7.6/doc/expr.n index 957d8cc..e13b5b4 100644 --- a/tcl7.3/doc/expr.n +++ b/tcl7.6/doc/expr.n @@ -1,50 +1,35 @@ '\" '\" Copyright (c) 1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/expr.n,v 1.5 93/09/02 16:41:26 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) expr.n 1.19 96/10/09 08:29:27 '\" .so man.macros -.HS expr tcl 7.0 +.TH expr n 7.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -expr \- Evalue an expression +expr \- Evaluate 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 +.CS \fBexpr 8.2 + 6\fR -.DE +.CE evaluates to 14.2. Tcl expressions differ from C expressions in the way that operands are specified. Also, Tcl expressions support @@ -90,11 +75,9 @@ 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. @@ -110,20 +93,20 @@ For some examples of simple expressions, suppose the variable 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 +.CS .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 +.CE .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 +\fB\-\0\0+\0\0~\0\0!\fR +Unary minus, unary plus, 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 @@ -131,16 +114,15 @@ applied only to integers. 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. +A right shift always propagates the sign bit. .TP 20 \fB<\0\0>\0\0<=\0\0>=\fR Boolean less, greater, less than or equal, and greater than or equal. @@ -179,26 +161,25 @@ 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 +.CS \fBexpr 4*2 < 7\fR -.DE +.CE returns 0. .PP -The \fB&&\fP, \fB||\fP, and \fB?:\fP operators have ``lazy +The \fB&&\fR, \fB||\fR, and \fB?:\fR 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 +.CS \fBexpr {$v ? [a] : [b]}\fR -.DE +.CE 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 +depending on the value of \fB$v\fR. 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 @@ -213,7 +194,7 @@ 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 +\fBabs(\fIarg\fB)\fR 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 @@ -229,14 +210,13 @@ If \fIarg\fR is an integer value, returns \fIarg\fR, otherwise converts 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 +In addition to these predefined 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. +\fIlong\fR, and all internal computations involving floating-point are +done with the C type \fIdouble\fR. 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 @@ -252,24 +232,23 @@ 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 +.CS \fBexpr 5 / 4\fR -.DE +.CE returns 1, while -.DS +.CS \fBexpr 5 / 4.0\fR -\fBexpr 5 / ( [string length "abcd"] + 0.0 ) -.DE +\fBexpr 5 / ( [string length "abcd"] + 0.0 )\fR +.CE 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 +.CS \fBexpr 20.0/5.0\fR -.DE +.CE returns ``4.0'', not ``4''. The global variable \fBtcl_precision\fR -determines the the number of significant digits that are retained +determines 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. @@ -278,7 +257,6 @@ 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 @@ -287,16 +265,21 @@ 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 +a string using the C \fIsprintf\fR format specifier \fB%d\fR for integers and \fB%g\fR for floating-point values. For example, the commands -.DS +.CS \fBexpr {"0x03" > "2"}\fR \fBexpr {"0y" < "0x12"}\fR -.DE +.CE 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''. +Because of Tcl's tendency to treat values as numbers whenever +possible, it isn't generally a good idea to use operators like \fB==\fR +when you really want string comparison and the values of the +operands could be arbitrary; it's better in these cases to use the +\fBstring compare\fR command instead. .SH KEYWORDS arithmetic, boolean, compare, expression diff --git a/tcl7.6/doc/fblocked.n b/tcl7.6/doc/fblocked.n new file mode 100644 index 0000000..3184e47 --- /dev/null +++ b/tcl7.6/doc/fblocked.n @@ -0,0 +1,32 @@ +'\" +'\" Copyright (c) 1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) fblocked.n 1.6 96/02/23 13:46:30 +.so man.macros +.TH fblocked n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +fblocked \- Test whether the last input operation exhausted all available input +.SH SYNOPSIS +\fBfblocked \fIchannelId\fR +.BE + +.SH DESCRIPTION +.PP +The \fBfblocked\fR command returns 1 if the most recent input operation +on \fIchannelId\fR returned less information than requested because all +available input was exhausted. +For example, if \fBgets\fR is invoked when there are only three +characters available for input and no end-of-line sequence, \fBgets\fR +returns an empty string and a subsequent call to \fBfblocked\fR will +return 1. +.PP +.SH "SEE ALSO" +gets(n), read(n) + +.SH KEYWORDS +blocking, nonblocking diff --git a/tcl7.6/doc/fconfigure.n b/tcl7.6/doc/fconfigure.n new file mode 100644 index 0000000..1c187ac --- /dev/null +++ b/tcl7.6/doc/fconfigure.n @@ -0,0 +1,178 @@ +'\" +'\" Copyright (c) 1995-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) fconfigure.n 1.23 96/04/16 08:20:07 +'\" +.so man.macros +.TH fconfigure n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +fconfigure \- Set and get options on a channel +.SH SYNOPSIS +.nf +\fBfconfigure \fIchannelId\fR +\fBfconfigure \fIchannelId\fR \fIname\fR +\fBfconfigure \fIchannelId\fR \fIname value \fR?\fIname value ...\fR? +.fi +.BE + +.SH DESCRIPTION +.PP +The \fBfconfigure\fR command sets and retrieves options for channels. +\fIChannelId\fR identifies the channel for which to set or query an option. +If no \fIname\fR or \fIvalue\fR arguments are supplied, the command +returns a list containing alternating option names and values for the channel. +If \fIname\fR is supplied but no \fIvalue\fR then the command returns +the current value of the given option. +If one or more pairs of \fIname\fR and \fIvalue\fR are supplied, the +command sets each of the named options to the corresponding \fIvalue\fR; +in this case the return value is an empty string. +.PP +The options described below are supported for all channels. In addition, +each channel type may add options that only it supports. See the manual +entry for the command that creates each type of channels for the options +that that specific type of channel supports. For example, see the manual +entry for the \fBsocket\fR command for its additional options. +.TP +\fB\-blocking\fR \fIboolean\fR +The \fB\-blocking\fR option determines whether I/O operations on the +channel can cause the process to block indefinitely. +The value of the option must be a proper boolean value. +Channels are normally in blocking mode; if a channel is placed into +nonblocking mode it will affect the operation of the \fBgets\fR, +\fBread\fR, \fBputs\fR, \fBflush\fR, and \fBclose\fR commands; +see the documentation for those commands for details. +For nonblocking mode to work correctly, the application must be +using the Tcl event loop (e.g. by calling \fBTcl_DoOneEvent\fR or +invoking the \fBvwait\fR command). +.TP +\fB\-buffering\fR \fInewValue\fR +If \fInewValue\fR is \fBfull\fR then the I/O system will buffer output +until its internal buffer is full or until the \fBflush\fR command is +invoked. If \fInewValue\fR is \fBline\fR, then the I/O system will +automatically flush output for the channel whenever a newline character +is output. If \fInewValue\fR is \fBnone\fR, the I/O system will flush +automatically after every output operation. +The default is for \fB\-buffering\fR to be set to \fBfull\fR except for +channels that connect to terminal-like devices; for these channels the +initial setting is \fBline\fR. +.TP +\fB\-buffersize\fR \fInewSize\fR +\fINewvalue\fR must be an integer; its value is used to set the size of +buffers, in bytes, subsequently allocated for this channel to store input +or output. \fINewvalue\fR must be between ten and one million, allowing +buffers of ten to one million bytes in size. +.TP +\fB\-eofchar\fR \fIchar\fR +.TP +\fB\-eofchar\fR \fB{\fIinChar outChar\fB}\fR +This option supports DOS file systems that use Control-z (\ex1a) as +an end of file marker. +If \fIchar\fR is not an empty string, then this character signals +end of file when it is encountered during input. +For output, the end of file character is output when +the channel is closed. +If \fIchar\fR is the empty string, then there is no special +end of file character marker. +For read-write channels, a two-element list specifies +the end of file marker for input and output, respectively. +As a convenience, when setting the end-of-file character +for a read-write channel +you can specify a single value that will apply to both reading and writing. +When querying the end-of-file character of a read-write channel, +a two-element list will always be returned. +The default value for \fB\-eofchar\fR is the empty string in all +cases except for files under Windows. In that case the \fB\-eofchar\fR +is Control-z (\ex1a) for reading and the empty string for writing. +.TP +\fB\-translation\fR \fImode\fR +.TP +\fB\-translation\fR \fB{\fIinMode outMode\fB}\fR +In Tcl scripts the end of a line is always represented using a +single newline character (\en). +However, in actual files and devices the end of a line may be +represented differently on different platforms, or even for +different devices on the same platform. For example, under UNIX +newlines are used in files, whereas carriage-return-linefeed +sequences are normally used in network connections. +On input (i.e., with \fBgets\fP and \fBread\fP) +the Tcl I/O system automatically translates the external end-of-line +representation into newline characters. +Upon output (i.e., with \fBputs\fP), +the I/O system translates newlines to the external +end-of-line representation. +The default translation mode, \fBauto\fP, handles all the common +cases automatically, but the \fB\-translation\fR option provides +explicit control over the end of line translations. +.RS +.PP +The value associated with \fB\-translation\fR is a single item for +read-only and write-only channels. +The value is a two-element list for read-write channels; +the read translation mode is the first element of the list, +and the write translation mode is the second element. +As a convenience, when setting the translation mode for a read-write channel +you can specify a single value that will apply to both reading and writing. +When querying the translation mode of a read-write channel, +a two-element list will always be returned. +The following values are currently supported: +.TP +\fBauto\fR +As the input translation mode, \fBauto\fR treats any of newline (\fBlf\fP), +carriage return (\fBcr\fP), or carriage return followed by a newline (\fBcrlf\fP) +as the end of line representation. The end of line representation can +even change from line-to-line, and all cases are translated to a newline. +As the output translation mode, \fBauto\fR chooses a platform specific +representation; for sockets on all platforms Tcl +chooses \fBcrlf\fR, for all Unix flavors, it chooses \fBlf\fR, for the +Macintosh platform it chooses \fBcr\fR and for the various flavors of +Windows it chooses \fBcrlf\fR. +The default setting for \fB\-translation\fR is \fBauto\fR for both +input and output. +.TP +\fBbinary\fR +No end-of-line translations are performed. This is nearly identical to +\fBlf\fP mode, except that in addition \fBbinary\fP mode also sets the +end of file character to the empty string, which disables it. +See the description of +\fB\-eofchar\fP for more information. +.TP +\fBcr\fR +The end of a line in the underlying file or device is represented +by a single carriage return character. +As the input translation mode, \fBcr\fP mode converts carriage returns +to newline characters. +As the output translation mode, \fBcr\fP mode +translates newline characters to carriage returns. +This mode is typically used on Macintosh platforms. +.TP +\fBcrlf\fR +The end of a line in the underlying file or device is represented +by a carriage return character followed by a linefeed character. +As the input translation mode, \fBcrlf\fP mode converts +carriage-return-linefeed sequences +to newline characters. +As the output translation mode, \fBcrlf\fP mode +translates newline characters to +carriage-return-linefeed sequences. +This mode is typically used on Windows platforms and for network +connections. +.TP +\fBlf\fR +The end of a line in the underlying file or device is represented +by a single newline (linefeed) character. +In this mode no translations occur during either input or output. +This mode is typically used on UNIX platforms. +.RE +.PP + +.SH "SEE ALSO" +close(n), flush(n), gets(n), puts(n), read(n), socket(n) + +.SH KEYWORDS +blocking, buffering, carriage return, end of line, flushing, linemode, +newline, nonblocking, platform, translation diff --git a/tcl7.6/doc/file.n b/tcl7.6/doc/file.n new file mode 100644 index 0000000..47353e8 --- /dev/null +++ b/tcl7.6/doc/file.n @@ -0,0 +1,273 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) file.n 1.20 96/10/04 05:06:20 +'\" +.so man.macros +.TH file n 7.6 Tcl "Tcl Built-In Commands" +.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 +\fBfilename\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 atime \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. +.PP +\fBfile copy \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIsource\fR \fItarget\fR +.br +\fBfile copy \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIsource\fR ?\fIsource\fR ...? \fItargetDir\fR +.RS +The first form makes a copy of the file or directory \fIsource\fR under +the pathname \fItarget\fR. If \fItarget\fR is an existing directory, +then the second form is used. The second form makes a copy inside +\fItargetDir\fR of each \fIsource\fR file listed. If a directory is +specified as a \fIsource\fR, then the contents of the directory will be +recursively copied into \fItargetDir\fR. Existing files will not be +overwritten unless the \fB\-force\fR option is specified. Trying to +overwrite a non-empty directory, overwrite a directory with a file, or a +file with a directory will all result in errors even if \fI\-force\fR was +specified. Arguments are processed in the order specified, halting at the +first error, if any. A \fB\-\|\-\fR marks the end of switches; the argument +following the \fB\-\|\-\fR will be treated as a \fIsource\fR even if it +starts with a \fB\-\fR. +.RE +.TP +\fBfile delete \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIpathname\fR ?\fIpathname\fR ... ? +. +Removes the file or directory specified by each \fIpathname\fR argument. +Non-empty directories will be removed only if the \fB\-force\fR option is +specified. Trying to delete a non-existant file is not considered an +error. Trying to delete a read-only file will cause the file to be deleted, +even if the \fB\-force\fR flags is not specified. Arguments are processed +in the order specified, halting at the first error, if any. A \fB\-\|\-\fR +marks the end of switches; the argument following the \fB\-\|\-\fR will be +treated as a \fIpathname\fR even if it starts with a \fB\-\fR. +.TP +\fBfile dirname \fIname\fR +Returns a name comprised of all of the path components in \fIname\fR +excluding the last element. If \fIname\fR is a relative file name and +only contains one path element, then returns ``\fB.\fR'' (or ``\fB:\fR'' +on the Macintosh). If \fIname\fR refers to a root directory, then the +root directory is returned. For example, +.RS +.CS +\fBfile dirname c:/\fR +.CE +returns \fBc:/\fR. +.PP +Note that tilde substitution will only be +performed if it is necessary to complete the command. For example, +.CS +\fBfile dirname ~/src/foo.c\fR +.CE +returns \fB~/src\fR, whereas +.CS +\fBfile dirname ~\fR +.CE +returns \fB/home\fR (or something similar). +.RE +.TP +\fBfile executable \fIname\fR +. +Returns \fB1\fR if file \fIname\fR is executable by the current user, +\fB0\fR otherwise. +.TP +\fBfile exists \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 extension \fIname\fR +. +Returns all of the characters in \fIname\fR after and including the last +dot in the last element of \fIname\fR. If there is no dot in the last +element of \fIname\fR then returns the empty string. +.TP +\fBfile isdirectory \fIname\fR +. +Returns \fB1\fR if file \fIname\fR is a directory, \fB0\fR otherwise. +.TP +\fBfile isfile \fIname\fR +. +Returns \fB1\fR if file \fIname\fR is a regular file, \fB0\fR otherwise. +.TP +\fBfile join \fIname\fR ?\fIname ...\fR? +. +Takes one or more file names and combines them, using the correct path +separator for the current platform. If a particular \fIname\fR is +relative, then it will be joined to the previous file name argument. +Otherwise, any earlier arguments will be discarded, and joining will +proceed from the current argument. For example, +.RS +.CS +\fBfile join a b /foo bar\fR +.CE +returns \fB/foo/bar\fR. +.PP +Note that any of the names can contain separators, and that the result +is always canonical for the current platform: \fB/\fR for Unix and +Windows, and \fB:\fR for Macintosh. +.RE +.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 mkdir \fIdir\fR ?\fIdir\fR ...? +. +Creates each directory specified. For each pathname \fIdir\fR specified, +this command will create all non-existing parent directories as +well as \fIdir\fR itself. If an existing directory is specified, then +no action is taken and no error is returned. Trying to overwrite an existing +file with a directory will result in an error. Arguments are processed in +the order specified, halting at the first error, if any. +.TP +\fBfile mtime \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 owned \fIname\fR +. +Returns \fB1\fR if file \fIname\fR is owned by the current user, \fB0\fR +otherwise. +.TP +\fBfile pathtype \fIname\fR +. +Returns one of \fBabsolute\fR, \fBrelative\fR, \fBvolumerelative\fR. If +\fIname\fR refers to a specific file on a specific volume, the path type +will be \fBabsolute\fR. If \fIname\fR refers to a file relative to the +current working directory, then the path type will be \fBrelative\fR. If +\fIname\fR refers to a file relative to the current working directory on +a specified volume, or to a specific file on the current working volume, then +the file type is \fBvolumerelative\fR. +.TP +\fBfile readable \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. +.PP +\fBfile rename \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIsource\fR \fItarget\fR +.br +\fBfile rename \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIsource\fR ?\fIsource\fR ...? \fItargetDir\fR +.RS +The first form takes the file or directory specified by pathname +\fIsource\fR and renames it to \fItarget\fR, moving the file if the +pathname \fItarget\fR specifies a name in a different directory. If +\fItarget\fR is an existing directory, then the second form is used. The +second form moves each \fIsource\fR file or directory into the directory +\fItargetDir\fR. Existing files will not be overwritten unless the +\fB\-force\fR option is specified. Trying to overwrite a non-empty +directory, overwrite a directory with a file, or a file with a directory +will all result in errors. Arguments are processed in the order specified, +halting at the first error, if any. A \fB\-\|\-\fR marks the end of +switches; the argument following the \fB\-\|\-\fR will be treated as a +\fIsource\fR even if it starts with a \fB\-\fR. +.RE +.TP +\fBfile rootname \fIname\fR +. +Returns all of the characters in \fIname\fR up to but not including the +last ``.'' character in the last component of name. If the last +component of \fIname\fR doesn't contain a dot, then returns \fIname\fR. +.TP +\fBfile size \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 split \fIname\fR +. +Returns a list whose elements are the path components in \fIname\fR. The +first element of the list will have the same path type as \fIname\fR. +All other elements will be relative. Path separators will be discarded +unless they are needed ensure that an element is unambiguously relative. +For example, under Unix +.RS +.CS +\fBfile split /foo/~bar/baz\fR +.CE +returns \fB/\0\0foo\0\0./~bar\0\0baz\fR to ensure that later commands +that use the third component do not attempt to perform tilde +substitution. +.RE +.TP +\fBfile stat \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 tail \fIname\fR +. +Returns all of the characters in \fIname\fR after the last directory +separator. If \fIname\fR contains no separators then returns +\fIname\fR. +.TP +\fBfile type \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 writable \fIname\fR +. +Returns \fB1\fR if file \fIname\fR is writable by the current user, +\fB0\fR otherwise. +.SH "PORTABILITY ISSUES" +.TP +\fBUnix\fR\0\0\0\0\0\0\0 +. +These commands always operate using the real user and group identifiers, +not the effective ones. + +.SH "SEE ALSO" +filename + +.SH KEYWORDS +attributes, copy files, delete files, directory, file, move files, name, rename files, stat diff --git a/tcl7.6/doc/fileevent.n b/tcl7.6/doc/fileevent.n new file mode 100644 index 0000000..daff74e --- /dev/null +++ b/tcl7.6/doc/fileevent.n @@ -0,0 +1,109 @@ +'\" +'\" Copyright (c) 1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) fileevent.n 1.6 96/02/23 13:46:29 +'\" +.so man.macros +.TH fileevent n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +fileevent \- Execute a script when a channel becomes readable or writable +.SH SYNOPSIS +\fBfileevent \fIchannelId \fBreadable \fR?\fIscript\fR? +.sp +\fBfileevent \fIchannelId \fBwritable \fR?\fIscript\fR? +.BE + +.SH DESCRIPTION +.PP +This command is used to create \fIfile event handlers\fR. A file event +handler is a binding between a channel and a script, such that the script +is evaluated whenever the channel becomes readable or writable. File event +handlers are most commonly used to allow data to be received from another +process on an event-driven basis, so that the receiver can continue to +interact with the user while waiting for the data to arrive. If an +application invokes \fBgets\fR or \fBread\fR on a blocking channel when +there is no input data available, the process will block; until the input +data arrives, it will not be able to service other events, so it will +appear to the user to ``freeze up''. With \fBfileevent\fR, the process can +tell when data is present and only invoke \fBgets\fR or \fBread\fR when +they won't block. +.PP +The \fIchannelId\fR argument to \fBfileevent\fR refers to an open channel, +such as the return value from a previous \fBopen\fR or \fBsocket\fR +command. +If the \fIscript\fR argument is specified, then \fBfileevent\fR +creates a new event handler: \fIscript\fR will be evaluated +whenever the channel becomes readable or writable (depending on the +second argument to \fBfileevent\fR). +In this case \fBfileevent\fR returns an empty string. +The \fBreadable\fR and \fBwritable\fR event handlers for a file +are independent, and may be created and deleted separately. +However, there may be at most one \fBreadable\fR and one \fBwritable\fR +handler for a file at a given time in a given interpreter. +If \fBfileevent\fR is called when the specified handler already +exists in the invoking interpreter, the new script replaces the old one. +.PP +If the \fIscript\fR argument is not specified, \fBfileevent\fR +returns the current script for \fIchannelId\fR, or an empty string +if there is none. +If the \fIscript\fR argument is specified as an empty string +then the event handler is deleted, so that no script will be invoked. +A file event handler is also deleted automatically whenever +its channel is closed or its interpreter is deleted. +.PP +A channel is considered to be readable if there is unread data +available on the underlying device. +A channel is also considered to be readable if there is unread +data in an input buffer, except in the special case where the +most recent attempt to read from the channel was a \fBgets\fR +call that could not find a complete line in the input buffer. +This feature allows a file to be read a line at a time in nonblocking mode +using events. +A channel is also considered to be readable if an end of file or +error condition is present on the underlying file or device. +It is important for \fIscript\fR to check for these conditions +and handle them appropriately; for example, if there is no special +check for end of file, an infinite loop may occur where \fIscript\fR +reads no data, returns, and is immediately invoked again. +.PP +A channel is considered to be writable if at least one byte of data +can be written to the underlying file or device without blocking, +or if an error condition is present on the underlying file or device. +.PP +Event-driven I/O works best for channels that have been +placed into nonblocking mode with the \fBfconfigure\fR command. +In blocking mode, a \fBputs\fR command may block if you give it +more data than the underlying file or device can accept, and a +\fBgets\fR or \fBread\fR command will block if you attempt to read +more data than is ready; no events will be processed while the +commands block. +In nonblocking mode \fBputs\fR, \fBread\fR, and \fBgets\fR never block. +See the documentation for the individual commands for information +on how they handle blocking and nonblocking channels. +.PP +The script for a file event is executed at global level (outside the +context of any Tcl procedure) in the interpreter in which the +\fBfileevent\fR command was invoked. +If an error occurs while executing the script then the +\fBbgerror\fR mechanism is used to report the error. +In addition, the file event handler is deleted if it ever returns +an error; this is done in order to prevent infinite loops due to +buggy handlers. + +.SH CREDITS +.PP +\fBfileevent\fR is based on the \fBaddinput\fR command created +by Mark Diekhans. + +.SH "SEE ALSO" +bgerror, fconfigure, gets, puts, read + +.SH KEYWORDS +asynchronous I/O, blocking, channel, event handler, nonblocking, readable, +script, writable. diff --git a/tcl7.6/doc/filename.n b/tcl7.6/doc/filename.n new file mode 100644 index 0000000..e1f38ae --- /dev/null +++ b/tcl7.6/doc/filename.n @@ -0,0 +1,197 @@ +'\" +'\" Copyright (c) 1995-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) filename.n 1.7 96/04/11 17:03:14 +'\" +.so man.macros +.TH filename n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +filename \- File name conventions supported by Tcl commands +.BE +.SH INTRODUCTION +.PP +All Tcl commands and C procedures that take file names as arguments +expect the file names to be in one of three forms, depending on the +current platform. On each platform, Tcl supports file names in the +standard forms(s) for that platform. In addition, on all platforms, +Tcl supports a Unix-like syntax intended to provide a convenient way +of constructing simple file names. However, scripts that are intended +to be portable should not assume a particular form for file names. +Instead, portable scripts must use the \fBfile split\fR and \fBfile +join\fR commands to manipulate file names (see the \fBfile\fR manual +entry for more details). + +.SH PATH TYPES +.PP +File names are grouped into three general types based on the starting point +for the path used to specify the file: absolute, relative, and +volume-relative. Absolute names are completely qualified, giving a path to +the file relative to a particular volume and the root directory on that +volume. Relative names are unqualified, giving a path to the file relative +to the current working directory. Volume-relative names are partially +qualified, either giving the path relative to the root directory on the +current volume, or relative to the current directory of the specified +volume. The \fBfile pathtype\fR command can be used to determine the +type of a given path. + +.SH PATH SYNTAX +.PP +The rules for native names depend on the value reported in the Tcl +array element \fBtcl_platform(platform)\fR: +.TP 10 +\fBmac\fR +On Apple Macintosh systems, Tcl supports two forms of path names. The +normal Mac style names use colons as path separators. Paths may be +relative or absolute, and file names may contain any character other +than colon. A leading colon causes the rest of the path to be +interpreted relative to the current directory. If a path contains a +colon that is not at the beginning, then the path is interpreted as an +absolute path. Sequences of two or more colons anywhere in the path +are used to construct relative paths where \fB::\fR refers to the +parent of the current directory, \fB:::\fR refers to the parent of the +parent, and so forth. +.RS +.PP +In addition to Macintosh style names, Tcl also supports a subset of +Unix-like names. If a path contains no colons, then it is interpreted +like a Unix path. Slash is used as the path separator. The file name +\fB\&.\fR refers to the current directory, and \fB\&..\fR refers to the +parent of the current directory. However, some names like \fB/\fR or +\fB/..\fR have no mapping, and are interpreted as Macintosh names. In +general, commands that generate file names will return Macintosh style +names, but commands that accept file names will take both Macintosh +and Unix-style names. +.PP +The following examples illustrate various forms of path names: +.TP 15 +\fB:\fR +Relative path to the current folder. +.TP 15 +\fBMyFile\fR +Relative path to a file named \fBMyFile\fR in the current folder. +.TP 15 +\fBMyDisk:MyFile\fR +Absolute path to a file named \fBMyFile\fR on the device named \fBMyDisk\fR. +.TP 15 +\fB:MyDir:MyFile\fR +Relative path to a file name \fBMyFile\fR in a folder named +\fBMyDir\fR in the current folder. +.TP 15 +\fB::MyFile\fR +Relative path to a file named \fBMyFile\fR in the folder above the +current folder. +.TP 15 +\fB:::MyFile\fR +Relative path to a file named \fBMyFile\fR in the folder two levels above the +current folder. +.TP 15 +\fB/MyDisk/MyFile\fR +Absolute path to a file named \fBMyFile\fR on the device named +\fBMyDisk\fR. +.TP 15 +\fB\&../MyFile\fR +Relative path to a file named \fBMyFile\fR in the folder above the +current folder. +.RE +.TP +\fBunix\fR +On Unix platforms, Tcl uses path names where the components are +separated by slashes. Path names may be relative or absolute, and +file names may contain any character other than slash. The file names +\fB\&.\fR and \fB\&..\fR are special and refer to the current directory +and the parent of the current directory respectively. Multiple +adjacent slash characters are interpreted as a single separator. +The following examples illustrate various forms of path names: +.RS +.TP 15 +\fB/\fR +Absolute path to the root directory. +.TP 15 +\fB/etc/passwd\fR +Absolute path to the file named \fBpasswd\fR in the directory +\fBetc\fR in the root directory. +.TP 15 +\fB\&.\fR +Relative path to the current directory. +.TP 15 +\fBfoo\fR +Relative path to the file \fBfoo\fR in the current directory. +.TP 15 +\fBfoo/bar\fR +Relative path to the file \fBbar\fR in the directory \fBfoo\fR in the +current directory. +.TP 15 +\fB\&../foo\fR +Relative path to the file \fBfoo\fR in the directory above the current +directory. +.RE +.TP +\fBwindows\fR +On Microsoft Windows platforms, Tcl supports both drive-relative and UNC +style names. Both \fB/\fR and \fB\e\fR may be used as directory separators +in either type of name. Drive-relative names consist of an optional drive +specifier followed by an absolute or relative path. UNC paths follow the +general form \fB\e\eservername\esharename\epath\efile\fR. In both forms, +the file names \fB.\fR and \fB..\fR are special and refer to the current +directory and the parent of the current directory respectively. The +following examples illustrate various forms of path names: +.RS +.TP 15 +\fB\&\e\eHost\eshare/file\fR +Absolute UNC path to a file called \fBfile\fR in the root directory of +the export point \fBshare\fR on the host \fBHost\fR. +.TP 15 +\fBc:foo\fR +Volume-relative path to a file \fBfoo\fR in the current directory on drive +\fBc\fR. +.TP 15 +\fBc:/foo\fR +Absolute path to a file \fBfoo\fR in the root directory of drive +\fBc\fR. +.TP 15 +\fBfoo\ebar\fR +Relative path to a file \fBbar\fR in the \fBfoo\fR directory in the current +directory on the current volume. +.TP 15 +\fB\&\efoo\fR +Volume-relative path to a file \fBfoo\fR in the root directory of the current +volume. +.RE + +.SH TILDE SUBSTITUTION +.PP +In addition to the file name rules described above, Tcl also supports +\fIcsh\fR-style tilde substitution. If a file name starts with a +tilde, then the file name will be interpreted as if the first element +is replaced with the location of the home directory for the given +user. If the tilde is followed immediately by a separator, then the +\fB$HOME\fR environment variable is substituted. Otherwise the +characters between the tilde and the next separator are taken as a +user name, which is used to retrieve the user's home directory for +substitution. +.PP +The Macintosh and Windows platforms do not support tilde substitution +when a user name follows the tilde. On these platforms, attempts to +use a tilde followed by a user name will generate an error. File +names that have a tilde without a user name will be substituted using +the \fB$HOME\fR environment variable, just like for Unix. + +.SH PORTABILITY ISSUES +.PP +Not all file systems are case sensitive, so scripts should avoid code +that depends on the case of characters in a file name. In addition, +the character sets allowed on different devices may differ, so scripts +should choose file names that do not contain special characters like: +\fB<>:"/\e|\fR. The safest approach is to use names consisting of +alphanumeric characters only. Also Windows 3.1 only supports file +names with a root of no more than 8 characters and an extension of no +more than 3 characters. + +.SH KEYWORDS +current directory, absolute file name, relative file name, +volume-relative file name, portability diff --git a/tcl7.6/doc/flush.n b/tcl7.6/doc/flush.n new file mode 100644 index 0000000..f69354a --- /dev/null +++ b/tcl7.6/doc/flush.n @@ -0,0 +1,35 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) flush.n 1.10 96/08/26 12:59:57 +'\" +.so man.macros +.TH flush n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +flush \- Flush buffered output for a channel +.SH SYNOPSIS +\fBflush \fIchannelId\fR +.BE + +.SH DESCRIPTION +.PP +Flushes any output that has been buffered for \fIchannelId\fR. +\fIChannelId\fR must be a channel identifier such as returned by a previous +\fBopen\fR or \fBsocket\fR command, and it must have been opened for writing. +If the channel is in blocking mode the command does not return until all the +buffered output has been flushed to the channel. If the channel is in +nonblocking mode, the command may return before all buffered output has been +flushed; the remainder will be flushed in the background as fast as the +underlying file or device is able to absorb it. + +.SH "SEE ALSO" +open(n), socket(n) + +.SH KEYWORDS +blocking, buffer, channel, flush, nonblocking, output diff --git a/tcl7.3/doc/for.n b/tcl7.6/doc/for.n similarity index 55% rename from tcl7.3/doc/for.n rename to tcl7.6/doc/for.n index 45915c6..11e5d01 100644 --- a/tcl7.3/doc/for.n +++ b/tcl7.6/doc/for.n @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/for.n,v 1.1 93/05/03 17:09:41 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) for.n 1.5 96/03/25 20:15:01 '\" .so man.macros -.HS for tcl +.TH for n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/tcl7.6/doc/foreach.n b/tcl7.6/doc/foreach.n new file mode 100644 index 0000000..0dec2a5 --- /dev/null +++ b/tcl7.6/doc/foreach.n @@ -0,0 +1,86 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) foreach.n 1.6 96/03/25 20:15:14 +'\" +.so man.macros +.TH foreach n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +foreach \- Iterate over all elements in one or more lists +.SH SYNOPSIS +\fBforeach \fIvarname list body\fR +.br +\fBforeach \fIvarlist1 list1\fR ?\fIvarlist2 list2 ...\fR? \fIbody\fR +.BE + +.SH DESCRIPTION +.PP +The \fBforeach\fR command implements a loop where the loop +variable(s) take on values from one or more lists. +In the simplest case there is one loop variable, \fIvarname\fR, +and one list, \fIlist\fR, that is a list of values to assign to \fIvarname\fR. +The \fIbody\fR argument is a Tcl script. +For each element of \fIlist\fR (in order +from first to last), \fBforeach\fR assigns the contents of the +element to \fIvarname\fR as if the \fBlindex\fR command had been used +to extract the element, then calls the Tcl interpreter to execute +\fIbody\fR. +.PP +In the general case there can be more than one value list +(e.g., \fIlist1\fR and \fIlist2\fR), +and each value list can be associated with a list of loop variables +(e.g., \fIvarlist1\fR and \fIvarlist2\fR). +During each iteration of the loop +the variables of each \fIvarlist\fP are assigned +consecutive values from the corresponding \fIlist\fP. +Values in each \fIlist\fP are used in order from first to last, +and each value is used exactly once. +The total number of loop iterations is large enough to use +up all the values from all the value lists. +If a value list does not contain enough +elements for each of its loop variables in each iteration, +empty values are used for the missing elements. +.PP +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 EXAMPLES +.PP +The following loop uses i and j as loop variables to iterate over +pairs of elements of a single list. +.DS +set x {} +foreach {i j} {a b c d e f} { + lappend x $j $i +} +# The value of x is "b a d c f e" +# There are 3 iterations of the loop. +.DE +.PP +The next loop uses i and j to iterate over two lists in parallel. +.DS +set x {} +foreach i {a b c} j {d e f g} { + lappend x $i $j +} +# The value of x is "a d b e c f {} g" +# There are 4 iterations of the loop. +.DE +.PP +The two forms are combined in the following example. +.DS +set x {} +foreach i {a b c} {j k} {d e f g} { + lappend x $i $j $k +} +# The value of x is "a d e b f g c {} {}" +# There are 3 iterations of the loop. +.DE +.SH KEYWORDS +foreach, iteration, list, looping diff --git a/tcl7.3/doc/format.n b/tcl7.6/doc/format.n similarity index 86% rename from tcl7.3/doc/format.n rename to tcl7.6/doc/format.n index 69f66d2..57c97d6 100644 --- a/tcl7.3/doc/format.n +++ b/tcl7.6/doc/format.n @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/format.n,v 1.4 93/08/05 13:56:19 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) format.n 1.11 96/08/26 12:59:57 '\" .so man.macros -.HS format tcl +.TH format n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -57,16 +44,13 @@ 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. @@ -79,7 +63,6 @@ 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: @@ -135,7 +118,7 @@ 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 +For integer conversions, it specifies a minimum 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. @@ -143,7 +126,7 @@ 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, +The fifth 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. @@ -209,25 +192,21 @@ 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/tcl7.6/doc/gets.n b/tcl7.6/doc/gets.n new file mode 100644 index 0000000..025f76d --- /dev/null +++ b/tcl7.6/doc/gets.n @@ -0,0 +1,50 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) gets.n 1.13 96/08/26 12:59:58 +'\" +.so man.macros +.TH gets n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +gets \- Read a line from a channel +.SH SYNOPSIS +\fBgets \fIchannelId\fR ?\fIvarName\fR? +.BE + +.SH DESCRIPTION +.PP +This command reads the next line from \fIchannelId\fR, returns everything +in the line up to (but not including) the end-of-line character(s), and +discards the end-of-line character(s). +If \fIvarName\fR is omitted the line is returned as the result of the +command. +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 +returned. +.PP +If end of file occurs while scanning for an end of +line, the command returns whatever input is available up to the end of file. +If \fIchannelId\fR is in nonblocking mode and there is not a full +line of input available, the command returns an empty string and +does not consume any input. +If \fIvarName\fR is specified and an empty string is returned in +\fIvarName\fR because of end-of-file or because of insufficient +data in nonblocking mode, then the return count is -1. +Note that if \fIvarName\fR is not specified then the end-of-file +and no-full-line-available cases can +produce the same results as if there were an input line consisting +only of the end-of-line character(s). +The \fBeof\fR and \fBfblocked\fR commands can be used to distinguish +these three cases. + +.SH "SEE ALSO" +eof(n), fblocked(n) + +.SH KEYWORDS +blocking, channel, end of file, end of line, line, nonblocking, read diff --git a/tcl7.3/doc/glob.n b/tcl7.6/doc/glob.n similarity index 65% rename from tcl7.3/doc/glob.n rename to tcl7.6/doc/glob.n index 3b358e2..2097534 100644 --- a/tcl7.3/doc/glob.n +++ b/tcl7.6/doc/glob.n @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/glob.n,v 1.3 93/06/17 15:50:54 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) glob.n 1.11 96/08/26 12:59:59 '\" .so man.macros -.HS glob tcl 7.0 +.TH glob n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -37,7 +24,6 @@ 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 @@ -47,8 +33,7 @@ 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 +be treated as a \fIpattern\fR even if it starts with a \fB\-\fR. .PP The \fIpattern\fR arguments may contain any of the following special characters: @@ -82,11 +67,18 @@ the HOME environment variable is used. 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 PORTABILITY ISSUES +.PP +Unlike other Tcl commands that will accept both network and native +style names (see the \fBfilename\fR manual entry for details on how +native and network names are specified), the \fBglob\fR command only +accepts native names. Also, for Windows UNC names, the servername and +sharename components of the path may not contain ?, *, or [] +constructs. .SH KEYWORDS exist, file, glob, pattern diff --git a/tcl7.6/doc/global.n b/tcl7.6/doc/global.n new file mode 100644 index 0000000..17ac62f --- /dev/null +++ b/tcl7.6/doc/global.n @@ -0,0 +1,30 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) global.n 1.5 96/03/25 20:16:10 +'\" +.so man.macros +.TH global n "" Tcl "Tcl Built-In Commands" +.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/tcl7.3/doc/history.n b/tcl7.6/doc/history.n similarity index 84% rename from tcl7.3/doc/history.n rename to tcl7.6/doc/history.n index 933b51b..a93e2fd 100644 --- a/tcl7.3/doc/history.n +++ b/tcl7.6/doc/history.n @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/history.n,v 1.1 93/05/03 17:09:47 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) history.n 1.6 96/03/25 20:16:25 '\" .so man.macros -.HS history tcl +.TH history n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -48,7 +35,7 @@ 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 +.PP The \fBhistory\fR command can take any of the following forms: .TP \fBhistory\fR @@ -118,9 +105,9 @@ 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 +.CS \fBformat {%s is %d years old} Alice [expr $ageInMonths/12]\fR -.DE +.CE Below are some history commands and the results they would produce: .DS .ta 4c @@ -144,9 +131,9 @@ 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 +.CS \fBset a [expr $b+2]\fR -.DE +.CE 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 diff --git a/tcl7.3/doc/if.n b/tcl7.6/doc/if.n similarity index 54% rename from tcl7.3/doc/if.n rename to tcl7.6/doc/if.n index d15b90a..9e86214 100644 --- a/tcl7.3/doc/if.n +++ b/tcl7.6/doc/if.n @@ -1,33 +1,20 @@ '\" '\" Copyright (c) 1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/if.n,v 1.1 93/05/03 17:34:01 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) if.n 1.7 96/08/26 13:00:00 '\" .so man.macros -.HS if tcl +.TH if n "" Tcl "Tcl Built-In Commands" .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? +\fBif \fIexpr1 \fR?\fBthen\fR? \fIbody1 \fBelseif \fIexpr2 \fR?\fBthen\fR? \fIbody2\fR \fBelseif\fR ... ?\fBelse\fR? ?\fIbodyN\fR? .BE .SH DESCRIPTION @@ -35,11 +22,9 @@ if \- Execute scripts conditionally 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 diff --git a/tcl7.6/doc/incr.n b/tcl7.6/doc/incr.n new file mode 100644 index 0000000..cfd76b8 --- /dev/null +++ b/tcl7.6/doc/incr.n @@ -0,0 +1,31 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) incr.n 1.5 96/03/25 20:16:58 +'\" +.so man.macros +.TH incr n "" Tcl "Tcl Built-In Commands" +.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/tcl7.3/doc/info.n b/tcl7.6/doc/info.n similarity index 69% rename from tcl7.3/doc/info.n rename to tcl7.6/doc/info.n index 2806aa4..bb6b8b8 100644 --- a/tcl7.3/doc/info.n +++ b/tcl7.6/doc/info.n @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/info.n,v 1.2 93/06/18 13:58:33 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) info.n 1.14 96/08/26 13:00:01 '\" .so man.macros -.HS info tcl 7.0 +.TH info n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -85,6 +72,10 @@ 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 hostname\fR +Returns the name of the computer on which this invocation is being +executed. +.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 @@ -101,17 +92,21 @@ levels mean. \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. +This is actually the value of the \fBtcl_library\fR +variable and may be changed by setting \fBtcl_library\fR. +See the \fBtclvars\fR manual entry for more information. +.TP +\fBinfo loaded \fR?\fIinterp\fR? +Returns a list describing all of the packages that have been loaded into +\fIinterp\fR with the \fBload\fR command. +Each list element is a sub-list with two elements consisting of the +name of the file from which the package was loaded and the name of +the package. +For statically-loaded packages the file name will be an empty string. +If \fIinterp\fR is omitted then information is returned for all packages +loaded in any interpreter in the process. +To get a list of just the packages in the current interpreter, specify +an empty string for the \fIinterp\fR argument. .TP \fBinfo locals \fR?\fIpattern\fR? If \fIpattern\fR isn't specified, returns a list of all the names @@ -123,12 +118,14 @@ 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 nameofexecutable\fR +Returns the full path name of the binary file from which the application +was invoked. If Tcl was unable to identify the file, then an empty +string is returned. +.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 +Returns the value of the global variable \fBtcl_patchLevel\fR; see +the \fBtclvars\fR manual entry for more information. .TP \fBinfo procs \fR?\fIpattern\fR? If \fIpattern\fR isn't specified, returns a list of all the @@ -144,11 +141,15 @@ 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 sharedlibextension\fR +Returns the extension used on this platform for the names of files +containing shared libraries (for example, \fB.so\fR under Solaris). +If shared libraries aren't supported on this platform then an empty +string is returned. +.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. +Returns the value of the global variable \fBtcl_version\fR; see +the \fBtclvars\fR manual entry for more information. .TP \fBinfo vars\fR ?\fIpattern\fR? If \fIpattern\fR isn't specified, diff --git a/tcl7.6/doc/interp.n b/tcl7.6/doc/interp.n new file mode 100644 index 0000000..867f5d7 --- /dev/null +++ b/tcl7.6/doc/interp.n @@ -0,0 +1,351 @@ +'\" +'\" Copyright (c) 1995-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) interp.n 1.23 96/08/21 10:02:02 +'\" +.so man.macros +.TH interp n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +interp \- Create and manipulate Tcl interpreters +.SH SYNOPSIS +\fBinterp \fIoption \fR?\fIarg arg ...\fR? +.BE +.SH DESCRIPTION +.PP +This command makes it possible to create one or more new Tcl +interpreters that co-exist with the creating interpreter in the +same application. The creating interpreter is called the \fImaster\fR +and the new interpreter is called a \fIslave\fR. +A master can create any number of slaves, and each slave can +itself create additional slaves for which it is master, resulting +in a hierarchy of interpreters. +.PP +Each interpreter is independent from the others: it has its own name +space for commands, procedures, and global variables. +A master interpreter may create connections between its slaves and +itself using a mechanism called an \fIalias\fR. An \fIalias\fR is +a command in a slave interpreter which, when invoked, causes a +command to be invoked in its master interpreter or in another slave +interpreter. The only other connections between interpreters are +through environment variables (the \fBenv\fR variable), which are +normally shared among all interpreters in the application. Note that the +name space for files (such as the names returned by the \fBopen\fR command) +is no longer shared between interpreters. Explicit commands are provided to +share files and to transfer references to open files from one interpreter +to another. +.PP +The \fBinterp\fR command also provides support for \fIsafe\fR +interpreters. A safe interpreter is a slave whose functions have +been greatly restricted, so that it is safe to execute untrusted +scripts without fear of them damaging other interpreters or the +application's environment. For example, all IO channel creation +commands and subprocess creation commands are removed from safe interpreters. +See SAFE INTERPRETERS below for more information on what features +are present in a safe interpreter. The alias mechanism can be +used for protected communication (analogous to a kernel call) +between a slave interpreter and its master. +.PP +A qualified interpreter name is a proper Tcl lists containing a subset of its +ancestors in the interpreter hierarchy, terminated by the string naming the +interpreter in its immediate master. Interpreter names are relative to the +interpreter in which they are used. For example, if \fIa\fR is a slave of +the current interpreter and it has a slave \fIa1\fR, which in turn has a +slave \fIa11\fR, the qualified name of \fIa11\fR in \fIa\fR is the list +\fI{a1 a11}\fR. +.PP +The \fBinterp\fR command, described below, accepts qualified interpreter +names as arguments; the interpreter in which the command is being evaluated +can always be referred to as \fI{}\fR (the empty list or string). Note that +it is impossible to refer to a master (ancestor) interpreter by name in a +slave interpreter except through aliases. Also, there is no global name by +which one can refer to the first interpreter created in an application. +Both restrictions are motivated by safety concerns. +.PP +The \fBinterp\fR command is used to create, delete, and manipulate +slave interpreters, and to share or transfer +channels between interpreters. It can have any of several forms, depending +on the \fIoption\fR argument: +.TP +\fBinterp \fBalias \fIsrcPath \fIsrcCmd\fR +Returns a Tcl list whose elements are the \fItargetCmd\fR and +\fIarg\fRs associated with the alias named \fIsrcCmd\fR +(all of these are the values specified when the alias was +created; it is possible that the actual source command in the +slave is different from \fIsrcCmd\fR if it was renamed). +.TP +\fBinterp \fBalias \fIsrcPath \fIsrcCmd\fR \fB{}\fR +Deletes the alias for \fIsrcCmd\fR in the slave interpreter identified by +\fIsrcPath\fR. +\fIsrcCmd\fR refers to the name under which the alias +was created; if the source command has been renamed, the renamed +command will be deleted. +.TP +\fBinterp \fBalias \fIsrcPath \fIsrcCmd\fR \fItargetPath \fItargetCmd \fR?\fIarg arg ...\fR? +This command creates an alias between one slave and another (see the +\fBalias\fR slave command below for creating aliases between a slave +and its master). In this command, either of the slave interpreters +may be anywhere in the hierarchy of interpreters under the interpreter +invoking the command. +\fISrcPath\fR and \fIsrcCmd\fR identify the source of the alias. +\fISrcPath\fR is a Tcl list whose elements select a particular +interpreter. For example, ``\fBa b\fR'' identifies an interpreter +\fBb\fR, which is a slave of interpreter \fBa\fR, which is a slave +of the invoking interpreter. An empty list specifies the interpreter +invoking the command. \fIsrcCmd\fR gives the name of a new +command, which will be created in the source interpreter. +\fITargetPath\fR and \fItargetCmd\fR specify a target interpreter +and command, and the \fIarg\fR arguments, if any, specify additional +arguments to \fItargetCmd\fR which are prepended to any arguments specified +in the invocation of \fIsrcCmd\fR. +\fITargetCmd\fR may be undefined at the time of this call, or it may +already exist; it is not created by this command. +The alias arranges for the given target command to be invoked +in the target interpreter whenever the given source command is +invoked in the source interpreter. See ALIAS INVOCATION below for +more details. +.TP +\fBinterp \fBaliases \fR?\fIpath\fR? +This command returns a Tcl list of the names of all the source commands for +aliases defined in the interpreter identified by \fIpath\fR. +.TP +\fBinterp \fBcreate \fR?\fB\-safe\fR? ?\fB\-\|\-\fR? ?\fIpath\fR? +Creates a slave interpreter identified by \fIpath\fR and a new command, +called a \fIslave command\fR. The name of the slave command is the last +component of \fIpath\fR. The new slave interpreter and the slave command +are created in the interpreter identified by the path obtained by removing +the last component from \fIpath\fR. For example, if \fIpath is ``\fBa b +c\fR'' then a new slave interpreter and slave command named ``\fBc\fR'' are +created in the interpreter identified by the path ``\fBa b\fR''. +The slave command may be used to manipulate the new interpreter as +described below. If \fIpath\fR is omitted, Tcl creates a unique name of the +form \fBinterp\fIx\fR, where \fIx\fR is an integer, and uses it for the +interpreter and the slave command. If the \fB\-safe\fR switch is specified +(or if the master interpreter is a safe interpreter), the new slave +interpreter will be created as a safe interpreter with limited +functionality; otherwise the slave will include the full set of Tcl +built-in commands and variables. The \fB\-\|\-\fR switch can be used to +mark the end of switches; it may be needed if \fIpath\fR is an unusual +value such as \fB\-safe\fR. The result of the command is the name of the +new interpreter. The name of a slave interpreter must be unique among all +the slaves for its master; an error occurs if a slave interpreter by the +given name already exists in this master. +.TP +\fBinterp \fBdelete \fR?\fIpath ...?\fR +Deletes zero or more interpreters given by the optional \fIpath\fR +arguments, and for each interpreter, it also deletes its slaves. The +command also deletes the slave command for each interpreter deleted. +For each \fIpath\fR argument, if no interpreter by that name +exists, the command raises an error. +.TP +\fBinterp \fBeval \fIpath arg \fR?\fIarg ...\fR? +This command concatenates all of the \fIarg\fR arguments in the same +fashion as the \fBconcat\fR command, then evaluates the resulting string as +a Tcl script in the slave interpreter identified by \fIpath\fR. The result +of this evaluation (including error information such as the \fBerrorInfo\fR +and \fBerrorCode\fR variables, if an error occurs) is returned to the +invoking interpreter. +.TP +\fBinterp \fBexists \fIpath\fR +Returns \fB1\fR if a slave interpreter by the specified \fIpath\fR +exists in this master, \fB0\fR otherwise. If \fIpath\fR is omitted, the +invoking interpreter is used. +.TP +\fBinterp \fBissafe\fR ?\fIpath\fR? +Returns \fB1\fR if the interpreter identified by the specified \fIpath\fR +is safe, \fB0\fR otherwise. +.TP +\fBinterp \fBshare\fR \fIsrcPath channelId destPath\fR +Causes the IO channel identified by \fIchannelId\fR to become shared +between the interpreter identified by \fIsrcPath\fR and the interpreter +identified by \fIdestPath\fR. Both interpreters have the same permissions +on the IO channel. +Both interpreters must close it to close the underlying IO channel; IO +channels accessible in an interpreter are automatically closed when an +interpreter is destroyed. +.TP +\fBinterp \fBslaves\fR ?\fIpath\fR? +Returns a Tcl list of the names of all the slave interpreters associated +with the interpreter identified by \fIpath\fR. If \fIpath\fR is omitted, +the invoking interpreter is used. +.TP +\fBinterp \fBtarget \fIpath alias\fR +Returns a Tcl list describing the target interpreter for an alias. The +alias is specified with an interpreter path and source command name, just +as in \fBinterp alias\fR above. The name of the target interpreter is +returned as an interpreter path, relative to the invoking interpreter. +If the target interpreter for the alias is the invoking interpreter then an +empty list is returned. If the target interpreter for the alias is not the +invoking interpreter or one of its descendants then an error is generated. +The target command does not have to be defined at the time of this invocation. +.TP +\fBinterp \fBtransfer\fR \fIsrcPath channelId destPath\fR +Causes the IO channel identified by \fIchannelId\fR to become available in +the interpreter identified by \fIdestPath\fR and unavailable in the +interpreter identified by \fIsrcPath\fR. +.SH "SLAVE COMMAND" +.PP +For each slave interpreter created with the \fBinterp\fR command, a +new Tcl command is created in the master interpreter with the same +name as the new interpreter. This command may be used to invoke +various operations on the interpreter. It has the following +general form: +.CS +\fIslave command \fR?\fIarg arg ...\fR? +.CE +\fISlave\fR is the name of the interpreter, and \fIcommand\fR +and the \fIarg\fRs determine the exact behavior of the command. +The valid forms of this command are: +.TP +\fIslave \fBaliases\fR +Returns a Tcl list whose elements are the names of all the +aliases in \fIslave\fR. The names returned are the \fIsrcCmd\fR +values used when the aliases were created (which may not be the same +as the current names of the commands, if they have been +renamed). +.TP +\fIslave \fBalias \fIsrcCmd\fR +Returns a Tcl list whose elements are the \fItargetCmd\fR and +\fIarg\fRs associated with the alias named \fIsrcCmd\fR +(all of these are the values specified when the alias was +created; it is possible that the actual source command in the +slave is different from \fIsrcCmd\fR if it was renamed). +.TP +\fIslave \fBalias \fIsrcCmd \fB{}\fR +Deletes the alias for \fIsrcCmd\fR in the slave interpreter. +\fIsrcCmd\fR refers to the name under which the alias +was created; if the source command has been renamed, the renamed +command will be deleted. +.TP +\fIslave \fBalias \fIsrcCmd targetCmd \fR?\fIarg ..\fR? +Creates an alias such that whenever \fIsrcCmd\fR is invoked +in \fIslave\fR, \fItargetCmd\fR is invoked in the master. +The \fIarg\fR arguments will be passed to \fItargetCmd\fR as additional +arguments, prepended before any arguments passed in the invocation of +\fIsrcCmd\fR. +See ALIAS INVOCATION below for details. +.TP +\fIslave \fBeval \fIarg \fR?\fIarg ..\fR? +This command concatenates all of the \fIarg\fR arguments in +the same fashion as the \fBconcat\fR command, then evaluates +the resulting string as a Tcl script in \fIslave\fR. +The result of this evaluation (including error information +such as the \fBerrorInfo\fR and \fBerrorCode\fR variables, if an +error occurs) is returned to the invoking interpreter. +.TP +\fIslave \fBissafe\fR +Returns \fB1\fR if the slave interpreter is safe, \fB0\fR otherwise. + +.SH "ALIAS INVOCATION" +.PP +The alias mechanism has been carefully designed so that it can +be used safely when an untrusted script is executing +in a safe slave and the target of the alias is a trusted +master. The most important thing in guaranteeing safety is to +ensure that information passed from the slave to the master is +never evaluated or substituted in the master; if this were to +occur, it would enable an evil script in the slave to invoke +arbitrary functions in the master, which would compromise security. +.PP +When the source for an alias is invoked in the slave interpreter, the +usual Tcl substitutions are performed when parsing that command. +These substitutions are carried out in the source interpreter just +as they would be for any other command invoked in that interpreter. +The command procedure for the source command takes its arguments +and merges them with the \fItargetCmd\fR and \fIarg\fRs for the +alias to create a new array of arguments. If the words +of \fIsrcCmd\fR were ``\fIsrcCmd arg1 arg2 ... argN\fR'', +the new set of words will be +``\fItargetCmd arg arg ... arg arg1 arg2 ... argN\fR'', +where \fItargetCmd\fR and \fIarg\fRs are the values supplied when the +alias was created. \fITargetCmd\fR is then used to locate a command +procedure in the target interpreter, and that command procedure +is invoked with the new set of arguments. An error occurs if +there is no command named \fItargetCmd\fR in the target interpreter. +No additional substitutions are performed on the words: the +target command procedure is invoked directly, without +going through the normal Tcl evaluation mechanism. +Substitutions are thus performed on each word exactly once: +\fItargetCmd\fR and \fIargs\fR were substituted when parsing the command +that created the alias, and \fIarg1 - argN\fR are substituted when +the alias's source command is parsed in the source interpreter. +.PP +When writing the \fItargetCmd\fRs for aliases in safe interpreters, +it is very important that the arguments to that command never be +evaluated or substituted, since this would provide an escape +mechanism whereby the slave interpreter could execute arbitrary +code in the master. This in turn would compromise the security +of the system. + +.SH "SAFE INTERPRETERS" +.PP +A safe interpreter is one with restricted functionality, so that +is safe to execute an arbitrary script from your worst enemy without +fear of that script damaging the enclosing application or the rest +of your computing environment. In order to make an interpreter +safe, certain commands and variables are removed from the interpreter. +For example, commands to create files on disk are removed, and the +\fBexec\fR command is removed, since it could be used to cause damage +through subprocesses. +Limited access to these facilities can be provided, by creating +aliases to the master interpreter which check their arguments carefully +and provide restricted access to a safe subset of facilities. +For example, file creation might be allowed in a particular subdirectory +and subprocess invocation might be allowed for a carefully selected and +fixed set of programs. +.PP +A safe interpreter is created by specifying the \fB\-safe\fR switch +to the \fBinterp create\fR command. Furthermore, any slave created +by a safe interpreter will also be safe. +.PP +A safe interpreter is created with exactly the following set of +built-in commands: +.DS +.ta 1.2i 2.4i 3.6i +\fBafter append array break +case catch clock close +concat continue eof error +eval expr fblocked fileevent +flush for foreach format +gets global history if +incr info interp join +lappend lindex linsert list +llength lower lrange lreplace +lsearch lsort package pid +proc puts read rename +return scan seek set +split string subst switch +tell trace unset update +uplevel upvar vwait while\fR +.DE +All commands not on this list are removed by \fBinterp create\fR when it +creates a safe interpreter. +These commands can be recreated later as Tcl procedures or aliases. +.PP +In addition, the \fBenv\fR variable is not present in a safe interpreter, +so it cannot share environment variables with other interpreters. The +\fBenv\fR variable poses a security risk, because users can store +sensitive information in an environment variable. For example, the PGP +manual recommends storing the PGP private key protection password in +the environment variable \fIPGPPASS\fR. Making this variable available +to untrusted code executing in a safe interpreter would incur a +security risk. +.PP +If extensions are loaded into a safe interpreter, they may also restrict +their own functionality to eliminate unsafe commands. For a discussion of +management of extensions for safety see the manual entries for the +\fBpackage\fR and \fBload\fR Tcl commands. +.SH CREDITS +.PP +This mechanism is based on the Safe-Tcl prototype implemented +by Nathaniel Borenstein and Marshall Rose. + +.SH "SEE ALSO" +load(n), package(n) Tcl_CreateSlave(3) + +.SH KEYWORDS +alias, master interpreter, safe interpreter, slave interpreter diff --git a/tcl7.6/doc/join.n b/tcl7.6/doc/join.n new file mode 100644 index 0000000..7e662cf --- /dev/null +++ b/tcl7.6/doc/join.n @@ -0,0 +1,29 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) join.n 1.5 96/03/25 20:17:46 +'\" +.so man.macros +.TH join n "" Tcl "Tcl Built-In Commands" +.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/tcl7.6/doc/lappend.n b/tcl7.6/doc/lappend.n new file mode 100644 index 0000000..a0c3b54 --- /dev/null +++ b/tcl7.6/doc/lappend.n @@ -0,0 +1,35 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) lappend.n 1.6 96/03/25 20:18:03 +'\" +.so man.macros +.TH lappend n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +lappend \- Append list elements onto a variable +.SH SYNOPSIS +\fBlappend \fIvarName \fR?\fIvalue value 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/tcl7.3/doc/library.n b/tcl7.6/doc/library.n similarity index 66% rename from tcl7.3/doc/library.n rename to tcl7.6/doc/library.n index 619ac1f..bbfc990 100644 --- a/tcl7.3/doc/library.n +++ b/tcl7.6/doc/library.n @@ -1,30 +1,13 @@ '\" '\" Copyright (c) 1991-1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/library.n,v 1.11 93/08/28 16:05:59 ouster Exp $ SPRITE (Berkeley) -' +'\" SCCS: @(#) library.n 1.22 96/09/05 11:47:12 .so man.macros -.de UL -\\$1\l'|0\(ul'\\$2 -.. -.HS library tcl +.TH library n "" Tcl "Tcl Built-In Commands" .BS .SH NAME library \- standard library of Tcl procedures @@ -35,8 +18,6 @@ library \- standard library of Tcl procedures \fBauto_mkindex \fIdir pattern pattern ...\fR \fBauto_reset\fR \fBparray \fIarrayName\fR -\fBunknown \fIcmd \fR?\fIarg arg ...\fR? -.fi .BE .SH INTRODUCTION @@ -56,12 +37,14 @@ For example, the location of the Tk library is kept in the variable 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. +.CS +\fBsource [file join [info library] init.tcl]\fR +.CE +If the library procedure \fBTcl_Init\fR is invoked from an application's +\fBTcl_AppInit\fR procedure, this happens automatically. +The code in \fBinit.tcl\fR 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 @@ -70,7 +53,7 @@ The following procedures are provided in the Tcl library: \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 +(given by the PATH environment 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 @@ -91,14 +74,12 @@ 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 @@ -116,20 +97,19 @@ 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. +If no pattern is given a pattern of \fB*.tcl\fR will be assumed. For example, the command .RS -.DS +.CS \fBauto_mkindex foo *.tcl\fR -.DE +.CE .LP will read all the \fB.tcl\fR files in subdirectory \fBfoo\fR and generate a new index file \fBfoo/tclIndex\fR. @@ -157,41 +137,6 @@ 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 diff --git a/tcl7.6/doc/license.terms b/tcl7.6/doc/license.terms new file mode 100644 index 0000000..96ad966 --- /dev/null +++ b/tcl7.6/doc/license.terms @@ -0,0 +1,39 @@ +This software is copyrighted by the Regents of the University of +California, Sun Microsystems, Inc., and other parties. The following +terms apply to all files associated with the software unless explicitly +disclaimed in individual files. + +The authors hereby grant permission to use, copy, modify, distribute, +and license this software and its documentation for any purpose, provided +that existing copyright notices are retained in all copies and that this +notice is included verbatim in any distributions. No written agreement, +license, or royalty fee is required for any of the authorized uses. +Modifications to this software may be copyrighted by their authors +and need not follow the licensing terms described here, provided that +the new terms are clearly indicated on the first page of each file where +they apply. + +IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY +FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES +ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY +DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + +THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE +IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE +NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR +MODIFICATIONS. + +GOVERNMENT USE: If you are acquiring this software on behalf of the +U.S. government, the Government shall have only "Restricted Rights" +in the software and related documentation as defined in the Federal +Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you +are acquiring the software on behalf of the Department of Defense, the +software shall be classified as "Commercial Computer Software" and the +Government shall have only "Restricted Rights" as defined in Clause +252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the +authors grant the U.S. Government and others acting in its behalf +permission to use and distribute the software in accordance with the +terms specified in this license. diff --git a/tcl7.6/doc/lindex.n b/tcl7.6/doc/lindex.n new file mode 100644 index 0000000..cf0979c --- /dev/null +++ b/tcl7.6/doc/lindex.n @@ -0,0 +1,35 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) lindex.n 1.8 96/08/26 13:00:02 +'\" +.so man.macros +.TH lindex n 7.4 Tcl "Tcl Built-In Commands" +.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. +If \fIindex\fR has the value \fBend\fR, it refers to the last element +in the list. + +.SH KEYWORDS +element, index, list diff --git a/tcl7.6/doc/linsert.n b/tcl7.6/doc/linsert.n new file mode 100644 index 0000000..7d62b5f --- /dev/null +++ b/tcl7.6/doc/linsert.n @@ -0,0 +1,33 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) linsert.n 1.8 96/08/26 13:00:03 +'\" +.so man.macros +.TH linsert n 7.4 Tcl "Tcl Built-In Commands" +.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 +has the value \fBend\fR, +or if it 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/tcl7.6/doc/list.n b/tcl7.6/doc/list.n new file mode 100644 index 0000000..5a688cb --- /dev/null +++ b/tcl7.6/doc/list.n @@ -0,0 +1,45 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) list.n 1.9 96/08/26 13:00:04 +'\" +.so man.macros +.TH list n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +list \- Create a list +.SH SYNOPSIS +\fBlist \fR?\fIarg arg ...\fR? +.BE + +.SH DESCRIPTION +.PP +This command returns a list comprised of all the \fIarg\fRs, +or an empty string if no \fIarg\fRs are specified. +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 +.CS +\fBlist a b {c d e} {f {g h}}\fR +.CE +will return +.CS +\fBa b {c d e} {f {g h}}\fR +.CE +while \fBconcat\fR with the same arguments will return +.CS +\fBa b c d e f {g h}\fR +.CE + +.SH KEYWORDS +element, list diff --git a/tcl7.6/doc/llength.n b/tcl7.6/doc/llength.n new file mode 100644 index 0000000..874a965 --- /dev/null +++ b/tcl7.6/doc/llength.n @@ -0,0 +1,26 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) llength.n 1.5 96/03/25 20:19:25 +'\" +.so man.macros +.TH llength n "" Tcl "Tcl Built-In Commands" +.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/tcl7.6/doc/load.n b/tcl7.6/doc/load.n new file mode 100644 index 0000000..bba9223 --- /dev/null +++ b/tcl7.6/doc/load.n @@ -0,0 +1,116 @@ +'\" +'\" Copyright (c) 1995-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) load.n 1.7 96/09/05 11:19:14 +'\" +.so man.macros +.TH load n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +load \- Load machine code and initialize new commands. +.SH SYNOPSIS +\fBload \fIfileName\fR +.br +\fBload \fIfileName packageName\fR +.br +\fBload \fIfileName packageName interp\fR +.BE + +.SH DESCRIPTION +.PP +This command loads binary code from a file into the +application's address space and calls an initialization procedure +in the package to incorporate it into an interpreter. \fIfileName\fR +is the name of the file containing the code; its exact form varies +from system to system but on most systems it is a shared library, +such as a \fB.so\fR file under Solaris or a DLL under Windows. +\fIpackageName\fR is the name of the package, and is used to +compute the name of an initialization procedure. +\fIinterp\fR is the path name of the interpreter into which to load +the package (see the \fBinterp\fR manual entry for details); +if \fIinterp\fR is omitted, it defaults to the +interpreter in which the \fBload\fR command was invoked. +.PP +Once the file has been loaded into the application's address space, +one of two initialization procedures will be invoked in the new code. +Typically the initialization procedure will add new commands to a +Tcl interpreter. +The name of the initialization procedure is determined by +\fIpackageName\fR and whether or not the target interpreter +is a safe one. For normal interpreters the name of the initialization +procedure will have the form \fIpkg\fB_Init\fR, where \fIpkg\fR +is the same as \fIpackageName\fR except that the first letter is +converted to upper case and all other letters +are converted to lower case. For example, if \fIpackageName\fR is +\fBfoo\fR or \fBFOo\fR, the initialization procedure's name will +be \fBFoo_Init\fR. +.PP +If the target interpreter is a safe interpreter, then the name +of the initialization procedure will be \fIpkg\fB_SafeInit\fR +instead of \fIpkg\fB_Init\fR. +.PP +The initialization procedure must match the following prototype: +.CS +typedef int Tcl_PackageInitProc(Tcl_Interp *\fIinterp\fR); +.CE +The \fIinterp\fR argument identifies the interpreter in which the +package is to be loaded. The initialization procedure must return +\fBTCL_OK\fR or \fBTCL_ERROR\fR to indicate whether or not it completed +successfully; in the event of an error it should set \fIinterp->result\fR +to point to an error message. The result of the \fBload\fR command +will be the result returned by the initialization procedure. +.PP +The actual loading of a file will only be done once for each \fIfileName\fR +in an application. If a given \fIfileName\fR is loaded into multiple +interpreters, then the first \fBload\fR will load the code and +call the initialization procedure; subsequent \fBload\fRs will +call the initialization procedure without loading the code again. +It is not possible to unload or reload a package. +.PP +The \fBload\fR command also supports packages that are statically +linked with the application, if those packages have been registered +by calling the \fBTcl_StaticPackage\fR procedure. +If \fIfileName\fR is an empty string, then \fIpackageName\fR must +be specified. +.PP +If \fIpackageName\fR is omitted or specified as an empty string, +Tcl tries to guess the name of the package. +This may be done differently on different platforms. +The default guess, which is used on most UNIX platforms, is to +take the last element of \fIfileName\fR, strip off the first +three characters if they are \fBlib\fR, and use any following +.VS +alphabetic and underline characters as the module name. +.VE +For example, the command \fBload libxyz4.2.so\fR uses the module +name \fBxyz\fR and the command \fBload bin/last.so {}\fR uses the +module name \fBlast\fR. +.VS br +.PP +If \fIfileName\fR is an empty string, then \fIpackageName\fR must +be specified. +The \fBload\fR command first searches for a statically loaded package +(one that has been registered by calling the \fBTcl_StaticPackage\fR +procedure) by that name; if one is found, it is used. +Otherwise, the \fBload\fR command searches for a dynamically loaded +package by that name, and uses it if it is found. If several +different files have been \fBload\fRed with different versions of +the package, Tcl picks the file that was loaded first. +.VE + +.SH BUGS +.PP +If the same file is \fBload\fRed by different \fIfileName\fRs, it will +be loaded into the process's address space multiple times. The +behavior of this varies from system to system (some systems may +detect the redundant loads, others may not). + +.SH "SEE ALSO" +\fBinfo sharedlibextension\fR, Tcl_StaticPackage + +.SH KEYWORDS +binary code, loading, shared library diff --git a/tcl7.6/doc/lrange.n b/tcl7.6/doc/lrange.n new file mode 100644 index 0000000..8a5d98c --- /dev/null +++ b/tcl7.6/doc/lrange.n @@ -0,0 +1,39 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) lrange.n 1.9 96/08/26 13:00:05 +'\" +.so man.macros +.TH lrange n 7.4 Tcl "Tcl Built-In Commands" +.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\fR +.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. +\fIFirst\fR or \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/tcl7.6/doc/lreplace.n b/tcl7.6/doc/lreplace.n new file mode 100644 index 0000000..0065da5 --- /dev/null +++ b/tcl7.6/doc/lreplace.n @@ -0,0 +1,43 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) lreplace.n 1.9 96/08/26 13:00:07 +'\" +.so man.macros +.TH lreplace n 7.4 Tcl "Tcl Built-In Commands" +.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 (0 refers to the first element). +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. +If \fIlast\fR is less than \fIfirst\fR then no elements are deleted; +the new elements are simply inserted before \fIfirst\fR. +\fIFirst\fR or \fIlast\fR may be \fBend\fR +(or any abbreviation of it) to refer to the last element of the list. +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/tcl7.3/doc/lsearch.n b/tcl7.6/doc/lsearch.n similarity index 51% rename from tcl7.3/doc/lsearch.n rename to tcl7.6/doc/lsearch.n index af87eb7..aca019d 100644 --- a/tcl7.3/doc/lsearch.n +++ b/tcl7.6/doc/lsearch.n @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/lsearch.n,v 1.2 93/05/07 14:27:07 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) lsearch.n 1.7 96/08/26 13:00:05 '\" .so man.macros -.HS lsearch tcl 7.0 +.TH lsearch n 7.0 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -37,7 +24,6 @@ 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: @@ -54,7 +40,6 @@ element using the same rules as the \fBstring match\fR command. 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/tcl7.3/doc/lsort.n b/tcl7.6/doc/lsort.n similarity index 57% rename from tcl7.3/doc/lsort.n rename to tcl7.6/doc/lsort.n index a9985d1..c29934a 100644 --- a/tcl7.3/doc/lsort.n +++ b/tcl7.6/doc/lsort.n @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/lsort.n,v 1.2 93/05/07 16:48:45 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) lsort.n 1.7 96/08/26 13:00:06 '\" .so man.macros -.HS lsort tcl 7.0 +.TH lsort n 7.0 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -35,7 +22,6 @@ lsort \- Sort the elements of a list 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): @@ -66,7 +52,6 @@ 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/tcl7.6/doc/man.macros b/tcl7.6/doc/man.macros new file mode 100644 index 0000000..67e6012 --- /dev/null +++ b/tcl7.6/doc/man.macros @@ -0,0 +1,234 @@ +'\" The definitions below are for supplemental macros used in Tcl/Tk +'\" manual entries. +'\" +'\" .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. +'\" +'\" .CS +'\" Begin code excerpt. +'\" +'\" .CE +'\" End code excerpt. +'\" +'\" .VS ?br? +'\" Begin vertical sidebar, for use in marking newly-changed parts +'\" of man pages. If an argument is present, then a line break is +'\" forced before starting the sidebar. +'\" +'\" .VE +'\" End of vertical sidebar. +'\" +'\" .DS +'\" Begin an indented unfilled display. +'\" +'\" .DE +'\" End of indented unfilled display. +'\" +'\" .SO +'\" Start of list of standard options for a Tk widget. The +'\" options follow on successive lines, in four columns separated +'\" by tabs. +'\" +'\" .SE +'\" End of list of standard options for a Tk widget. +'\" +'\" .OP cmdName dbName dbClass +'\" Start of description of a specific option. cmdName gives the +'\" option's name as specified in the class command, dbName gives +'\" the option's name in the option database, and dbClass gives +'\" the option's class in the option database. +'\" +'\" .UL arg1 arg2 +'\" Print arg1 underlined, then print arg2 normally. +'\" +'\" SCCS: @(#) man.macros 1.8 96/02/15 20:02:24 +'\" +'\" # Set up traps and other miscellaneous stuff for Tcl/Tk man pages. +.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 +.. +.AS Tcl_Interp Tcl_CreateInterp in/out +'\" # 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 +.if !"\\$1"" .br +.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 +.. +'\" # SO - start of list of standard options +.de SO +.SH "STANDARD OPTIONS" +.LP +.nf +.ta 4c 8c 12c +.ft B +.. +'\" # SE - end of list of standard options +.de SE +.fi +.ft R +.LP +See the \\fBoptions\\fR manual entry for details on the standard options. +.. +'\" # OP - start of full description for a single option +.de OP +.LP +.nf +.ta 4c +Command-Line Name: \\fB\\$1\\fR +Database Name: \\fB\\$2\\fR +Database Class: \\fB\\$3\\fR +.fi +.IP +.. +'\" # CS - begin code excerpt +.de CS +.RS +.nf +.ta .25i .5i .75i 1i +.. +'\" # CE - end code excerpt +.de CE +.fi +.RE +.. +.de UL +\\$1\l'|0\(ul'\\$2 +.. diff --git a/tcl7.6/doc/open.n b/tcl7.6/doc/open.n new file mode 100644 index 0000000..57cf9a8 --- /dev/null +++ b/tcl7.6/doc/open.n @@ -0,0 +1,210 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) open.n 1.15 96/09/18 15:05:40 +'\" +.so man.macros +.TH open n 7.6 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +open \- Open a file-based or command pipeline channel +.SH SYNOPSIS +.sp +\fBopen \fIfileName\fR +.br +\fBopen \fIfileName access\fR +.br +\fBopen \fIfileName access permissions\fR +.BE + +.SH DESCRIPTION +.PP +This command opens a file or command pipeline and returns a channel +identifier that may be used in future invocations of commands like +\fBread\fR, \fBputs\fR, and \fBclose\fR. +If the first character of \fIfileName\fR is not \fB|\fR then +the command opens a file: +\fIfileName\fR gives the name of the file to open, and it must conform to the +conventions described in the \fBfilename\fR manual entry. +.PP +The \fIaccess\fR argument, if present, indicates the way in which the file +(or command pipeline) is to be accessed. +In the first form \fIaccess\fR may have any of the following values: +.TP 15 +\fBr\fR +Open the file for reading only; the file must already exist. This is the +default value if \fIaccess\fR is not specified. +.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 +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 also specified, 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, and +possibly in subsequent I/O operations. The exact behavior of +this flag is system- and device-dependent; its use is discouraged +(it is better to use the \fBfconfigure\fR command to put a file +in nonblocking mode). +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. +.SH "COMMAND PIPELINES" +.PP +If the first character of \fIfileName\fR is ``|'' then the +remaining characters of \fIfileName\fR are treated as a list of arguments +that describe a command pipeline to invoke, in the same style as the +arguments for \fBexec\fR. +In this case, the channel identifier returned by \fBopen\fR may be used +to write to the command's input pipe or read from its output pipe, +depending on the value of \fIaccess\fR. +If write-only access is used (e.g. \fIaccess\fR is \fBw\fR), then +standard output for the pipeline is directed to the current standard +output unless overridden by the command. +If read-only access is used (e.g. \fIaccess\fR is \fBr\fR), +standard input for the pipeline is taken from the current standard +input unless overridden by the command. + +.VS +.SH "PORTABILITY ISSUES" +.sp +.TP +\fBWindows NT\fR +. +When running Tcl interactively, there may be some strange interactions +between the real console, if one is present, and a command pipeline that uses +standard input or output. If a command pipeline is opened for reading, some +of the lines entered at the console will be sent to the command pipeline and +some will be sent to the Tcl evaluator. If a command pipeline is opened for +writing, keystrokes entered into the console are not visible until the the +pipe is closed. This behavior occurs whether the command pipeline is +executing 16-bit or 32-bit applications. These problems only occur because +both Tcl and the child application are competing for the console at +the same time. If the command pipeline is started from a script, so that Tcl +is not accessing the console, or if the command pipeline does not use +standard input or output, but is redirected from or to a file, then the +above problems do not occur. +.TP +\fBWindows 95\fR +. +A command pipeline that executes a 16-bit DOS application cannot be opened +for both reading and writing, since 16-bit DOS applications that receive +standard input from a pipe and send standard output to a pipe run +synchronously. Command pipelines that do not execute 16-bit DOS +applications run asynchronously and can be opened for both reading and +writing. +.sp +When running Tcl interactively, there may be some strange interactions +between the real console, if one is present, and a command pipeline that uses +standard input or output. If a command pipeline is opened for reading from +a 32-bit application, some of the keystrokes entered at the console will be +sent to the command pipeline and some will be sent to the Tcl evaluator. If +a command pipeline is opened for writing to a 32-bit application, no output +is visible on the console until the the pipe is closed. These problems only +occur because both Tcl and the child application are competing for the +console at the same time. If the command pipeline is started from a script, +so that Tcl is not accessing the console, or if the command pipeline does +not use standard input or output, but is redirected from or to a file, then +the above problems do not occur. +.sp +Whether or not Tcl is running interactively, if a command pipeline is opened +for reading from a 16-bit DOS application, the call to \fBopen\fR will not +return until end-of-file has been received from the command pipeline's +standard output. If a command pipeline is opened for writing to a 16-bit DOS +application, no data will be sent to the command pipeline's standard output +until the pipe is actually closed. This problem occurs because 16-bit DOS +applications are run synchronously, as described above. +.TP +\fBWindows 3.X\fR +. +A command pipeline can execute 16-bit or 32-bit DOS or Windows +applications, but the call to \fBopen\fR will not return until the last +program in the pipeline has finished executing; command pipelines run +synchronously. If the pipeline is opened with write access (either just +writing or both reading and writing) the first application in the +pipeline will instead see an immediate end-of-file; any data the caller +writes to the open pipe will instead be discarded. +.sp +Since Tcl cannot be run with a real console under Windows 3.X, there are +no interactions between command pipelines and the console. +.TP +\fBMacintosh\fR +Opening a command pipeline is not supported under Macintosh, since +applications do not support the concept of standard input or output. +.TP +\fBUnix\fR\0\0\0\0\0\0\0 +When running Tcl interactively, there may be some strange interactions +between the console, if one is present, and a command pipeline that uses +standard input. If a command pipeline is opened for reading, some +of the lines entered at the console will be sent to the command pipeline and +some will be sent to the Tcl evaluator. This problem only occurs because +both Tcl and the child application are competing for the console at the +same time. If the command pipeline is started from a script, so that Tcl is +not accessing the console, or if the command pipeline does not use standard +input, but is redirected from a file, then the above problem does not occur. +.LP +See the PORTABILITY ISSUES section of the \fBexec\fR command for additional +information not specific to command pipelines about executing +applications on the various platforms +.SH "SEE ALSO" +close(n), filename(n), gets(n), read(n), puts(n), exec(n) +.VE +.SH KEYWORDS +access mode, append, create, file, non-blocking, open, permissions, +pipeline, process diff --git a/tcl7.6/doc/package.n b/tcl7.6/doc/package.n new file mode 100644 index 0000000..b485caa --- /dev/null +++ b/tcl7.6/doc/package.n @@ -0,0 +1,188 @@ +'\" +'\" Copyright (c) 1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) package.n 1.5 96/03/18 14:17:31 +'\" +.so man.macros +.TH package n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +package \- Facilities for package loading and version control +.SH SYNOPSIS +.nf +\fBpackage forget \fIpackage\fR +\fBpackage ifneeded \fIpackage version\fR ?\fIscript\fR? +\fBpackage names\fR +\fBpackage provide \fIpackage \fR?\fIversion\fR? +\fBpackage require \fR?\fB\-exact\fR? \fIpackage \fR?\fIversion\fR? +\fBpackage unknown \fR?\fIcommand\fR? +\fBpackage vcompare \fIversion1 version2\fR +\fBpackage versions \fIpackage\fR +\fBpackage vsatisfies \fIversion1 version2\fR +.fi +.BE + +.SH DESCRIPTION +.PP +This command keeps a simple database of the packages available for +use by the current interpreter and how to load them into the +interpreter. +It supports multiple versions of each package and arranges +for the correct version of a package to be loaded based on what +is needed by the application. +This command also detects and reports version clashes. +Typically, only the \fBpackage require\fR and \fBpackage provide\fR +commands are invoked in normal Tcl scripts; the other commands are used +primarily by system scripts that maintain the package database. +.PP +The behavior of the \fBpackage\fR command is determined by its first argument. +The following forms are permitted: +.TP +\fBpackage forget \fIpackage\fR +Removes all information about \fIpackage\fR from this interpreter, +including information provided by both \fBpackage ifneeded\fR and +\fBpackage provide\fR. +.TP +\fBpackage ifneeded \fIpackage version\fR ?\fIscript\fR? +This command typically appears only in system configuration +scripts to set up the package database. +It indicates that a particular version of +a particular package is available if needed, and that the package +can be added to the interpreter by executing \fIscript\fR. +The script is saved in a database for use by subsequent +\fBpackage require\fR commands; typically, \fIscript\fR +sets up auto-loading for the commands in the package (or calls +\fBload\fR and/or \fBsource\fR directly), then invokes +\fBpackage provide\fR to indicate that the package is present. +There may be information in the database for several different +versions of a single package. +If the database already contains information for \fIpackage\fR +and \fIversion\fR, the new \fIscript\fR replaces the existing +one. +If the \fIscript\fR argument is omitted, the current script for +version \fIversion\fR of package \fIpackage\fR is returned, +or an empty string if no \fBpackage ifneeded\fR command has +been invoked for this \fIpackage\fR and \fIversion\fR. +.TP +\fBpackage names\fR +Returns a list of the names of all packages in the +interpreter for which a version has been provided (via +\fBpackage provide\fR) or for which a \fBpackage ifneeded\fR +script is available. +The order of elements in the list is arbitrary. +.TP +\fBpackage provide \fIpackage \fR?\fIversion\fR? +This command is invoked to indicate that version \fIversion\fR +of package \fIpackage\fR is now present in the interpreter. +It is typically invoked once as part of an \fBifneeded\fR script, +and again by the package itself when it is finally loaded. +An error occurs if a different version of \fIpackage\fR has been +provided by a previous \fBpackage provide\fR command. +If the \fIversion\fR argument is omitted, then the command +returns the version number that is currently provided, or an +empty string if no \fBpackage provide\fR command has been +invoked for \fIpackage\fR in this interpreter. +.TP +\fBpackage require \fR?\fB\-exact\fR? \fIpackage \fR?\fIversion\fR? +This command is typically invoked by Tcl code that wishes to use +a particular version of a particular package. The arguments +indicate which package is wanted, and the command ensures that +a suitable version of the package is loaded into the interpreter. +If the command succeeds, it returns the version number that is +loaded; otherwise it generates an error. +If both the \fB\-exact\fR +switch and the \fIversion\fR argument are specified then only the +given version is acceptable. If \fB\-exact\fR is omitted but +\fIversion\fR is specified, then versions later than \fIversion\fR +are also acceptable as long as they have the same major version +number as \fIversion\fR. +If both \fB\-exact\fR and \fIversion\fR are omitted then any +version whatsoever is acceptable. +If a version of \fIpackage\fR has already been provided (by invoking +the \fBpackage provide\fR command), then its version number must +satisfy the criteria given by \fB\-exact\fR and \fIversion\fR and +the command returns immediately. +Otherwise, the command searches the database of information provided by +previous \fBpackage ifneeded\fR commands to see if an acceptable +version of the package is available. +If so, the script for the highest acceptable version number is invoked; +it must do whatever is necessary to load the package, +including calling \fBpackage provide\fR for the package. +If the \fBpackage ifneeded\fR database does not contain an acceptable +version of the package and a \fBpackage unknown\fR command has been +specified for the interpreter then that command is invoked; when +it completes, Tcl checks again to see if the package is now provided +or if there is a \fBpackage ifneeded\fR script for it. +If all of these steps fail to provide an acceptable version of the +package, then the command returns an error. +.TP +\fBpackage unknown \fR?\fIcommand\fR? +This command supplies a ``last resort'' command to invoke during +\fBpackage require\fR if no suitable version of a package can be found +in the \fBpackage ifneeded\fR database. +If the \fIcommand\fR argument is supplied, it contains the first part +of a command; when the command is invoked during a \fBpackage require\fR +command, Tcl appends two additional arguments giving the desired package +name and version. +For example, if \fIcommand\fR is \fBfoo bar\fR and later the command +\fBpackage require test 2.4\fR is invoked, then Tcl will execute +the command \fBfoo bar test 2.4\fR to load the package. +If no version number is supplied to the \fBpackage require\fR command, +then the version argument for the invoked command will be an empty string. +If the \fBpackage unknown\fR command is invoked without a \fIcommand\fR +argument, then the current \fBpackage unknown\fR script is returned, +or an empty string if there is none. +If \fIcommand\fR is specified as an empty string, then the current +\fBpackage unknown\fR script is removed, if there is one. +.TP +\fBpackage vcompare \fIversion1 version2\fR +Compares the two version numbers given by \fIversion1\fR and \fIversion2\fR. +Returns -1 if \fIversion1\fR is an earlier version than \fIversion2\fR, +0 if they are equal, and 1 if \fIversion1\fR is later than \fBversion2\fR. +.TP +\fBpackage versions \fIpackage\fR +Returns a list of all the version numbers of \fIpackage\fR +for which information has been provided by \fBpackage ifneeded\fR +commands. +.TP +\fBpackage vsatisfies \fIversion1 version2\fR +Returns 1 if scripts written for \fIversion2\fR will work unchanged +with \fIversion1\fR (i.e. \fIversion1\fR is equal to or greater +than \fIversion2\fR and they both have the same major version +number), 0 otherwise. + +.SH "VERSION NUMBERS" +.PP +Version numbers consist of one or more decimal numbers separated +by dots, such as 2 or 1.162 or 3.1.13.1. +The first number is called the major version number. +Larger numbers correspond to later versions of a package, with +leftmost numbers having greater significance. +For example, version 2.1 is later than 1.3 and version +3.4.6 is later than 3.3.5. +Missing fields are equivalent to zeroes: version 1.3 is the +same as version 1.3.0 and 1.3.0.0, so it is earlier than 1.3.1 or 1.3.0.2. +A later version number is assumed to be upwards compatible with +an earlier version number as long as both versions have the same +major version number. +For example, Tcl scripts written for version 2.3 of a package should +work unchanged under versions 2.3.2, 2.4, and 2.5.1. +Changes in the major version number signify incompatible changes: +if code is written to use version 2.1 of a package, it is not guaranteed +to work unmodified with either version 1.7.3 or version 3.1. + +.SH "PACKAGE INDICES" +.PP +The recommended way to use packages in Tcl is to invoke \fBpackage require\fR +and \fBpackage provide\fR commands in scripts, and use the procedure +\fBpkg_mkIndex\fR to create package index files. +Once you've done this, packages will be loaded automatically +in response to \fBpackage require\fR commands. +See the documentation for \fBpkg_mkIndex\fR for details. + +.SH KEYWORDS +package, version diff --git a/tcl7.6/doc/pid.n b/tcl7.6/doc/pid.n new file mode 100644 index 0000000..2db8b32 --- /dev/null +++ b/tcl7.6/doc/pid.n @@ -0,0 +1,34 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) pid.n 1.5 96/03/25 20:20:57 +'\" +.so man.macros +.TH pid n 7.0 Tcl "Tcl Built-In Commands" +.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/tcl7.6/doc/pkgMkIndex.n b/tcl7.6/doc/pkgMkIndex.n new file mode 100644 index 0000000..a0f32fd --- /dev/null +++ b/tcl7.6/doc/pkgMkIndex.n @@ -0,0 +1,135 @@ +'\" +'\" Copyright (c) 1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) pkgMkIndex.n 1.6 96/10/04 11:31:53 +'\" +.so man.macros +.TH pkg_mkIndex n 7.6 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +pkg_mkIndex \- Build an index for automatic loading of packages +.SH SYNOPSIS +.nf +\fBpkg_mkIndex \fIdir \fIpattern \fR?\fIpattern pattern ...\fR? +.fi +.BE + +.SH DESCRIPTION +.PP +\fBPkg_mkIndex\fR is a utility procedure that is part of the standard +Tcl library. +It is used to create index files that allow packages to be loaded +automatically when \fBpackage require\fR commands are executed. +To use \fBpkg_mkIndex\fR, follow these steps: +.IP [1] +Create the package(s). +Each package may consist of one or more Tcl script files or binary files. +Binary files must be suitable for loading with the \fBload\fR command +with a single argument; for example, if the file is \fBtest.so\fR it must +be possible to load this file with the command \fBload test.so\fR. +Each script file must contain a \fBpackage provide\fR command to declare +the package and version number, and each binary file must contain +a call to \fBTcl_PkgProvide\fR. +.IP [2] +Create the index by invoking \fBpkg_mkIndex\fR. +The \fIdir\fR argument gives the name of a directory and each +\fIpattern\fR argument is a \fBglob\fR-style pattern that selects +script or binary files in \fIdir\fR. +\fBPkg_mkIndex\fR will create a file \fBpkgIndex.tcl\fR in \fIdir\fR +with package information about all the files given by the \fIpattern\fR +arguments. +It does this by loading each file and seeing what packages +and new commands appear (this is why it is essential to have +\fBpackage provide\fR commands or \fBTcl_PkgProvide\fR calls +in the files, as described above). +.VS br +.IP [3] +Install the package as a subdirectory of one of the directories given by +the \fBtcl_pkgPath\fR variable. If \fB$tcl_pkgPath\fR contains more +than one directory, machine-dependent packages (e.g., those that +contain binary shared libraries) should normally be installed +under the first directory and machine-independent packages (e.g., +those that contain only Tcl scripts) should be installed under the +second directory. +The subdirectory should include +the package's script and/or binary files as well as the \fBpkgIndex.tcl\fR +file. As long as the package is installed as a subdirectory of a +directory in \fB$tcl_pkgPath\fR it will automatically be found during +\fBpackage require\fR commands. +.RS +.LP +If you install the package anywhere else, then you must ensure that +the directory contaiingn the package is in the \fBauto_path\fR global variable +or an immediate subdirectory of one of the directories in \fBauto_path\fR. +\fBAuto_path\fR contains a list of directories that are searched +by both the auto-loader and the package loader; by default it +includes \fB$tcl_pkgPath\fR. +The package loader also checks all of the subdirectories of the +directories in \fBauto_path\fR. +.VE +You can add a directory to \fBauto_path\fR explicitly in your +application, or you can add the directory to your \fBTCLLIBPATH\fR +environment variable: if this environment variable is present, +Tcl initializes \fBauto_path\fR from it during application startup. +.RE +.IP [4] +Once the above steps have been taken, all you need to do to use a +package is to invoke \fBpackage require\fR. +For example, if versions 2.1, 2.3, and 3.1 of package \fBTest\fR +have been indexed by \fBpkg_mkIndex\fR, the command +\fBpackage require Test\fR will make version 3.1 available +and the command \fBpackage require \-exact Test 2.1\fR will +make version 2.1 available. +There may be many versions of a package in the various index files +in \fBauto_path\fR, but only one will actually be loaded in a given +interpreter, based on the first call to \fBpackage require\fR. +Different versions of a package may be loaded in different +interpreters. + +.SH "PACKAGES AND THE AUTO-LOADER" +.PP +The package management facilities overlap somewhat with the auto-loader, +in that both arrange for files to be loaded on-demand. +However, package management is a higher-level mechanism that uses +the auto-loader for the last step in the loading process. +It is generally better to index a package with \fBpkg_mkIndex\fR +rather than \fBauto_mkindex\fR because the package mechanism provides +version control: several versions of a package can be made available +in the index files, with different applications using different +versions based on \fBpackage require\fR commands. +In contrast, \fBauto_mkindex\fR does not understand versions so +it can only handle a single version of each package. +It is probably not a good idea to index a given package with both +\fBpkg_mkIndex\fR and \fBauto_mkindex\fR. +If you use \fBpkg_mkIndex\fR to index a package, its commands cannot +be invoked until \fBpackage require\fR has been used to select a +version; in contrast, packages indexed with \fBauto_mkindex\fR +can be used immediately since there is no version control. + +.SH "HOW IT WORKS" +.PP +\fBPkg_mkIndex\fR depends on the \fBpackage unknown\fR command, +the \fBpackage ifneeded\fR command, and the auto-loader. +The first time a \fBpackage require\fR command is invoked, +the \fBpackage unknown\fR script is invoked. +This is set by Tcl initialization to a script that +evaluates all of the \fBpkgIndex.tcl\fR files in the +\fBauto_path\fR. +The \fBpkgIndex.tcl\fR files contain \fBpackage ifneeded\fR +commands for each version of each available package; these commands +invoke \fBpackage provide\fR commands to announce the +availability of the package, and they setup auto-loader +information to load the files of the package. +A given file of a given version of a given package isn't +actually loaded until the first time one of its commands +is invoked. +Thus, after invoking \fBpackage require\fR you won't see +the package's commands in the interpreter, but you will be able +to invoke the commands and they will be auto-loaded. + +.SH KEYWORDS +auto-load, index, package, version diff --git a/tcl7.3/doc/proc.n b/tcl7.6/doc/proc.n similarity index 70% rename from tcl7.3/doc/proc.n rename to tcl7.6/doc/proc.n index 1406120..85ee2da 100644 --- a/tcl7.3/doc/proc.n +++ b/tcl7.6/doc/proc.n @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/proc.n,v 1.1 93/05/10 17:10:18 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) proc.n 1.5 96/03/25 20:21:12 '\" .so man.macros -.HS proc tcl +.TH proc n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/tcl7.6/doc/puts.n b/tcl7.6/doc/puts.n new file mode 100644 index 0000000..e455071 --- /dev/null +++ b/tcl7.6/doc/puts.n @@ -0,0 +1,69 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) puts.n 1.11 96/08/26 13:00:09 +'\" +.so man.macros +.TH puts n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +puts \- Write to a channel +.SH SYNOPSIS +\fBputs \fR?\fB\-nonewline\fR? ?\fIchannelId\fR? \fIstring\fR +.BE + +.SH DESCRIPTION +.PP +Writes the characters given by \fIstring\fR to the channel given +by \fIchannelId\fR. +\fIChannelId\fR must be a channel identifier such as returned from a +previous invocation of \fBopen\fR or \fBsocket\fR. It must have been opened +for output. If no \fIchannelId\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. +.PP +Newline characters in the output are translated by \fBputs\fR to +platform-specific end-of-line sequences according to the current +value of the \fB\-translation\fR option for the channel (for example, +on PCs newlines are normally replaced with carriage-return-linefeed +sequences; on Macintoshes newlines are normally replaced with +carriage-returns). +See the \fBfconfigure\fR manual entry for a discussion of end-of-line +translations. +.PP +Tcl buffers output internally, so characters written with \fBputs\fR +may not appear immediately on the output file or device; Tcl will +normally delay output until the buffer is full or the channel is +closed. +You can force output to appear immediately with the \fBflush\fR +command. +.PP +When the output buffer fills up, the \fBputs\fR command will normally +block until all the buffered data has been accepted for output by the +operating system. +If \fIchannelId\fR is in nonblocking mode then the \fBputs\fR command +will not block even if the operating system cannot accept the data. +Instead, Tcl continues to buffer the data and writes it in the +background as fast as the underlying file or device can accept it. +The application must use the Tcl event loop for nonblocking output +to work; otherwise Tcl never finds out that the file or device is +ready for more output data. +It is possible for an arbitrarily large amount of data to be +buffered for a channel in nonblocking mode, which could consume a +large amount of memory. +To avoid wasting memory, nonblocking I/O should normally +be used in an event-driven fashion with the \fBfileevent\fR command +(don't invoke \fBputs\fR unless you have recently been notified +via a file event that the channel is ready for more output data). + +.SH "SEE ALSO" +fileevent(n) + +.SH KEYWORDS +channel, newline, output, write diff --git a/tcl7.6/doc/pwd.n b/tcl7.6/doc/pwd.n new file mode 100644 index 0000000..adc8811 --- /dev/null +++ b/tcl7.6/doc/pwd.n @@ -0,0 +1,25 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) pwd.n 1.5 96/03/25 20:21:30 +'\" +.so man.macros +.TH pwd n "" Tcl "Tcl Built-In Commands" +.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/tcl7.6/doc/read.n b/tcl7.6/doc/read.n new file mode 100644 index 0000000..20206fe --- /dev/null +++ b/tcl7.6/doc/read.n @@ -0,0 +1,50 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) read.n 1.15 96/08/26 13:00:09 +'\" +.so man.macros +.TH read n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +read \- Read from a channel +.SH SYNOPSIS +\fBread \fR?\fB\-nonewline\fR? \fIchannelId\fR +.sp +\fBread \fIchannelId numBytes\fR +.BE + +.SH DESCRIPTION +.PP +In the first form, the \fBread\fR command reads all of the data from +\fIchannelId\fR up to the end of the file. +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 that many bytes will be read and returned, unless +there are fewer than \fInumBytes\fR left in the file; in this case +all the remaining bytes are returned. +.PP +If \fIchannelId\fR is in nonblocking mode, the command may not read +as many bytes as requested: once all available input has been read, +the command will return the data that is available rather than blocking +for more input. +The \fB\-nonewline\fR switch is ignored if the command returns +before reaching the end of the file. +.PP +\fBRead\fR translates end-of-line sequences in the input into +newline characters according to the \fB\-translation\fR option +for the channel. +See the manual entry for \fBfconfigure\fR for details on the +\fB\-translation\fR option. + +.SH "SEE ALSO" +eof(n), fblocked(n), fconfigure(n) + +.SH KEYWORDS +blocking, channel, end of line, end of file, nonblocking, read, translation diff --git a/tcl7.3/doc/regexp.n b/tcl7.6/doc/regexp.n similarity index 81% rename from tcl7.3/doc/regexp.n rename to tcl7.6/doc/regexp.n index b3a5d71..f3951ee 100644 --- a/tcl7.3/doc/regexp.n +++ b/tcl7.6/doc/regexp.n @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/regexp.n,v 1.4 93/08/03 16:37:28 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) regexp.n 1.12 96/08/26 13:00:10 '\" .so man.macros -.HS regexp tcl +.TH regexp n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -46,7 +33,6 @@ 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 @@ -64,8 +50,7 @@ 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 +be treated as \fIexp\fR even if it starts with a \fB\-\fR. .LP If there are more \fIsubMatchVar\fR's than parenthesized subexpressions within \fIexp\fR, or if a particular subexpression @@ -115,15 +100,15 @@ To include a literal ``\-'', make it the first or last character. .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 +.CS +\fBregexp (a*)b* aabaaabb x y\fR +.CE 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 +In other words, it considers 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 @@ -145,9 +130,9 @@ 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 +.CS +\fBregexp (ab|a)(b*)c abc x y z\fR +.CE 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 diff --git a/tcl7.3/doc/regsub.n b/tcl7.6/doc/regsub.n similarity index 65% rename from tcl7.3/doc/regsub.n rename to tcl7.6/doc/regsub.n index 0a3e704..62720ac 100644 --- a/tcl7.3/doc/regsub.n +++ b/tcl7.6/doc/regsub.n @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/regsub.n,v 1.2 93/06/17 13:31:43 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) regsub.n 1.9 96/08/26 13:00:11 '\" .so man.macros -.HS regsub tcl +.TH regsub n 7.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -34,13 +21,10 @@ regsub \- Perform substitutions based on regular expression pattern matching .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 @@ -58,7 +42,6 @@ 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 @@ -78,9 +61,10 @@ 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 +be treated as \fIexp\fR even if it starts with a \fB\-\fR. .PP +The command returns a count of the number of matching ranges that +were found and replaced. See the manual entry for \fBregexp\fR for details on the interpretation of regular expressions. diff --git a/tcl7.6/doc/rename.n b/tcl7.6/doc/rename.n new file mode 100644 index 0000000..a3e185d --- /dev/null +++ b/tcl7.6/doc/rename.n @@ -0,0 +1,28 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) rename.n 1.5 96/03/25 20:22:11 +'\" +.so man.macros +.TH rename n "" Tcl "Tcl Built-In Commands" +.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/tcl7.3/doc/return.n b/tcl7.6/doc/return.n similarity index 72% rename from tcl7.3/doc/return.n rename to tcl7.6/doc/return.n index cb80b61..fdf783b 100644 --- a/tcl7.3/doc/return.n +++ b/tcl7.6/doc/return.n @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/return.n,v 1.8 93/08/03 16:15:41 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) return.n 1.13 96/08/26 13:00:12 '\" .so man.macros -.HS return tcl 7.0 +.TH return n 7.0 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -40,7 +27,6 @@ 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 @@ -98,7 +84,6 @@ 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/tcl7.3/doc/scan.n b/tcl7.6/doc/scan.n similarity index 77% rename from tcl7.3/doc/scan.n rename to tcl7.6/doc/scan.n index b2b1520..96121f8 100644 --- a/tcl7.3/doc/scan.n +++ b/tcl7.6/doc/scan.n @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/scan.n,v 1.3 93/08/04 17:18:42 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) scan.n 1.12 96/08/26 13:00:13 '\" .so man.macros -.HS scan tcl +.TH scan n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -34,7 +21,8 @@ scan \- Parse string using conversion specifiers in the style of sscanf .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. +of conversions performed, or -1 if the end of the input string is +reached before any conversions have been performed. \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 @@ -45,9 +33,10 @@ and assigned to the corresponding variable. .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. +matches any number of white space characters in \fIstring\fR (including +zero). Otherwise, if it isn't a \fB%\fR character then it -must match the next non-white-space character of \fIstring\fR. +must match the next 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: @@ -90,13 +79,13 @@ 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 optional sign, a string of decimal digits possibly +containing 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] +\fB[\fIchars\fB]\fR The input field consists of any number of characters in \fIchars\fR. The matching string is stored in the variable. @@ -104,7 +93,7 @@ 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] +\fB[^\fIchars\fB]\fR The input field consists of any number of characters not in \fIchars\fR. The matching string is stored in the variable. @@ -127,23 +116,19 @@ then no variable is assigned and the next scan argument is not consumed. 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/tcl7.6/doc/seek.n b/tcl7.6/doc/seek.n new file mode 100644 index 0000000..ac796e6 --- /dev/null +++ b/tcl7.6/doc/seek.n @@ -0,0 +1,55 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) seek.n 1.10 96/08/26 13:00:14 +'\" +.so man.macros +.TH seek n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +seek \- Change the access position for an open channel +.SH SYNOPSIS +\fBseek \fIchannelId offset \fR?\fIorigin\fR? +.BE + +.SH DESCRIPTION +.PP +Changes the current access position for \fIchannelId\fR. +\fIChannelId\fR must be a channel identifier such as returned from a +previous invocation of \fBopen\fR or \fBsocket\fR. +The \fIoffset\fR and \fIorigin\fR +arguments specify the position at which the next read or write will occur +for \fIchannelId\fR. \fIOffset\fR must be an integer (which may be +negative) and \fIorigin\fR must be one of the following: +.TP 10 +\fBstart\fR +The new access position will be \fIoffset\fR bytes from the start +of the underlying file or device. +.TP 10 +\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 underlying file or device. +.TP 10 +\fBend\fR +The new access position will be \fIoffset\fR bytes from the end of +the file or device. 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. +.PP +The command flushes all buffered output for the channel before the command +returns, even if the channel is in nonblocking mode. +It also discards any buffered and unread input. +This command returns an empty string. +An error occurs if this command is applied to channels whose underlying +file or device does not support seeking. + +.SH KEYWORDS +access position, file, seek diff --git a/tcl7.3/doc/set.n b/tcl7.6/doc/set.n similarity index 50% rename from tcl7.3/doc/set.n rename to tcl7.6/doc/set.n index 1fda124..84f63ee 100644 --- a/tcl7.3/doc/set.n +++ b/tcl7.6/doc/set.n @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/set.n,v 1.1 93/06/07 16:48:27 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) set.n 1.5 96/03/25 20:23:07 '\" .so man.macros -.HS set tcl +.TH set n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/tcl7.6/doc/socket.n b/tcl7.6/doc/socket.n new file mode 100644 index 0000000..1377497 --- /dev/null +++ b/tcl7.6/doc/socket.n @@ -0,0 +1,125 @@ +'\" +'\" Copyright (c) 1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) socket.n 1.13 96/04/05 12:05:26 +.so man.macros +.TH socket n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +socket \- Open a TCP network connection +.SH SYNOPSIS +.sp +\fBsocket \fR?\fIoptions\fR? \fIhost port\fR +.sp +\fBsocket \fB\-server \fIcommand\fR ?\fIoptions\fR? \fIport\fR +.BE + +.SH DESCRIPTION +.PP +This command opens a network socket and returns a channel +identifier that may be used in future invocations of commands like +\fBread\fR, \fBputs\fR and \fBflush\fR. +At present only the TCP network protocol is supported; future +releases may include support for additional protocols. +The \fBsocket\fR command may be used to open either the client or +server side of a connection, depending on whether the \fB\-server\fR +switch is specified. + +.SH "CLIENT SOCKETS" +.PP +If the \fB\-server\fR option is not specified, then the client side of a +connection is opened and the command returns a channel identifier +that can be used for both reading and writing. +\fIPort\fR and \fIhost\fR specify a port +to connect to; there must be a server accepting connections on +this port. \fIPort\fR is an integer port number and \fIhost\fR +is either a domain-style name such as \fBwww.sunlabs.com\fR or +a numerical IP address such as \fB127.0.0.1\fR. +Use \fIlocalhost\fR to refer to the host on which the command is invoked. +.PP +The following options may also be present before \fIhost\fR +to specify additional information about the connection: +.TP +\fB\-myaddr\fI addr\fR +\fIAddr\fR gives the domain-style name or numerical IP address of +the client-side network interface to use for the connection. +This option may be useful if the client machine has multiple network +interfaces. If the option is omitted then the client-side interface +will be chosen by the system software. +.TP +\fB\-myport\fI port\fR +\fIPort\fR specifies an integer port number to use for the client's +side of the connection. If this option is omitted, the client's +port number will be chosen at random by the system software. +.TP +\fB\-async\fR +The \fB\-async\fR option will cause the client socket to be connected +asynchronously. This means that the socket will be created immediately but +may not yet be connected to the server, when the call to \fBsocket\fR +returns. When a \fBgets\fR or \fBflush\fR is done on the socket before the +connection attempt succeeds or fails, if the socket is in blocking mode, the +operation will wait until the connection is completed or fails. If the +socket is in nonblocking mode and a \fBgets\fR or \fBflush\fR is done on +the socket before the connection attempt succeeds or fails, the operation +returns immediately and \fBfblocked\fR on the socket returns 1. + +.SH "SERVER SOCKETS" +.PP +If the \fB\-server\fR option is specified then the new socket +will be a server for the port given by \fIport\fR. +Tcl will automatically accept connections to the given port. +For each connection Tcl will create a new channel that may be used to +communicate with the client. Tcl then invokes \fIcommand\fR +with three additional arguments: the name of the new channel, the +address, in network address notation, of the client's host, and +the client's port number. +.PP +The following additional option may also be specified before \fIhost\fR: +.TP +\fB\-myaddr\fI addr\fR +\fIAddr\fR gives the domain-style name or numerical IP address of +the server-side network interface to use for the connection. +This option may be useful if the server machine has multiple network +interfaces. If the option is omitted then the server socket is bound +to the special address INADDR_ANY so that it can accept connections from +any interface. +.PP +Server channels cannot be used for input or output; their sole use is to +accept new client connections. The channels created for each incoming +client connection are opened for input and output. Closing the server +channel shuts down the server so that no new connections will be +accepted; however, existing connections will be unaffected. +.PP +Server sockets depend on the Tcl event mechanism to find out when +new connections are opened. If the application doesn't enter the +event loop, for example by invoking the \fBvwait\fR command or +calling the C procedure \fBTcl_DoOneEvent\fR, then no connections +will be accepted. + +.SH CONFIGURATION OPTIONS +The \fBfconfigure\fR command can be used to query several readonly +configuration options for socket channels: +.TP +\fB\-sockname\fR +This option returns a list of three elements, the address, the host name +and the port number for the socket. If the host name cannot be computed, +the second element is identical to the address, the first element of the +list. +.TP +\fB\-peername\fR +This option is not supported by server sockets. For client and accepted +sockets, this option returns a list of three elements; these are the +address, the host name and the port to which the peer socket is connected +or bound. If the host name cannot be computed, the second element of the +list is identical to the address, its first element. +.PP + +.SH "SEE ALSO" +flush(n), open(n), read(n) + +.SH KEYWORDS +bind, channel, connection, domain name, host, network address, socket, tcp diff --git a/tcl7.6/doc/source.n b/tcl7.6/doc/source.n new file mode 100644 index 0000000..4b153b9 --- /dev/null +++ b/tcl7.6/doc/source.n @@ -0,0 +1,44 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) source.n 1.7 96/04/15 13:07:38 +'\" +.so man.macros +.TH source n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +source \- Evaluate a file or resource as a Tcl script +.SH SYNOPSIS +\fBsource \fIfileName\fR +.sp +\fBsource \fB\-rsrc \fIresourceName \fR?\fIfileName\fR? +.sp +\fBsource \fB\-rsrcid \fIresourceId \fR?\fIfileName\fR? +.BE + +.SH DESCRIPTION +.PP +This command takes the contents of the specified file or resource +and passes it to the Tcl interpreter as a text script. The return +value from \fBsource\fR is the return value of the last command +executed in the script. If an error occurs in evaluating the contents +of the script then the \fBsource\fR command will return that error. +If a \fBreturn\fR command is invoked from within the script 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. + +The \fI\-rsrc\fR and \fI\-rsrcid\fR forms of this command are only +available on Macintosh computers. These versions of the command +allow you to source a script from a \fBTEXT\fR resource. You may specify +what \fBTEXT\fR resource to source by either name or id. By default Tcl +searches all open resource files, which include the current +application and any loaded C extensions. Alternatively, you may +specify the \fIfileName\fR where the \fBTEXT\fR resource can be found. + +.SH KEYWORDS +file, script diff --git a/tcl7.6/doc/split.n b/tcl7.6/doc/split.n new file mode 100644 index 0000000..eff0058 --- /dev/null +++ b/tcl7.6/doc/split.n @@ -0,0 +1,44 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) split.n 1.6 96/03/25 20:23:53 +'\" +.so man.macros +.TH split n "" Tcl "Tcl Built-In Commands" +.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, +.CS +\fBsplit "comp.unix.misc" .\fR +.CE +returns \fB"comp unix misc"\fR and +.CS +\fBsplit "Hello world" {}\fR +.CE +returns \fB"H e l l o { } w o r l d"\fR. + +.SH KEYWORDS +list, split, string diff --git a/tcl7.3/doc/string.n b/tcl7.6/doc/string.n similarity index 75% rename from tcl7.3/doc/string.n rename to tcl7.6/doc/string.n index defd385..0bccf30 100644 --- a/tcl7.3/doc/string.n +++ b/tcl7.6/doc/string.n @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/string.n,v 1.1 93/06/16 16:48:24 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) string.n 1.9 96/08/26 13:00:14 '\" .so man.macros -.HS string tcl +.TH string n 7.6 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -90,9 +77,10 @@ avoiding the special interpretation of the characters \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. +character whose index is \fIlast\fR. An index of 0 refers to the +first character of the string. +An index of \fBend\fR (or any +abbreviation of it) refers 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 @@ -126,6 +114,18 @@ 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 wordend \fIstring index\fR +Returns the index of the character just after the last one in the +word containing character \fIindex\fR of \fIstring\fR. +A word is considered to be any contiguous range of alphanumeric +or underscore characters, or any single character other than these. +.TP +\fBstring wordstart \fIstring index\fR +Returns the index of the first character in the +word containing character \fIindex\fR of \fIstring\fR. +A word is considered to be any contiguous range of alphanumeric +or underscore characters, or any single character other than these. .SH KEYWORDS -case conversion, compare, index, match, pattern, string +case conversion, compare, index, match, pattern, string, word diff --git a/tcl7.6/doc/subst.n b/tcl7.6/doc/subst.n new file mode 100644 index 0000000..7a19b91 --- /dev/null +++ b/tcl7.6/doc/subst.n @@ -0,0 +1,48 @@ +'\" +'\" Copyright (c) 1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) subst.n 1.9 96/03/25 20:24:17 +'\" +.so man.macros +.TH subst n 7.4 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +subst \- Perform backslash, command, and variable substitutions +.SH SYNOPSIS +\fBsubst \fR?\fB\-nobackslashes\fR? ?\fB\-nocommands\fR? ?\fB\-novariables\fR? \fIstring\fR +.BE + +.SH DESCRIPTION +.PP +This command performs variable substitutions, command substitutions, +and backslash substitutions on its \fIstring\fR argument and +returns the fully-substituted result. +The substitutions are performed in exactly the same way as for +Tcl commands. +As a result, the \fIstring\fR argument is actually substituted twice, +once by the Tcl parser in the usual fashion for Tcl commands, and +again by the \fIsubst\fR command. +.PP +If any of the \fB\-nobackslashes\fR, \fB\-nocommands\fR, or +\fB\-novariables\fR are specified, then the corresponding substitutions +are not performed. +For example, if \fB\-nocommands\fR is specified, no command substitution +is performed: open and close brackets are treated as ordinary characters +with no special interpretation. +.PP +Note: when it performs its substitutions, \fIsubst\fR does not +give any special treatment to double quotes or curly braces. For +example, the script +.CS +\fBset a 44 +subst {xyz {$a}}\fR +.CE +returns ``\fBxyz {44}\fR'', not ``\fBxyz {$a}\fR''. + +.SH KEYWORDS +backslash substitution, command substitution, variable substitution diff --git a/tcl7.3/doc/switch.n b/tcl7.6/doc/switch.n similarity index 72% rename from tcl7.3/doc/switch.n rename to tcl7.6/doc/switch.n index a8a5d1d..f92540d 100644 --- a/tcl7.3/doc/switch.n +++ b/tcl7.6/doc/switch.n @@ -1,34 +1,21 @@ '\" '\" Copyright (c) 1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/switch.n,v 1.2 93/06/17 13:31:26 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) switch.n 1.8 96/03/25 20:24:31 '\" .so man.macros -.HS switch tcl 7.0 +.TH switch n 7.0 Tcl "Tcl Built-In Commands" .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 +.sp \fBswitch\fI \fR?\fIoptions\fR?\fI string \fR{\fIpattern body \fR?\fIpattern body \fR...?} .BE @@ -64,7 +51,7 @@ expression matching .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\-. +be treated as \fIstring\fR even if it starts with a \fB\-\fR. .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; @@ -89,22 +76,20 @@ 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 +.CS +\fBswitch\0abc\0a\0\-\0b\0{format 1}\0abc\0{format 2}\0default\0{format 3}\fR +.CE will return \fB2\fR, -.DS -.ta .5c 1c +.CS \fBswitch\0\-regexp\0aaab { ^a.*b$\0\- b\0{format 1} a*\0{format 2} default\0{format 3} -} -.DE +}\fR +.CE will return \fB1\fR, and -.DS -.ta .5c 1c +.CS \fBswitch\0xyz { a \- @@ -114,8 +99,8 @@ will return \fB1\fR, and {format 2} default {format 3} -} -.DE +}\fR +.CE will return \fB3\fR. .SH KEYWORDS diff --git a/tcl7.3/doc/tclsh.1 b/tcl7.6/doc/tclsh.1 similarity index 62% rename from tcl7.3/doc/tclsh.1 rename to tcl7.6/doc/tclsh.1 index ba88be4..2922d81 100644 --- a/tcl7.3/doc/tclsh.1 +++ b/tcl7.6/doc/tclsh.1 @@ -1,33 +1,20 @@ '\" '\" Copyright (c) 1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) tclsh.1 1.13 96/08/26 13:00:15 '\" -'\" $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 +.TH tclsh 1 "" Tcl "Tcl Applications" .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 +\fBtclsh\fR ?\fIfileName arg arg ...\fR? .BE .SH DESCRIPTION @@ -55,14 +42,43 @@ 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 +.CS +\fB#!/usr/local/bin/tclsh\fR +.CE 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. +Many UNIX systems do not allow the \fB#!\fR line to exceed about +30 characters in length, so be sure that the \fBtclsh\fR +executable can be accessed with a short file name. +.PP +An even better approach is to start your script files with the +following three lines: +.CS +\fB#!/bin/sh +# the next line restarts using tclsh \e +exec tclsh "$0" "$@"\fR +.CE +This approach has three advantages over the approach in the previous +paragraph. First, the location of the \fBtclsh\fR binary doesn't have +to be hard-wired into the script: it can be anywhere in your shell +search path. Second, it gets around the 30-character file name limit +in the previous approach. +Third, this approach will work even if \fBtclsh\fR is +itself a shell script (this is done on some systems in order to +handle multiple architectures or operating systems: the \fBtclsh\fR +script selects one of several binaries to run). The three lines +cause both \fBsh\fR and \fBtclsh\fR to process the script, but the +\fBexec\fR is only executed by \fBsh\fR. +\fBsh\fR processes the script first; it treats the second +line as a comment and executes the third line. +The \fBexec\fR statement cause the shell to stop processing and +instead to start up \fBtclsh\fR to reprocess the entire script. +When \fBtclsh\fR starts up, it treats all three lines as comments, +since the backslash at the end of the second line causes the third +line to be treated as part of the comment on the second line. .SH "VARIABLES" .PP @@ -84,7 +100,6 @@ Otherwise, contains the name by which \fBtclsh\fR was invoked. 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 diff --git a/tcl7.3/doc/tclvars.n b/tcl7.6/doc/tclvars.n similarity index 50% rename from tcl7.3/doc/tclvars.n rename to tcl7.6/doc/tclvars.n index 5b8c1e1..4fbebae 100644 --- a/tcl7.3/doc/tclvars.n +++ b/tcl7.6/doc/tclvars.n @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/tclvars.n,v 1.1 93/06/16 16:52:49 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) tclvars.n 1.22 96/10/04 13:07:32 '\" .so man.macros -.HS tclvars tcl +.TH tclvars n 7.6 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -35,7 +22,6 @@ 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 @@ -63,7 +49,6 @@ 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 @@ -71,9 +56,8 @@ 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), +OVERFLOW (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 @@ -105,17 +89,14 @@ 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. @@ -124,10 +105,7 @@ 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 +procedures such as \fBTcl_SetErrorCode\fR and \fBTcl_PosixError\fR, 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 @@ -141,8 +119,80 @@ 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_library\fR +This variable holds the name of a directory containing the +system library of Tcl scripts, such as those used for auto-loading. +The value of this variable is returned by the \fBinfo library\fR command. +See the \fBlibrary\fR manual entry for details of the facilities +provided by the Tcl script library. +Normally each application or package will have its own application-specific +script library in addition to the Tcl script library; +each application should set a global variable with a name like +\fB$\fIapp\fB_library\fR (where \fIapp\fR is the application's name) +to hold the network file name for that application's library directory. +The initial value of \fBtcl_library\fR is set when an interpreter +is created by searching several different directories until one is +found that contains an appropriate Tcl startup script. +If the \fBTCL_LIBRARY\fR environment variable exists, then +the directory it names is checked first. +If \fBTCL_LIBRARY\fR isn't set or doesn't refer to an appropriate +directory, then Tcl checks several other directories based on a +compiled-in default location, the location of the binary containing +the application, and the current working directory. +.TP +\fBtcl_patchLevel\fR +When an interpreter is created Tcl initializes this variable to +hold a string giving the current patch level for Tcl, such as +\fB7.3p2\fR for Tcl 7.3 with the first two official patches, or +\fB7.4b4\fR for the fourth beta release of Tcl 7.4. +The value of this variable is returned by the \fBinfo patchlevel\fR +command. +.VS br +.TP +\fBtcl_pkgPath\fR +This variable holds a list of directories indicating where packages are +normally installed. It typically contains either one or two entries; +if it contains two entries, the first is normally a directory for +platform-dependent packages (e.g., shared library binaries) and the +second is normally a directory for platform-independent packages (e.g., +script files). Typically a package is installed as a subdirectory of one +of the entries in \fB$tcl_pkgPath\fR. The directories in +\fB$tcl_pkgPath\fR are included by default in the \fBauto_path\fR +variable, so they and their immediate subdirectories are automatically +searched for packages during \fBpackage require\fR commands. +.VE +.TP +\fBtcl_platform\fR +This is an associative array whose elements contain information about +the platform on which the application is running, such as the name of +the operating system, its current release number, and the machine's +instruction set. The elements listed below will always +be defined, but they may have empty strings as values if Tcl couldn't +retrieve any relevant information. In addition, extensions +and applications may add additional values to the array. The +predefined elements are: +.RS +.TP +\fBmachine\fR +The instruction set executed by this machine, such as +\fBPPC\fR, \fB68k\fR, or \fBsun4m\fR. On UNIX machines, this +is the value returned by \fBuname -m\fR. +.TP +\fBos\fR +The name of the operating system running on this machine, such +as \fBWin95\fR, \fBMacOS\fR, or \fBSunOS\fR. On UNIX machines, +this is the value returned by \fBuname -s\fR. +.TP +\fBosVersion\fR +The version number for the operating system running on this machine. +On UNIX machines, this is the value returned by \fBuname -r\fR. +.TP +\fBplatform\fR +Either \fBwindows\fR, \fBmacintosh\fR, or \fBunix\fR. This identifies the +general operating environment of the machine. +.RE +.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. @@ -150,7 +200,32 @@ 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 +.TP +\fBtcl_rcFileName\fR +This variable is used during initialization to indicate the name of a +user-specific startup file. If it is set by application-specific +initialization, then the Tcl startup code will check for the existence +of this file and \fBsource\fR it if it exists. For example, for \fBwish\fR +the variable is set to \fB~/.wishrc\fR for Unix and \fB~/wishrc.tcl\fR +for Windows. +.TP +\fBtcl_rcRsrcName\fR +This variable is only used on Macintosh systems. The variable is used +during initialization to indicate the name of a user-specific +\fBTEXT\fR resource located in the application or extension resource +forks. If it is set by application-specific initialization, then the +Tcl startup code will check for the existence of this resource and +\fBsource\fR it if it exists. For example, the Macintosh \fBwish\fR +application has the variable is set to \fBtclshrc\fR. +.TP +\fBtcl_version\fR +When an interpreter is created Tcl initializes this variable to +hold the version number for this version of Tcl in the form \fIx.y\fR. +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. +The value of this variable is returned by the \fBinfo tclversion\fR +command. .SH KEYWORDS arithmetic, error, environment, POSIX, precision, subprocess, variables diff --git a/tcl7.6/doc/tell.n b/tcl7.6/doc/tell.n new file mode 100644 index 0000000..b2c0ec1 --- /dev/null +++ b/tcl7.6/doc/tell.n @@ -0,0 +1,28 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) tell.n 1.9 96/08/26 13:00:17 +'\" +.so man.macros +.TH tell n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +tell \- Return current access position for an open channel +.SH SYNOPSIS +\fBtell \fIchannelId\fR +.BE + +.SH DESCRIPTION +.PP +Returns a decimal string giving the current access position in +\fIchannelId\fR. +The value returned is -1 for channels that do not support +seeking. + +.SH KEYWORDS +access position, channel, seeking diff --git a/tcl7.6/doc/time.n b/tcl7.6/doc/time.n new file mode 100644 index 0000000..19b99fb --- /dev/null +++ b/tcl7.6/doc/time.n @@ -0,0 +1,33 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) time.n 1.6 96/03/25 20:25:30 +'\" +.so man.macros +.TH time n "" Tcl "Tcl Built-In Commands" +.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 +.CS +\fB503 microseconds per iteration\fR +.CE +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/tcl7.3/doc/trace.n b/tcl7.6/doc/trace.n similarity index 83% rename from tcl7.3/doc/trace.n rename to tcl7.6/doc/trace.n index 7d8652e..cabf495 100644 --- a/tcl7.3/doc/trace.n +++ b/tcl7.6/doc/trace.n @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/trace.n,v 1.3 93/06/16 16:36:39 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) trace.n 1.12 96/08/26 13:00:18 '\" .so man.macros -.HS trace tcl +.TH trace n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -45,10 +32,9 @@ 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 +.PP \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. @@ -63,13 +49,12 @@ 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 +.PP When the trace triggers, three arguments are appended to \fIcommand\fR so that the actual command is as follows: -.DS C +.CS \fIcommand name1 name2 op\fR -.DE +.CE \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; @@ -78,10 +63,14 @@ 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. +\fIName1\fR and \fIname2\fR are not necessarily the same as the +name used in the \fBtrace variable\fR command: the \fBupvar\fR +command allows a procedure to reference a variable under a +different name. \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 +.PP \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 @@ -94,7 +83,7 @@ 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 +.PP 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 @@ -103,9 +92,7 @@ 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 @@ -113,17 +100,15 @@ 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 +.PP 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 +.PP 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 @@ -133,10 +118,8 @@ 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 +.PP 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 @@ -144,14 +127,14 @@ 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 +.PP 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 +.PP This command returns an empty string. .RE .TP diff --git a/tcl7.6/doc/unknown.n b/tcl7.6/doc/unknown.n new file mode 100644 index 0000000..a7be942 --- /dev/null +++ b/tcl7.6/doc/unknown.n @@ -0,0 +1,75 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) unknown.n 1.8 96/10/09 08:29:28 +'\" +.so man.macros +.TH unknown n "" Tcl "Tcl Built-In Commands" +.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 is invoked by the Tcl interpreter whenever a script +tries to invoke a command that doesn't exist. The implementation +of \fBunknown\fR isn't part of the Tcl core; instead, it is a +library procedure defined by default when Tcl starts up. You +can override the default \fBunknown\fR to change its functionality. +.PP +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. +.PP +The default implementation of \fBunknown\fR behaves as follows. +It first calls the \fBauto_load\fR library procedure to load the command. +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 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. +Finally, \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 KEYWORDS +error, non-existent command diff --git a/tcl7.6/doc/unset.n b/tcl7.6/doc/unset.n new file mode 100644 index 0000000..6073256 --- /dev/null +++ b/tcl7.6/doc/unset.n @@ -0,0 +1,34 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) unset.n 1.5 96/03/25 20:26:21 +'\" +.so man.macros +.TH unset n "" Tcl "Tcl Built-In Commands" +.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/tcl7.6/doc/update.n b/tcl7.6/doc/update.n new file mode 100644 index 0000000..522b176 --- /dev/null +++ b/tcl7.6/doc/update.n @@ -0,0 +1,48 @@ +'\" +'\" Copyright (c) 1990-1992 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) update.n 1.3 96/03/25 20:26:34 +'\" +.so man.macros +.TH update n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +update \- Process pending events and idle callbacks +.SH SYNOPSIS +\fBupdate\fR ?\fBidletasks\fR? +.BE + +.SH DESCRIPTION +.PP +This command is used to bring the application ``up to date'' +by entering the event loop repeated until all pending events +(including idle callbacks) have been processed. +.PP +If the \fBidletasks\fR keyword is specified as an argument to the +command, then no new events or errors are processed; only idle +callbacks are invoked. +This causes operations that are normally deferred, such as display +updates and window layout calculations, to be performed immediately. +.PP +The \fBupdate idletasks\fR command is useful in scripts where +changes have been made to the application's state and you want those +changes to appear on the display immediately, rather than waiting +for the script to complete. Most display updates are performed as +idle callbacks, so \fBupdate idletasks\fR will cause them to run. +However, there are some kinds of updates that only happen in +response to events, such as those triggered by window size changes; +these updates will not occur in \fBupdate idletasks\fR. +.PP +The \fBupdate\fR command with no options is useful in scripts where +you are performing a long-running computation but you still want +the application to respond to events such as user interactions; if +you occasionally call \fBupdate\fR then user input will be processed +during the next call to \fBupdate\fR. + +.SH KEYWORDS +event, flush, handler, idle, update diff --git a/tcl7.3/doc/uplevel.n b/tcl7.6/doc/uplevel.n similarity index 67% rename from tcl7.3/doc/uplevel.n rename to tcl7.6/doc/uplevel.n index d40e966..574900e 100644 --- a/tcl7.3/doc/uplevel.n +++ b/tcl7.6/doc/uplevel.n @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/uplevel.n,v 1.1 93/06/16 16:48:27 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) uplevel.n 1.7 96/03/25 20:26:46 '\" .so man.macros -.HS uplevel tcl +.TH uplevel n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -56,16 +43,16 @@ at top-level (only global variables will be visible). 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 +.CS +\fBuplevel 1 {set x 43; d}\fR +.CE 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 +.CS +\fBuplevel {set x 42}\fR +.CE 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 diff --git a/tcl7.3/doc/upvar.n b/tcl7.6/doc/upvar.n similarity index 61% rename from tcl7.3/doc/upvar.n rename to tcl7.6/doc/upvar.n index 7a83ea2..e6e47ce 100644 --- a/tcl7.3/doc/upvar.n +++ b/tcl7.6/doc/upvar.n @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/tcl/man/RCS/upvar.n,v 1.3 93/06/16 16:41:13 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) upvar.n 1.15 96/08/26 13:00:19 '\" .so man.macros -.HS upvar tcl +.TH upvar n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -45,25 +32,25 @@ 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 +an ordinary variable. There must not exist a variable by the +name \fImyVar\fR at the time \fBupvar\fR is invoked. +\fIMyVar\fR is always treated as the name of a variable, not an +array element. Even if the name looks like an array element, +such as \fBa(b)\fR, a regular variable is created. +\fIOtherVar\fR may refer to a scalar variable, an array, +or an array element. \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 +.CS \fBproc add2 name { - upvar $name x - set x [expr $x+2] -} -.DE + upvar $name x + set x [expr $x+2] +}\fR +.CE \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 @@ -77,6 +64,14 @@ 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. + +.SH BUGS +.PP +If \fIotherVar\fR refers to an element of an array, then variable +traces set for the entire array will not be invoked when \fImyVar\fR +is accessed (but traces on the particular element will still be +invoked). In particular, if the array is \fBenv\fR, then changes +made to \fImyVar\fR will not be passed to subprocesses correctly. .VE .SH KEYWORDS diff --git a/tcl7.6/doc/vwait.n b/tcl7.6/doc/vwait.n new file mode 100644 index 0000000..868f5dc --- /dev/null +++ b/tcl7.6/doc/vwait.n @@ -0,0 +1,38 @@ +'\" +'\" Copyright (c) 1995-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) vwait.n 1.3 96/03/25 20:27:21 +'\" +.so man.macros +.TH vwait n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +vwait \- Process events until a variable is written +.SH SYNOPSIS +\fBvwait\fR ?\fIvarName\fR? +.BE + +.SH DESCRIPTION +.PP +This command enters the Tcl event loop to process events, blocking +the application if no events are ready. It continues processing +events until some event handler sets the value of variable +\fIvarName\fR. Once \fIvarName\fR has been set, the \fBvwait\fR +command will return as soon as the event handler that modified +\fIvarName\fR completes. +.PP +In some cases the \fBvwait\fR command may not return immediately +after \fIvarName\fR is set. This can happen if the event handler +that sets \fIvarName\fR does not complete immediately. For example, +if an event handler sets \fIvarName\fR and then itself calls +\fBvwait\fR to wait for a different variable, then it may not return +for a long time. During this time the top-level \fBvwait\fR is +blocked waiting for the event handler to complete, so it cannot +return either. + +.SH KEYWORDS +event, variable, wait diff --git a/tcl7.6/doc/while.n b/tcl7.6/doc/while.n new file mode 100644 index 0000000..8703684 --- /dev/null +++ b/tcl7.6/doc/while.n @@ -0,0 +1,37 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) while.n 1.6 96/03/25 20:27:35 +'\" +.so man.macros +.TH while n "" Tcl "Tcl Built-In Commands" +.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\fR +.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/tcl7.6/generic/README b/tcl7.6/generic/README new file mode 100644 index 0000000..4b3aa4f --- /dev/null +++ b/tcl7.6/generic/README @@ -0,0 +1,5 @@ +This directory contains Tcl source files that work on all the platforms +where Tcl runs (e.g. UNIX, PCs, and Macintoshes). Platform-specific +sources are in the directories ../unix, ../win, and ../mac. + +SCCS ID: @(#) README 1.1 95/09/11 14:02:13 diff --git a/tcl7.6/generic/panic.c b/tcl7.6/generic/panic.c new file mode 100644 index 0000000..420a157 --- /dev/null +++ b/tcl7.6/generic/panic.c @@ -0,0 +1,96 @@ +/* + * 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. + * Copyright (c) 1994 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) panic.c 1.15 96/09/12 14:55:25 + */ + +#include +#ifdef NO_STDLIB_H +# include "../compat/stdlib.h" +#else +# include +#endif + +#define panic panicDummy +#include "tcl.h" +#undef panic + +EXTERN void panic _ANSI_ARGS_((char *format, char *arg1, + char *arg2, char *arg3, char *arg4, char *arg5, + char *arg6, char *arg7, char *arg8)); + +/* + * The panicProc variable contains a pointer to an application + * specific panic procedure. + */ + +void (*panicProc) _ANSI_ARGS_(TCL_VARARGS(char *,format)) = NULL; + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetPanicProc -- + * + * Replace the default panic behavior with the specified functiion. + * + * Results: + * None. + * + * Side effects: + * Sets the panicProc variable. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetPanicProc(proc) + void (*proc) _ANSI_ARGS_(TCL_VARARGS(char *,format)); +{ + panicProc = proc; +} + +/* + *---------------------------------------------------------------------- + * + * 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; +{ + if (panicProc != NULL) { + (void) (*panicProc)(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); + } else { + (void) fprintf(stderr, format, arg1, arg2, arg3, arg4, arg5, arg6, + arg7, arg8); + (void) fprintf(stderr, "\n"); + (void) fflush(stderr); + abort(); + } +} diff --git a/tcl7.3/regexp.c b/tcl7.6/generic/regexp.c similarity index 62% rename from tcl7.3/regexp.c rename to tcl7.6/generic/regexp.c index 6dc0e29..52e5a51 100644 --- a/tcl7.3/regexp.c +++ b/tcl7.6/generic/regexp.c @@ -1,5 +1,5 @@ /* - * TclRegComp and TclRegExec -- TclRegSub and TclRegError are elsewhere + * TclRegComp and TclRegExec -- TclRegSub is elsewhere * * Copyright (c) 1986 by University of Toronto. * Written by Henry Spencer. Not derived from licensed software. @@ -31,8 +31,33 @@ * *** 3. Names have been changed, e.g. from regcomp to *** * *** TclRegComp, to avoid clashes with other *** * *** regexp implementations used by applications. *** + * *** 4. Added errMsg declaration and TclRegError procedure *** + * *** 5. Various lint-like things, such as casting arguments *** + * *** in procedure calls. *** + * + * *** NOTE: This code has been altered for use in MT-Sturdy Tcl *** + * *** 1. All use of static variables has been changed to access *** + * *** fields of a structure. *** + * *** 2. This in addition to changes to TclRegError makes the *** + * *** code multi-thread safe. *** + * + * SCCS: @(#) regexp.c 1.12 96/04/02 13:54:57 */ + #include "tclInt.h" +#include "tclPort.h" + +/* + * 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 the + * procedures TclRegError and TclGetRegError can be modified to use + * thread-specific storage for the variable and thereby make the code + * thread-safe. + */ + +static char *errMsg = NULL; /* * The "internal use only" fields in regexp.h are present to pass info from @@ -85,7 +110,7 @@ #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. */ +#define CLOSE (OPEN+NSUBEXP) /* no Analogous to OPEN. */ /* * Opcode notes: @@ -152,11 +177,14 @@ /* * Global work variables for TclRegComp(). */ -static char *regparse; /* Input-scan pointer. */ -static int regnpar; /* () count. */ +struct regcomp_state { + char *regparse; /* Input-scan pointer. */ + int regnpar; /* () count. */ + char *regcode; /* Code-emit pointer; ®dummy = don't. */ + long regsize; /* Code size. */ +}; + 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 @@ -168,21 +196,27 @@ static long regsize; /* Code size. */ /* * 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(); + +static char * reg _ANSI_ARGS_((int paren, int *flagp, + struct regcomp_state *rcstate)); +static char * regatom _ANSI_ARGS_((int *flagp, + struct regcomp_state *rcstate)); +static char * regbranch _ANSI_ARGS_((int *flagp, + struct regcomp_state *rcstate)); +static void regc _ANSI_ARGS_((int b, + struct regcomp_state *rcstate)); +static void reginsert _ANSI_ARGS_((int op, char *opnd, + struct regcomp_state *rcstate)); +static char * regnext _ANSI_ARGS_((char *p)); +static char * regnode _ANSI_ARGS_((int op, + struct regcomp_state *rcstate)); +static void regoptail _ANSI_ARGS_((char *p, char *val)); +static char * regpiece _ANSI_ARGS_((int *flagp, + struct regcomp_state *rcstate)); +static void regtail _ANSI_ARGS_((char *p, char *val)); + #ifdef STRCSPN -STATIC int strcspn(); +static int strcspn _ANSI_ARGS_((char *s1, char *s2)); #endif /* @@ -209,34 +243,36 @@ char *exp; register char *longest; register int len; int flags; + struct regcomp_state state; + struct regcomp_state *rcstate= &state; 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) + rcstate->regparse = exp; + rcstate->regnpar = 1; + rcstate->regsize = 0L; + rcstate->regcode = ®dummy; + regc(MAGIC, rcstate); + if (reg(0, &flags, rcstate) == NULL) return(NULL); /* Small enough for pointer-storage convention? */ - if (regsize >= 32767L) /* Probably could be 65535L. */ + if (rcstate->regsize >= 32767L) /* Probably could be 65535L. */ FAIL("regexp too big"); /* Allocate space. */ - r = (regexp *)ckalloc(sizeof(regexp) + (unsigned)regsize); + r = (regexp *)ckalloc(sizeof(regexp) + (unsigned)rcstate->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) + rcstate->regparse = exp; + rcstate->regnpar = 1; + rcstate->regcode = r->program; + regc(MAGIC, rcstate); + if (reg(0, &flags, rcstate) == NULL) return(NULL); /* Dig out information for optimizations. */ @@ -288,9 +324,10 @@ char *exp; * follows makes it hard to avoid. */ static char * -reg(paren, flagp) +reg(paren, flagp, rcstate) int paren; /* Parenthesized? */ int *flagp; +struct regcomp_state *rcstate; { register char *ret; register char *br; @@ -302,16 +339,16 @@ int *flagp; /* Make an OPEN node, if parenthesized. */ if (paren) { - if (regnpar >= NSUBEXP) + if (rcstate->regnpar >= NSUBEXP) FAIL("too many ()"); - parno = regnpar; - regnpar++; - ret = regnode(OPEN+parno); + parno = rcstate->regnpar; + rcstate->regnpar++; + ret = regnode(OPEN+parno,rcstate); } else ret = NULL; /* Pick up the branches, linking them together. */ - br = regbranch(&flags); + br = regbranch(&flags,rcstate); if (br == NULL) return(NULL); if (ret != NULL) @@ -321,9 +358,9 @@ int *flagp; if (!(flags&HASWIDTH)) *flagp &= ~HASWIDTH; *flagp |= flags&SPSTART; - while (*regparse == '|') { - regparse++; - br = regbranch(&flags); + while (*rcstate->regparse == '|') { + rcstate->regparse++; + br = regbranch(&flags,rcstate); if (br == NULL) return(NULL); regtail(ret, br); /* BRANCH -> BRANCH. */ @@ -333,7 +370,7 @@ int *flagp; } /* Make a closing node, and hook it on the end. */ - ender = regnode((paren) ? CLOSE+parno : END); + ender = regnode((paren) ? CLOSE+parno : END,rcstate); regtail(ret, ender); /* Hook the tails of the branches to the closing node. */ @@ -341,10 +378,10 @@ int *flagp; regoptail(br, ender); /* Check for proper termination. */ - if (paren && *regparse++ != ')') { + if (paren && *rcstate->regparse++ != ')') { FAIL("unmatched ()"); - } else if (!paren && *regparse != '\0') { - if (*regparse == ')') { + } else if (!paren && *rcstate->regparse != '\0') { + if (*rcstate->regparse == ')') { FAIL("unmatched ()"); } else FAIL("junk on end"); /* "Can't happen". */ @@ -360,8 +397,9 @@ int *flagp; * Implements the concatenation operator. */ static char * -regbranch(flagp) +regbranch(flagp, rcstate) int *flagp; +struct regcomp_state *rcstate; { register char *ret; register char *chain; @@ -370,10 +408,11 @@ int *flagp; *flagp = WORST; /* Tentatively. */ - ret = regnode(BRANCH); + ret = regnode(BRANCH,rcstate); chain = NULL; - while (*regparse != '\0' && *regparse != '|' && *regparse != ')') { - latest = regpiece(&flags); + while (*rcstate->regparse != '\0' && *rcstate->regparse != '|' && + *rcstate->regparse != ')') { + latest = regpiece(&flags, rcstate); if (latest == NULL) return(NULL); *flagp |= flags&HASWIDTH; @@ -384,7 +423,7 @@ int *flagp; chain = latest; } if (chain == NULL) /* Loop ran zero times. */ - (void) regnode(NOTHING); + (void) regnode(NOTHING,rcstate); return(ret); } @@ -399,19 +438,20 @@ int *flagp; * endmarker role is not redundant. */ static char * -regpiece(flagp) +regpiece(flagp, rcstate) int *flagp; +struct regcomp_state *rcstate; { register char *ret; register char op; register char *next; int flags; - ret = regatom(&flags); + ret = regatom(&flags,rcstate); if (ret == NULL) return(NULL); - op = *regparse; + op = *rcstate->regparse; if (!ISMULT(op)) { *flagp = flags; return(ret); @@ -422,33 +462,33 @@ int *flagp; *flagp = (op != '+') ? (WORST|SPSTART) : (WORST|HASWIDTH); if (op == '*' && (flags&SIMPLE)) - reginsert(STAR, ret); + reginsert(STAR, ret, rcstate); else if (op == '*') { /* Emit x* as (x&|), where & means "self". */ - reginsert(BRANCH, ret); /* Either x */ - regoptail(ret, regnode(BACK)); /* and loop */ + reginsert(BRANCH, ret, rcstate); /* Either x */ + regoptail(ret, regnode(BACK,rcstate)); /* and loop */ regoptail(ret, ret); /* back */ - regtail(ret, regnode(BRANCH)); /* or */ - regtail(ret, regnode(NOTHING)); /* null. */ + regtail(ret, regnode(BRANCH,rcstate)); /* or */ + regtail(ret, regnode(NOTHING,rcstate)); /* null. */ } else if (op == '+' && (flags&SIMPLE)) - reginsert(PLUS, ret); + reginsert(PLUS, ret, rcstate); else if (op == '+') { /* Emit x+ as x(&|), where & means "self". */ - next = regnode(BRANCH); /* Either */ + next = regnode(BRANCH,rcstate); /* Either */ regtail(ret, next); - regtail(regnode(BACK), ret); /* loop back */ - regtail(next, regnode(BRANCH)); /* or */ - regtail(ret, regnode(NOTHING)); /* null. */ + regtail(regnode(BACK,rcstate), ret); /* loop back */ + regtail(next, regnode(BRANCH,rcstate)); /* or */ + regtail(ret, regnode(NOTHING,rcstate)); /* null. */ } else if (op == '?') { /* Emit x? as (x|) */ - reginsert(BRANCH, ret); /* Either x */ - regtail(ret, regnode(BRANCH)); /* or */ - next = regnode(NOTHING); /* null. */ + reginsert(BRANCH, ret, rcstate); /* Either x */ + regtail(ret, regnode(BRANCH,rcstate)); /* or */ + next = regnode(NOTHING,rcstate); /* null. */ regtail(ret, next); regoptail(ret, next); } - regparse++; - if (ISMULT(*regparse)) + rcstate->regparse++; + if (ISMULT(*rcstate->regparse)) FAIL("nested *?+"); return(ret); @@ -463,62 +503,63 @@ int *flagp; * separate node; the code is simpler that way and it's not worth fixing. */ static char * -regatom(flagp) +regatom(flagp, rcstate) int *flagp; +struct regcomp_state *rcstate; { register char *ret; int flags; *flagp = WORST; /* Tentatively. */ - switch (*regparse++) { + switch (*rcstate->regparse++) { case '^': - ret = regnode(BOL); + ret = regnode(BOL,rcstate); break; case '$': - ret = regnode(EOL); + ret = regnode(EOL,rcstate); break; case '.': - ret = regnode(ANY); + ret = regnode(ANY,rcstate); *flagp |= HASWIDTH|SIMPLE; break; case '[': { register int clss; register int classend; - if (*regparse == '^') { /* Complement of range. */ - ret = regnode(ANYBUT); - regparse++; + if (*rcstate->regparse == '^') { /* Complement of range. */ + ret = regnode(ANYBUT,rcstate); + rcstate->regparse++; } else - ret = regnode(ANYOF); - if (*regparse == ']' || *regparse == '-') - regc(*regparse++); - while (*regparse != '\0' && *regparse != ']') { - if (*regparse == '-') { - regparse++; - if (*regparse == ']' || *regparse == '\0') - regc('-'); + ret = regnode(ANYOF,rcstate); + if (*rcstate->regparse == ']' || *rcstate->regparse == '-') + regc(*rcstate->regparse++,rcstate); + while (*rcstate->regparse != '\0' && *rcstate->regparse != ']') { + if (*rcstate->regparse == '-') { + rcstate->regparse++; + if (*rcstate->regparse == ']' || *rcstate->regparse == '\0') + regc('-',rcstate); else { - clss = UCHARAT(regparse-2)+1; - classend = UCHARAT(regparse); + clss = UCHARAT(rcstate->regparse-2)+1; + classend = UCHARAT(rcstate->regparse); if (clss > classend+1) FAIL("invalid [] range"); for (; clss <= classend; clss++) - regc(clss); - regparse++; + regc((char)clss,rcstate); + rcstate->regparse++; } } else - regc(*regparse++); + regc(*rcstate->regparse++,rcstate); } - regc('\0'); - if (*regparse != ']') + regc('\0',rcstate); + if (*rcstate->regparse != ']') FAIL("unmatched []"); - regparse++; + rcstate->regparse++; *flagp |= HASWIDTH|SIMPLE; } break; case '(': - ret = reg(1, &flags); + ret = reg(1, &flags, rcstate); if (ret == NULL) return(NULL); *flagp |= flags&(HASWIDTH|SPSTART); @@ -536,33 +577,33 @@ int *flagp; /* NOTREACHED */ break; case '\\': - if (*regparse == '\0') + if (*rcstate->regparse == '\0') FAIL("trailing \\"); - ret = regnode(EXACTLY); - regc(*regparse++); - regc('\0'); + ret = regnode(EXACTLY,rcstate); + regc(*rcstate->regparse++,rcstate); + regc('\0',rcstate); *flagp |= HASWIDTH|SIMPLE; break; default: { register int len; register char ender; - regparse--; - len = strcspn(regparse, META); + rcstate->regparse--; + len = strcspn(rcstate->regparse, META); if (len <= 0) FAIL("internal disaster"); - ender = *(regparse+len); + ender = *(rcstate->regparse+len); if (len > 1 && ISMULT(ender)) len--; /* Back off clear of ?+* operand. */ *flagp |= HASWIDTH; if (len == 1) *flagp |= SIMPLE; - ret = regnode(EXACTLY); + ret = regnode(EXACTLY,rcstate); while (len > 0) { - regc(*regparse++); + regc(*rcstate->regparse++,rcstate); len--; } - regc('\0'); + regc('\0',rcstate); } break; } @@ -574,23 +615,24 @@ int *flagp; - regnode - emit a node */ static char * /* Location. */ -regnode(op) -char op; +regnode(op, rcstate) +int op; +struct regcomp_state *rcstate; { register char *ret; register char *ptr; - ret = regcode; + ret = rcstate->regcode; if (ret == ®dummy) { - regsize += 3; + rcstate->regsize += 3; return(ret); } ptr = ret; - *ptr++ = op; + *ptr++ = (char)op; *ptr++ = '\0'; /* Null "next" pointer. */ *ptr++ = '\0'; - regcode = ptr; + rcstate->regcode = ptr; return(ret); } @@ -599,13 +641,14 @@ char op; - regc - emit (if appropriate) a byte of code */ static void -regc(b) -char b; +regc(b, rcstate) +int b; +struct regcomp_state *rcstate; { - if (regcode != ®dummy) - *regcode++ = b; + if (rcstate->regcode != ®dummy) + *rcstate->regcode++ = (char)b; else - regsize++; + rcstate->regsize++; } /* @@ -614,29 +657,30 @@ char b; * Means relocating the operand. */ static void -reginsert(op, opnd) -char op; +reginsert(op, opnd, rcstate) +int op; char *opnd; +struct regcomp_state *rcstate; { register char *src; register char *dst; register char *place; - if (regcode == ®dummy) { - regsize += 3; + if (rcstate->regcode == ®dummy) { + rcstate->regsize += 3; return; } - src = regcode; - regcode += 3; - dst = regcode; + src = rcstate->regcode; + rcstate->regcode += 3; + dst = rcstate->regcode; while (src > opnd) *--dst = *--src; place = opnd; /* Op node, where operand used to be. */ - *place++ = op; - *place++ = '\0'; + *place++ = (char)op; *place++ = '\0'; + *place = '\0'; } /* @@ -667,8 +711,8 @@ char *val; offset = scan - val; else offset = val - scan; - *(scan+1) = (offset>>8)&0377; - *(scan+2) = offset&0377; + *(scan+1) = (char)((offset>>8)&0377); + *(scan+2) = (char)(offset&0377); } /* @@ -692,22 +736,27 @@ char *val; /* * 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. */ +struct regexec_state { + char *reginput; /* String-input pointer. */ + char *regbol; /* Beginning of input, for ^ check. */ + char **regstartp; /* Pointer to startp array. */ + char **regendp; /* Ditto for endp. */ +}; /* * Forwards. */ -STATIC int regtry(); -STATIC int regmatch(); -STATIC int regrepeat(); +static int regtry _ANSI_ARGS_((regexp *prog, char *string, + struct regexec_state *restate)); +static int regmatch _ANSI_ARGS_((char *prog, + struct regexec_state *restate)); +static int regrepeat _ANSI_ARGS_((char *p, + struct regexec_state *restate)); #ifdef DEBUG int regnarrate = 0; -void regdump(); -STATIC char *regprop(); +void regdump _ANSI_ARGS_((regexp *r)); +static char *regprop _ANSI_ARGS_((char *op)); #endif /* @@ -720,6 +769,8 @@ register char *string; char *start; { register char *s; + struct regexec_state state; + struct regexec_state *restate= &state; /* Be paranoid... */ if (prog == NULL || string == NULL) { @@ -737,7 +788,8 @@ char *start; if (prog->regmust != NULL) { s = string; while ((s = strchr(s, prog->regmust[0])) != NULL) { - if (strncmp(s, prog->regmust, prog->regmlen) == 0) + if (strncmp(s, prog->regmust, (size_t) prog->regmlen) + == 0) break; /* Found it. */ s++; } @@ -746,25 +798,25 @@ char *start; } /* Mark beginning of line for ^ . */ - regbol = start; + restate->regbol = start; /* Simplest case: anchored match need be tried only once. */ if (prog->reganch) - return(regtry(prog, string)); + return(regtry(prog, string, restate)); /* 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)) + if (regtry(prog, s, restate)) return(1); s++; } else /* We don't -- general case. */ do { - if (regtry(prog, s)) + if (regtry(prog, s, restate)) return(1); } while (*s++ != '\0'); @@ -776,17 +828,18 @@ char *start; - regtry - try match at specific point */ static int /* 0 failure, 1 success */ -regtry(prog, string) +regtry(prog, string, restate) regexp *prog; char *string; +struct regexec_state *restate; { register int i; register char **sp; register char **ep; - reginput = string; - regstartp = prog->startp; - regendp = prog->endp; + restate->reginput = string; + restate->regstartp = prog->startp; + restate->regendp = prog->endp; sp = prog->startp; ep = prog->endp; @@ -794,9 +847,9 @@ char *string; *sp++ = NULL; *ep++ = NULL; } - if (regmatch(prog->program + 1)) { + if (regmatch(prog->program + 1,restate)) { prog->startp[0] = string; - prog->endp[0] = reginput; + prog->endp[0] = restate->reginput; return(1); } else return(0); @@ -813,207 +866,216 @@ char *string; * by recursion. */ static int /* 0 failure, 1 success */ -regmatch(prog) +regmatch(prog, restate) char *prog; +struct regexec_state *restate; { - register char *scan; /* Current node. */ - char *next; /* Next node. */ + register char *scan; /* Current node. */ + char *next; /* Next node. */ - scan = prog; + scan = prog; #ifdef DEBUG - if (scan != NULL && regnarrate) - fprintf(stderr, "%s(\n", regprop(scan)); + if (scan != NULL && regnarrate) + fprintf(stderr, "%s(\n", regprop(scan)); #endif - while (scan != NULL) { + while (scan != NULL) { #ifdef DEBUG - if (regnarrate) - fprintf(stderr, "%s...\n", regprop(scan)); + if (regnarrate) + fprintf(stderr, "%s...\n", regprop(scan)); #endif - next = regnext(scan); + 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; + switch (OP(scan)) { + case BOL: + if (restate->reginput != restate->regbol) { + return 0; } + break; + case EOL: + if (*restate->reginput != '\0') { + return 0; + } + break; + case ANY: + if (*restate->reginput == '\0') { + return 0; + } + restate->reginput++; + break; + case EXACTLY: { + register int len; + register char *opnd; - scan = next; + opnd = OPERAND(scan); + /* Inline the first character, for speed. */ + if (*opnd != *restate->reginput) { + return 0 ; + } + len = strlen(opnd); + if (len > 1 && strncmp(opnd, restate->reginput, (size_t) len) + != 0) { + return 0; + } + restate->reginput += len; + break; + } + case ANYOF: + if (*restate->reginput == '\0' + || strchr(OPERAND(scan), *restate->reginput) == NULL) { + return 0; + } + restate->reginput++; + break; + case ANYBUT: + if (*restate->reginput == '\0' + || strchr(OPERAND(scan), *restate->reginput) != NULL) { + return 0; + } + restate->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; + + doOpen: + no = OP(scan) - OPEN; + save = restate->reginput; + + if (regmatch(next,restate)) { + /* + * Don't set startp if some later invocation of the + * same parentheses already has. + */ + if (restate->regstartp[no] == NULL) { + restate->regstartp[no] = save; + } + return 1; + } else { + return 0; + } + } + 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; + + doClose: + no = OP(scan) - CLOSE; + save = restate->reginput; + + if (regmatch(next,restate)) { + /* + * Don't set endp if some later + * invocation of the same parentheses + * already has. + */ + if (restate->regendp[no] == NULL) + restate->regendp[no] = save; + return 1; + } else { + return 0; + } + } + case BRANCH: { + register char *save; + + if (OP(next) != BRANCH) { /* No choice. */ + next = OPERAND(scan); /* Avoid recursion. */ + } else { + do { + save = restate->reginput; + if (regmatch(OPERAND(scan),restate)) + return(1); + restate->reginput = save; + scan = regnext(scan); + } while (scan != NULL && OP(scan) == BRANCH); + return 0; + } + 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 = restate->reginput; + no = regrepeat(OPERAND(scan),restate); + while (no >= min) { + /* If it could work, try it. */ + if (nextch == '\0' || *restate->reginput == nextch) + if (regmatch(next,restate)) + return(1); + /* Couldn't or didn't -- back up. */ + no--; + restate->reginput = save + no; + } + return(0); + } + case END: + return(1); /* Success! */ + default: + if (OP(scan) > OPEN && OP(scan) < OPEN+NSUBEXP) { + goto doOpen; + } else if (OP(scan) > CLOSE && OP(scan) < CLOSE+NSUBEXP) { + goto doClose; + } + TclRegError("memory corruption"); + return 0; } - /* - * We get here only if there's trouble -- normally "case END" is - * the terminating point. - */ - TclRegError("corrupted pointers"); - return(0); + 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) +regrepeat(p, restate) char *p; +struct regexec_state *restate; { register int count = 0; register char *scan; register char *opnd; - scan = reginput; + scan = restate->reginput; opnd = OPERAND(p); switch (OP(p)) { case ANY: @@ -1043,7 +1105,7 @@ char *p; count = 0; /* Best compromise. */ break; } - reginput = scan; + restate->reginput = scan; return(count); } @@ -1072,7 +1134,7 @@ register char *p; #ifdef DEBUG -STATIC char *regprop(); +static char *regprop(); /* - regdump - dump a regexp onto stdout in vaguely comprehensible form @@ -1191,7 +1253,16 @@ char *op; p = "PLUS"; break; default: - TclRegError("corrupted opcode"); + if (OP(op) > OPEN && OP(op) < OPEN+NSUBEXP) { + sprintf(buf+strlen(buf), "OPEN%d", OP(op)-OPEN); + p = NULL; + break; + } else if (OP(op) > CLOSE && OP(op) < CLOSE+NSUBEXP) { + sprintf(buf+strlen(buf), "CLOSE%d", OP(op)-CLOSE); + p = NULL; + } else { + TclRegError("corrupted opcode"); + } break; } if (p != NULL) @@ -1231,3 +1302,34 @@ char *s2; return(count); } #endif + +/* + *---------------------------------------------------------------------- + * + * TclRegError -- + * + * This procedure is invoked by the 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 "errMsg". + * + *---------------------------------------------------------------------- + */ + +void +TclRegError(string) + char *string; /* Error message. */ +{ + errMsg = string; +} + +char * +TclGetRegError() +{ + return errMsg; +} diff --git a/tcl7.6/generic/tcl.h b/tcl7.6/generic/tcl.h new file mode 100644 index 0000000..a97f407 --- /dev/null +++ b/tcl7.6/generic/tcl.h @@ -0,0 +1,1141 @@ +/* + * tcl.h -- + * + * This header file describes the externally-visible facilities + * of the Tcl interpreter. + * + * Copyright (c) 1987-1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tcl.h 1.283 96/10/02 17:17:39 + */ + +#ifndef _TCL +#define _TCL + +/* + * When version numbers change here, must also go into the following files + * and update the version numbers: + * + * library/init.tcl + * unix/configure.in + * unix/Makefile.in + * unix/pkginfo + * win/makefile.bc + * win/makefile.vc + * + * The release level should be 0 for alpha, 1 for beta, and 2 for + * final/patch. The release serial value is the number that follows the + * "a", "b", or "p" in the patch level; for example, if the patch level + * is 7.6b2, TCL_RELEASE_SERIAL is 2. It restarts at 1 whenever the + * release level is changed, except for the final release which is 0 + * (the first patch will start at 1). + */ + +#define TCL_MAJOR_VERSION 7 +#define TCL_MINOR_VERSION 6 +#define TCL_RELEASE_LEVEL 2 +#define TCL_RELEASE_SERIAL 0 + +#define TCL_VERSION "7.6" +#define TCL_PATCH_LEVEL "7.6" + +/* + * The following definitions set up the proper options for Windows + * compilers. We use this method because there is no autoconf equivalent. + */ + +#ifndef __WIN32__ +# if defined(_WIN32) || defined(WIN32) +# define __WIN32__ +# endif +#endif + +#ifdef __WIN32__ +# ifndef STRICT +# define STRICT +# endif +# ifndef USE_PROTOTYPE +# define USE_PROTOTYPE 1 +# endif +# ifndef HAS_STDARG +# define HAS_STDARG 1 +# endif +# ifndef USE_PROTOTYPE +# define USE_PROTOTYPE 1 +# endif +# ifndef USE_TCLALLOC +# define USE_TCLALLOC 1 +# endif +# ifndef STRINGIFY +# define STRINGIFY(x) STRINGIFY1(x) +# define STRINGIFY1(x) #x +# endif +#endif /* __WIN32__ */ + +/* + * The following definitions set up the proper options for Macintosh + * compilers. We use this method because there is no autoconf equivalent. + */ + +#ifdef MAC_TCL +# ifndef HAS_STDARG +# define HAS_STDARG 1 +# endif +# ifndef USE_TCLALLOC +# define USE_TCLALLOC 1 +# endif +# ifndef NO_STRERROR +# define NO_STRERROR 1 +# endif +#endif + +/* + * A special definition used to allow this header file to be included + * in resource files so that they can get obtain version information from + * this file. Resource compilers don't like all the C stuff, like typedefs + * and procedure declarations, that occur below. + */ + +#ifndef RESOURCE_INCLUDED + +#ifndef BUFSIZ +#include +#endif + +/* + * Definitions that allow Tcl functions with variable numbers of + * arguments to be used with either varargs.h or stdarg.h. TCL_VARARGS + * is used in procedure prototypes. TCL_VARARGS_DEF is used to declare + * the arguments in a function definiton: it takes the type and name of + * the first argument and supplies the appropriate argument declaration + * string for use in the function definition. TCL_VARARGS_START + * initializes the va_list data structure and returns the first argument. + */ + +#if defined(__STDC__) || defined(HAS_STDARG) +# define TCL_VARARGS(type, name) (type name, ...) +# define TCL_VARARGS_DEF(type, name) (type name, ...) +# define TCL_VARARGS_START(type, name, list) (va_start(list, name), name) +#else +# ifdef __cplusplus +# define TCL_VARARGS(type, name) (type name, ...) +# define TCL_VARARGS_DEF(type, name) (type va_alist, ...) +# else +# define TCL_VARARGS(type, name) () +# define TCL_VARARGS_DEF(type, name) (va_alist) +# endif +# define TCL_VARARGS_START(type, name, list) \ + (va_start(list), va_arg(list, type)) +#endif + +/* + * 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) || defined(USE_PROTOTYPE) +# define _USING_PROTOTYPES_ 1 +# define _ANSI_ARGS_(x) x +# define CONST const +#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 __WIN32__ +#ifndef VOID +# ifdef __STDC__ +# define VOID void +# else +# define VOID char +# endif +#endif +#else /* __WIN32__ */ +/* + * The following code is copied from winnt.h + */ +#ifndef VOID +#define VOID void +typedef char CHAR; +typedef short SHORT; +typedef long LONG; +#endif +#endif /* __WIN32__ */ + +/* + * Miscellaneous declarations. + */ + +#ifndef NULL +#define NULL 0 +#endif + +#ifndef _CLIENTDATA +# if defined(__STDC__) || defined(__cplusplus) + 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. + * TCL_DYNAMIC means result was allocated with + * ckalloc and should be freed with ckfree. + * Other values give 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 struct Tcl_AsyncHandler_ *Tcl_AsyncHandler; +typedef struct Tcl_Command_ *Tcl_Command; +typedef struct Tcl_Event Tcl_Event; +typedef struct Tcl_File_ *Tcl_File; +typedef struct Tcl_Channel_ *Tcl_Channel; +typedef struct Tcl_RegExp_ *Tcl_RegExp; +typedef struct Tcl_TimerToken_ *Tcl_TimerToken; +typedef struct Tcl_Trace_ *Tcl_Trace; + +/* + * 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. */ + long intValue; /* Integer value. */ + double doubleValue; /* Double-precision floating value. */ +} Tcl_Value; + +/* + * Procedure types defined by Tcl: + */ + +typedef int (Tcl_AppInitProc) _ANSI_ARGS_((Tcl_Interp *interp)); +typedef int (Tcl_AsyncProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int code)); +typedef void (Tcl_ChannelProc) _ANSI_ARGS_((ClientData clientData, int mask)); +typedef void (Tcl_CloseProc) _ANSI_ARGS_((ClientData data)); +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 int (Tcl_EventProc) _ANSI_ARGS_((Tcl_Event *evPtr, int flags)); +typedef void (Tcl_EventCheckProc) _ANSI_ARGS_((ClientData clientData, + int flags)); +typedef int (Tcl_EventDeleteProc) _ANSI_ARGS_((Tcl_Event *evPtr, + ClientData clientData)); +typedef void (Tcl_EventSetupProc) _ANSI_ARGS_((ClientData clientData, + int flags)); +typedef void (Tcl_ExitProc) _ANSI_ARGS_((ClientData clientData)); +typedef void (Tcl_FileProc) _ANSI_ARGS_((ClientData clientData, int mask)); +typedef void (Tcl_FileFreeProc) _ANSI_ARGS_((ClientData clientData)); +typedef void (Tcl_FreeProc) _ANSI_ARGS_((char *blockPtr)); +typedef void (Tcl_IdleProc) _ANSI_ARGS_((ClientData clientData)); +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 int (Tcl_PackageInitProc) _ANSI_ARGS_((Tcl_Interp *interp)); +typedef void (Tcl_TcpAcceptProc) _ANSI_ARGS_((ClientData callbackData, + Tcl_Channel chan, char *address, int port)); +typedef void (Tcl_TimerProc) _ANSI_ARGS_((ClientData clientData)); +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 to implement 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) +#define Tcl_DStringTrunc Tcl_DStringSetLength + +/* + * 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 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 values passed to Tcl_RecordAndEval. + * WARNING: these bit choices must not conflict with the bit choices + * for evalFlag bits in tclInt.h!! + */ + +#define TCL_NO_EVAL 0x10000 +#define TCL_EVAL_GLOBAL 0x20000 + +/* + * 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 *) 3) + +/* + * 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 + +/* + * 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. + */ + +EXTERN char * Tcl_Alloc _ANSI_ARGS_((unsigned int size)); +EXTERN void Tcl_Free _ANSI_ARGS_((char *ptr)); +EXTERN char * Tcl_Realloc _ANSI_ARGS_((char *ptr, + unsigned int size)); + +#ifdef TCL_MEM_DEBUG + +# define Tcl_Alloc(x) Tcl_DbCkalloc(x, __FILE__, __LINE__) +# define Tcl_Free(x) Tcl_DbCkfree(x, __FILE__, __LINE__) +# define Tcl_Realloc(x,y) Tcl_DbCkrealloc((x), (y),__FILE__, __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__) + +EXTERN int Tcl_DumpActiveMemory _ANSI_ARGS_((char *fileName)); +EXTERN void Tcl_ValidateAllMemory _ANSI_ARGS_((char *file, + int line)); + +#else + +# if USE_TCLALLOC +# define ckalloc(x) Tcl_Alloc(x) +# define ckfree(x) Tcl_Free(x) +# define ckrealloc(x,y) Tcl_Realloc(x,y) +# else +# define ckalloc(x) malloc(x) +# define ckfree(x) free(x) +# define ckrealloc(x,y) realloc(x,y) +# endif +# define Tcl_DumpActiveMemory(x) +# define Tcl_ValidateAllMemory(x,y) + +#endif /* TCL_MEM_DEBUG */ + +/* + * Macro to free result of interpreter. + */ + +#define Tcl_FreeResult(interp) \ + if ((interp)->freeProc != 0) { \ + if (((interp)->freeProc == TCL_DYNAMIC) \ + || ((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 that + * is the size of the key. + */ + 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) + +/* + * Flag values to pass to Tcl_DoOneEvent to disable searches + * for some kinds of events: + */ + +#define TCL_DONT_WAIT (1<<1) +#define TCL_WINDOW_EVENTS (1<<2) +#define TCL_FILE_EVENTS (1<<3) +#define TCL_TIMER_EVENTS (1<<4) +#define TCL_IDLE_EVENTS (1<<5) /* WAS 0x10 ???? */ +#define TCL_ALL_EVENTS (~TCL_DONT_WAIT) + +/* + * The following structure defines a generic event for the Tcl event + * system. These are the things that are queued in calls to Tcl_QueueEvent + * and serviced later by Tcl_DoOneEvent. There can be many different + * kinds of events with different fields, corresponding to window events, + * timer events, etc. The structure for a particular event consists of + * a Tcl_Event header followed by additional information specific to that + * event. + */ + +struct Tcl_Event { + Tcl_EventProc *proc; /* Procedure to call to service this event. */ + struct Tcl_Event *nextPtr; /* Next in list of pending events, or NULL. */ +}; + +/* + * Positions to pass to Tk_QueueEvent: + */ + +typedef enum { + TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK +} Tcl_QueuePosition; + +/* + * The following structure keeps is used to hold a time value, either as + * an absolute time (the number of seconds from the epoch) or as an + * elapsed time. On Unix systems the epoch is Midnight Jan 1, 1970 GMT. + * On Macintosh systems the epoch is Midnight Jan 1, 1904 GMT. + */ + +typedef struct Tcl_Time { + long sec; /* Seconds. */ + long usec; /* Microseconds. */ +} Tcl_Time; + +/* + * Bits to pass to Tcl_CreateFileHandler and Tcl_CreateChannelHandler + * to indicate what sorts of events are of interest: + */ + +#define TCL_READABLE (1<<1) +#define TCL_WRITABLE (1<<2) +#define TCL_EXCEPTION (1<<3) + +/* + * Flag values to pass to Tcl_OpenCommandChannel to indicate the + * disposition of the stdio handles. TCL_STDIN, TCL_STDOUT, TCL_STDERR, + * are also used in Tcl_GetStdChannel. + */ + +#define TCL_STDIN (1<<1) +#define TCL_STDOUT (1<<2) +#define TCL_STDERR (1<<3) +#define TCL_ENFORCE_MODE (1<<4) + +/* + * Typedefs for the various operations in a channel type: + */ + +typedef int (Tcl_DriverBlockModeProc) _ANSI_ARGS_((ClientData instanceData, + int mode)); +typedef int (Tcl_DriverCloseProc) _ANSI_ARGS_((ClientData instanceData, + Tcl_Interp *interp)); +typedef int (Tcl_DriverInputProc) _ANSI_ARGS_((ClientData instanceData, + char *buf, int toRead, int *errorCodePtr)); +typedef int (Tcl_DriverOutputProc) _ANSI_ARGS_((ClientData instanceData, + char *buf, int toWrite, int *errorCodePtr)); +typedef int (Tcl_DriverSeekProc) _ANSI_ARGS_((ClientData instanceData, + long offset, int mode, int *errorCodePtr)); +typedef int (Tcl_DriverSetOptionProc) _ANSI_ARGS_(( + ClientData instanceData, Tcl_Interp *interp, + char *optionName, char *value)); +typedef int (Tcl_DriverGetOptionProc) _ANSI_ARGS_(( + ClientData instanceData, char *optionName, + Tcl_DString *dsPtr)); +typedef void (Tcl_DriverWatchChannelProc) _ANSI_ARGS_(( + ClientData instanceData, int mask)); +typedef int (Tcl_DriverChannelReadyProc) _ANSI_ARGS_(( + ClientData instanceData, int mask)); +typedef Tcl_File (Tcl_DriverGetFileProc) _ANSI_ARGS_((ClientData instanceData, + int mask)); + +/* + * Enum for different end of line translation and recognition modes. + */ + +typedef enum Tcl_EolTranslation { + TCL_TRANSLATE_AUTO, /* Eol == \r, \n and \r\n. */ + TCL_TRANSLATE_CR, /* Eol == \r. */ + TCL_TRANSLATE_LF, /* Eol == \n. */ + TCL_TRANSLATE_CRLF /* Eol == \r\n. */ +} Tcl_EolTranslation; + +/* + * struct Tcl_ChannelType: + * + * One such structure exists for each type (kind) of channel. + * It collects together in one place all the functions that are + * part of the specific channel type. + */ + +typedef struct Tcl_ChannelType { + char *typeName; /* The name of the channel type in Tcl + * commands. This storage is owned by + * channel type. */ + Tcl_DriverBlockModeProc *blockModeProc; + /* Set blocking mode for the + * raw channel. May be NULL. */ + Tcl_DriverCloseProc *closeProc; /* Procedure to call to close + * the channel. */ + Tcl_DriverInputProc *inputProc; /* Procedure to call for input + * on channel. */ + Tcl_DriverOutputProc *outputProc; /* Procedure to call for output + * on channel. */ + Tcl_DriverSeekProc *seekProc; /* Procedure to call to seek + * on the channel. May be NULL. */ + Tcl_DriverSetOptionProc *setOptionProc; + /* Set an option on a channel. */ + Tcl_DriverGetOptionProc *getOptionProc; + /* Get an option from a channel. */ + Tcl_DriverWatchChannelProc *watchChannelProc; + /* Set up the notifier to watch + * for events on this channel. */ + Tcl_DriverChannelReadyProc *channelReadyProc; + /* Check for events of interest on + * this channel. */ + Tcl_DriverGetFileProc *getFileProc; /* Get a Tcl_File from the channel + * or NULL if not supported. */ +} Tcl_ChannelType; + +/* + * The following flags determine whether the blockModeProc above should + * set the channel into blocking or nonblocking mode. They are passed + * as arguments to the blockModeProc procedure in the above structure. + */ + +#define TCL_MODE_BLOCKING 0 /* Put channel into blocking mode. */ +#define TCL_MODE_NONBLOCKING 1 /* Put channel into nonblocking + * mode. */ + +/* + * Types for file handles: + */ + +#define TCL_UNIX_FD 1 +#define TCL_MAC_FILE 2 +#define TCL_MAC_SOCKET 3 +#define TCL_WIN_PIPE 4 +#define TCL_WIN_FILE 5 +#define TCL_WIN_SOCKET 6 +#define TCL_WIN_CONSOLE 7 +#define TCL_WIN32S_PIPE 8 + +/* + * Enum for different types of file paths. + */ + +typedef enum Tcl_PathType { + TCL_PATH_ABSOLUTE, + TCL_PATH_RELATIVE, + TCL_PATH_VOLUME_RELATIVE +} Tcl_PathType; + +/* + * The following interface is exported for backwards compatibility, but + * is only implemented on Unix. Portable applications should use + * Tcl_OpenCommandChannel, instead. + */ + +EXTERN int Tcl_CreatePipeline _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv, int **pidArrayPtr, + int *inPipePtr, int *outPipePtr, + int *errFilePtr)); + +/* + * Exported Tcl procedures: + */ + +EXTERN void Tcl_AddErrorInfo _ANSI_ARGS_((Tcl_Interp *interp, + char *message)); +EXTERN void Tcl_AllowExceptions _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN void Tcl_AppendElement _ANSI_ARGS_((Tcl_Interp *interp, + char *string)); +EXTERN void Tcl_AppendResult _ANSI_ARGS_( + TCL_VARARGS(Tcl_Interp *,interp)); +EXTERN int Tcl_AppInit _ANSI_ARGS_((Tcl_Interp *interp)); +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_AsyncMark _ANSI_ARGS_((Tcl_AsyncHandler async)); +EXTERN int Tcl_AsyncReady _ANSI_ARGS_((void)); +EXTERN void Tcl_BackgroundError _ANSI_ARGS_((Tcl_Interp *interp)); +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 void Tcl_CancelIdleCall _ANSI_ARGS_((Tcl_IdleProc *idleProc, + ClientData clientData)); +#define Tcl_Ckalloc Tcl_Alloc +#define Tcl_Ckfree Tcl_Free +#define Tcl_Ckrealloc Tcl_Realloc +EXTERN int Tcl_Close _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Channel chan)); +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 int Tcl_CreateAlias _ANSI_ARGS_((Tcl_Interp *slave, + char *slaveCmd, Tcl_Interp *target, + char *targetCmd, int argc, char **argv)); +EXTERN Tcl_Channel Tcl_CreateChannel _ANSI_ARGS_(( + Tcl_ChannelType *typePtr, char *chanName, + ClientData instanceData, int mask)); +EXTERN void Tcl_CreateChannelHandler _ANSI_ARGS_(( + Tcl_Channel chan, int mask, + Tcl_ChannelProc *proc, ClientData clientData)); +EXTERN void Tcl_CreateCloseHandler _ANSI_ARGS_(( + Tcl_Channel chan, Tcl_CloseProc *proc, + ClientData clientData)); +EXTERN Tcl_Command Tcl_CreateCommand _ANSI_ARGS_((Tcl_Interp *interp, + char *cmdName, Tcl_CmdProc *proc, + ClientData clientData, + Tcl_CmdDeleteProc *deleteProc)); +EXTERN void Tcl_CreateEventSource _ANSI_ARGS_(( + Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc + *checkProc, ClientData clientData)); +EXTERN void Tcl_CreateExitHandler _ANSI_ARGS_((Tcl_ExitProc *proc, + ClientData clientData)); +EXTERN void Tcl_CreateFileHandler _ANSI_ARGS_(( + Tcl_File file, int mask, Tcl_FileProc *proc, + ClientData clientData)); +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 void Tcl_CreateModalTimeout _ANSI_ARGS_((int milliseconds, + Tcl_TimerProc *proc, ClientData clientData)); +EXTERN Tcl_Interp *Tcl_CreateSlave _ANSI_ARGS_((Tcl_Interp *interp, + char *slaveName, int isSafe)); +EXTERN Tcl_TimerToken Tcl_CreateTimerHandler _ANSI_ARGS_((int milliseconds, + Tcl_TimerProc *proc, ClientData clientData)); +EXTERN Tcl_Trace Tcl_CreateTrace _ANSI_ARGS_((Tcl_Interp *interp, + int level, Tcl_CmdTraceProc *proc, + ClientData clientData)); +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 void Tcl_DeleteAssocData _ANSI_ARGS_((Tcl_Interp *interp, + char *name)); +EXTERN int Tcl_DeleteCommand _ANSI_ARGS_((Tcl_Interp *interp, + char *cmdName)); +EXTERN void Tcl_DeleteChannelHandler _ANSI_ARGS_(( + Tcl_Channel chan, Tcl_ChannelProc *proc, + ClientData clientData)); +EXTERN void Tcl_DeleteCloseHandler _ANSI_ARGS_(( + Tcl_Channel chan, Tcl_CloseProc *proc, + ClientData clientData)); +EXTERN void Tcl_DeleteEventSource _ANSI_ARGS_(( + Tcl_EventSetupProc *setupProc, + Tcl_EventCheckProc *checkProc, + ClientData clientData)); +EXTERN void Tcl_DeleteEvents _ANSI_ARGS_(( + Tcl_EventDeleteProc *proc, + ClientData clientData)); +EXTERN void Tcl_DeleteExitHandler _ANSI_ARGS_((Tcl_ExitProc *proc, + ClientData clientData)); +EXTERN void Tcl_DeleteFileHandler _ANSI_ARGS_(( + Tcl_File file)); +EXTERN void Tcl_DeleteHashEntry _ANSI_ARGS_(( + Tcl_HashEntry *entryPtr)); +EXTERN void Tcl_DeleteHashTable _ANSI_ARGS_(( + Tcl_HashTable *tablePtr)); +EXTERN void Tcl_DeleteInterp _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN void Tcl_DeleteModalTimeout _ANSI_ARGS_(( + Tcl_TimerProc *proc, ClientData clientData)); +EXTERN void Tcl_DeleteTimerHandler _ANSI_ARGS_(( + Tcl_TimerToken token)); +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 int Tcl_DoOneEvent _ANSI_ARGS_((int flags)); +EXTERN void Tcl_DoWhenIdle _ANSI_ARGS_((Tcl_IdleProc *proc, + ClientData clientData)); +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_DStringGetResult _ANSI_ARGS_((Tcl_Interp *interp, + 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_DStringSetLength _ANSI_ARGS_((Tcl_DString *dsPtr, + int length)); +EXTERN void Tcl_DStringStartSublist _ANSI_ARGS_(( + Tcl_DString *dsPtr)); +EXTERN int Tcl_Eof _ANSI_ARGS_((Tcl_Channel chan)); +EXTERN char * Tcl_ErrnoId _ANSI_ARGS_((void)); +EXTERN char * Tcl_ErrnoMsg _ANSI_ARGS_((int err)); +EXTERN int Tcl_Eval _ANSI_ARGS_((Tcl_Interp *interp, char *cmd)); +EXTERN int Tcl_EvalFile _ANSI_ARGS_((Tcl_Interp *interp, + char *fileName)); +EXTERN void Tcl_EventuallyFree _ANSI_ARGS_((ClientData clientData, + Tcl_FreeProc *freeProc)); +EXTERN void Tcl_Exit _ANSI_ARGS_((int status)); +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_FileReady _ANSI_ARGS_((Tcl_File file, + int mask)); +EXTERN void Tcl_FindExecutable _ANSI_ARGS_((char *argv0)); +EXTERN Tcl_HashEntry * Tcl_FirstHashEntry _ANSI_ARGS_(( + Tcl_HashTable *tablePtr, + Tcl_HashSearch *searchPtr)); +EXTERN int Tcl_Flush _ANSI_ARGS_((Tcl_Channel chan)); +EXTERN void Tcl_FreeFile _ANSI_ARGS_(( + Tcl_File file)); +EXTERN int Tcl_GetAlias _ANSI_ARGS_((Tcl_Interp *interp, + char *slaveCmd, Tcl_Interp **targetInterpPtr, + char **targetCmdPtr, int *argcPtr, + char ***argvPtr)); +EXTERN ClientData Tcl_GetAssocData _ANSI_ARGS_((Tcl_Interp *interp, + char *name, Tcl_InterpDeleteProc **procPtr)); +EXTERN int Tcl_GetBoolean _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int *boolPtr)); +EXTERN Tcl_Channel Tcl_GetChannel _ANSI_ARGS_((Tcl_Interp *interp, + char *chanName, int *modePtr)); +EXTERN int Tcl_GetChannelBufferSize _ANSI_ARGS_(( + Tcl_Channel chan)); +EXTERN Tcl_File Tcl_GetChannelFile _ANSI_ARGS_((Tcl_Channel chan, + int direction)); +EXTERN ClientData Tcl_GetChannelInstanceData _ANSI_ARGS_(( + Tcl_Channel chan)); +EXTERN int Tcl_GetChannelMode _ANSI_ARGS_((Tcl_Channel chan)); +EXTERN char * Tcl_GetChannelName _ANSI_ARGS_((Tcl_Channel chan)); +EXTERN int Tcl_GetChannelOption _ANSI_ARGS_((Tcl_Channel chan, + char *optionName, Tcl_DString *dsPtr)); +EXTERN Tcl_ChannelType * Tcl_GetChannelType _ANSI_ARGS_((Tcl_Channel chan)); +EXTERN int Tcl_GetCommandInfo _ANSI_ARGS_((Tcl_Interp *interp, + char *cmdName, Tcl_CmdInfo *infoPtr)); +EXTERN char * Tcl_GetCommandName _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Command command)); +EXTERN char * Tcl_GetCwd _ANSI_ARGS_((char *buf, int len)); +EXTERN int Tcl_GetDouble _ANSI_ARGS_((Tcl_Interp *interp, + char *string, double *doublePtr)); +EXTERN int Tcl_GetErrno _ANSI_ARGS_((void)); +EXTERN Tcl_File Tcl_GetFile _ANSI_ARGS_((ClientData fileData, + int type)); +EXTERN ClientData Tcl_GetFileInfo _ANSI_ARGS_((Tcl_File file, + int *typePtr)); +EXTERN char * Tcl_GetHostName _ANSI_ARGS_((void)); +EXTERN int Tcl_GetInt _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int *intPtr)); +EXTERN int Tcl_GetInterpPath _ANSI_ARGS_((Tcl_Interp *askInterp, + Tcl_Interp *slaveInterp)); +EXTERN Tcl_Interp *Tcl_GetMaster _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN ClientData Tcl_GetNotifierData _ANSI_ARGS_((Tcl_File file, + Tcl_FileFreeProc **freeProcPtr)); +EXTERN int Tcl_GetOpenFile _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int write, int checkUsage, + ClientData *filePtr)); +EXTERN Tcl_PathType Tcl_GetPathType _ANSI_ARGS_((char *path)); +EXTERN int Tcl_Gets _ANSI_ARGS_((Tcl_Channel chan, + Tcl_DString *dsPtr)); +EXTERN Tcl_Interp *Tcl_GetSlave _ANSI_ARGS_((Tcl_Interp *interp, + char *slaveName)); +EXTERN Tcl_Channel Tcl_GetStdChannel _ANSI_ARGS_((int type)); +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_InputBlocked _ANSI_ARGS_((Tcl_Channel chan)); +EXTERN int Tcl_InputBuffered _ANSI_ARGS_((Tcl_Channel chan)); +EXTERN int Tcl_InterpDeleted _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int Tcl_IsSafe _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN char * Tcl_JoinPath _ANSI_ARGS_((int argc, char **argv, + Tcl_DString *resultPtr)); +EXTERN int Tcl_LinkVar _ANSI_ARGS_((Tcl_Interp *interp, + char *varName, char *addr, int type)); +EXTERN void Tcl_Main _ANSI_ARGS_((int argc, char **argv, + Tcl_AppInitProc *appInitProc)); +EXTERN Tcl_Channel Tcl_MakeFileChannel _ANSI_ARGS_((ClientData inFile, + ClientData outFile, int mode)); +EXTERN int Tcl_MakeSafe _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN Tcl_Channel Tcl_MakeTcpClientChannel _ANSI_ARGS_(( + ClientData tcpSocket)); +EXTERN char * Tcl_Merge _ANSI_ARGS_((int argc, char **argv)); +EXTERN Tcl_HashEntry * Tcl_NextHashEntry _ANSI_ARGS_(( + Tcl_HashSearch *searchPtr)); +EXTERN Tcl_Channel Tcl_OpenCommandChannel _ANSI_ARGS_(( + Tcl_Interp *interp, int argc, char **argv, + int flags)); +EXTERN Tcl_Channel Tcl_OpenFileChannel _ANSI_ARGS_((Tcl_Interp *interp, + char *fileName, char *modeString, + int permissions)); +EXTERN Tcl_Channel Tcl_OpenTcpClient _ANSI_ARGS_((Tcl_Interp *interp, + int port, char *address, char *myaddr, + int myport, int async)); +EXTERN Tcl_Channel Tcl_OpenTcpServer _ANSI_ARGS_((Tcl_Interp *interp, + int port, char *host, + Tcl_TcpAcceptProc *acceptProc, + ClientData callbackData)); +EXTERN char * Tcl_ParseVar _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char **termPtr)); +EXTERN int Tcl_PkgProvide _ANSI_ARGS_((Tcl_Interp *interp, + char *name, char *version)); +EXTERN char * Tcl_PkgRequire _ANSI_ARGS_((Tcl_Interp *interp, + char *name, char *version, int exact)); +EXTERN char * Tcl_PosixError _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN void Tcl_Preserve _ANSI_ARGS_((ClientData data)); +EXTERN void Tcl_PrintDouble _ANSI_ARGS_((Tcl_Interp *interp, + double value, char *dst)); +EXTERN int Tcl_PutEnv _ANSI_ARGS_((CONST char *string)); +EXTERN void Tcl_QueueEvent _ANSI_ARGS_((Tcl_Event *evPtr, + Tcl_QueuePosition position)); +EXTERN int Tcl_Read _ANSI_ARGS_((Tcl_Channel chan, + char *bufPtr, int toRead)); +EXTERN void Tcl_ReapDetachedProcs _ANSI_ARGS_((void)); +EXTERN int Tcl_RecordAndEval _ANSI_ARGS_((Tcl_Interp *interp, + char *cmd, int flags)); +EXTERN Tcl_RegExp Tcl_RegExpCompile _ANSI_ARGS_((Tcl_Interp *interp, + char *string)); +EXTERN int Tcl_RegExpExec _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_RegExp regexp, char *string, char *start)); +EXTERN int Tcl_RegExpMatch _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char *pattern)); +EXTERN void Tcl_RegExpRange _ANSI_ARGS_((Tcl_RegExp regexp, + int index, char **startPtr, char **endPtr)); +EXTERN void Tcl_RegisterChannel _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Channel chan)); +EXTERN void Tcl_Release _ANSI_ARGS_((ClientData clientData)); +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_Seek _ANSI_ARGS_((Tcl_Channel chan, + int offset, int mode)); +EXTERN void Tcl_SetAssocData _ANSI_ARGS_((Tcl_Interp *interp, + char *name, Tcl_InterpDeleteProc *proc, + ClientData clientData)); +EXTERN void Tcl_SetChannelBufferSize _ANSI_ARGS_(( + Tcl_Channel chan, int sz)); +EXTERN int Tcl_SetChannelOption _ANSI_ARGS_(( + Tcl_Interp *interp, Tcl_Channel chan, + char *optionName, char *newValue)); +EXTERN int Tcl_SetCommandInfo _ANSI_ARGS_((Tcl_Interp *interp, + char *cmdName, Tcl_CmdInfo *infoPtr)); +EXTERN void Tcl_SetErrno _ANSI_ARGS_((int err)); +EXTERN void Tcl_SetErrorCode _ANSI_ARGS_( + TCL_VARARGS(Tcl_Interp *,interp)); +EXTERN void Tcl_SetMaxBlockTime _ANSI_ARGS_((Tcl_Time *timePtr)); +EXTERN void Tcl_SetNotifierData _ANSI_ARGS_((Tcl_File file, + Tcl_FileFreeProc *freeProcPtr, ClientData data)); +EXTERN void Tcl_SetPanicProc _ANSI_ARGS_((void (*proc) + _ANSI_ARGS_(TCL_VARARGS(char *, format)))); +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 void Tcl_SetStdChannel _ANSI_ARGS_((Tcl_Channel channel, + int type)); +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 void Tcl_Sleep _ANSI_ARGS_((int ms)); +EXTERN void Tcl_SourceRCFile _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int Tcl_SplitList _ANSI_ARGS_((Tcl_Interp *interp, + char *list, int *argcPtr, char ***argvPtr)); +EXTERN void Tcl_SplitPath _ANSI_ARGS_((char *path, + int *argcPtr, char ***argvPtr)); +EXTERN void Tcl_StaticPackage _ANSI_ARGS_((Tcl_Interp *interp, + char *pkgName, Tcl_PackageInitProc *initProc, + Tcl_PackageInitProc *safeInitProc)); +EXTERN int Tcl_StringMatch _ANSI_ARGS_((char *string, + char *pattern)); +EXTERN int Tcl_Tell _ANSI_ARGS_((Tcl_Channel chan)); +#define Tcl_TildeSubst Tcl_TranslateFileName +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 char * Tcl_TranslateFileName _ANSI_ARGS_((Tcl_Interp *interp, + char *name, Tcl_DString *bufferPtr)); +EXTERN void Tcl_UnlinkVar _ANSI_ARGS_((Tcl_Interp *interp, + char *varName)); +EXTERN int Tcl_UnregisterChannel _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Channel chan)); +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)); +EXTERN void Tcl_UpdateLinkedVar _ANSI_ARGS_((Tcl_Interp *interp, + char *varName)); +EXTERN int Tcl_UpVar _ANSI_ARGS_((Tcl_Interp *interp, + char *frameName, char *varName, + char *localName, int flags)); +EXTERN int Tcl_UpVar2 _ANSI_ARGS_((Tcl_Interp *interp, + char *frameName, char *part1, char *part2, + char *localName, int flags)); +EXTERN int Tcl_VarEval _ANSI_ARGS_( + TCL_VARARGS(Tcl_Interp *,interp)); +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)); +EXTERN int Tcl_WaitForEvent _ANSI_ARGS_((Tcl_Time *timePtr)); +EXTERN int Tcl_WaitPid _ANSI_ARGS_((int pid, int *statPtr, + int options)); +EXTERN void Tcl_WatchFile _ANSI_ARGS_((Tcl_File file, + int mask)); +EXTERN int Tcl_Write _ANSI_ARGS_((Tcl_Channel chan, + char *s, int slen)); + +#endif /* RESOURCE_INCLUDED */ +#endif /* _TCL */ diff --git a/tcl7.3/tclAsync.c b/tcl7.6/generic/tclAsync.c similarity index 80% rename from tcl7.3/tclAsync.c rename to tcl7.6/generic/tclAsync.c index 447f5d4..905b664 100644 --- a/tcl7.3/tclAsync.c +++ b/tcl7.6/generic/tclAsync.c @@ -7,30 +7,14 @@ * Mark Diekhans and Don Libes. * * Copyright (c) 1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1994 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tclAsync.c 1.6 96/02/15 11:46:15 */ -#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" /* @@ -61,15 +45,15 @@ 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. + * checked elsewhere in the application by calling Tcl_AsyncReady to see + * if Tcl_AsyncInvoke should be invoked. */ -int tcl_AsyncReady = 0; +static int asyncReady = 0; /* * The variable below indicates whether Tcl_AsyncInvoke is currently - * working. If so then we won't set tcl_AsyncReady again until + * working. If so then we won't set asyncReady again until * Tcl_AsyncInvoke returns. */ @@ -141,7 +125,7 @@ Tcl_AsyncMark(async) { ((AsyncHandler *) async)->ready = 1; if (!asyncActive) { - tcl_AsyncReady = 1; + asyncReady = 1; } } @@ -176,10 +160,10 @@ Tcl_AsyncInvoke(interp, code) { AsyncHandler *asyncPtr; - if (tcl_AsyncReady == 0) { + if (asyncReady == 0) { return code; } - tcl_AsyncReady = 0; + asyncReady = 0; asyncActive = 1; if (interp == NULL) { code = 0; @@ -254,3 +238,28 @@ Tcl_AsyncDelete(async) } ckfree((char *) asyncPtr); } + +/* + *---------------------------------------------------------------------- + * + * Tcl_AsyncReady -- + * + * This procedure can be used to tell whether Tcl_AsyncInvoke + * needs to be called. This procedure is the external interface + * for checking the internal asyncReady variable. + * + * Results: + * The return value is 1 whenever a handler is ready and is 0 + * when no handlers are ready. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_AsyncReady() +{ + return asyncReady; +} diff --git a/tcl7.3/tclBasic.c b/tcl7.6/generic/tclBasic.c similarity index 61% rename from tcl7.3/tclBasic.c rename to tcl7.6/generic/tclBasic.c index 929490c..d9ce936 100644 --- a/tcl7.3/tclBasic.c +++ b/tcl7.6/generic/tclBasic.c @@ -5,36 +5,26 @@ * 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. + * Copyright (c) 1987-1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tclBasic.c 1.220 96/09/19 16:34:22 */ -#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" +# include "tclPort.h" #endif +/* + * Static procedures in this file: + */ + +static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp)); + /* * The following structure defines all of the commands in the Tcl core, * and the C procedures that execute them. @@ -59,11 +49,14 @@ static CmdInfo builtInCmds[] = { {"break", Tcl_BreakCmd}, {"case", Tcl_CaseCmd}, {"catch", Tcl_CatchCmd}, + {"clock", Tcl_ClockCmd}, {"concat", Tcl_ConcatCmd}, {"continue", Tcl_ContinueCmd}, {"error", Tcl_ErrorCmd}, {"eval", Tcl_EvalCmd}, + {"exit", Tcl_ExitCmd}, {"expr", Tcl_ExprCmd}, + {"fileevent", Tcl_FileEventCmd}, {"for", Tcl_ForCmd}, {"foreach", Tcl_ForeachCmd}, {"format", Tcl_FormatCmd}, @@ -72,16 +65,19 @@ static CmdInfo builtInCmds[] = { {"if", Tcl_IfCmd}, {"incr", Tcl_IncrCmd}, {"info", Tcl_InfoCmd}, + {"interp", Tcl_InterpCmd}, {"join", Tcl_JoinCmd}, {"lappend", Tcl_LappendCmd}, {"lindex", Tcl_LindexCmd}, {"linsert", Tcl_LinsertCmd}, {"list", Tcl_ListCmd}, {"llength", Tcl_LlengthCmd}, + {"load", Tcl_LoadCmd}, {"lrange", Tcl_LrangeCmd}, {"lreplace", Tcl_LreplaceCmd}, {"lsearch", Tcl_LsearchCmd}, {"lsort", Tcl_LsortCmd}, + {"package", Tcl_PackageCmd}, {"proc", Tcl_ProcCmd}, {"regexp", Tcl_RegexpCmd}, {"regsub", Tcl_RegsubCmd}, @@ -91,6 +87,7 @@ static CmdInfo builtInCmds[] = { {"set", Tcl_SetCmd}, {"split", Tcl_SplitCmd}, {"string", Tcl_StringCmd}, + {"subst", Tcl_SubstCmd}, {"switch", Tcl_SwitchCmd}, {"trace", Tcl_TraceCmd}, {"unset", Tcl_UnsetCmd}, @@ -103,11 +100,12 @@ static CmdInfo builtInCmds[] = { */ #ifndef TCL_GENERIC_ONLY + {"after", Tcl_AfterCmd}, {"cd", Tcl_CdCmd}, {"close", Tcl_CloseCmd}, {"eof", Tcl_EofCmd}, - {"exec", Tcl_ExecCmd}, - {"exit", Tcl_ExitCmd}, + {"fblocked", Tcl_FblockedCmd}, + {"fconfigure", Tcl_FconfigureCmd}, {"file", Tcl_FileCmd}, {"flush", Tcl_FlushCmd}, {"gets", Tcl_GetsCmd}, @@ -118,9 +116,29 @@ static CmdInfo builtInCmds[] = { {"pwd", Tcl_PwdCmd}, {"read", Tcl_ReadCmd}, {"seek", Tcl_SeekCmd}, - {"source", Tcl_SourceCmd}, + {"socket", Tcl_SocketCmd}, {"tell", Tcl_TellCmd}, {"time", Tcl_TimeCmd}, + {"update", Tcl_UpdateCmd}, + {"vwait", Tcl_VwaitCmd}, + {"unsupported0", TclUnsupported0Cmd}, + +#ifdef MAC_TCL + {"beep", Tcl_MacBeepCmd}, + {"cp", Tcl_CpCmd}, + {"echo", Tcl_EchoCmd}, + {"ls", Tcl_LsCmd}, + {"mkdir", Tcl_MkdirCmd}, + {"mv", Tcl_MvCmd}, + {"resource", Tcl_ResourceCmd}, + {"rm", Tcl_RmCmd}, + {"rmdir", Tcl_RmdirCmd}, + {"source", Tcl_MacSourceCmd}, +#else + {"exec", Tcl_ExecCmd}, + {"source", Tcl_SourceCmd}, +#endif /* MAC_TCL */ + #endif /* TCL_GENERIC_ONLY */ {NULL, (Tcl_CmdProc *) NULL} }; @@ -139,8 +157,7 @@ static CmdInfo builtInCmds[] = { * * 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). + * table and the built-in commands. * *---------------------------------------------------------------------- */ @@ -152,7 +169,6 @@ Tcl_CreateInterp() register Command *cmdPtr; register CmdInfo *cmdInfoPtr; int i; - static int firstInterp = 1; iPtr = (Interp *) ckalloc(sizeof(Interp)); iPtr->result = iPtr->resultSpace; @@ -185,6 +201,8 @@ Tcl_CreateInterp() iPtr->patLengths[i] = -1; iPtr->regexps[i] = NULL; } + Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS); + iPtr->packageUnknown = NULL; strcpy(iPtr->pdFormat, DEFAULT_PD_FORMAT); iPtr->pdPrec = DEFAULT_PD_PREC; iPtr->cmdCount = 0; @@ -193,7 +211,7 @@ Tcl_CreateInterp() iPtr->scriptFile = NULL; iPtr->flags = 0; iPtr->tracePtr = NULL; - iPtr->deleteCallbackPtr = NULL; + iPtr->assocData = (Tcl_HashTable *) NULL; iPtr->resultSpace[0] = 0; /* @@ -210,82 +228,59 @@ Tcl_CreateInterp() cmdInfoPtr->name, &new); if (new) { cmdPtr = (Command *) ckalloc(sizeof(Command)); + cmdPtr->hPtr = hPtr; cmdPtr->proc = cmdInfoPtr->proc; cmdPtr->clientData = (ClientData) NULL; cmdPtr->deleteProc = NULL; cmdPtr->deleteData = (ClientData) NULL; + cmdPtr->deleted = 0; 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 + /* + * Do Safe-Tcl init stuff + */ + + (void) TclInterpInit((Tcl_Interp *)iPtr); + + /* + * Set up variables such as tcl_library and tcl_precision. + */ + + TclPlatformInit((Tcl_Interp *)iPtr); + Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_patchLevel", TCL_PATCH_LEVEL, + TCL_GLOBAL_ONLY); + Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_version", TCL_VERSION, + TCL_GLOBAL_ONLY); Tcl_TraceVar2((Tcl_Interp *) iPtr, "tcl_precision", (char *) NULL, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, TclPrecTraceProc, (ClientData) NULL); + + /* + * Register Tcl's version number. + */ + + Tcl_PkgProvide((Tcl_Interp *) iPtr, "Tcl", TCL_VERSION); + 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. + * interpreter is deleted. The procedure is called as soon + * as Tcl_DeleteInterp is called; if Tcl_CallWhenDeleted is + * called on an interpreter that has already been deleted, + * the procedure will be called when the last Tcl_Release is + * done on the interpreter. * * Results: * None. @@ -305,22 +300,24 @@ Tcl_CallWhenDeleted(interp, proc, clientData) * is about to be deleted. */ ClientData clientData; /* One-word value to pass to proc. */ { - DeleteCallback *dcPtr, *prevPtr; Interp *iPtr = (Interp *) interp; + static int assocDataCounter = 0; + int new; + char buffer[128]; + AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData)); + Tcl_HashEntry *hPtr; - 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; + sprintf(buffer, "Assoc Data Key #%d", assocDataCounter); + assocDataCounter++; + + if (iPtr->assocData == (Tcl_HashTable *) NULL) { + iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); } + hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &new); + dPtr->proc = proc; + dPtr->clientData = clientData; + Tcl_SetHashValue(hPtr, dPtr); } /* @@ -350,22 +347,340 @@ Tcl_DontCallWhenDeleted(interp, proc, clientData) * is about to be deleted. */ ClientData clientData; /* One-word value to pass to proc. */ { - DeleteCallback *prevPtr, *dcPtr; Interp *iPtr = (Interp *) interp; + Tcl_HashTable *hTablePtr; + Tcl_HashSearch hSearch; + Tcl_HashEntry *hPtr; + AssocData *dPtr; - 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; + hTablePtr = iPtr->assocData; + if (hTablePtr == (Tcl_HashTable *) NULL) { + return; } + for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + dPtr = (AssocData *) Tcl_GetHashValue(hPtr); + if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) { + ckfree((char *) dPtr); + Tcl_DeleteHashEntry(hPtr); + return; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetAssocData -- + * + * Creates a named association between user-specified data, a delete + * function and this interpreter. If the association already exists + * the data is overwritten with the new data. The delete function will + * be invoked when the interpreter is deleted. + * + * Results: + * None. + * + * Side effects: + * Sets the associated data, creates the association if needed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetAssocData(interp, name, proc, clientData) + Tcl_Interp *interp; /* Interpreter to associate with. */ + char *name; /* Name for association. */ + Tcl_InterpDeleteProc *proc; /* Proc to call when interpreter is + * about to be deleted. */ + ClientData clientData; /* One-word value to pass to proc. */ +{ + Interp *iPtr = (Interp *) interp; + AssocData *dPtr; + Tcl_HashEntry *hPtr; + int new; + + if (iPtr->assocData == (Tcl_HashTable *) NULL) { + iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); + } + hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &new); + if (new == 0) { + dPtr = (AssocData *) Tcl_GetHashValue(hPtr); + } else { + dPtr = (AssocData *) ckalloc(sizeof(AssocData)); + } + dPtr->proc = proc; + dPtr->clientData = clientData; + + Tcl_SetHashValue(hPtr, dPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteAssocData -- + * + * Deletes a named association of user-specified data with + * the specified interpreter. + * + * Results: + * None. + * + * Side effects: + * Deletes the association. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteAssocData(interp, name) + Tcl_Interp *interp; /* Interpreter to associate with. */ + char *name; /* Name of association. */ +{ + Interp *iPtr = (Interp *) interp; + AssocData *dPtr; + Tcl_HashEntry *hPtr; + + if (iPtr->assocData == (Tcl_HashTable *) NULL) { + return; + } + hPtr = Tcl_FindHashEntry(iPtr->assocData, name); + if (hPtr == (Tcl_HashEntry *) NULL) { + return; + } + dPtr = (AssocData *) Tcl_GetHashValue(hPtr); + if (dPtr->proc != NULL) { + (dPtr->proc) (dPtr->clientData, interp); + } + ckfree((char *) dPtr); + Tcl_DeleteHashEntry(hPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetAssocData -- + * + * Returns the client data associated with this name in the + * specified interpreter. + * + * Results: + * The client data in the AssocData record denoted by the named + * association, or NULL. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +ClientData +Tcl_GetAssocData(interp, name, procPtr) + Tcl_Interp *interp; /* Interpreter associated with. */ + char *name; /* Name of association. */ + Tcl_InterpDeleteProc **procPtr; /* Pointer to place to store address + * of current deletion callback. */ +{ + Interp *iPtr = (Interp *) interp; + AssocData *dPtr; + Tcl_HashEntry *hPtr; + + if (iPtr->assocData == (Tcl_HashTable *) NULL) { + return (ClientData) NULL; + } + hPtr = Tcl_FindHashEntry(iPtr->assocData, name); + if (hPtr == (Tcl_HashEntry *) NULL) { + return (ClientData) NULL; + } + dPtr = (AssocData *) Tcl_GetHashValue(hPtr); + if (procPtr != (Tcl_InterpDeleteProc **) NULL) { + *procPtr = dPtr->proc; + } + return dPtr->clientData; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteInterpProc -- + * + * Helper procedure to delete an interpreter. This procedure is + * called when the last call to Tcl_Preserve on this interpreter + * is matched by a call to Tcl_Release. The procedure cleans up + * all resources used in the interpreter and calls all currently + * registered interpreter deletion callbacks. + * + * Results: + * None. + * + * Side effects: + * Whatever the interpreter deletion callbacks do. Frees resources + * used by the interpreter. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteInterpProc(interp) + Tcl_Interp *interp; /* Interpreter to delete. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + int i; + Tcl_HashTable *hTablePtr; + AssocData *dPtr; + + /* + * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup. + */ + + if (iPtr->numLevels > 0) { + panic("DeleteInterpProc called with active evals"); + } + + /* + * The interpreter should already be marked deleted; otherwise how + * did we get here? + */ + + if (!(iPtr->flags & DELETED)) { + panic("DeleteInterpProc called on interpreter not marked deleted"); + } + + /* + * First delete all the commands. There's a special hack here + * because "tkerror" is just a synonym for "bgerror" (they share + * a Command structure). Just delete the hash table entry for + * "tkerror" without invoking its callback or cleaning up its + * Command structure. + */ + + hPtr = Tcl_FindHashEntry(&iPtr->commandTable, "tkerror"); + if (hPtr != NULL) { + Tcl_DeleteHashEntry(hPtr); + } + for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search); + hPtr != NULL; + hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search)) { + Tcl_DeleteCommand(interp, + Tcl_GetHashKey(&iPtr->commandTable, hPtr)); + } + 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); + + /* + * Invoke deletion callbacks; note that a callback can create new + * callbacks, so we iterate. + */ + + while (iPtr->assocData != (Tcl_HashTable *) NULL) { + hTablePtr = iPtr->assocData; + iPtr->assocData = (Tcl_HashTable *) NULL; + for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search); + hPtr != NULL; + hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) { + dPtr = (AssocData *) Tcl_GetHashValue(hPtr); + Tcl_DeleteHashEntry(hPtr); + if (dPtr->proc != NULL) { + (*dPtr->proc)(dPtr->clientData, interp); + } + ckfree((char *) dPtr); + } + Tcl_DeleteHashTable(hTablePtr); + ckfree((char *) hTablePtr); + } + + /* + * Delete all global variables: + */ + + 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); + interp->result = NULL; + + if (iPtr->errorInfo != NULL) { + ckfree(iPtr->errorInfo); + iPtr->errorInfo = NULL; + } + if (iPtr->errorCode != NULL) { + ckfree(iPtr->errorCode); + iPtr->errorCode = NULL; + } + if (iPtr->events != NULL) { + int i; + + for (i = 0; i < iPtr->numEvents; i++) { + ckfree(iPtr->events[i].command); + } + ckfree((char *) iPtr->events); + iPtr->events = NULL; + } + while (iPtr->revPtr != NULL) { + HistoryRev *nextPtr = iPtr->revPtr->nextPtr; + + ckfree(iPtr->revPtr->newBytes); + ckfree((char *) iPtr->revPtr); + iPtr->revPtr = nextPtr; + } + if (iPtr->appendResult != NULL) { + ckfree(iPtr->appendResult); + iPtr->appendResult = NULL; + } + for (i = 0; i < NUM_REGEXPS; i++) { + if (iPtr->patterns[i] == NULL) { + break; + } + ckfree(iPtr->patterns[i]); + ckfree((char *) iPtr->regexps[i]); + iPtr->regexps[i] = NULL; + } + TclFreePackageInfo(iPtr); + while (iPtr->tracePtr != NULL) { + Trace *nextPtr = iPtr->tracePtr->nextPtr; + + ckfree((char *) iPtr->tracePtr); + iPtr->tracePtr = nextPtr; + } + + ckfree((char *) iPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_InterpDeleted -- + * + * Returns nonzero if the interpreter has been deleted with a call + * to Tcl_DeleteInterp. + * + * Results: + * Nonzero if the interpreter is deleted, zero otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_InterpDeleted(interp) + Tcl_Interp *interp; +{ + return (((Interp *) interp)->flags & DELETED) ? 1 : 0; } /* @@ -373,15 +688,20 @@ Tcl_DontCallWhenDeleted(interp, proc, clientData) * * Tcl_DeleteInterp -- * - * Delete an interpreter and free up all of the resources associated - * with it. + * Ensures that the interpreter will be deleted eventually. If there + * are no Tcl_Preserve calls in effect for this interpreter, it is + * deleted immediately, otherwise the interpreter is deleted when + * the last Tcl_Preserve is matched by a call to Tcl_Release. In either + * case, the procedure runs the currently registered deletion callbacks. * * Results: * None. * * Side effects: - * The interpreter is destroyed. The caller should never again - * use the interp token. + * The interpreter is marked as deleted. The caller may still use it + * safely if there are calls to Tcl_Preserve in effect for the + * interpreter, but further calls to Tcl_Eval etc in this interpreter + * will fail. * *---------------------------------------------------------------------- */ @@ -392,97 +712,27 @@ Tcl_DeleteInterp(interp) * 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. + * If the interpreter has already been marked deleted, just punt. + */ + + if (iPtr->flags & DELETED) { + return; + } + + /* + * Mark the interpreter as deleted. No further evals will be allowed. */ iPtr->flags |= DELETED; - if (iPtr->numLevels != 0) { - return; - } /* - * Invoke deletion callbacks. + * Ensure that the interpreter is eventually deleted. */ - 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_EventuallyFree((ClientData) interp, + (Tcl_FreeProc *) DeleteInterpProc); } /* @@ -493,7 +743,8 @@ Tcl_DeleteInterp(interp) * Define a new command in a command table. * * Results: - * None. + * The return value is a token for the command, which can + * be used in future calls to Tcl_NameOfCommand. * * Side effects: * If a command named cmdName already exists for interp, it is @@ -505,7 +756,7 @@ Tcl_DeleteInterp(interp) *---------------------------------------------------------------------- */ -void +Tcl_Command Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) Tcl_Interp *interp; /* Token for command interpreter (returned * by a previous call to Tcl_CreateInterp). */ @@ -518,28 +769,75 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) * this command is deleted. */ { Interp *iPtr = (Interp *) interp; - register Command *cmdPtr; + Command *cmdPtr; Tcl_HashEntry *hPtr; int new; - hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, cmdName, &new); - if (!new) { + /* + * The code below was added in 11/95 to preserve backwards compatibility + * when "tkerror" was renamed "bgerror": if anyone attempts to define + * "tkerror" as a command, it is actually created as "bgerror". This + * code should eventually be removed. + */ + + if ((cmdName[0] == 't') && (strcmp(cmdName, "tkerror") == 0)) { + cmdName = "bgerror"; + } + + if (iPtr->flags & DELETED) { + /* - * Command already exists: delete the old one. + * The interpreter is being deleted. Don't create any new + * commands; it's not safe to muck with the interpreter anymore. */ - cmdPtr = (Command *) Tcl_GetHashValue(hPtr); - if (cmdPtr->deleteProc != NULL) { - (*cmdPtr->deleteProc)(cmdPtr->deleteData); - } - } else { - cmdPtr = (Command *) ckalloc(sizeof(Command)); - Tcl_SetHashValue(hPtr, cmdPtr); + return (Tcl_Command) NULL; } + hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, cmdName, &new); + if (!new) { + + /* + * Command already exists: delete the old one. + */ + + Tcl_DeleteCommand(interp, Tcl_GetHashKey(&iPtr->commandTable, hPtr)); + hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, cmdName, &new); + if (!new) { + + /* + * If the deletion callback recreated the command, just throw + * away the new command (if we try to delete it again, we + * could get stuck in an infinite loop). + */ + + ckfree((char *) Tcl_GetHashValue(hPtr)); + } + } + cmdPtr = (Command *) ckalloc(sizeof(Command)); + Tcl_SetHashValue(hPtr, cmdPtr); + cmdPtr->hPtr = hPtr; cmdPtr->proc = proc; cmdPtr->clientData = clientData; cmdPtr->deleteProc = deleteProc; cmdPtr->deleteData = clientData; + cmdPtr->deleted = 0; + + /* + * The code below provides more backwards compatibility for the + * renaming of "tkerror" to "bgerror". Like the code above, this + * code should eventually become unnecessary. + */ + + if ((cmdName[0] == 'b') && (strcmp(cmdName, "bgerror") == 0)) { + /* + * We're currently creating the "bgerror" command; create + * a "tkerror" command that shares the same Command structure. + */ + + hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, "tkerror", &new); + Tcl_SetHashValue(hPtr, cmdPtr); + } + return (Tcl_Command) cmdPtr; } /* @@ -626,6 +924,47 @@ Tcl_GetCommandInfo(interp, cmdName, infoPtr) return 1; } +/* + *---------------------------------------------------------------------- + * + * Tcl_GetCommandName -- + * + * Given a token returned by Tcl_CreateCommand, this procedure + * returns the current name of the command (which may have changed + * due to renaming). + * + * Results: + * The return value is the name of the given command. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_GetCommandName(interp, command) + Tcl_Interp *interp; /* Interpreter containing the command. */ + Tcl_Command command; /* Token for the command, returned by a + * previous call to Tcl_CreateCommand. + * The command must not have been deleted. */ +{ + Command *cmdPtr = (Command *) command; + Interp *iPtr = (Interp *) interp; + + if ((cmdPtr == NULL) || (cmdPtr->hPtr == NULL)) { + + /* + * This should only happen if command was "created" after the + * interpreter began to be deleted, so there isn't really any + * command. Just return an empty string. + */ + + return ""; + } + return Tcl_GetHashKey(&iPtr->commandTable, cmdPtr->hPtr); +} + /* *---------------------------------------------------------------------- * @@ -652,19 +991,85 @@ Tcl_DeleteCommand(interp, cmdName) char *cmdName; /* Name of command to remove. */ { Interp *iPtr = (Interp *) interp; - Tcl_HashEntry *hPtr; + Tcl_HashEntry *hPtr, *tkErrorHPtr; Command *cmdPtr; + /* + * The code below was added in 11/95 to preserve backwards compatibility + * when "tkerror" was renamed "bgerror": if anyone attempts to delete + * "tkerror", delete both it and "bgerror". This code should + * eventually be removed. + */ + + if ((cmdName[0] == 't') && (strcmp(cmdName, "tkerror") == 0)) { + cmdName = "bgerror"; + } hPtr = Tcl_FindHashEntry(&iPtr->commandTable, cmdName); if (hPtr == NULL) { return -1; } cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + + /* + * The code here is tricky. We can't delete the hash table entry + * before invoking the deletion callback because there are cases + * where the deletion callback needs to invoke the command (e.g. + * object systems such as OTcl). However, this means that the + * callback could try to delete or rename the command. The deleted + * flag allows us to detect these cases and skip nested deletes. + */ + + if (cmdPtr->deleted) { + + /* + * Another deletion is already in progress. Remove the hash + * table entry now, but don't invoke a callback or free the + * command structure. + */ + + Tcl_DeleteHashEntry(cmdPtr->hPtr); + cmdPtr->hPtr = NULL; + return 0; + } + cmdPtr->deleted = 1; if (cmdPtr->deleteProc != NULL) { (*cmdPtr->deleteProc)(cmdPtr->deleteData); } + + /* + * The code below provides more backwards compatibility for the + * renaming of "tkerror" to "bgerror". Like the code above, this + * code should eventually become unnecessary. + */ + + if ((cmdName[0] == 'b') && (strcmp(cmdName, "bgerror") == 0)) { + + /* + * When the "bgerror" command is deleted, delete "tkerror" + * as well. It shared the same Command structure as "bgerror", + * so all we have to do is throw away the hash table entry. + * NOTE: we have to be careful since tkerror may already have + * been deleted before bgerror. + */ + + tkErrorHPtr = Tcl_FindHashEntry(&iPtr->commandTable, "tkerror"); + if (tkErrorHPtr != (Tcl_HashEntry *) NULL) { + Tcl_DeleteHashEntry(tkErrorHPtr); + } + } + + /* + * Don't use hPtr to delete the hash entry here, because it's + * possible that the deletion callback renamed the command. + * Instead, use cmdPtr->hptr, and make sure that no-one else + * has already deleted the hash entry. + */ + + if (cmdPtr->hPtr != NULL) { + Tcl_DeleteHashEntry(cmdPtr->hPtr); + } ckfree((char *) cmdPtr); - Tcl_DeleteHashEntry(hPtr); + return 0; } @@ -728,8 +1133,9 @@ Tcl_Eval(interp, cmd) * procedure was called. */ int result; /* Return value. */ register Interp *iPtr = (Interp *) interp; - Tcl_HashEntry *hPtr; - Command *cmdPtr; + Tcl_HashEntry *hPtr; /* Search variable. */ + Command *cmdPtr; /* Command structure for the command + * being evaled or invoked. */ char *termPtr; /* Contains character just after the * last one in the command. */ char *cmdStart; /* Points to first non-blank char. in @@ -741,6 +1147,8 @@ Tcl_Eval(interp, cmd) * in errorInfo. "" means that the * command is all there. */ register Trace *tracePtr; + int oldCount = iPtr->cmdCount; /* Used to tell whether any commands + * at all were executed. */ /* * Initialize the result to an empty string and clear out any @@ -793,6 +1201,21 @@ Tcl_Eval(interp, cmd) */ while (*src != termChar) { + + /* + * If we have been deleted, return an error preventing further + * evals. + */ + + if (iPtr->flags & DELETED) { + Tcl_ResetResult(interp); + interp->result = "attempt to call eval in deleted interpreter"; + Tcl_SetErrorCode(interp, "CORE", "IDELETE", interp->result, + (char *) NULL); + iPtr->numLevels--; + return TCL_ERROR; + } + iPtr->flags &= ~(ERR_IN_PROGRESS | ERROR_CODE_SET); /* @@ -809,10 +1232,17 @@ Tcl_Eval(interp, cmd) src += 1; } if (*src == '#') { - for (src++; *src != 0; src++) { - if ((*src == '\n') && (src[-1] != '\\')) { + while (*src != 0) { + if (*src == '\\') { + int length; + Tcl_Backslash(src, &length); + src += length; + } else if (*src == '\n') { src++; + termPtr = src; break; + } else { + src++; } } continue; @@ -905,33 +1335,26 @@ Tcl_Eval(interp, cmd) iPtr->evalFirst = cmdStart; iPtr->evalLast = src-1; } + + hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[0]); + if (hPtr == NULL) { + int i; - /* - * 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); + 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. @@ -963,7 +1386,7 @@ Tcl_Eval(interp, cmd) iPtr->result = iPtr->resultSpace; iPtr->resultSpace[0] = 0; result = (*cmdPtr->proc)(cmdPtr->clientData, interp, argc, argv); - if (tcl_AsyncReady) { + if (Tcl_AsyncReady()) { result = Tcl_AsyncInvoke(interp, result); } if (result != TCL_OK) { @@ -971,11 +1394,24 @@ Tcl_Eval(interp, cmd) } } + done: + + /* + * If no commands at all were executed, check for asynchronous + * handlers so that they at least get one change to execute. + * This is needed to handle event loops written in Tcl with + * empty bodies (I'm not sure that loops like this are a good + * idea, but...). + */ + + if ((oldCount == iPtr->cmdCount) && (Tcl_AsyncReady())) { + result = Tcl_AsyncInvoke(interp, result); + } + /* * Free up any extra resources that were allocated. */ - done: if (pv.buffer != copyStorage) { ckfree((char *) pv.buffer); } @@ -985,9 +1421,10 @@ Tcl_Eval(interp, cmd) iPtr->numLevels--; if (iPtr->numLevels == 0) { if (result == TCL_RETURN) { - result = TCL_OK; + result = TclUpdateReturnInfo(iPtr); } - if ((result != TCL_OK) && (result != TCL_ERROR)) { + if ((result != TCL_OK) && (result != TCL_ERROR) + && !(flags & TCL_ALLOW_EXCEPTIONS)) { Tcl_ResetResult(interp); if (result == TCL_BREAK) { iPtr->result = "invoked \"break\" outside of a loop"; @@ -1000,9 +1437,6 @@ Tcl_Eval(interp, cmd) } result = TCL_ERROR; } - if (iPtr->flags & DELETED) { - Tcl_DeleteInterp(interp); - } } /* @@ -1238,21 +1672,11 @@ Tcl_AddErrorInfo(interp, message) */ /* VARARGS2 */ /* ARGSUSED */ int -#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 +Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1) { va_list argList; -#define FIXED_SIZE 200 - char fixedSpace[FIXED_SIZE+1]; - int spaceAvl, spaceUsed, length; - char *string, *cmd; + Tcl_DString buf; + char *string; Tcl_Interp *interp; int result; @@ -1263,39 +1687,19 @@ Tcl_VarEval(iPtr, p, va_alist) * space. */ - va_start(argList); - interp = va_arg(argList, Tcl_Interp *); - spaceAvl = FIXED_SIZE; - spaceUsed = 0; - cmd = fixedSpace; + interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList); + Tcl_DStringInit(&buf); 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; + Tcl_DStringAppend(&buf, string, -1); } va_end(argList); - cmd[spaceUsed] = '\0'; - result = Tcl_Eval(interp, cmd); - if (cmd != fixedSpace) { - ckfree(cmd); - } + result = Tcl_Eval(interp, Tcl_DStringValue(&buf)); + Tcl_DStringFree(&buf); return result; } @@ -1367,3 +1771,32 @@ Tcl_SetRecursionLimit(interp, depth) } return old; } + +/* + *---------------------------------------------------------------------- + * + * Tcl_AllowExceptions -- + * + * Sets a flag in an interpreter so that exceptions can occur + * in the next call to Tcl_Eval without them being turned into + * errors. + * + * Results: + * None. + * + * Side effects: + * The TCL_ALLOW_EXCEPTIONS flag gets set in the interpreter's + * evalFlags structure. See the reference documentation for + * more details. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AllowExceptions(interp) + Tcl_Interp *interp; /* Interpreter in which to set flag. */ +{ + Interp *iPtr = (Interp *) interp; + + iPtr->evalFlags |= TCL_ALLOW_EXCEPTIONS; +} diff --git a/tcl7.3/tclCkalloc.c b/tcl7.6/generic/tclCkalloc.c similarity index 57% rename from tcl7.3/tclCkalloc.c rename to tcl7.6/generic/tclCkalloc.c index 6f04922..c7edde6 100644 --- a/tcl7.3/tclCkalloc.c +++ b/tcl7.6/generic/tclCkalloc.c @@ -1,60 +1,90 @@ /* * 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. + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * This code contributed by Karl Lehenbauer and Mark Diekhans * + * + * SCCS: @(#) tclCkalloc.c 1.24 96/09/17 13:23:02 */ #include "tclInt.h" +#include "tclPort.h" #define FALSE 0 #define TRUE 1 #ifdef TCL_MEM_DEBUG -#ifndef TCL_GENERIC_ONLY -#include "tclUnix.h" -#endif -#define GUARD_SIZE 8 +/* + * One of the following structures is allocated each time the + * "memory tag" command is invoked, to hold the current tag. + */ +typedef struct MemTag { + int refCount; /* Number of mem_headers referencing + * this tag. */ + char string[4]; /* Actual size of string will be as + * large as needed for actual tag. This + * must be the last field in the structure. */ +} MemTag; + +#define TAG_SIZE(bytesInString) ((unsigned) sizeof(MemTag) + bytesInString - 3) + +static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers + * (set by "memory tag" command). */ + +/* + * One of the following structures is allocated just before each + * dynamically allocated chunk of memory, both to record information + * about the chunk and to help detect chunk under-runs. + */ + +#define LOW_GUARD_SIZE (8 + (32 - (sizeof(long) + sizeof(int)))%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]; + struct mem_header *flink; + struct mem_header *blink; + MemTag *tagPtr; /* Tag from "memory tag" command; may be + * NULL. */ + char *file; + long length; + int line; + unsigned char low_guard[LOW_GUARD_SIZE]; + /* Aligns body on 8-byte boundary, plus + * provides at least 8 additional guard bytes + * to detect underruns. */ + char body[1]; /* First byte of client's space. Actual + * size of this field will be larger than + * one. */ }; static struct mem_header *allocHead = NULL; /* List of allocated structures */ -#define GUARD_VALUE 0341 +#define GUARD_VALUE 0141 -/* static char high_guard[] = {0x89, 0xab, 0xcd, 0xef}; */ +/* + * The following macro determines the amount of guard space *above* each + * chunk of memory. + */ + +#define HIGH_GUARD_SIZE 8 + +/* + * The following macro computes the offset of the "body" field within + * mem_header. It is used to get back to the header pointer from the + * body pointer that's used by clients. + */ + +#define BODY_OFFSET \ + ((unsigned long) (&((struct mem_header *) 0)->body)) static int total_mallocs = 0; static int total_frees = 0; @@ -114,7 +144,7 @@ dump_memory_info(outFile) *---------------------------------------------------------------------- */ static void -ValidateMemory (memHeaderP, file, line, nukeGuards) +ValidateMemory(memHeaderP, file, line, nukeGuards) struct mem_header *memHeaderP; char *file; int line; @@ -125,28 +155,28 @@ ValidateMemory (memHeaderP, file, line, nukeGuards) int guard_failed = FALSE; int byte; - for (idx = 0; idx < GUARD_SIZE; idx++) { + for (idx = 0; idx < LOW_GUARD_SIZE; idx++) { byte = *(memHeaderP->low_guard + idx); if (byte != GUARD_VALUE) { guard_failed = TRUE; - fflush (stdout); + 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, + dump_memory_info(stderr); + fprintf(stderr, "low guard failed at %lx, %s %d\n", + (long unsigned int) memHeaderP->body, file, line); + fflush(stderr); /* In case name pointer is bad. */ + fprintf(stderr, "%ld 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++) { + for (idx = 0; idx < HIGH_GUARD_SIZE; idx++) { byte = *(hiPtr + idx); if (byte != GUARD_VALUE) { guard_failed = TRUE; @@ -159,17 +189,18 @@ ValidateMemory (memHeaderP, file, line, nukeGuards) 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"); + fprintf(stderr, "high guard failed at %lx, %s %d\n", + (long unsigned int) memHeaderP->body, file, line); + fflush(stderr); /* In case name pointer is bad. */ + fprintf(stderr, "%ld 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); + memset ((char *) memHeaderP->low_guard, 0, LOW_GUARD_SIZE); + memset ((char *) hiPtr, 0, HIGH_GUARD_SIZE); } } @@ -190,7 +221,7 @@ Tcl_ValidateAllMemory (file, line) struct mem_header *memScanP; for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) - ValidateMemory (memScanP, file, line, FALSE); + ValidateMemory(memScanP, file, line, FALSE); } @@ -213,15 +244,17 @@ Tcl_DumpActiveMemory (fileName) struct mem_header *memScanP; char *address; - fileP = fopen (fileName, "w"); + 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); + fprintf(fileP, "%8lx - %8lx %7ld @ %s %d %s", + (long unsigned int) address, + (long unsigned int) address + memScanP->length - 1, + memScanP->length, memScanP->file, memScanP->line, + (memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string); (void) fputc('\n', fileP); } fclose (fileP); @@ -257,8 +290,8 @@ Tcl_DbCkalloc(size, file, line) if (validate_memory) Tcl_ValidateAllMemory (file, line); - result = (struct mem_header *)malloc((unsigned)size + - sizeof(struct mem_header) + GUARD_SIZE); + result = (struct mem_header *) TclpAlloc((unsigned)size + + sizeof(struct mem_header) + HIGH_GUARD_SIZE); if (result == NULL) { fflush(stdout); dump_memory_info(stderr); @@ -273,12 +306,16 @@ Tcl_DbCkalloc(size, file, line) */ if (init_malloced_bodies) { memset ((VOID *) result, GUARD_VALUE, - size + sizeof(struct mem_header) + GUARD_SIZE); + size + sizeof(struct mem_header) + HIGH_GUARD_SIZE); } else { - memset ((char *) result->low_guard, GUARD_VALUE, GUARD_SIZE); - memset (result->body + size, GUARD_VALUE, GUARD_SIZE); + memset ((char *) result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE); + memset (result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE); } result->length = size; + result->tagPtr = curTagPtr; + if (curTagPtr != NULL) { + curTagPtr->refCount++; + } result->file = file; result->line = line; result->flink = allocHead; @@ -298,8 +335,8 @@ Tcl_DbCkalloc(size, file, line) } if (alloc_tracing) - fprintf(stderr,"ckalloc %lx %d %s %d\n", result->body, size, - file, line); + fprintf(stderr,"ckalloc %lx %d %s %d\n", + (long unsigned int) result->body, size, file, line); if (break_on_malloc && (total_mallocs >= break_on_malloc)) { break_on_malloc = 0; @@ -346,33 +383,40 @@ Tcl_DbCkfree(ptr, file, line) 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 + * The following cast is *very* tricky. Must convert the pointer + * to an integer before doing arithmetic on it, because otherwise + * the arithmetic will be done differently (and incorrectly) on + * word-addressed machines such as Crays (will subtract only bytes, + * even though BODY_OFFSET is in words on these machines). */ -#ifdef _CRAYCOM - memp = (struct mem_header *)((char *) ptr - (sizeof(int)*((unsigned)&(memp->body)))); -#else - memp = (struct mem_header *)(((char *) ptr) - (int)memp->body); -#endif + + struct mem_header *memp = (struct mem_header *) + (((unsigned long) ptr) - BODY_OFFSET); if (alloc_tracing) - fprintf(stderr, "ckfree %lx %ld %s %d\n", memp->body, - memp->length, file, line); + fprintf(stderr, "ckfree %lx %ld %s %d\n", + (long unsigned int) memp->body, memp->length, file, line); if (validate_memory) - Tcl_ValidateAllMemory (file, line); + Tcl_ValidateAllMemory(file, line); - ValidateMemory (memp, file, line, TRUE); + ValidateMemory(memp, file, line, TRUE); if (init_malloced_bodies) { - memset((VOID *) ptr, GUARD_VALUE, memp->length); + memset((VOID *) ptr, GUARD_VALUE, (size_t) memp->length); } total_frees++; current_malloc_packets--; current_bytes_malloced -= memp->length; + if (memp->tagPtr != NULL) { + memp->tagPtr->refCount--; + if ((memp->tagPtr->refCount == 0) && (curTagPtr != memp->tagPtr)) { + TclpFree((char *) memp->tagPtr); + } + } + /* * Delink from allocated list */ @@ -382,7 +426,7 @@ Tcl_DbCkfree(ptr, file, line) memp->blink->flink = memp->flink; if (allocHead == memp) allocHead = memp->flink; - free((char *) memp); + TclpFree((char *) memp); return 0; } @@ -407,22 +451,68 @@ Tcl_DbCkrealloc(ptr, size, file, 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 + /* + * See comment from Tcl_DbCkfree before you change the following + * line. + */ + + struct mem_header *memp = (struct mem_header *) + (((unsigned long) ptr) - BODY_OFFSET); + copySize = size; if (copySize > memp->length) { copySize = memp->length; } new = Tcl_DbCkalloc(size, file, line); - memcpy((VOID *) new, (VOID *) ptr, (int) copySize); + memcpy((VOID *) new, (VOID *) ptr, (size_t) copySize); Tcl_DbCkfree(ptr, file, line); return(new); } + + +/* + *---------------------------------------------------------------------- + * + * Tcl_Alloc, et al. -- + * + * These functions are defined in terms of the debugging versions + * when TCL_MEM_DEBUG is set. + * + * Results: + * Same as the debug versions. + * + * Side effects: + * Same as the debug versions. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_Alloc +#undef Tcl_Free +#undef Tcl_Realloc + +char * +Tcl_Alloc(size) + unsigned int size; +{ + return Tcl_DbCkalloc(size, "unknown", 0); +} + +void +Tcl_Free(ptr) + char *ptr; +{ + Tcl_DbCkfree(ptr, "unknown", 0); +} + +char * +Tcl_Realloc(ptr, size) + char *ptr; + unsigned int size; +{ + return Tcl_DbCkrealloc(ptr, size, "unknown", 0); +} /* *---------------------------------------------------------------------- @@ -454,55 +544,18 @@ MemoryCmd (clientData, interp, argc, argv) int result; if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", + 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); + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " active file\"", (char *) NULL); return TCL_ERROR; } - fileName = Tcl_TildeSubst(interp, argv[2], &buffer); + fileName = Tcl_TranslateFileName(interp, argv[2], &buffer); if (fileName == NULL) { return TCL_ERROR; } @@ -515,18 +568,77 @@ MemoryCmd (clientData, interp, argc, argv) } 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],"init") == 0) { + if (argc != 3) { + goto bad_suboption; + } + init_malloced_bodies = (strcmp(argv[2],"on") == 0); + return TCL_OK; + } + if (strcmp(argv[1],"tag") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " tag string\"", (char *) NULL); + return TCL_ERROR; + } + if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) { + TclpFree((char *) curTagPtr); + } + curTagPtr = (MemTag *) TclpAlloc(TAG_SIZE(strlen(argv[2]))); + curTagPtr->refCount = 0; + strcpy(curTagPtr->string, argv[2]); + return TCL_OK; + } + 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],"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],"validate") == 0) { + if (argc != 3) { + goto bad_suboption; + } + validate_memory = (strcmp(argv[2],"on") == 0); + 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); + "\": should be active, break_on_malloc, info, init, ", + "tag, trace, trace_on_at_malloc, or validate", (char *) NULL); return TCL_ERROR; argError: - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ", argv[1], "count\"", (char *) NULL); + 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], + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ", argv[1], " on|off\"", (char *) NULL); return TCL_ERROR; } @@ -543,8 +655,8 @@ void Tcl_InitMemory(interp) Tcl_Interp *interp; { -Tcl_CreateCommand (interp, "memory", MemoryCmd, (ClientData) NULL, - (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand (interp, "memory", MemoryCmd, (ClientData) NULL, + (Tcl_CmdDeleteProc *) NULL); } #else @@ -553,39 +665,112 @@ Tcl_CreateCommand (interp, "memory", MemoryCmd, (ClientData) NULL, /* *---------------------------------------------------------------------- * - * Tcl_Ckalloc -- - * Interface to malloc when TCL_MEM_DEBUG is disabled. It does check + * Tcl_Alloc -- + * Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does check * that memory was actually allocated. * *---------------------------------------------------------------------- */ -VOID * -Tcl_Ckalloc (size) + +char * +Tcl_Alloc (size) unsigned int size; { char *result; - result = malloc(size); + result = TclpAlloc(size); if (result == NULL) panic("unable to alloc %d bytes", size); return result; } + +char * +Tcl_DbCkalloc(size, file, line) + unsigned int size; + char *file; + int line; +{ + char *result; + + result = (char *) TclpAlloc(size); + + if (result == NULL) { + fflush(stdout); + panic("unable to alloc %d bytes, %s line %d", size, file, + line); + } + return result; +} + + +/* + *---------------------------------------------------------------------- + * + * Tcl_Realloc -- + * Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does + * check that memory was actually allocated. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_Realloc(ptr, size) + char *ptr; + unsigned int size; +{ + char *result; + + result = TclpRealloc(ptr, size); + if (result == NULL) + panic("unable to realloc %d bytes", size); + return result; +} + +char * +Tcl_DbCkrealloc(ptr, size, file, line) + char *ptr; + unsigned int size; + char *file; + int line; +{ + char *result; + + result = (char *) TclpRealloc(ptr, size); + + if (result == NULL) { + fflush(stdout); + panic("unable to realloc %d bytes, %s line %d", size, file, + line); + } + 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_Free -- + * Interface to TclpFree 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; +Tcl_Free (ptr) + char *ptr; { - free (ptr); + TclpFree(ptr); +} + +int +Tcl_DbCkfree(ptr, file, line) + char * ptr; + char *file; + int line; +{ + TclpFree(ptr); + return 0; } /* @@ -604,4 +789,25 @@ Tcl_InitMemory(interp) { } +#undef Tcl_DumpActiveMemory +#undef Tcl_ValidateAllMemory + +extern int Tcl_DumpActiveMemory _ANSI_ARGS_((char *fileName)); +extern void Tcl_ValidateAllMemory _ANSI_ARGS_((char *file, + int line)); + +int +Tcl_DumpActiveMemory(fileName) + char *fileName; +{ + return TCL_OK; +} + +void +Tcl_ValidateAllMemory(file, line) + char *file; + int line; +{ +} + #endif diff --git a/tcl7.6/generic/tclClock.c b/tcl7.6/generic/tclClock.c new file mode 100644 index 0000000..3eaf99a --- /dev/null +++ b/tcl7.6/generic/tclClock.c @@ -0,0 +1,359 @@ +/* + * tclClock.c -- + * + * Contains the time and date related commands. This code + * is derived from the time and date facilities of TclX, + * by Mark Diekhans and Karl Lehenbauer. + * + * Copyright 1991-1995 Karl Lehenbauer and Mark Diekhans. + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclClock.c 1.20 96/07/23 16:14:45 + */ + +#include "tcl.h" +#include "tclInt.h" +#include "tclPort.h" + +/* + * Function prototypes for local procedures in this file: + */ + +static int FormatClock _ANSI_ARGS_((Tcl_Interp *interp, + unsigned long clockVal, int useGMT, + char *format)); +static int ParseTime _ANSI_ARGS_((Tcl_Interp *interp, + char *string, unsigned long *timePtr)); + +/* + *----------------------------------------------------------------------------- + * + * Tcl_ClockCmd -- + * + * This procedure is invoked to process the "clock" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *----------------------------------------------------------------------------- + */ + +int +Tcl_ClockCmd (dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int c; + size_t length; + char **argPtr; + int useGMT = 0; + unsigned long clockVal; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + c = argv[1][0]; + length = strlen(argv[1]); + if ((c == 'c') && (strncmp(argv[1], "clicks", length) == 0)) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # arguments: must be \"", + argv[0], " clicks\"", (char *) NULL); + return TCL_ERROR; + } + sprintf(interp->result, "%lu", TclpGetClicks()); + return TCL_OK; + } else if ((c == 'f') && (strncmp(argv[1], "format", length) == 0)) { + char *format = "%a %b %d %X %Z %Y"; + + if ((argc < 3) || (argc > 7)) { + wrongFmtArgs: + Tcl_AppendResult(interp, "wrong # args: ", argv [0], + " format clockval ?-format string? ?-gmt boolean?", + (char *) NULL); + return TCL_ERROR; + } + + if (ParseTime(interp, argv[2], &clockVal) != TCL_OK) { + return TCL_ERROR; + } + + argPtr = argv+3; + argc -= 3; + while ((argc > 1) && (argPtr[0][0] == '-')) { + if (strcmp(argPtr[0], "-format") == 0) { + format = argPtr[1]; + } else if (strcmp(argPtr[0], "-gmt") == 0) { + if (Tcl_GetBoolean(interp, argPtr[1], &useGMT) != TCL_OK) { + return TCL_ERROR; + } + } else { + Tcl_AppendResult(interp, "bad option \"", argPtr[0], + "\": must be -format or -gmt", (char *) NULL); + return TCL_ERROR; + } + argPtr += 2; + argc -= 2; + } + if (argc != 0) { + goto wrongFmtArgs; + } + + return FormatClock(interp, clockVal, useGMT, format); + } else if ((c == 's') && (strncmp(argv[1], "scan", length) == 0)) { + unsigned long baseClock; + long zone; + char * baseStr = NULL; + + if ((argc < 3) || (argc > 7)) { + wrongScanArgs: + Tcl_AppendResult (interp, "wrong # args: ", argv [0], + " scan dateString ?-base clockValue? ?-gmt boolean?", + (char *) NULL); + return TCL_ERROR; + } + + argPtr = argv+3; + argc -= 3; + while ((argc > 1) && (argPtr[0][0] == '-')) { + if (strcmp(argPtr[0], "-base") == 0) { + baseStr = argPtr[1]; + } else if (strcmp(argPtr[0], "-gmt") == 0) { + if (Tcl_GetBoolean(interp, argPtr[1], &useGMT) != TCL_OK) { + return TCL_ERROR; + } + } else { + Tcl_AppendResult(interp, "bad option \"", argPtr[0], + "\": must be -base or -gmt", (char *) NULL); + return TCL_ERROR; + } + argPtr += 2; + argc -= 2; + } + if (argc != 0) { + goto wrongScanArgs; + } + + if (baseStr != NULL) { + if (ParseTime(interp, baseStr, &baseClock) != TCL_OK) + return TCL_ERROR; + } else { + baseClock = TclpGetSeconds(); + } + + if (useGMT) { + zone = -50000; /* Force GMT */ + } else { + zone = TclpGetTimeZone(baseClock); + } + + if (TclGetDate(argv[2], baseClock, zone, &clockVal) < 0) { + Tcl_AppendResult(interp, "unable to convert date-time string \"", + argv[2], "\"", (char *) NULL); + return TCL_ERROR; + } + + sprintf(interp->result, "%lu", (long) clockVal); + return TCL_OK; + } else if ((c == 's') && (strncmp(argv[1], "seconds", length) == 0)) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # arguments: must be \"", + argv[0], " seconds\"", (char *) NULL); + return TCL_ERROR; + } + sprintf(interp->result, "%lu", TclpGetSeconds()); + return TCL_OK; + } else { + Tcl_AppendResult(interp, "unknown option \"", argv[1], + "\": must be clicks, format, scan, or seconds", + (char *) NULL); + return TCL_ERROR; + } +} + +/* + *----------------------------------------------------------------------------- + * + * ParseTime -- + * + * Given a string, produce the corresponding time_t value. + * + * Results: + * The return value is normally TCL_OK; in this case *timePtr + * 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. + * + *----------------------------------------------------------------------------- + */ + +static int +ParseTime(interp, string, timePtr) + Tcl_Interp *interp; + char *string; + unsigned long *timePtr; +{ + char *end, *p; + unsigned long i; + + /* + * Since some strtoul functions don't detect negative numbers, check + * in advance. + */ + errno = 0; + for (p = (char *) string; isspace(UCHAR(*p)); p++) { + /* Empty loop body. */ + } + if (*p == '+') { + p++; + } + i = strtoul(p, &end, 0); + if (end == p) { + goto badTime; + } + if (errno == ERANGE) { + interp->result = "integer value too large to represent"; + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", + interp->result, (char *) NULL); + return TCL_ERROR; + } + while ((*end != '\0') && isspace(UCHAR(*end))) { + end++; + } + if (*end != '\0') { + goto badTime; + } + + *timePtr = (time_t) i; + if (*timePtr != i) { + goto badTime; + } + return TCL_OK; + + badTime: + Tcl_AppendResult (interp, "expected unsigned time but got \"", + string, "\"", (char *) NULL); + return TCL_ERROR; +} + +/* + *----------------------------------------------------------------------------- + * + * FormatClock -- + * + * Formats a time value based on seconds into a human readable + * string. + * + * Results: + * Standard Tcl result. + * + * Side effects: + * None. + * + *----------------------------------------------------------------------------- + */ + +static int +FormatClock(interp, clockVal, useGMT, format) + Tcl_Interp *interp; /* Current interpreter. */ + unsigned long clockVal; /* Time in seconds. */ + int useGMT; /* Boolean */ + char *format; /* Format string */ +{ + struct tm *timeDataPtr; + Tcl_DString buffer; + int bufSize; + char *p; +#ifdef TCL_USE_TIMEZONE_VAR + int savedTimeZone; + char *savedTZEnv; +#endif + +#ifdef HAVE_TZSET + /* + * Some systems forgot to call tzset in localtime, make sure its done. + */ + static int calledTzset = 0; + + if (!calledTzset) { + tzset(); + calledTzset = 1; + } +#endif + +#ifdef TCL_USE_TIMEZONE_VAR + /* + * This is a horrible kludge for systems not having the timezone in + * struct tm. No matter what was specified, they use the global time + * zone. (Thanks Solaris). + */ + if (useGMT) { + char *varValue; + + varValue = Tcl_GetVar2(interp, "env", "TZ", TCL_GLOBAL_ONLY); + if (varValue != NULL) { + savedTZEnv = strcpy(ckalloc(strlen(varValue) + 1), varValue); + } else { + savedTZEnv = NULL; + } + Tcl_SetVar2(interp, "env", "TZ", "GMT", TCL_GLOBAL_ONLY); + savedTimeZone = timezone; + timezone = 0; + tzset(); + } +#endif + + timeDataPtr = TclpGetDate((time_t *) &clockVal, useGMT); + + /* + * Make a guess at the upper limit on the substituted string size + * based on the number of percents in the string. + */ + + for (bufSize = 0, p = format; *p != '\0'; p++) { + if (*p == '%') { + bufSize += 40; + } else { + bufSize++; + } + } + Tcl_DStringInit(&buffer); + Tcl_DStringSetLength(&buffer, bufSize); + + if (TclStrftime(buffer.string, (unsigned int) bufSize, format, + timeDataPtr) == 0) { + Tcl_DStringFree(&buffer); + Tcl_AppendResult(interp, "bad format string", (char *)NULL); + return TCL_ERROR; + } + +#ifdef TCL_USE_TIMEZONE_VAR + if (useGMT) { + if (savedTZEnv != NULL) { + Tcl_SetVar2(interp, "env", "TZ", savedTZEnv, TCL_GLOBAL_ONLY); + ckfree(savedTZEnv); + } else { + Tcl_UnsetVar2(interp, "env", "TZ", TCL_GLOBAL_ONLY); + } + timezone = savedTimeZone; + tzset(); + } +#endif + + Tcl_DStringResult(interp, &buffer); + return TCL_OK; +} + diff --git a/tcl7.6/generic/tclCmdAH.c b/tcl7.6/generic/tclCmdAH.c new file mode 100644 index 0000000..789ff20 --- /dev/null +++ b/tcl7.6/generic/tclCmdAH.c @@ -0,0 +1,1714 @@ +/* + * 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. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclCmdAH.c 1.115 96/09/30 11:38:37 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * Prototypes for local procedures defined in this file: + */ + +static char * GetTypeFromMode _ANSI_ARGS_((int mode)); +static int StoreStatData _ANSI_ARGS_((Tcl_Interp *interp, + char *varName, struct stat *statPtr)); + +/* + *---------------------------------------------------------------------- + * + * 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_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_TranslateFileName(interp, dirName, &buffer); + if (dirName == NULL) { + return TCL_ERROR; + } + result = TclChdir(interp, dirName); + Tcl_DStringFree(&buffer); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * 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_DYNAMIC; + } + 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_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) { + value = 0; + } else if (Tcl_GetInt(interp, argv[1], &value) != TCL_OK) { + return TCL_ERROR; + } + Tcl_Exit(value); + /*NOTREACHED*/ + return TCL_OK; /* Better not ever reach this! */ +} + +/* + *---------------------------------------------------------------------- + * + * 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_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 *fileName, *extension; + int c, statOp, result; + size_t length; + int mode = 0; /* Initialized only to prevent + * compiler warning message. */ + struct stat statBuf; + 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; + Tcl_DStringInit(&buffer); + + /* + * First handle operations on the file name. + */ + + if ((c == 'd') && (strncmp(argv[1], "dirname", length) == 0)) { + int pargc; + char **pargv; + + if (argc != 3) { + argv[1] = "dirname"; + goto not3Args; + } + + fileName = argv[2]; + + /* + * If there is only one element, and it starts with a tilde, + * perform tilde substitution and resplit the path. + */ + + Tcl_SplitPath(fileName, &pargc, &pargv); + if ((pargc == 1) && (*fileName == '~')) { + ckfree((char*) pargv); + fileName = Tcl_TranslateFileName(interp, fileName, &buffer); + if (fileName == NULL) { + result = TCL_ERROR; + goto done; + } + Tcl_SplitPath(fileName, &pargc, &pargv); + Tcl_DStringSetLength(&buffer, 0); + } + + /* + * Return all but the last component. If there is only one + * component, return it if the path was non-relative, otherwise + * return the current directory. + */ + + if (pargc > 1) { + Tcl_JoinPath(pargc-1, pargv, &buffer); + Tcl_DStringResult(interp, &buffer); + } else if ((pargc == 0) + || (Tcl_GetPathType(pargv[0]) == TCL_PATH_RELATIVE)) { + Tcl_SetResult(interp, + (tclPlatform == TCL_PLATFORM_MAC) ? ":" : ".", TCL_STATIC); + } else { + Tcl_SetResult(interp, pargv[0], TCL_VOLATILE); + } + ckfree((char *)pargv); + goto done; + + } else if ((c == 't') && (strncmp(argv[1], "tail", length) == 0) + && (length >= 2)) { + int pargc; + char **pargv; + + if (argc != 3) { + argv[1] = "tail"; + goto not3Args; + } + + fileName = argv[2]; + + /* + * If there is only one element, and it starts with a tilde, + * perform tilde substitution and resplit the path. + */ + + Tcl_SplitPath(fileName, &pargc, &pargv); + if ((pargc == 1) && (*fileName == '~')) { + ckfree((char*) pargv); + fileName = Tcl_TranslateFileName(interp, fileName, &buffer); + if (fileName == NULL) { + result = TCL_ERROR; + goto done; + } + Tcl_SplitPath(fileName, &pargc, &pargv); + Tcl_DStringSetLength(&buffer, 0); + } + + /* + * Return the last component, unless it is the only component, and it + * is the root of an absolute path. + */ + + if (pargc > 0) { + if ((pargc > 1) + || (Tcl_GetPathType(pargv[0]) == TCL_PATH_RELATIVE)) { + Tcl_SetResult(interp, pargv[pargc-1], TCL_VOLATILE); + } + } + ckfree((char *)pargv); + goto done; + + } else if ((c == 'r') && (strncmp(argv[1], "rootname", length) == 0) + && (length >= 2)) { + char tmp; + if (argc != 3) { + argv[1] = "rootname"; + goto not3Args; + } + extension = TclGetExtension(argv[2]); + if (extension == NULL) { + Tcl_SetResult(interp, argv[2], TCL_VOLATILE); + } else { + tmp = *extension; + *extension = 0; + Tcl_SetResult(interp, argv[2], TCL_VOLATILE); + *extension = tmp; + } + goto done; + } else if ((c == 'e') && (strncmp(argv[1], "extension", length) == 0) + && (length >= 3)) { + if (argc != 3) { + argv[1] = "extension"; + goto not3Args; + } + extension = TclGetExtension(argv[2]); + + if (extension != NULL) { + Tcl_SetResult(interp, extension, TCL_VOLATILE); + } + goto done; + } else if ((c == 'p') && (strncmp(argv[1], "pathtype", length) == 0)) { + if (argc != 3) { + argv[1] = "pathtype"; + goto not3Args; + } + switch (Tcl_GetPathType(argv[2])) { + case TCL_PATH_ABSOLUTE: + Tcl_SetResult(interp, "absolute", TCL_STATIC); + break; + case TCL_PATH_RELATIVE: + Tcl_SetResult(interp, "relative", TCL_STATIC); + break; + case TCL_PATH_VOLUME_RELATIVE: + Tcl_SetResult(interp, "volumerelative", TCL_STATIC); + break; + } + goto done; + } else if ((c == 's') && (strncmp(argv[1], "split", length) == 0) + && (length >= 2)) { + int pargc, i; + char **pargvList; + + if (argc != 3) { + argv[1] = "split"; + goto not3Args; + } + + Tcl_SplitPath(argv[2], &pargc, &pargvList); + for (i = 0; i < pargc; i++) { + Tcl_AppendElement(interp, pargvList[i]); + } + ckfree((char *) pargvList); + goto done; + } else if ((c == 'j') && (strncmp(argv[1], "join", length) == 0)) { + Tcl_JoinPath(argc-2, argv+2, &buffer); + Tcl_DStringResult(interp, &buffer); + goto done; + } else if ((c == 'r') && (strncmp(argv[1], "rename", length) == 0)) { + result = TclFileRenameCmd(interp, argc, argv); + goto done ; + } else if ((c == 'm') && (strncmp(argv[1], "mkdir", length) == 0)) { + result = TclFileMakeDirsCmd(interp, argc, argv); + goto done ; + } else if ((c == 'd') && (strncmp(argv[1], "delete", length) == 0)) { + result = TclFileDeleteCmd(interp, argc, argv); + goto done ; + } else if ((c == 'c') && (strncmp(argv[1], "copy", length) == 0)) { + result = TclFileCopyCmd(interp, argc, argv); + goto done ; + } + + + /* + * Next, handle operations that can be satisfied with the "access" + * kernel call. + */ + + fileName = Tcl_TranslateFileName(interp, argv[2], &buffer); + 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", (long) 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", (long) 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, "%lu", (unsigned long) 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 = GetTypeFromMode((int) statBuf.st_mode); + goto done; + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be atime, copy, delete, dirname, executable, ", + "exists, extension, isdirectory, isfile, join, ", + "lstat, mtime, mkdir, owned, pathtype, readable, readlink, ", + "rename, root, size, split, 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: + /* + * For Windows and Macintosh, there are no user ids + * associated with a file, so we always return 1. + */ + +#if (defined(__WIN32__) || defined(MAC_TCL)) + mode = 1; +#else + mode = (geteuid() == statBuf.st_uid); +#endif + 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; + + not3Args: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ", argv[1], " name\"", (char *) NULL); + result = TCL_ERROR; + goto done; +} + +/* + *---------------------------------------------------------------------- + * + * 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, "%ld", (long) statPtr->st_dev); + if (Tcl_SetVar2(interp, varName, "dev", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%ld", (long) statPtr->st_ino); + if (Tcl_SetVar2(interp, varName, "ino", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%ld", (long) statPtr->st_mode); + if (Tcl_SetVar2(interp, varName, "mode", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%ld", (long) statPtr->st_nlink); + if (Tcl_SetVar2(interp, varName, "nlink", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%ld", (long) statPtr->st_uid); + if (Tcl_SetVar2(interp, varName, "uid", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%ld", (long) statPtr->st_gid); + if (Tcl_SetVar2(interp, varName, "gid", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%lu", (unsigned long) statPtr->st_size); + if (Tcl_SetVar2(interp, varName, "size", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%ld", (long) statPtr->st_atime); + if (Tcl_SetVar2(interp, varName, "atime", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%ld", (long) statPtr->st_mtime); + if (Tcl_SetVar2(interp, varName, "mtime", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%ld", (long) statPtr->st_ctime); + if (Tcl_SetVar2(interp, varName, "ctime", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + if (Tcl_SetVar2(interp, varName, "type", + GetTypeFromMode((int) statPtr->st_mode), TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * GetTypeFromMode -- + * + * 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 * +GetTypeFromMode(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_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 result = TCL_OK; + int i; /* i selects a value list */ + int j, maxj; /* Number of loop iterations */ + int v; /* v selects a loop variable */ + int numLists; /* Count of value lists */ +#define STATIC_SIZE 4 + int indexArray[STATIC_SIZE]; /* Array of value list indices */ + int varcListArray[STATIC_SIZE]; /* Number of loop variables per list */ + char **varvListArray[STATIC_SIZE]; /* Array of variable name lists */ + int argcListArray[STATIC_SIZE]; /* Array of value list sizes */ + char **argvListArray[STATIC_SIZE]; /* Array of value lists */ + + int *index = indexArray; + int *varcList = varcListArray; + char ***varvList = varvListArray; + int *argcList = argcListArray; + char ***argvList = argvListArray; + + if (argc < 4 || (argc%2 != 0)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " varList list ?varList list ...? command\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * Manage numList parallel value lists. + * argvList[i] is a value list counted by argcList[i] + * varvList[i] is the list of variables associated with the value list + * varcList[i] is the number of variables associated with the value list + * index[i] is the current pointer into the value list argvList[i] + */ + + numLists = (argc-2)/2; + if (numLists > STATIC_SIZE) { + index = (int *) ckalloc(numLists * sizeof(int)); + varcList = (int *) ckalloc(numLists * sizeof(int)); + varvList = (char ***) ckalloc(numLists * sizeof(char **)); + argcList = (int *) ckalloc(numLists * sizeof(int)); + argvList = (char ***) ckalloc(numLists * sizeof(char **)); + } + for (i=0 ; i maxj) { + maxj = j; + } + } + + /* + * Iterate maxj times through the lists in parallel + * If some value lists run out of values, set loop vars to "" + */ + for (j = 0; j < maxj; j++) { + for (i=0 ; ierrorLine); + Tcl_AddErrorInfo(interp, msg); + break; + } else { + break; + } + } + } + if (result == TCL_OK) { + Tcl_ResetResult(interp); + } +errorReturn: + for (i=0 ; i STATIC_SIZE) { + ckfree((char *) index); + ckfree((char *) varcList); + ckfree((char *) argcList); + ckfree((char *) varvList); + ckfree((char *) argvList); + } +#undef STATIC_SIZE + 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.), width, and precision. */ + int intValue; /* Used to hold value to pass to sprintf, if + * it's a one-word integer or char value */ + char *ptrValue = NULL; /* Used to hold value to pass to sprintf, if + * it's a one-word value. */ + double doubleValue; /* Used to hold value to pass to sprintf if + * it's a double value. */ + int whichValue; /* Indicates which of intValue, ptrValue, + * or doubleValue has the value to pass to + * sprintf, according to the following + * definitions: */ +# define INT_VALUE 0 +# define PTR_VALUE 1 +# define DOUBLE_VALUE 2 + 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 = noPercent = useShort = 0; + whichValue = PTR_VALUE; + + /* + * Get rid of any characters before the next field specifier. + */ + + if (*format != '%') { + register char *p; + + ptrValue = p = format; + while ((*format != '%') && (*format != 0)) { + *p = *format; + p++; + format++; + } + size = p - ptrValue; + noPercent = 1; + goto doField; + } + + if (format[1] == '%') { + ptrValue = 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 > 100000) { + /* + * Don't allow arbitrarily large widths: could cause core + * dump when we try to allocate a zillion bytes of memory + * below. + */ + + width = 100000; + } else if (width < 0) { + width = 0; + } + 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 *) &intValue) + != TCL_OK) { + goto fmtError; + } + whichValue = INT_VALUE; + size = 40 + precision; + break; + case 's': + ptrValue = argv[argIndex]; + size = strlen(argv[argIndex]); + break; + case 'c': + if (Tcl_GetInt(interp, argv[argIndex], (int *) &intValue) + != TCL_OK) { + goto fmtError; + } + whichValue = INT_VALUE; + size = 1; + break; + case 'e': + case 'E': + case 'f': + case 'g': + case 'G': + if (Tcl_GetDouble(interp, argv[argIndex], &doubleValue) + != TCL_OK) { + goto fmtError; + } + whichValue = DOUBLE_VALUE; + 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, (size_t) dstSize); + } + if (dstSpace != TCL_RESULT_SIZE) { + ckfree(dst); + } + dst = newDst; + dstSpace = newSpace; + } + if (noPercent) { + memcpy((VOID *) (dst+dstSize), (VOID *) ptrValue, (size_t) size); + dstSize += size; + dst[dstSize] = 0; + } else { + if (whichValue == DOUBLE_VALUE) { + sprintf(dst+dstSize, newFormat, doubleValue); + } else if (whichValue == INT_VALUE) { + if (useShort) { + sprintf(dst+dstSize, newFormat, (short) intValue); + } else { + sprintf(dst+dstSize, newFormat, intValue); + } + } else { + sprintf(dst+dstSize, newFormat, ptrValue); + } + dstSize += strlen(dst+dstSize); + } + } + + interp->result = dst; + if (dstSpace != TCL_RESULT_SIZE) { + interp->freeProc = TCL_DYNAMIC; + } 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/tcl7.3/tclCmdIL.c b/tcl7.6/generic/tclCmdIL.c similarity index 84% rename from tcl7.3/tclCmdIL.c rename to tcl7.6/generic/tclCmdIL.c index d32e0f1..0a3b25a 100644 --- a/tcl7.3/tclCmdIL.c +++ b/tcl7.6/generic/tclCmdIL.c @@ -7,32 +7,25 @@ * (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. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tclCmdIL.c 1.120 96/07/10 17:16:03 */ -#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" +#include "tclPort.h" + +/* + * The following variable holds the full path name of the binary + * from which this application was executed, or NULL if it isn't + * know. The value of the variable is set by the procedure + * Tcl_FindExecutable. The storage space is dynamically allocated. + */ + +char *tclExecutableName = NULL; /* * The variables below are used to implement the "lsort" command. @@ -43,7 +36,8 @@ static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclCmdIL.c,v 1.103 93/10/2 * "lsort" needs internal mutual exclusion. */ -static Tcl_Interp *sortInterp; /* Interpreter for "lsort" command. */ +static Tcl_Interp *sortInterp = NULL; /* Interpreter for "lsort" command. + * NULL means no lsort is active. */ static enum {ASCII, INTEGER, REAL, COMMAND} sortMode; /* Mode for sorting: compare as strings, * compare as numbers, or call @@ -250,8 +244,8 @@ Tcl_InfoCmd(dummy, interp, argc, argv) char **argv; /* Argument strings. */ { register Interp *iPtr = (Interp *) interp; - int length; - char c; + size_t length; + int c; Arg *argPtr; Proc *procPtr; Var *varPtr; @@ -309,7 +303,7 @@ Tcl_InfoCmd(dummy, interp, argc, argv) && (length >= 4)) { if (argc > 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " commands [pattern]\"", (char *) NULL); + " commands ?pattern?\"", (char *) NULL); return TCL_ERROR; } for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search); @@ -420,7 +414,7 @@ Tcl_InfoCmd(dummy, interp, argc, argv) if (argc > 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " globals [pattern]\"", (char *) NULL); + " globals ?pattern?\"", (char *) NULL); return TCL_ERROR; } for (hPtr = Tcl_FirstHashEntry(&iPtr->globalTable, &search); @@ -436,6 +430,14 @@ Tcl_InfoCmd(dummy, interp, argc, argv) Tcl_AppendElement(interp, name); } return TCL_OK; + } else if ((c == 'h') && (strncmp(argv[1], "hostname", length) == 0)) { + if (argc > 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " hostname\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_AppendResult(interp, Tcl_GetHostName(), NULL); + return TCL_OK; } else if ((c == 'l') && (strncmp(argv[1], "level", length) == 0) && (length >= 2)) { if (argc == 2) { @@ -471,7 +473,7 @@ Tcl_InfoCmd(dummy, interp, argc, argv) goto levelError; } iPtr->result = Tcl_Merge(framePtr->argc, framePtr->argv); - iPtr->freeProc = (Tcl_FreeProc *) free; + iPtr->freeProc = TCL_DYNAMIC; return TCL_OK; } Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], @@ -484,23 +486,27 @@ Tcl_InfoCmd(dummy, interp, argc, argv) " library\"", (char *) NULL); return TCL_ERROR; } - interp->result = getenv("TCL_LIBRARY"); + interp->result = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY); if (interp->result == NULL) { -#ifdef TCL_LIBRARY - interp->result = TCL_LIBRARY; -#else - interp->result = "there is no Tcl library at this installation"; + interp->result = "no library has been specified for Tcl"; return TCL_ERROR; -#endif } return TCL_OK; + } else if ((c == 'l') && (strncmp(argv[1], "loaded", length) == 0) + && (length >= 3)) { + if ((argc != 2) && (argc != 3)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " loaded ?interp?\"", (char *) NULL); + return TCL_ERROR; + } + return TclGetLoadedPackages(interp, argv[2]); } else if ((c == 'l') && (strncmp(argv[1], "locals", length) == 0) - && (length >= 2)) { + && (length >= 3)) { char *name; if (argc > 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " locals [pattern]\"", (char *) NULL); + " locals ?pattern?\"", (char *) NULL); return TCL_ERROR; } if (iPtr->varFramePtr == NULL) { @@ -519,20 +525,38 @@ Tcl_InfoCmd(dummy, interp, argc, argv) Tcl_AppendElement(interp, name); } return TCL_OK; + } else if ((c == 'n') && (strncmp(argv[1], "nameofexecutable", + length) == 0)) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " nameofexecutable\"", (char *) NULL); + return TCL_ERROR; + } + if (tclExecutableName != NULL) { + interp->result = tclExecutableName; + } + return TCL_OK; } else if ((c == 'p') && (strncmp(argv[1], "patchlevel", length) == 0) && (length >= 2)) { + char *value; + 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); + value = Tcl_GetVar(interp, "tcl_patchLevel", + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG); + if (value == NULL) { + return TCL_ERROR; + } + interp->result = value; 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); + " procs ?pattern?\"", (char *) NULL); return TCL_ERROR; } for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search); @@ -549,7 +573,8 @@ Tcl_InfoCmd(dummy, interp, argc, argv) Tcl_AppendElement(interp, name); } return TCL_OK; - } else if ((c == 's') && (strncmp(argv[1], "script", length) == 0)) { + } else if ((c == 's') && (strncmp(argv[1], "script", length) == 0) + && (length >= 2)) { if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " script\"", (char *) NULL); @@ -565,19 +590,31 @@ Tcl_InfoCmd(dummy, interp, argc, argv) Tcl_SetResult(interp, iPtr->scriptFile, TCL_VOLATILE); } return TCL_OK; + } else if ((c == 's') && (strncmp(argv[1], "sharedlibextension", + length) == 0) && (length >= 2)) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " sharedlibextension\"", (char *) NULL); + return TCL_ERROR; + } +#ifdef TCL_SHLIB_EXT + interp->result = TCL_SHLIB_EXT; +#endif + return TCL_OK; } else if ((c == 't') && (strncmp(argv[1], "tclversion", length) == 0)) { + char *value; + 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); + value = Tcl_GetVar(interp, "tcl_version", + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG); + if (value == NULL) { + return TCL_ERROR; + } + interp->result = value; return TCL_OK; } else if ((c == 'v') && (strncmp(argv[1], "vars", length)) == 0) { Tcl_HashTable *tablePtr; @@ -585,7 +622,7 @@ Tcl_InfoCmd(dummy, interp, argc, argv) if (argc > 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " vars [pattern]\"", (char *) NULL); + argv[0], " vars ?pattern?\"", (char *) NULL); return TCL_ERROR; } if (iPtr->varFramePtr == NULL) { @@ -610,8 +647,9 @@ Tcl_InfoCmd(dummy, interp, argc, argv) 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", + "exists, globals, hostname, level, library, loaded, locals, ", + "nameofexecutable, patchlevel, procs, script, ", + "sharedlibextension, tclversion, or vars", (char *) NULL); return TCL_ERROR; } @@ -695,36 +733,46 @@ Tcl_LindexCmd(dummy, interp, argc, argv) int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { - char *p, *element; - int index, size, parenthesized, result; + char *p, *element, *next; + int index, size, parenthesized, result, returnLast; 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 ((*argv[2] == 'e') && (strncmp(argv[2], "end", strlen(argv[2])) == 0)) { + returnLast = 1; + index = INT_MAX; + } else { + returnLast = 0; + 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, + result = TclFindElement(interp, p, &element, &next, &size, &parenthesized); if (result != TCL_OK) { return result; } + if ((*next == 0) && returnLast) { + break; + } + p = next; } if (size == 0) { return TCL_OK; } if (size >= TCL_RESULT_SIZE) { interp->result = (char *) ckalloc((unsigned) size+1); - interp->freeProc = (Tcl_FreeProc *) free; + interp->freeProc = TCL_DYNAMIC; } if (parenthesized) { - memcpy((VOID *) interp->result, (VOID *) element, size); + memcpy((VOID *) interp->result, (VOID *) element, (size_t) size); interp->result[size] = 0; } else { TclCopyAndCollapse(size, element, interp->result); @@ -765,7 +813,9 @@ Tcl_LinsertCmd(dummy, interp, argc, argv) " list index element ?element ...?\"", (char *) NULL); return TCL_ERROR; } - if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) { + if ((*argv[2] == 'e') && (strncmp(argv[2], "end", strlen(argv[2])) == 0)) { + index = INT_MAX; + } else if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) { return TCL_ERROR; } @@ -844,7 +894,7 @@ Tcl_ListCmd(dummy, interp, argc, argv) { if (argc >= 2) { interp->result = Tcl_Merge(argc-1, argv+1); - interp->freeProc = (Tcl_FreeProc *) free; + interp->freeProc = TCL_DYNAMIC; } return TCL_OK; } @@ -922,32 +972,37 @@ Tcl_LrangeCmd(notUsed, interp, argc, argv) char **argv; /* Argument strings. */ { int first, last, result; - char *begin, *end, c, *dummy; - int count; + char *begin, *end, c, *dummy, *next; + int count, firstIsEnd; 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 ((*argv[2] == 'e') && (strncmp(argv[2], "end", strlen(argv[2])) == 0)) { + firstIsEnd = 1; + first = INT_MAX; + } else { + firstIsEnd = 0; + 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; + last = INT_MAX; } else { if (Tcl_GetInt(interp, argv[3], &last) != TCL_OK) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, - "expected integer or \"end\" but got \"", + Tcl_AppendResult(interp, "expected integer or \"end\" but got \"", argv[3], "\"", (char *) NULL); return TCL_ERROR; } } - if (first > last) { + if ((first > last) && !firstIsEnd) { return TCL_OK; } @@ -955,13 +1010,18 @@ Tcl_LrangeCmd(notUsed, interp, argc, argv) * Extract a range of fields. */ - for (count = 0, begin = argv[1]; count < first; count++) { - result = TclFindElement(interp, begin, &dummy, &begin, (int *) NULL, + for (count = 0, begin = argv[1]; count < first; begin = next, count++) { + result = TclFindElement(interp, begin, &dummy, &next, (int *) NULL, (int *) NULL); if (result != TCL_OK) { return result; } - if (*begin == 0) { + if (*next == 0) { + if (firstIsEnd) { + first = count; + } else { + begin = next; + } break; } } @@ -973,12 +1033,16 @@ Tcl_LrangeCmd(notUsed, interp, argc, argv) return result; } } + if (end == begin) { + return TCL_OK; + } /* * Chop off trailing spaces. */ - while (isspace(UCHAR(end[-1]))) { + while ((end != begin) && (isspace(UCHAR(end[-1]))) + && (((end-1) == begin) || (end[-2] != '\\'))) { end--; } c = *end; @@ -1013,31 +1077,39 @@ Tcl_LreplaceCmd(notUsed, interp, argc, argv) int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { - char *p1, *p2, *element, savedChar, *dummy; - int i, first, last, count, result, size; + char *p1, *p2, *element, savedChar, *dummy, *next; + int i, first, last, count, result, size, firstIsEnd; 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 ((*argv[2] == 'e') && (strncmp(argv[2], "end", strlen(argv[2])) == 0)) { + firstIsEnd = 1; + first = INT_MAX; + } else { + firstIsEnd = 0; + if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad index \"", argv[2], + "\": must be integer or \"end\"", (char *) NULL); + return TCL_ERROR; + } } - if (TclGetListIndex(interp, argv[3], &last) != TCL_OK) { - return TCL_ERROR; + if ((*argv[3] == 'e') && (strncmp(argv[3], "end", strlen(argv[3])) == 0)) { + last = INT_MAX; + } else { + if (Tcl_GetInt(interp, argv[3], &last) != TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad index \"", argv[3], + "\": must be integer or \"end\"", (char *) NULL); + 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". @@ -1046,11 +1118,15 @@ Tcl_LreplaceCmd(notUsed, interp, argc, argv) size = 0; element = argv[1]; for (count = 0, p1 = argv[1]; (count < first) && (*p1 != 0); count++) { - result = TclFindElement(interp, p1, &element, &p1, &size, + result = TclFindElement(interp, p1, &element, &next, &size, (int *) NULL); if (result != TCL_OK) { return result; } + if ((*next == 0) && firstIsEnd) { + break; + } + p1 = next; } if (*p1 == 0) { Tcl_AppendResult(interp, "list doesn't contain element ", @@ -1071,16 +1147,15 @@ Tcl_LreplaceCmd(notUsed, interp, argc, argv) } /* - * Add the elements before "first" to the result. Be sure to - * include quote or brace characters that might terminate the - * last of these elements. + * Add the elements before "first" to the result. Remove any + * trailing white space, to make the result look as clean as + * possible (this matters primarily if the replacement string is + * empty). */ - p1 = element+size; - if (element != argv[1]) { - while ((*p1 != 0) && !isspace(UCHAR(*p1))) { - p1++; - } + while ((p1 != argv[1]) && (isspace(UCHAR(p1[-1]))) + && (((p1-1) == argv[1]) || (p1[-2] != '\\'))) { + p1--; } savedChar = *p1; *p1 = 0; @@ -1215,7 +1290,8 @@ Tcl_LsortCmd(notUsed, interp, argc, argv) int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { - int listArgc, i, c, length; + int listArgc, i, c; + size_t length; char **listArgv; char *command = NULL; /* Initialization needed only to * prevent compiler warning. */ @@ -1227,6 +1303,11 @@ Tcl_LsortCmd(notUsed, interp, argc, argv) return TCL_ERROR; } + if (sortInterp != NULL) { + interp->result = "can't invoke \"lsort\" recursively"; + return TCL_ERROR; + } + /* * Parse arguments to set up the mode for the sort. */ @@ -1242,7 +1323,8 @@ Tcl_LsortCmd(notUsed, interp, argc, argv) Tcl_AppendResult(interp, "bad switch \"", argv[i], "\": must be -ascii, -integer, -real, -increasing", " -decreasing, or -command", (char *) NULL); - return TCL_ERROR; + sortCode = TCL_ERROR; + goto done; } c = argv[i][1]; if ((c == 'a') && (strncmp(argv[i], "-ascii", length) == 0)) { @@ -1251,7 +1333,8 @@ Tcl_LsortCmd(notUsed, interp, argc, argv) if (i == argc-2) { Tcl_AppendResult(interp, "\"-command\" must be", " followed by comparison command", (char *) NULL); - return TCL_ERROR; + sortCode = TCL_ERROR; + goto done; } sortMode = COMMAND; command = argv[i+1]; @@ -1278,18 +1361,23 @@ Tcl_LsortCmd(notUsed, interp, argc, argv) } if (Tcl_SplitList(interp, argv[argc-1], &listArgc, &listArgv) != TCL_OK) { - return TCL_ERROR; + sortCode = TCL_ERROR; + goto done; } - qsort((VOID *) listArgv, listArgc, sizeof (char *), SortCompareProc); + qsort((VOID *) listArgv, (size_t) listArgc, sizeof (char *), + SortCompareProc); if (sortCode == TCL_OK) { Tcl_ResetResult(interp); interp->result = Tcl_Merge(listArgc, listArgv); - interp->freeProc = (Tcl_FreeProc *) free; + interp->freeProc = TCL_DYNAMIC; } if (sortMode == COMMAND) { Tcl_DStringFree(&sortCmd); } ckfree((char *) listArgv); + + done: + sortInterp = NULL; return sortCode; } diff --git a/tcl7.3/tclCmdMZ.c b/tcl7.6/generic/tclCmdMZ.c similarity index 76% rename from tcl7.3/tclCmdMZ.c rename to tcl7.6/generic/tclCmdMZ.c index 92f9340..90cb8ef 100644 --- a/tcl7.3/tclCmdMZ.c +++ b/tcl7.6/generic/tclCmdMZ.c @@ -7,31 +7,16 @@ * those that don't depend much upon UNIX facilities). * * Copyright (c) 1987-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tclCmdMZ.c 1.68 96/10/12 17:05:57 */ -#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" +#include "tclPort.h" /* * Structure used to hold information about variable traces: @@ -58,6 +43,47 @@ static char * TraceVarProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, char *name1, char *name2, int flags)); +/* + *---------------------------------------------------------------------- + * + * 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 *dirName; + + if (argc != 1) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], "\"", (char *) NULL); + return TCL_ERROR; + } + + dirName = TclGetCwd(interp); + if (dirName == NULL) { + return TCL_ERROR; + } + interp->result = dirName; + return TCL_OK; +} + /* *---------------------------------------------------------------------- * @@ -85,8 +111,8 @@ Tcl_RegexpCmd(dummy, interp, argc, argv) { int noCase = 0; int indices = 0; - regexp *regexpPtr; - char **argPtr, *string, *pattern; + Tcl_RegExp regExpr; + char **argPtr, *string, *pattern, *start, *end; int match = 0; /* Initialization needed only to * prevent compiler warning. */ int i; @@ -135,7 +161,7 @@ Tcl_RegexpCmd(dummy, interp, argc, argv) pattern = Tcl_DStringValue(&patternDString); for (p = pattern; *p != 0; p++) { if (isupper(UCHAR(*p))) { - *p = tolower(*p); + *p = (char)tolower(UCHAR(*p)); } } Tcl_DStringInit(&stringDString); @@ -143,28 +169,25 @@ Tcl_RegexpCmd(dummy, interp, argc, argv) string = Tcl_DStringValue(&stringDString); for (p = string; *p != 0; p++) { if (isupper(UCHAR(*p))) { - *p = tolower(*p); + *p = (char)tolower(UCHAR(*p)); } } } else { pattern = argPtr[0]; string = argPtr[1]; } - regexpPtr = TclCompileRegexp(interp, pattern); - if (regexpPtr != NULL) { - tclRegexpError = NULL; - match = TclRegExec(regexpPtr, string, string); + regExpr = Tcl_RegExpCompile(interp, pattern); + if (regExpr != NULL) { + match = Tcl_RegExpExec(interp, regExpr, string, string); } if (noCase) { Tcl_DStringFree(&stringDString); Tcl_DStringFree(&patternDString); } - if (regexpPtr == NULL) { + if (regExpr == NULL) { return TCL_ERROR; } - if (tclRegexpError != NULL) { - Tcl_AppendResult(interp, "error while matching pattern: ", - tclRegexpError, (char *) NULL); + if (match < 0) { return TCL_ERROR; } if (!match) { @@ -178,14 +201,11 @@ Tcl_RegexpCmd(dummy, interp, argc, argv) */ 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) { + Tcl_RegExpRange(regExpr, i, &start, &end); + if (start == NULL) { if (indices) { result = Tcl_SetVar(interp, argPtr[i+2], "-1 -1", 0); } else { @@ -193,14 +213,14 @@ Tcl_RegexpCmd(dummy, interp, argc, argv) } } else { if (indices) { - sprintf(info, "%d %d", regexpPtr->startp[i] - string, - regexpPtr->endp[i] - string - 1); + sprintf(info, "%d %d", (int)(start - string), + (int)(end - 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); + first = argPtr[1] + (start - string); + last = argPtr[1] + (end - string); savedChar = *last; *last = 0; result = Tcl_SetVar(interp, argPtr[i+2], first, 0); @@ -243,9 +263,10 @@ Tcl_RegsubCmd(dummy, interp, argc, argv) char **argv; /* Argument strings. */ { int noCase = 0, all = 0; - regexp *regexpPtr; + Tcl_RegExp regExpr; char *string, *pattern, *p, *firstChar, *newValue, **argPtr; - int match, flags, code, anyMatches; + int match, flags, code, numMatches; + char *start, *end, *subStart, *subEnd; register char *src, c; Tcl_DString stringDString, patternDString; @@ -288,7 +309,7 @@ Tcl_RegsubCmd(dummy, interp, argc, argv) pattern = Tcl_DStringValue(&patternDString); for (p = pattern; *p != 0; p++) { if (isupper(UCHAR(*p))) { - *p = tolower(*p); + *p = (char)tolower(UCHAR(*p)); } } Tcl_DStringInit(&stringDString); @@ -296,15 +317,15 @@ Tcl_RegsubCmd(dummy, interp, argc, argv) string = Tcl_DStringValue(&stringDString); for (p = string; *p != 0; p++) { if (isupper(UCHAR(*p))) { - *p = tolower(*p); + *p = (char)tolower(UCHAR(*p)); } } } else { pattern = argPtr[0]; string = argPtr[1]; } - regexpPtr = TclCompileRegexp(interp, pattern); - if (regexpPtr == NULL) { + regExpr = Tcl_RegExpCompile(interp, pattern); + if (regExpr == NULL) { code = TCL_ERROR; goto done; } @@ -317,27 +338,25 @@ Tcl_RegsubCmd(dummy, interp, argc, argv) */ flags = 0; - anyMatches = 0; + numMatches = 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); + match = Tcl_RegExpExec(interp, regExpr, p, string); + if (match < 0) { code = TCL_ERROR; goto done; } if (!match) { break; } - anyMatches = 1; + numMatches += 1; /* * Copy the portion of the source string before the match to the * result variable. */ - - src = argPtr[1] + (regexpPtr->startp[0] - string); + + Tcl_RegExpRange(regExpr, 0, &start, &end); + src = argPtr[1] + (start - string); c = *src; *src = 0; newValue = Tcl_SetVar(interp, argPtr[3], argPtr[1] + (p - string), @@ -397,12 +416,12 @@ Tcl_RegsubCmd(dummy, interp, argc, argv) goto cantSet; } } - if ((index < NSUBEXP) && (regexpPtr->startp[index] != NULL) - && (regexpPtr->endp[index] != NULL)) { + Tcl_RegExpRange(regExpr, index, &subStart, &subEnd); + if ((subStart != NULL) && (subEnd != NULL)) { char *first, *last, saved; - first = argPtr[1] + (regexpPtr->startp[index] - string); - last = argPtr[1] + (regexpPtr->endp[index] - string); + first = argPtr[1] + (subStart - string); + last = argPtr[1] + (subEnd - string); saved = *last; *last = 0; newValue = Tcl_SetVar(interp, argPtr[3], first, @@ -423,7 +442,7 @@ Tcl_RegsubCmd(dummy, interp, argc, argv) goto cantSet; } } - if (regexpPtr->endp[0] == p) { + if (end == p) { char tmp[2]; /* @@ -437,9 +456,9 @@ Tcl_RegsubCmd(dummy, interp, argc, argv) if (newValue == NULL) { goto cantSet; } - p = regexpPtr->endp[0] + 1; + p = end + 1; } else { - p = regexpPtr->endp[0]; + p = end; } if (!all) { break; @@ -451,17 +470,13 @@ Tcl_RegsubCmd(dummy, interp, argc, argv) * result variable. */ - if ((*p != 0) || !anyMatches) { + if ((*p != 0) || (numMatches == 0)) { if (Tcl_SetVar(interp, argPtr[3], argPtr[1] + (p - string), flags) == NULL) { goto cantSet; } } - if (anyMatches) { - interp->result = "1"; - } else { - interp->result = "0"; - } + sprintf(interp->result, "%d", numMatches); code = TCL_OK; done: @@ -501,6 +516,7 @@ Tcl_RenameCmd(dummy, interp, argc, argv) Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hPtr; int new; + char *srcName, *dstName; if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], @@ -515,22 +531,76 @@ Tcl_RenameCmd(dummy, interp, argc, argv) } return TCL_OK; } - hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[2]); + + srcName = argv[1]; + dstName = argv[2]; + hPtr = Tcl_FindHashEntry(&iPtr->commandTable, dstName); 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]); + + /* + * The code below was added in 11/95 to preserve backwards compatibility + * when "tkerror" was renamed "bgerror": we guarantee that the hash + * table entries for both commands refer to a single shared Command + * structure. This code should eventually become unnecessary. + */ + + if ((srcName[0] == 't') && (strcmp(srcName, "tkerror") == 0)) { + srcName = "bgerror"; + } + dstName = argv[2]; + if ((dstName[0] == 't') && (strcmp(dstName, "tkerror") == 0)) { + dstName = "bgerror"; + } + + hPtr = Tcl_FindHashEntry(&iPtr->commandTable, srcName); if (hPtr == NULL) { Tcl_AppendResult(interp, "can't rename \"", argv[1], - "\": command doesn't exist", (char *) NULL); + "\": command doesn't exist", (char *) NULL); return TCL_ERROR; } cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + + /* + * Prevent formation of alias loops through renaming. + */ + + if (TclPreventAliasLoop(interp, interp, dstName, cmdPtr->proc, + cmdPtr->clientData) != TCL_OK) { + return TCL_ERROR; + } + Tcl_DeleteHashEntry(hPtr); - hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, argv[2], &new); + hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, dstName, &new); Tcl_SetHashValue(hPtr, cmdPtr); + cmdPtr->hPtr = hPtr; + + /* + * The code below provides more backwards compatibility for the + * "tkerror" => "bgerror" renaming. As with the other compatibility + * code above, it should eventually be removed. + */ + + if ((dstName[0] == 'b') && (strcmp(dstName, "bgerror") == 0)) { + /* + * The destination command is "bgerror"; create a "tkerror" + * command that shares the same Command structure. + */ + + hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, "tkerror", &new); + Tcl_SetHashValue(hPtr, cmdPtr); + } + if ((srcName[0] == 'b') && (strcmp(srcName, "bgerror") == 0)) { + /* + * The source command is "bgerror": delete the hash table + * entry for "tkerror" if it exists. + */ + + Tcl_DeleteHashEntry(Tcl_FindHashEntry(&iPtr->commandTable, "tkerror")); + } return TCL_OK; } @@ -592,10 +662,10 @@ Tcl_ReturnCmd(dummy, interp, argc, argv) return TCL_ERROR; } } else if (strcmp(argv[0], "-errorinfo") == 0) { - iPtr->errorInfo = ckalloc((unsigned) (strlen(argv[1]) + 1)); + iPtr->errorInfo = (char *) 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)); + iPtr->errorCode = (char *) ckalloc((unsigned) (strlen(argv[1]) + 1)); strcpy(iPtr->errorCode, argv[1]); } else { Tcl_AppendResult(interp, "bad option \"", argv[0], @@ -690,7 +760,7 @@ Tcl_ScanCmd(dummy, interp, argc, argv) if (length < STATIC_SIZE) { fmtCopy = copyBuf; } else { - fmtCopy = ckalloc((unsigned) length); + fmtCopy = (char *) ckalloc((unsigned) length); } dst = fmtCopy; for (fmt = argv[2]; *fmt != 0; fmt++) { @@ -780,6 +850,11 @@ Tcl_ScanCmd(dummy, interp, argc, argv) curField->size = strlen(argv[1]) + 1; do { fmt++; + if (*fmt == 0) { + interp->result = "unmatched [ in format string"; + code = TCL_ERROR; + goto done; + } *dst = *fmt; dst++; } while (*fmt != ']'); @@ -901,6 +976,39 @@ Tcl_ScanCmd(dummy, interp, argc, argv) return code; } +/* + *---------------------------------------------------------------------- + * + * 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]); +} + /* *---------------------------------------------------------------------- * @@ -1002,10 +1110,9 @@ Tcl_StringCmd(dummy, interp, argc, argv) int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { - int length; - register char *p, c; - int match; - int first; + size_t length; + register char *p; + int match, c, first; int left = 0, right = 0; if (argc < 2) { @@ -1110,8 +1217,17 @@ Tcl_StringCmd(dummy, interp, argc, argv) return TCL_ERROR; } stringLength = strlen(argv[2]); - if (Tcl_GetInt(interp, argv[3], &first) != TCL_OK) { - return TCL_ERROR; + if ((*argv[3] == 'e') + && (strncmp(argv[3], "end", strlen(argv[3])) == 0)) { + first = stringLength-1; + } else { + if (Tcl_GetInt(interp, argv[3], &first) != TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, + "expected integer or \"end\" but got \"", + argv[3], "\"", (char *) NULL); + return TCL_ERROR; + } } if ((*argv[4] == 'e') && (strncmp(argv[4], "end", strlen(argv[4])) == 0)) { @@ -1153,7 +1269,7 @@ Tcl_StringCmd(dummy, interp, argc, argv) Tcl_SetResult(interp, argv[2], TCL_VOLATILE); for (p = interp->result; *p != 0; p++) { if (isupper(UCHAR(*p))) { - *p = tolower(*p); + *p = (char)tolower(UCHAR(*p)); } } return TCL_OK; @@ -1169,7 +1285,7 @@ Tcl_StringCmd(dummy, interp, argc, argv) Tcl_SetResult(interp, argv[2], TCL_VOLATILE); for (p = interp->result; *p != 0; p++) { if (islower(UCHAR(*p))) { - *p = toupper(*p); + *p = (char) toupper(UCHAR(*p)); } } return TCL_OK; @@ -1228,13 +1344,221 @@ Tcl_StringCmd(dummy, interp, argc, argv) right = 1; argv[1] = "trimright"; goto trim; + } else if ((c == 'w') && (strncmp(argv[1], "wordend", length) == 0) + && (length > 4)) { + int length, index, cur; + char *string; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ", argv[1], " string index\"", (char *) NULL); + return TCL_ERROR; + } + string = argv[2]; + if (Tcl_GetInt(interp, argv[3], &index) != TCL_OK) { + return TCL_ERROR; + } + length = strlen(argv[2]); + if (index < 0) { + index = 0; + } + if (index >= length) { + cur = length; + goto wordendDone; + } + for (cur = index ; cur < length; cur++) { + c = UCHAR(string[cur]); + if (!isalnum(c) && (c != '_')) { + break; + } + } + if (cur == index) { + cur = index+1; + } + wordendDone: + sprintf(interp->result, "%d", cur); + return TCL_OK; + } else if ((c == 'w') && (strncmp(argv[1], "wordstart", length) == 0) + && (length > 4)) { + int length, index, cur; + char *string; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ", argv[1], " string index\"", (char *) NULL); + return TCL_ERROR; + } + string = argv[2]; + if (Tcl_GetInt(interp, argv[3], &index) != TCL_OK) { + return TCL_ERROR; + } + length = strlen(argv[2]); + if (index >= length) { + index = length-1; + } + if (index <= 0) { + cur = 0; + goto wordstartDone; + } + for (cur = index ; cur >= 0; cur--) { + c = UCHAR(string[cur]); + if (!isalnum(c) && (c != '_')) { + break; + } + } + if (cur != index) { + cur += 1; + } + wordstartDone: + sprintf(interp->result, "%d", cur); + return TCL_OK; } else { Tcl_AppendResult(interp, "bad option \"", argv[1], "\": should be compare, first, index, last, length, match, ", - "range, tolower, toupper, trim, trimleft, or trimright", + "range, tolower, toupper, trim, trimleft, trimright, ", + "wordend, or wordstart", (char *) NULL); + return TCL_ERROR; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SubstCmd -- + * + * This procedure is invoked to process the "subst" Tcl command. + * See the user documentation for details on what it does. This + * command is an almost direct copy of an implementation by + * Andrew Payne. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_SubstCmd(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; + Tcl_DString result; + char *p, *old, *value; + int code, count, doVars, doCmds, doBackslashes, i; + size_t length; + char c; + + /* + * Parse command-line options. + */ + + doVars = doCmds = doBackslashes = 1; + for (i = 1; i < (argc-1); i++) { + p = argv[i]; + if (*p != '-') { + break; + } + length = strlen(p); + if (length < 4) { + badSwitch: + Tcl_AppendResult(interp, "bad switch \"", p, + "\": must be -nobackslashes, -nocommands, ", + "or -novariables", (char *) NULL); + return TCL_ERROR; + } + if ((p[3] == 'b') && (strncmp(p, "-nobackslashes", length) == 0)) { + doBackslashes = 0; + } else if ((p[3] == 'c') && (strncmp(p, "-nocommands", length) == 0)) { + doCmds = 0; + } else if ((p[3] == 'v') && (strncmp(p, "-novariables", length) == 0)) { + doVars = 0; + } else { + goto badSwitch; + } + } + if (i != (argc-1)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?-nobackslashes? ?-nocommands? ?-novariables? string\"", (char *) NULL); return TCL_ERROR; } + + /* + * Scan through the string one character at a time, performing + * command, variable, and backslash substitutions. + */ + + Tcl_DStringInit(&result); + old = p = argv[i]; + while (*p != 0) { + switch (*p) { + case '\\': + if (doBackslashes) { + if (p != old) { + Tcl_DStringAppend(&result, old, p-old); + } + c = Tcl_Backslash(p, &count); + Tcl_DStringAppend(&result, &c, 1); + p += count; + old = p; + } else { + p++; + } + break; + + case '$': + if (doVars) { + if (p != old) { + Tcl_DStringAppend(&result, old, p-old); + } + value = Tcl_ParseVar(interp, p, &p); + if (value == NULL) { + Tcl_DStringFree(&result); + return TCL_ERROR; + } + Tcl_DStringAppend(&result, value, -1); + old = p; + } else { + p++; + } + break; + + case '[': + if (doCmds) { + if (p != old) { + Tcl_DStringAppend(&result, old, p-old); + } + iPtr->evalFlags = TCL_BRACKET_TERM; + code = Tcl_Eval(interp, p+1); + if (code == TCL_ERROR) { + Tcl_DStringFree(&result); + return code; + } + old = p = iPtr->termPtr+1; + Tcl_DStringAppend(&result, iPtr->result, -1); + Tcl_ResetResult(interp); + } else { + p++; + } + break; + + default: + p++; + break; + } + } + if (p != old) { + Tcl_DStringAppend(&result, old, p-old); + } + Tcl_DStringResult(interp, &result); + return TCL_OK; } /* @@ -1393,6 +1717,67 @@ Tcl_SwitchCmd(dummy, interp, argc, argv) return code; } +/* + *---------------------------------------------------------------------- + * + * 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; + Tcl_Time start, stop; + + 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; + } + TclpGetTime(&start); + 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; + } + } + TclpGetTime(&stop); + timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); + Tcl_ResetResult(interp); + sprintf(interp->result, "%.0f microseconds per iteration", + (count <= 0) ? 0 : timePer/count); + return TCL_OK; +} + /* *---------------------------------------------------------------------- * @@ -1418,8 +1803,8 @@ Tcl_TraceCmd(dummy, interp, argc, argv) int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { - char c; - int length; + int c; + size_t length; if (argc < 2) { Tcl_AppendResult(interp, "too few args: should be \"", @@ -1510,7 +1895,8 @@ Tcl_TraceCmd(dummy, interp, argc, argv) TraceVarProc, clientData)) != 0) { tvarPtr = (TraceVarInfo *) clientData; if ((tvarPtr->length == length) && (tvarPtr->flags == flags) - && (strncmp(argv[4], tvarPtr->command, length) == 0)) { + && (strncmp(argv[4], tvarPtr->command, + (size_t) length) == 0)) { Tcl_UntraceVar(interp, argv[2], flags | TCL_TRACE_UNSETS, TraceVarProc, clientData); if (tvarPtr->errMsg != NULL) { @@ -1650,7 +2036,7 @@ TraceVarProc(clientData, interp, name1, name2, flags) code = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); Tcl_DStringFree(&cmd); if (code != TCL_OK) { - tvarPtr->errMsg = ckalloc((unsigned) (strlen(interp->result) + 1)); + tvarPtr->errMsg = (char *) ckalloc((unsigned) (strlen(interp->result) + 1)); strcpy(tvarPtr->errMsg, interp->result); result = tvarPtr->errMsg; Tcl_ResetResult(interp); /* Must clear error state. */ diff --git a/tcl7.6/generic/tclDate.c b/tcl7.6/generic/tclDate.c new file mode 100644 index 0000000..4010574 --- /dev/null +++ b/tcl7.6/generic/tclDate.c @@ -0,0 +1,1616 @@ +/* + * tclDate.c -- + * + * This file is generated from a yacc grammar defined in + * the file tclGetDate.y + * + * Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans. + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * @(#) tclDate.c 1.27 96/10/12 17:05:59 + */ + +#include "tclInt.h" +#include "tclPort.h" + +#ifdef MAC_TCL +# define EPOCH 1904 +# define START_OF_TIME 1904 +# define END_OF_TIME 2039 +#else +# define EPOCH 1970 +# define START_OF_TIME 1902 +# define END_OF_TIME 2037 +#endif + +#define HOUR(x) ((int) (60 * x)) +#define SECSPERDAY (24L * 60L * 60L) + + +/* + * An entry in the lexical lookup table. + */ +typedef struct _TABLE { + char *name; + int type; + time_t value; +} TABLE; + + +/* + * Daylight-savings mode: on, off, or not yet known. + */ +typedef enum _DSTMODE { + DSTon, DSToff, DSTmaybe +} DSTMODE; + +/* + * Meridian: am, pm, or 24-hour style. + */ +typedef enum _MERIDIAN { + MERam, MERpm, MER24 +} MERIDIAN; + + +/* + * Global variables. We could get rid of most of these by using a good + * union as the yacc stack. (This routine was originally written before + * yacc had the %union construct.) Maybe someday; right now we only use + * the %union very rarely. + */ +static char *TclDateInput; +static DSTMODE TclDateDSTmode; +static time_t TclDateDayOrdinal; +static time_t TclDateDayNumber; +static int TclDateHaveDate; +static int TclDateHaveDay; +static int TclDateHaveRel; +static int TclDateHaveTime; +static int TclDateHaveZone; +static time_t TclDateTimezone; +static time_t TclDateDay; +static time_t TclDateHour; +static time_t TclDateMinutes; +static time_t TclDateMonth; +static time_t TclDateSeconds; +static time_t TclDateYear; +static MERIDIAN TclDateMeridian; +static time_t TclDateRelMonth; +static time_t TclDateRelSeconds; + + +/* + * Prototypes of internal functions. + */ +static void +TclDateerror _ANSI_ARGS_((char *s)); + +static time_t +ToSeconds _ANSI_ARGS_((time_t Hours, + time_t Minutes, + time_t Seconds, + MERIDIAN Meridian)); + +static int +Convert _ANSI_ARGS_((time_t Month, + time_t Day, + time_t Year, + time_t Hours, + time_t Minutes, + time_t Seconds, + MERIDIAN Meridia, + DSTMODE DSTmode, + time_t *TimePtr)); + +static time_t +DSTcorrect _ANSI_ARGS_((time_t Start, + time_t Future)); + +static time_t +RelativeDate _ANSI_ARGS_((time_t Start, + time_t DayOrdinal, + time_t DayNumber)); + +static int +RelativeMonth _ANSI_ARGS_((time_t Start, + time_t RelMonth, + time_t *TimePtr)); +static int +LookupWord _ANSI_ARGS_((char *buff)); + +static int +TclDatelex _ANSI_ARGS_((void)); + +int +TclDateparse _ANSI_ARGS_((void)); +typedef union +#ifdef __cplusplus + YYSTYPE +#endif + { + time_t Number; + enum _MERIDIAN Meridian; +} YYSTYPE; +# define tAGO 257 +# define tDAY 258 +# define tDAYZONE 259 +# define tID 260 +# define tMERIDIAN 261 +# define tMINUTE_UNIT 262 +# define tMONTH 263 +# define tMONTH_UNIT 264 +# define tSEC_UNIT 265 +# define tSNUMBER 266 +# define tUNUMBER 267 +# define tZONE 268 +# define tEPOCH 269 +# define tDST 270 + + + +#ifdef __cplusplus + +#ifndef TclDateerror + void TclDateerror(const char *); +#endif + +#ifndef TclDatelex +#ifdef __EXTERN_C__ + extern "C" { int TclDatelex(void); } +#else + int TclDatelex(void); +#endif +#endif + int TclDateparse(void); + +#endif +#define TclDateclearin TclDatechar = -1 +#define TclDateerrok TclDateerrflag = 0 +extern int TclDatechar; +extern int TclDateerrflag; +YYSTYPE TclDatelval; +YYSTYPE TclDateval; +typedef int TclDatetabelem; +#ifndef YYMAXDEPTH +#define YYMAXDEPTH 150 +#endif +#if YYMAXDEPTH > 0 +int TclDate_TclDates[YYMAXDEPTH], *TclDates = TclDate_TclDates; +YYSTYPE TclDate_TclDatev[YYMAXDEPTH], *TclDatev = TclDate_TclDatev; +#else /* user does initial allocation */ +int *TclDates; +YYSTYPE *TclDatev; +#endif +static int TclDatemaxdepth = YYMAXDEPTH; +# define YYERRCODE 256 + + +/* + * Month and day table. + */ +static TABLE MonthDayTable[] = { + { "january", tMONTH, 1 }, + { "february", tMONTH, 2 }, + { "march", tMONTH, 3 }, + { "april", tMONTH, 4 }, + { "may", tMONTH, 5 }, + { "june", tMONTH, 6 }, + { "july", tMONTH, 7 }, + { "august", tMONTH, 8 }, + { "september", tMONTH, 9 }, + { "sept", tMONTH, 9 }, + { "october", tMONTH, 10 }, + { "november", tMONTH, 11 }, + { "december", tMONTH, 12 }, + { "sunday", tDAY, 0 }, + { "monday", tDAY, 1 }, + { "tuesday", tDAY, 2 }, + { "tues", tDAY, 2 }, + { "wednesday", tDAY, 3 }, + { "wednes", tDAY, 3 }, + { "thursday", tDAY, 4 }, + { "thur", tDAY, 4 }, + { "thurs", tDAY, 4 }, + { "friday", tDAY, 5 }, + { "saturday", tDAY, 6 }, + { NULL } +}; + +/* + * Time units table. + */ +static TABLE UnitsTable[] = { + { "year", tMONTH_UNIT, 12 }, + { "month", tMONTH_UNIT, 1 }, + { "fortnight", tMINUTE_UNIT, 14 * 24 * 60 }, + { "week", tMINUTE_UNIT, 7 * 24 * 60 }, + { "day", tMINUTE_UNIT, 1 * 24 * 60 }, + { "hour", tMINUTE_UNIT, 60 }, + { "minute", tMINUTE_UNIT, 1 }, + { "min", tMINUTE_UNIT, 1 }, + { "second", tSEC_UNIT, 1 }, + { "sec", tSEC_UNIT, 1 }, + { NULL } +}; + +/* + * Assorted relative-time words. + */ +static TABLE OtherTable[] = { + { "tomorrow", tMINUTE_UNIT, 1 * 24 * 60 }, + { "yesterday", tMINUTE_UNIT, -1 * 24 * 60 }, + { "today", tMINUTE_UNIT, 0 }, + { "now", tMINUTE_UNIT, 0 }, + { "last", tUNUMBER, -1 }, + { "this", tMINUTE_UNIT, 0 }, + { "next", tUNUMBER, 2 }, +#if 0 + { "first", tUNUMBER, 1 }, +/* { "second", tUNUMBER, 2 }, */ + { "third", tUNUMBER, 3 }, + { "fourth", tUNUMBER, 4 }, + { "fifth", tUNUMBER, 5 }, + { "sixth", tUNUMBER, 6 }, + { "seventh", tUNUMBER, 7 }, + { "eighth", tUNUMBER, 8 }, + { "ninth", tUNUMBER, 9 }, + { "tenth", tUNUMBER, 10 }, + { "eleventh", tUNUMBER, 11 }, + { "twelfth", tUNUMBER, 12 }, +#endif + { "ago", tAGO, 1 }, + { "epoch", tEPOCH, 0 }, + { NULL } +}; + +/* + * The timezone table. (Note: This table was modified to not use any floating + * point constants to work around an SGI compiler bug). + */ +static TABLE TimezoneTable[] = { + { "gmt", tZONE, HOUR( 0) }, /* Greenwich Mean */ + { "ut", tZONE, HOUR( 0) }, /* Universal (Coordinated) */ + { "utc", tZONE, HOUR( 0) }, + { "wet", tZONE, HOUR( 0) } , /* Western European */ + { "bst", tDAYZONE, HOUR( 0) }, /* British Summer */ + { "wat", tZONE, HOUR( 1) }, /* West Africa */ + { "at", tZONE, HOUR( 2) }, /* Azores */ +#if 0 + /* For completeness. BST is also British Summer, and GST is + * also Guam Standard. */ + { "bst", tZONE, HOUR( 3) }, /* Brazil Standard */ + { "gst", tZONE, HOUR( 3) }, /* Greenland Standard */ +#endif + { "nft", tZONE, HOUR( 7/2) }, /* Newfoundland */ + { "nst", tZONE, HOUR( 7/2) }, /* Newfoundland Standard */ + { "ndt", tDAYZONE, HOUR( 7/2) }, /* Newfoundland Daylight */ + { "ast", tZONE, HOUR( 4) }, /* Atlantic Standard */ + { "adt", tDAYZONE, HOUR( 4) }, /* Atlantic Daylight */ + { "est", tZONE, HOUR( 5) }, /* Eastern Standard */ + { "edt", tDAYZONE, HOUR( 5) }, /* Eastern Daylight */ + { "cst", tZONE, HOUR( 6) }, /* Central Standard */ + { "cdt", tDAYZONE, HOUR( 6) }, /* Central Daylight */ + { "mst", tZONE, HOUR( 7) }, /* Mountain Standard */ + { "mdt", tDAYZONE, HOUR( 7) }, /* Mountain Daylight */ + { "pst", tZONE, HOUR( 8) }, /* Pacific Standard */ + { "pdt", tDAYZONE, HOUR( 8) }, /* Pacific Daylight */ + { "yst", tZONE, HOUR( 9) }, /* Yukon Standard */ + { "ydt", tDAYZONE, HOUR( 9) }, /* Yukon Daylight */ + { "hst", tZONE, HOUR(10) }, /* Hawaii Standard */ + { "hdt", tDAYZONE, HOUR(10) }, /* Hawaii Daylight */ + { "cat", tZONE, HOUR(10) }, /* Central Alaska */ + { "ahst", tZONE, HOUR(10) }, /* Alaska-Hawaii Standard */ + { "nt", tZONE, HOUR(11) }, /* Nome */ + { "idlw", tZONE, HOUR(12) }, /* International Date Line West */ + { "cet", tZONE, -HOUR( 1) }, /* Central European */ + { "met", tZONE, -HOUR( 1) }, /* Middle European */ + { "mewt", tZONE, -HOUR( 1) }, /* Middle European Winter */ + { "mest", tDAYZONE, -HOUR( 1) }, /* Middle European Summer */ + { "swt", tZONE, -HOUR( 1) }, /* Swedish Winter */ + { "sst", tDAYZONE, -HOUR( 1) }, /* Swedish Summer */ + { "fwt", tZONE, -HOUR( 1) }, /* French Winter */ + { "fst", tDAYZONE, -HOUR( 1) }, /* French Summer */ + { "eet", tZONE, -HOUR( 2) }, /* Eastern Europe, USSR Zone 1 */ + { "bt", tZONE, -HOUR( 3) }, /* Baghdad, USSR Zone 2 */ + { "it", tZONE, -HOUR( 7/2) }, /* Iran */ + { "zp4", tZONE, -HOUR( 4) }, /* USSR Zone 3 */ + { "zp5", tZONE, -HOUR( 5) }, /* USSR Zone 4 */ + { "ist", tZONE, -HOUR(11/2) }, /* Indian Standard */ + { "zp6", tZONE, -HOUR( 6) }, /* USSR Zone 5 */ +#if 0 + /* For completeness. NST is also Newfoundland Stanard, nad SST is + * also Swedish Summer. */ + { "nst", tZONE, -HOUR(13/2) }, /* North Sumatra */ + { "sst", tZONE, -HOUR( 7) }, /* South Sumatra, USSR Zone 6 */ +#endif /* 0 */ + { "wast", tZONE, -HOUR( 7) }, /* West Australian Standard */ + { "wadt", tDAYZONE, -HOUR( 7) }, /* West Australian Daylight */ + { "jt", tZONE, -HOUR(15/2) }, /* Java (3pm in Cronusland!) */ + { "cct", tZONE, -HOUR( 8) }, /* China Coast, USSR Zone 7 */ + { "jst", tZONE, -HOUR( 9) }, /* Japan Standard, USSR Zone 8 */ + { "cast", tZONE, -HOUR(19/2) }, /* Central Australian Standard */ + { "cadt", tDAYZONE, -HOUR(19/2) }, /* Central Australian Daylight */ + { "east", tZONE, -HOUR(10) }, /* Eastern Australian Standard */ + { "eadt", tDAYZONE, -HOUR(10) }, /* Eastern Australian Daylight */ + { "gst", tZONE, -HOUR(10) }, /* Guam Standard, USSR Zone 9 */ + { "nzt", tZONE, -HOUR(12) }, /* New Zealand */ + { "nzst", tZONE, -HOUR(12) }, /* New Zealand Standard */ + { "nzdt", tDAYZONE, -HOUR(12) }, /* New Zealand Daylight */ + { "idle", tZONE, -HOUR(12) }, /* International Date Line East */ + /* ADDED BY Marco Nijdam */ + { "dst", tDST, HOUR( 0) }, /* DST on (hour is ignored) */ + /* End ADDED */ + { NULL } +}; + +/* + * Military timezone table. + */ +static TABLE MilitaryTable[] = { + { "a", tZONE, HOUR( 1) }, + { "b", tZONE, HOUR( 2) }, + { "c", tZONE, HOUR( 3) }, + { "d", tZONE, HOUR( 4) }, + { "e", tZONE, HOUR( 5) }, + { "f", tZONE, HOUR( 6) }, + { "g", tZONE, HOUR( 7) }, + { "h", tZONE, HOUR( 8) }, + { "i", tZONE, HOUR( 9) }, + { "k", tZONE, HOUR( 10) }, + { "l", tZONE, HOUR( 11) }, + { "m", tZONE, HOUR( 12) }, + { "n", tZONE, HOUR(- 1) }, + { "o", tZONE, HOUR(- 2) }, + { "p", tZONE, HOUR(- 3) }, + { "q", tZONE, HOUR(- 4) }, + { "r", tZONE, HOUR(- 5) }, + { "s", tZONE, HOUR(- 6) }, + { "t", tZONE, HOUR(- 7) }, + { "u", tZONE, HOUR(- 8) }, + { "v", tZONE, HOUR(- 9) }, + { "w", tZONE, HOUR(-10) }, + { "x", tZONE, HOUR(-11) }, + { "y", tZONE, HOUR(-12) }, + { "z", tZONE, HOUR( 0) }, + { NULL } +}; + + +/* + * Dump error messages in the bit bucket. + */ +static void +TclDateerror(s) + char *s; +{ +} + + +static time_t +ToSeconds(Hours, Minutes, Seconds, Meridian) + time_t Hours; + time_t Minutes; + time_t Seconds; + MERIDIAN Meridian; +{ + if (Minutes < 0 || Minutes > 59 || Seconds < 0 || Seconds > 59) + return -1; + switch (Meridian) { + case MER24: + if (Hours < 0 || Hours > 23) + return -1; + return (Hours * 60L + Minutes) * 60L + Seconds; + case MERam: + if (Hours < 1 || Hours > 12) + return -1; + return ((Hours % 12) * 60L + Minutes) * 60L + Seconds; + case MERpm: + if (Hours < 1 || Hours > 12) + return -1; + return (((Hours % 12) + 12) * 60L + Minutes) * 60L + Seconds; + } + return -1; /* Should never be reached */ +} + + +static int +Convert(Month, Day, Year, Hours, Minutes, Seconds, Meridian, DSTmode, TimePtr) + time_t Month; + time_t Day; + time_t Year; + time_t Hours; + time_t Minutes; + time_t Seconds; + MERIDIAN Meridian; + DSTMODE DSTmode; + time_t *TimePtr; +{ + static int DaysInMonth[12] = { + 31, 0, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 + }; + time_t tod; + time_t Julian; + int i; + + if (Year < 0) + Year = -Year; + if (Year < 100) + Year += 1900; + DaysInMonth[1] = Year % 4 == 0 && (Year % 100 != 0 || Year % 400 == 0) + ? 29 : 28; + if (Month < 1 || Month > 12 + || Year < START_OF_TIME || Year > END_OF_TIME + || Day < 1 || Day > DaysInMonth[(int)--Month]) + return -1; + + for (Julian = Day - 1, i = 0; i < Month; i++) + Julian += DaysInMonth[i]; + if (Year >= EPOCH) { + for (i = EPOCH; i < Year; i++) + Julian += 365 + (i % 4 == 0); + } else { + for (i = Year; i < EPOCH; i++) + Julian -= 365 + (i % 4 == 0); + } + Julian *= SECSPERDAY; + Julian += TclDateTimezone * 60L; + if ((tod = ToSeconds(Hours, Minutes, Seconds, Meridian)) < 0) + return -1; + Julian += tod; + if (DSTmode == DSTon + || (DSTmode == DSTmaybe && TclpGetDate(&Julian, 0)->tm_isdst)) + Julian -= 60 * 60; + *TimePtr = Julian; + return 0; +} + + +static time_t +DSTcorrect(Start, Future) + time_t Start; + time_t Future; +{ + time_t StartDay; + time_t FutureDay; + + StartDay = (TclpGetDate(&Start, 0)->tm_hour + 1) % 24; + FutureDay = (TclpGetDate(&Future, 0)->tm_hour + 1) % 24; + return (Future - Start) + (StartDay - FutureDay) * 60L * 60L; +} + + +static time_t +RelativeDate(Start, DayOrdinal, DayNumber) + time_t Start; + time_t DayOrdinal; + time_t DayNumber; +{ + struct tm *tm; + time_t now; + + now = Start; + tm = TclpGetDate(&now, 0); + now += SECSPERDAY * ((DayNumber - tm->tm_wday + 7) % 7); + now += 7 * SECSPERDAY * (DayOrdinal <= 0 ? DayOrdinal : DayOrdinal - 1); + return DSTcorrect(Start, now); +} + + +static int +RelativeMonth(Start, RelMonth, TimePtr) + time_t Start; + time_t RelMonth; + time_t *TimePtr; +{ + struct tm *tm; + time_t Month; + time_t Year; + time_t Julian; + + if (RelMonth == 0) { + *TimePtr = 0; + return 0; + } + tm = TclpGetDate(&Start, 0); + Month = 12 * tm->tm_year + tm->tm_mon + RelMonth; + Year = Month / 12; + Month = Month % 12 + 1; + if (Convert(Month, (time_t)tm->tm_mday, Year, + (time_t)tm->tm_hour, (time_t)tm->tm_min, (time_t)tm->tm_sec, + MER24, DSTmaybe, &Julian) < 0) + return -1; + *TimePtr = DSTcorrect(Start, Julian); + return 0; +} + + +static int +LookupWord(buff) + char *buff; +{ + register char *p; + register char *q; + register TABLE *tp; + int i; + int abbrev; + + /* + * Make it lowercase. + */ + for (p = buff; *p; p++) { + if (isupper(UCHAR(*p))) { + *p = (char) tolower(UCHAR(*p)); + } + } + + if (strcmp(buff, "am") == 0 || strcmp(buff, "a.m.") == 0) { + TclDatelval.Meridian = MERam; + return tMERIDIAN; + } + if (strcmp(buff, "pm") == 0 || strcmp(buff, "p.m.") == 0) { + TclDatelval.Meridian = MERpm; + return tMERIDIAN; + } + + /* + * See if we have an abbreviation for a month. + */ + if (strlen(buff) == 3) { + abbrev = 1; + } else if (strlen(buff) == 4 && buff[3] == '.') { + abbrev = 1; + buff[3] = '\0'; + } else { + abbrev = 0; + } + + for (tp = MonthDayTable; tp->name; tp++) { + if (abbrev) { + if (strncmp(buff, tp->name, 3) == 0) { + TclDatelval.Number = tp->value; + return tp->type; + } + } else if (strcmp(buff, tp->name) == 0) { + TclDatelval.Number = tp->value; + return tp->type; + } + } + + for (tp = TimezoneTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + TclDatelval.Number = tp->value; + return tp->type; + } + } + + for (tp = UnitsTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + TclDatelval.Number = tp->value; + return tp->type; + } + } + + /* + * Strip off any plural and try the units table again. + */ + i = strlen(buff) - 1; + if (buff[i] == 's') { + buff[i] = '\0'; + for (tp = UnitsTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + TclDatelval.Number = tp->value; + return tp->type; + } + } + } + + for (tp = OtherTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + TclDatelval.Number = tp->value; + return tp->type; + } + } + + /* + * Military timezones. + */ + if (buff[1] == '\0' && isalpha(UCHAR(*buff))) { + for (tp = MilitaryTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + TclDatelval.Number = tp->value; + return tp->type; + } + } + } + + /* + * Drop out any periods and try the timezone table again. + */ + for (i = 0, p = q = buff; *q; q++) + if (*q != '.') + *p++ = *q; + else + i++; + *p = '\0'; + if (i) + for (tp = TimezoneTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + TclDatelval.Number = tp->value; + return tp->type; + } + } + + return tID; +} + + +static int +TclDatelex() +{ + register char c; + register char *p; + char buff[20]; + int Count; + int sign; + + for ( ; ; ) { + while (isspace((unsigned char) (*TclDateInput))) { + TclDateInput++; + } + + if (isdigit(c = *TclDateInput) || c == '-' || c == '+') { + if (c == '-' || c == '+') { + sign = c == '-' ? -1 : 1; + if (!isdigit(*++TclDateInput)) { + /* + * skip the '-' sign + */ + continue; + } + } else { + sign = 0; + } + for (TclDatelval.Number = 0; isdigit(c = *TclDateInput++); ) { + TclDatelval.Number = 10 * TclDatelval.Number + c - '0'; + } + TclDateInput--; + if (sign < 0) { + TclDatelval.Number = -TclDatelval.Number; + } + return sign ? tSNUMBER : tUNUMBER; + } + if (isalpha(UCHAR(c))) { + for (p = buff; isalpha(c = *TclDateInput++) || c == '.'; ) { + if (p < &buff[sizeof buff - 1]) { + *p++ = c; + } + } + *p = '\0'; + TclDateInput--; + return LookupWord(buff); + } + if (c != '(') { + return *TclDateInput++; + } + Count = 0; + do { + c = *TclDateInput++; + if (c == '\0') { + return c; + } else if (c == '(') { + Count++; + } else if (c == ')') { + Count--; + } + } while (Count > 0); + } +} + +/* + * Specify zone is of -50000 to force GMT. (This allows BST to work). + */ + +int +TclGetDate(p, now, zone, timePtr) + char *p; + unsigned long now; + long zone; + unsigned long *timePtr; +{ + struct tm *tm; + time_t Start; + time_t Time; + time_t tod; + + TclDateInput = p; + tm = TclpGetDate((time_t *) &now, 0); + TclDateYear = tm->tm_year; + TclDateMonth = tm->tm_mon + 1; + TclDateDay = tm->tm_mday; + TclDateTimezone = zone; + if (zone == -50000) { + TclDateDSTmode = DSToff; /* assume GMT */ + TclDateTimezone = 0; + } else { + TclDateDSTmode = DSTmaybe; + } + TclDateHour = 0; + TclDateMinutes = 0; + TclDateSeconds = 0; + TclDateMeridian = MER24; + TclDateRelSeconds = 0; + TclDateRelMonth = 0; + TclDateHaveDate = 0; + TclDateHaveDay = 0; + TclDateHaveRel = 0; + TclDateHaveTime = 0; + TclDateHaveZone = 0; + + if (TclDateparse() || TclDateHaveTime > 1 || TclDateHaveZone > 1 || TclDateHaveDate > 1 || + TclDateHaveDay > 1) { + return -1; + } + + if (TclDateHaveDate || TclDateHaveTime || TclDateHaveDay) { + if (Convert(TclDateMonth, TclDateDay, TclDateYear, TclDateHour, TclDateMinutes, TclDateSeconds, + TclDateMeridian, TclDateDSTmode, &Start) < 0) + return -1; + } + else { + Start = now; + if (!TclDateHaveRel) + Start -= ((tm->tm_hour * 60L) + tm->tm_min * 60L) + tm->tm_sec; + } + + Start += TclDateRelSeconds; + if (RelativeMonth(Start, TclDateRelMonth, &Time) < 0) { + return -1; + } + Start += Time; + + if (TclDateHaveDay && !TclDateHaveDate) { + tod = RelativeDate(Start, TclDateDayOrdinal, TclDateDayNumber); + Start += tod; + } + + *timePtr = Start; + return 0; +} +TclDatetabelem TclDateexca[] ={ +-1, 1, + 0, -1, + -2, 0, + }; +# define YYNPROD 41 +# define YYLAST 227 +TclDatetabelem TclDateact[]={ + + 14, 11, 23, 28, 17, 12, 19, 18, 16, 9, + 10, 13, 42, 21, 46, 45, 44, 48, 41, 37, + 36, 35, 32, 29, 34, 33, 31, 43, 39, 38, + 30, 15, 8, 7, 6, 5, 4, 3, 2, 1, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 47, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 22, 0, 0, 20, 25, 24, 27, + 26, 42, 0, 0, 0, 0, 40 }; +TclDatetabelem TclDatepact[]={ + +-10000000, -258,-10000000,-10000000,-10000000,-10000000,-10000000,-10000000,-10000000, -45, + -267,-10000000, -244,-10000000, -14, -231, -240,-10000000,-10000000,-10000000, +-10000000, -246,-10000000, -247, -248,-10000000,-10000000,-10000000,-10000000, -15, +-10000000,-10000000,-10000000,-10000000,-10000000, -40, -20,-10000000, -251,-10000000, +-10000000, -252,-10000000, -253,-10000000, -249,-10000000,-10000000,-10000000 }; +TclDatetabelem TclDatepgo[]={ + + 0, 28, 39, 38, 37, 36, 35, 34, 33, 32, + 31 }; +TclDatetabelem TclDater1[]={ + + 0, 2, 2, 3, 3, 3, 3, 3, 3, 4, + 4, 4, 4, 4, 5, 5, 5, 7, 7, 7, + 6, 6, 6, 6, 6, 6, 6, 8, 8, 10, + 10, 10, 10, 10, 10, 10, 10, 10, 9, 1, + 1 }; +TclDatetabelem TclDater2[]={ + + 0, 0, 4, 3, 3, 3, 3, 3, 2, 5, + 9, 9, 13, 13, 5, 3, 3, 3, 5, 5, + 7, 11, 5, 9, 5, 3, 7, 5, 2, 5, + 5, 3, 5, 5, 3, 5, 5, 3, 3, 1, + 3 }; +TclDatetabelem TclDatechk[]={ + +-10000000, -2, -3, -4, -5, -6, -7, -8, -9, 267, + 268, 259, 263, 269, 258, -10, 266, 262, 265, 264, + 261, 58, 258, 47, 263, 262, 265, 264, 270, 267, + 44, 257, 262, 265, 264, 267, 267, 267, 44, -1, + 266, 58, 261, 47, 267, 267, 267, -1, 266 }; +TclDatetabelem TclDatedef[]={ + + 1, -2, 2, 3, 4, 5, 6, 7, 8, 38, + 15, 16, 0, 25, 17, 28, 0, 31, 34, 37, + 9, 0, 19, 0, 24, 29, 33, 36, 14, 22, + 18, 27, 30, 32, 35, 39, 20, 26, 0, 10, + 11, 0, 40, 0, 23, 39, 21, 12, 13 }; +typedef struct +#ifdef __cplusplus + TclDatetoktype +#endif +{ char *t_name; int t_val; } TclDatetoktype; +#ifndef YYDEBUG +# define YYDEBUG 0 /* don't allow debugging */ +#endif + +#if YYDEBUG + +TclDatetoktype TclDatetoks[] = +{ + "tAGO", 257, + "tDAY", 258, + "tDAYZONE", 259, + "tID", 260, + "tMERIDIAN", 261, + "tMINUTE_UNIT", 262, + "tMONTH", 263, + "tMONTH_UNIT", 264, + "tSEC_UNIT", 265, + "tSNUMBER", 266, + "tUNUMBER", 267, + "tZONE", 268, + "tEPOCH", 269, + "tDST", 270, + "-unknown-", -1 /* ends search */ +}; + +char * TclDatereds[] = +{ + "-no such reduction-", + "spec : /* empty */", + "spec : spec item", + "item : time", + "item : zone", + "item : date", + "item : day", + "item : rel", + "item : number", + "time : tUNUMBER tMERIDIAN", + "time : tUNUMBER ':' tUNUMBER o_merid", + "time : tUNUMBER ':' tUNUMBER tSNUMBER", + "time : tUNUMBER ':' tUNUMBER ':' tUNUMBER o_merid", + "time : tUNUMBER ':' tUNUMBER ':' tUNUMBER tSNUMBER", + "zone : tZONE tDST", + "zone : tZONE", + "zone : tDAYZONE", + "day : tDAY", + "day : tDAY ','", + "day : tUNUMBER tDAY", + "date : tUNUMBER '/' tUNUMBER", + "date : tUNUMBER '/' tUNUMBER '/' tUNUMBER", + "date : tMONTH tUNUMBER", + "date : tMONTH tUNUMBER ',' tUNUMBER", + "date : tUNUMBER tMONTH", + "date : tEPOCH", + "date : tUNUMBER tMONTH tUNUMBER", + "rel : relunit tAGO", + "rel : relunit", + "relunit : tUNUMBER tMINUTE_UNIT", + "relunit : tSNUMBER tMINUTE_UNIT", + "relunit : tMINUTE_UNIT", + "relunit : tSNUMBER tSEC_UNIT", + "relunit : tUNUMBER tSEC_UNIT", + "relunit : tSEC_UNIT", + "relunit : tSNUMBER tMONTH_UNIT", + "relunit : tUNUMBER tMONTH_UNIT", + "relunit : tMONTH_UNIT", + "number : tUNUMBER", + "o_merid : /* empty */", + "o_merid : tMERIDIAN", +}; +#endif /* YYDEBUG */ +/* + * Copyright (c) 1993 by Sun Microsystems, Inc. + */ + + +/* +** Skeleton parser driver for yacc output +*/ + +/* +** yacc user known macros and defines +*/ +#define YYERROR goto TclDateerrlab +#define YYACCEPT return(0) +#define YYABORT return(1) +#define YYBACKUP( newtoken, newvalue )\ +{\ + if ( TclDatechar >= 0 || ( TclDater2[ TclDatetmp ] >> 1 ) != 1 )\ + {\ + TclDateerror( "syntax error - cannot backup" );\ + goto TclDateerrlab;\ + }\ + TclDatechar = newtoken;\ + TclDatestate = *TclDateps;\ + TclDatelval = newvalue;\ + goto TclDatenewstate;\ +} +#define YYRECOVERING() (!!TclDateerrflag) +#define YYNEW(type) malloc(sizeof(type) * TclDatenewmax) +#define YYCOPY(to, from, type) \ + (type *) memcpy(to, (char *) from, TclDatenewmax * sizeof(type)) +#define YYENLARGE( from, type) \ + (type *) realloc((char *) from, TclDatenewmax * sizeof(type)) +#ifndef YYDEBUG +# define YYDEBUG 1 /* make debugging available */ +#endif + +/* +** user known globals +*/ +int TclDatedebug; /* set to 1 to get debugging */ + +/* +** driver internal defines +*/ +#define YYFLAG (-10000000) + +/* +** global variables used by the parser +*/ +YYSTYPE *TclDatepv; /* top of value stack */ +int *TclDateps; /* top of state stack */ + +int TclDatestate; /* current state */ +int TclDatetmp; /* extra var (lasts between blocks) */ + +int TclDatenerrs; /* number of errors */ +int TclDateerrflag; /* error recovery flag */ +int TclDatechar; /* current input token number */ + + + +#ifdef YYNMBCHARS +#define YYLEX() TclDatecvtok(TclDatelex()) +/* +** TclDatecvtok - return a token if i is a wchar_t value that exceeds 255. +** If i<255, i itself is the token. If i>255 but the neither +** of the 30th or 31st bit is on, i is already a token. +*/ +#if defined(__STDC__) || defined(__cplusplus) +int TclDatecvtok(int i) +#else +int TclDatecvtok(i) int i; +#endif +{ + int first = 0; + int last = YYNMBCHARS - 1; + int mid; + wchar_t j; + + if(i&0x60000000){/*Must convert to a token. */ + if( TclDatembchars[last].character < i ){ + return i;/*Giving up*/ + } + while ((last>=first)&&(first>=0)) {/*Binary search loop*/ + mid = (first+last)/2; + j = TclDatembchars[mid].character; + if( j==i ){/*Found*/ + return TclDatembchars[mid].tvalue; + }else if( j= 0; + TclDate_i++ ) + { + if ( TclDatetoks[TclDate_i].t_val == TclDatechar ) + break; + } + printf( "%s\n", TclDatetoks[TclDate_i].t_name ); + } + } +#endif /* YYDEBUG */ + if ( ++TclDate_ps >= &TclDates[ TclDatemaxdepth ] ) /* room on stack? */ + { + /* + ** reallocate and recover. Note that pointers + ** have to be reset, or bad things will happen + */ + int TclDateps_index = (TclDate_ps - TclDates); + int TclDatepv_index = (TclDate_pv - TclDatev); + int TclDatepvt_index = (TclDatepvt - TclDatev); + int TclDatenewmax; +#ifdef YYEXPAND + TclDatenewmax = YYEXPAND(TclDatemaxdepth); +#else + TclDatenewmax = 2 * TclDatemaxdepth; /* double table size */ + if (TclDatemaxdepth == YYMAXDEPTH) /* first time growth */ + { + char *newTclDates = (char *)YYNEW(int); + char *newTclDatev = (char *)YYNEW(YYSTYPE); + if (newTclDates != 0 && newTclDatev != 0) + { + TclDates = YYCOPY(newTclDates, TclDates, int); + TclDatev = YYCOPY(newTclDatev, TclDatev, YYSTYPE); + } + else + TclDatenewmax = 0; /* failed */ + } + else /* not first time */ + { + TclDates = YYENLARGE(TclDates, int); + TclDatev = YYENLARGE(TclDatev, YYSTYPE); + if (TclDates == 0 || TclDatev == 0) + TclDatenewmax = 0; /* failed */ + } +#endif + if (TclDatenewmax <= TclDatemaxdepth) /* tables not expanded */ + { + TclDateerror( "yacc stack overflow" ); + YYABORT; + } + TclDatemaxdepth = TclDatenewmax; + + TclDate_ps = TclDates + TclDateps_index; + TclDate_pv = TclDatev + TclDatepv_index; + TclDatepvt = TclDatev + TclDatepvt_index; + } + *TclDate_ps = TclDate_state; + *++TclDate_pv = TclDateval; + + /* + ** we have a new state - find out what to do + */ + TclDate_newstate: + if ( ( TclDate_n = TclDatepact[ TclDate_state ] ) <= YYFLAG ) + goto TclDatedefault; /* simple state */ +#if YYDEBUG + /* + ** if debugging, need to mark whether new token grabbed + */ + TclDatetmp = TclDatechar < 0; +#endif + if ( ( TclDatechar < 0 ) && ( ( TclDatechar = YYLEX() ) < 0 ) ) + TclDatechar = 0; /* reached EOF */ +#if YYDEBUG + if ( TclDatedebug && TclDatetmp ) + { + register int TclDate_i; + + printf( "Received token " ); + if ( TclDatechar == 0 ) + printf( "end-of-file\n" ); + else if ( TclDatechar < 0 ) + printf( "-none-\n" ); + else + { + for ( TclDate_i = 0; TclDatetoks[TclDate_i].t_val >= 0; + TclDate_i++ ) + { + if ( TclDatetoks[TclDate_i].t_val == TclDatechar ) + break; + } + printf( "%s\n", TclDatetoks[TclDate_i].t_name ); + } + } +#endif /* YYDEBUG */ + if ( ( ( TclDate_n += TclDatechar ) < 0 ) || ( TclDate_n >= YYLAST ) ) + goto TclDatedefault; + if ( TclDatechk[ TclDate_n = TclDateact[ TclDate_n ] ] == TclDatechar ) /*valid shift*/ + { + TclDatechar = -1; + TclDateval = TclDatelval; + TclDate_state = TclDate_n; + if ( TclDateerrflag > 0 ) + TclDateerrflag--; + goto TclDate_stack; + } + + TclDatedefault: + if ( ( TclDate_n = TclDatedef[ TclDate_state ] ) == -2 ) + { +#if YYDEBUG + TclDatetmp = TclDatechar < 0; +#endif + if ( ( TclDatechar < 0 ) && ( ( TclDatechar = YYLEX() ) < 0 ) ) + TclDatechar = 0; /* reached EOF */ +#if YYDEBUG + if ( TclDatedebug && TclDatetmp ) + { + register int TclDate_i; + + printf( "Received token " ); + if ( TclDatechar == 0 ) + printf( "end-of-file\n" ); + else if ( TclDatechar < 0 ) + printf( "-none-\n" ); + else + { + for ( TclDate_i = 0; + TclDatetoks[TclDate_i].t_val >= 0; + TclDate_i++ ) + { + if ( TclDatetoks[TclDate_i].t_val + == TclDatechar ) + { + break; + } + } + printf( "%s\n", TclDatetoks[TclDate_i].t_name ); + } + } +#endif /* YYDEBUG */ + /* + ** look through exception table + */ + { + register int *TclDatexi = TclDateexca; + + while ( ( *TclDatexi != -1 ) || + ( TclDatexi[1] != TclDate_state ) ) + { + TclDatexi += 2; + } + while ( ( *(TclDatexi += 2) >= 0 ) && + ( *TclDatexi != TclDatechar ) ) + ; + if ( ( TclDate_n = TclDatexi[1] ) < 0 ) + YYACCEPT; + } + } + + /* + ** check for syntax error + */ + if ( TclDate_n == 0 ) /* have an error */ + { + /* no worry about speed here! */ + switch ( TclDateerrflag ) + { + case 0: /* new error */ + TclDateerror( "syntax error" ); + goto skip_init; + /* + ** get globals into registers. + ** we have a user generated syntax type error + */ + TclDate_pv = TclDatepv; + TclDate_ps = TclDateps; + TclDate_state = TclDatestate; + skip_init: + TclDatenerrs++; + /* FALLTHRU */ + case 1: + case 2: /* incompletely recovered error */ + /* try again... */ + TclDateerrflag = 3; + /* + ** find state where "error" is a legal + ** shift action + */ + while ( TclDate_ps >= TclDates ) + { + TclDate_n = TclDatepact[ *TclDate_ps ] + YYERRCODE; + if ( TclDate_n >= 0 && TclDate_n < YYLAST && + TclDatechk[TclDateact[TclDate_n]] == YYERRCODE) { + /* + ** simulate shift of "error" + */ + TclDate_state = TclDateact[ TclDate_n ]; + goto TclDate_stack; + } + /* + ** current state has no shift on + ** "error", pop stack + */ +#if YYDEBUG +# define _POP_ "Error recovery pops state %d, uncovers state %d\n" + if ( TclDatedebug ) + printf( _POP_, *TclDate_ps, + TclDate_ps[-1] ); +# undef _POP_ +#endif + TclDate_ps--; + TclDate_pv--; + } + /* + ** there is no state on stack with "error" as + ** a valid shift. give up. + */ + YYABORT; + case 3: /* no shift yet; eat a token */ +#if YYDEBUG + /* + ** if debugging, look up token in list of + ** pairs. 0 and negative shouldn't occur, + ** but since timing doesn't matter when + ** debugging, it doesn't hurt to leave the + ** tests here. + */ + if ( TclDatedebug ) + { + register int TclDate_i; + + printf( "Error recovery discards " ); + if ( TclDatechar == 0 ) + printf( "token end-of-file\n" ); + else if ( TclDatechar < 0 ) + printf( "token -none-\n" ); + else + { + for ( TclDate_i = 0; + TclDatetoks[TclDate_i].t_val >= 0; + TclDate_i++ ) + { + if ( TclDatetoks[TclDate_i].t_val + == TclDatechar ) + { + break; + } + } + printf( "token %s\n", + TclDatetoks[TclDate_i].t_name ); + } + } +#endif /* YYDEBUG */ + if ( TclDatechar == 0 ) /* reached EOF. quit */ + YYABORT; + TclDatechar = -1; + goto TclDate_newstate; + } + }/* end if ( TclDate_n == 0 ) */ + /* + ** reduction by production TclDate_n + ** put stack tops, etc. so things right after switch + */ +#if YYDEBUG + /* + ** if debugging, print the string that is the user's + ** specification of the reduction which is just about + ** to be done. + */ + if ( TclDatedebug ) + printf( "Reduce by (%d) \"%s\"\n", + TclDate_n, TclDatereds[ TclDate_n ] ); +#endif + TclDatetmp = TclDate_n; /* value to switch over */ + TclDatepvt = TclDate_pv; /* $vars top of value stack */ + /* + ** Look in goto table for next state + ** Sorry about using TclDate_state here as temporary + ** register variable, but why not, if it works... + ** If TclDater2[ TclDate_n ] doesn't have the low order bit + ** set, then there is no action to be done for + ** this reduction. So, no saving & unsaving of + ** registers done. The only difference between the + ** code just after the if and the body of the if is + ** the goto TclDate_stack in the body. This way the test + ** can be made before the choice of what to do is needed. + */ + { + /* length of production doubled with extra bit */ + register int TclDate_len = TclDater2[ TclDate_n ]; + + if ( !( TclDate_len & 01 ) ) + { + TclDate_len >>= 1; + TclDateval = ( TclDate_pv -= TclDate_len )[1]; /* $$ = $1 */ + TclDate_state = TclDatepgo[ TclDate_n = TclDater1[ TclDate_n ] ] + + *( TclDate_ps -= TclDate_len ) + 1; + if ( TclDate_state >= YYLAST || + TclDatechk[ TclDate_state = + TclDateact[ TclDate_state ] ] != -TclDate_n ) + { + TclDate_state = TclDateact[ TclDatepgo[ TclDate_n ] ]; + } + goto TclDate_stack; + } + TclDate_len >>= 1; + TclDateval = ( TclDate_pv -= TclDate_len )[1]; /* $$ = $1 */ + TclDate_state = TclDatepgo[ TclDate_n = TclDater1[ TclDate_n ] ] + + *( TclDate_ps -= TclDate_len ) + 1; + if ( TclDate_state >= YYLAST || + TclDatechk[ TclDate_state = TclDateact[ TclDate_state ] ] != -TclDate_n ) + { + TclDate_state = TclDateact[ TclDatepgo[ TclDate_n ] ]; + } + } + /* save until reenter driver code */ + TclDatestate = TclDate_state; + TclDateps = TclDate_ps; + TclDatepv = TclDate_pv; + } + /* + ** code supplied by user is placed in this switch + */ + switch( TclDatetmp ) + { + +case 3:{ + TclDateHaveTime++; + } break; +case 4:{ + TclDateHaveZone++; + } break; +case 5:{ + TclDateHaveDate++; + } break; +case 6:{ + TclDateHaveDay++; + } break; +case 7:{ + TclDateHaveRel++; + } break; +case 9:{ + TclDateHour = TclDatepvt[-1].Number; + TclDateMinutes = 0; + TclDateSeconds = 0; + TclDateMeridian = TclDatepvt[-0].Meridian; + } break; +case 10:{ + TclDateHour = TclDatepvt[-3].Number; + TclDateMinutes = TclDatepvt[-1].Number; + TclDateSeconds = 0; + TclDateMeridian = TclDatepvt[-0].Meridian; + } break; +case 11:{ + TclDateHour = TclDatepvt[-3].Number; + TclDateMinutes = TclDatepvt[-1].Number; + TclDateMeridian = MER24; + TclDateDSTmode = DSToff; + TclDateTimezone = - (TclDatepvt[-0].Number % 100 + (TclDatepvt[-0].Number / 100) * 60); + } break; +case 12:{ + TclDateHour = TclDatepvt[-5].Number; + TclDateMinutes = TclDatepvt[-3].Number; + TclDateSeconds = TclDatepvt[-1].Number; + TclDateMeridian = TclDatepvt[-0].Meridian; + } break; +case 13:{ + TclDateHour = TclDatepvt[-5].Number; + TclDateMinutes = TclDatepvt[-3].Number; + TclDateSeconds = TclDatepvt[-1].Number; + TclDateMeridian = MER24; + TclDateDSTmode = DSToff; + TclDateTimezone = - (TclDatepvt[-0].Number % 100 + (TclDatepvt[-0].Number / 100) * 60); + } break; +case 14:{ + TclDateTimezone = TclDatepvt[-1].Number; + TclDateDSTmode = DSTon; + } break; +case 15:{ + TclDateTimezone = TclDatepvt[-0].Number; + TclDateDSTmode = DSToff; + } break; +case 16:{ + TclDateTimezone = TclDatepvt[-0].Number; + TclDateDSTmode = DSTon; + } break; +case 17:{ + TclDateDayOrdinal = 1; + TclDateDayNumber = TclDatepvt[-0].Number; + } break; +case 18:{ + TclDateDayOrdinal = 1; + TclDateDayNumber = TclDatepvt[-1].Number; + } break; +case 19:{ + TclDateDayOrdinal = TclDatepvt[-1].Number; + TclDateDayNumber = TclDatepvt[-0].Number; + } break; +case 20:{ + TclDateMonth = TclDatepvt[-2].Number; + TclDateDay = TclDatepvt[-0].Number; + } break; +case 21:{ + TclDateMonth = TclDatepvt[-4].Number; + TclDateDay = TclDatepvt[-2].Number; + TclDateYear = TclDatepvt[-0].Number; + } break; +case 22:{ + TclDateMonth = TclDatepvt[-1].Number; + TclDateDay = TclDatepvt[-0].Number; + } break; +case 23:{ + TclDateMonth = TclDatepvt[-3].Number; + TclDateDay = TclDatepvt[-2].Number; + TclDateYear = TclDatepvt[-0].Number; + } break; +case 24:{ + TclDateMonth = TclDatepvt[-0].Number; + TclDateDay = TclDatepvt[-1].Number; + } break; +case 25:{ + TclDateMonth = 1; + TclDateDay = 1; + TclDateYear = EPOCH; + } break; +case 26:{ + TclDateMonth = TclDatepvt[-1].Number; + TclDateDay = TclDatepvt[-2].Number; + TclDateYear = TclDatepvt[-0].Number; + } break; +case 27:{ + TclDateRelSeconds = -TclDateRelSeconds; + TclDateRelMonth = -TclDateRelMonth; + } break; +case 29:{ + TclDateRelSeconds += TclDatepvt[-1].Number * TclDatepvt[-0].Number * 60L; + } break; +case 30:{ + TclDateRelSeconds += TclDatepvt[-1].Number * TclDatepvt[-0].Number * 60L; + } break; +case 31:{ + TclDateRelSeconds += TclDatepvt[-0].Number * 60L; + } break; +case 32:{ + TclDateRelSeconds += TclDatepvt[-1].Number; + } break; +case 33:{ + TclDateRelSeconds += TclDatepvt[-1].Number; + } break; +case 34:{ + TclDateRelSeconds++; + } break; +case 35:{ + TclDateRelMonth += TclDatepvt[-1].Number * TclDatepvt[-0].Number; + } break; +case 36:{ + TclDateRelMonth += TclDatepvt[-1].Number * TclDatepvt[-0].Number; + } break; +case 37:{ + TclDateRelMonth += TclDatepvt[-0].Number; + } break; +case 38:{ + if (TclDateHaveTime && TclDateHaveDate && !TclDateHaveRel) { + TclDateYear = TclDatepvt[-0].Number; + } else { + TclDateHaveTime++; + if (TclDatepvt[-0].Number < 100) { + TclDateHour = 0; + TclDateMinutes = TclDatepvt[-0].Number; + } else { + TclDateHour = TclDatepvt[-0].Number / 100; + TclDateMinutes = TclDatepvt[-0].Number % 100; + } + TclDateSeconds = 0; + TclDateMeridian = MER24; + } + } break; +case 39:{ + TclDateval.Meridian = MER24; + } break; +case 40:{ + TclDateval.Meridian = TclDatepvt[-0].Meridian; + } break; + } + goto TclDatestack; /* reset registers in driver code */ +} + diff --git a/tcl7.3/tclEnv.c b/tcl7.6/generic/tclEnv.c similarity index 80% rename from tcl7.3/tclEnv.c rename to tcl7.6/generic/tclEnv.c index b9b1205..35d6b01 100644 --- a/tcl7.3/tclEnv.c +++ b/tcl7.6/generic/tclEnv.c @@ -4,31 +4,15 @@ * Tcl support for environment variables, including a setenv * procedure. * - * Copyright (c) 1991-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tclEnv.c 1.39 96/08/22 10:47:09 */ -#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 @@ -38,7 +22,7 @@ static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclEnv.c,v 1.17 93/10/13 1 #define putenv ignore_putenv #define setenv ignore_setenv #include "tclInt.h" -#include "tclUnix.h" +#include "tclPort.h" #undef putenv #undef setenv @@ -72,6 +56,7 @@ static int environSize = 0; /* Non-zero means that the all of the * Declarations for local procedures defined in this file: */ +static void EnvExitProc _ANSI_ARGS_((ClientData clientData)); static void EnvInit _ANSI_ARGS_((void)); static char * EnvTraceProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, char *name1, char *name2, @@ -111,7 +96,9 @@ TclSetupEnv(interp) * managed. */ { EnvInterp *eiPtr; - int i; + char *p, *p2; + Tcl_DString ds; + int i, sz; /* * First, initialize our environment-related information, if @@ -122,6 +109,13 @@ TclSetupEnv(interp) EnvInit(); } + /* + * Next, initialize the DString we are going to use for copying + * the names of the environment variables. + */ + + Tcl_DStringInit(&ds); + /* * Next, add the interpreter to the list of those that we manage. */ @@ -139,8 +133,6 @@ TclSetupEnv(interp) (void) Tcl_UnsetVar2(interp, "env", (char *) NULL, TCL_GLOBAL_ONLY); for (i = 0; ; i++) { - char *p, *p2; - p = environ[i]; if (p == NULL) { break; @@ -148,13 +140,21 @@ TclSetupEnv(interp) for (p2 = p; *p2 != '='; p2++) { /* Empty loop body. */ } - *p2 = 0; - (void) Tcl_SetVar2(interp, "env", p, p2+1, TCL_GLOBAL_ONLY); - *p2 = '='; + sz = p2 - p; + Tcl_DStringSetLength(&ds, 0); + Tcl_DStringAppend(&ds, p, sz); + (void) Tcl_SetVar2(interp, "env", Tcl_DStringValue(&ds), + p2+1, TCL_GLOBAL_ONLY); } Tcl_TraceVar2(interp, "env", (char *) NULL, TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS, EnvTraceProc, (ClientData) NULL); + + /* + * Finally clean up the DString. + */ + + Tcl_DStringFree(&ds); } /* @@ -186,7 +186,7 @@ FindVariable(name, lengthPtr) * searches). */ { int i; - CONST register char *p1, *p2; + register CONST char *p1, *p2; for (i = 0, p1 = environ[i]; p1 != NULL; i++, p1 = environ[i]) { for (p2 = name; *p2 == *p1; p1++, p2++) { @@ -201,6 +201,53 @@ FindVariable(name, lengthPtr) return -1; } +/* + *---------------------------------------------------------------------- + * + * TclGetEnv -- + * + * Get an environment variable or return NULL if the variable + * doesn't exist. This procedure is intended to be a + * stand-in for the UNIX "getenv" procedure so that applications + * using that procedure will interface properly to Tcl. To make + * it a stand-in, the Makefile must define "TclGetEnv" to "getenv". + * + * Results: + * ptr to value on success, NULL if error. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +TclGetEnv(name) + char *name; /* Name of desired environment variable. */ +{ + int i; + size_t len, nameLen; + char *equal; + + nameLen = strlen(name); + for (i = 0; environ[i] != NULL; i++) { + equal = strchr(environ[i], '='); + if (equal == NULL) { + continue; + } + len = (size_t) (equal - environ[i]); + if ((len == nameLen) && (strncmp(name, environ[i], len) == 0)) { + /* + * The caller of this function should regard this + * as static memory. + */ + return &environ[i][len+1]; + } + } + + return NULL; +} + /* *---------------------------------------------------------------------- * @@ -294,6 +341,12 @@ TclSetEnv(name, value) (void) Tcl_SetVar2(eiPtr->interp, "env", (char *) name, p+1, TCL_GLOBAL_ONLY); } + + /* + * Update the system environment. + */ + + TclSetSystemEnv(name, value); } /* @@ -344,8 +397,8 @@ Tcl_PutEnv(string) if (nameLength == 0) { return 0; } - name = ckalloc((unsigned) nameLength+1); - memcpy(name, string, nameLength); + name = (char *) ckalloc((unsigned) nameLength+1); + memcpy(name, string, (size_t) nameLength); name[nameLength] = 0; TclSetEnv(name, value+1); ckfree(name); @@ -408,6 +461,12 @@ TclUnsetEnv(name) (void) Tcl_UnsetVar2(eiPtr->interp, "env", (char *) name, TCL_GLOBAL_ONLY); } + + /* + * Update the system environment. + */ + + TclSetSystemEnv(name, NULL); } /* @@ -510,6 +569,9 @@ EnvTraceProc(clientData, interp, name1, name2, flags) static void EnvInit() { +#ifdef MAC_TCL + environSize = TclMacCreateEnv(); +#else char **newEnviron; int i, length; @@ -528,4 +590,42 @@ EnvInit() } newEnviron[length] = NULL; environ = newEnviron; + Tcl_CreateExitHandler(EnvExitProc, (ClientData) NULL); +#endif +} + +/* + *---------------------------------------------------------------------- + * + * EnvExitProc -- + * + * This procedure is called just before the process exits. It + * frees the memory associated with environment variables. + * + * Results: + * None. + * + * Side effects: + * Memory is freed. + * + *---------------------------------------------------------------------- + */ + +static void +EnvExitProc(clientData) + ClientData clientData; /* Not used. */ +{ + char **p; + + for (p = environ; *p != NULL; p++) { + ckfree(*p); + } + ckfree((char *) environ); + + /* + * Note that we need to reset the environ global so the Borland C run-time + * doesn't choke on exit. + */ + + environ = NULL; } diff --git a/tcl7.6/generic/tclEvent.c b/tcl7.6/generic/tclEvent.c new file mode 100644 index 0000000..ad14a57 --- /dev/null +++ b/tcl7.6/generic/tclEvent.c @@ -0,0 +1,2189 @@ +/* + * tclEvent.c -- + * + * This file provides basic event-managing facilities for Tcl, + * including an event queue, and mechanisms for attaching + * callbacks to certain events. + * + * It also contains the command procedures for the commands + * "after", "vwait", and "update". + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclEvent.c 1.131 96/08/26 13:11:03 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * For each file registered in a call to Tcl_CreateFileHandler, + * there is one record of the following type. All of these records + * are chained together into a single list. + */ + +typedef struct FileHandler { + Tcl_File file; /* Generic file handle for file. */ + int mask; /* Mask of desired events: TCL_READABLE, etc. */ + int readyMask; /* Events that were ready the last time that + * FileHandlerCheckProc checked this file. */ + Tcl_FileProc *proc; /* Procedure to call, in the style of + * Tcl_CreateFileHandler. This is NULL + * if the handler was created by + * Tcl_CreateFileHandler2. */ + ClientData clientData; /* Argument to pass to proc. */ + struct FileHandler *nextPtr;/* Next in list of all files we care + * about (NULL for end of list). */ +} FileHandler; + +static FileHandler *firstFileHandlerPtr = (FileHandler *) NULL; + /* List of all file handlers. */ +static int fileEventSourceCreated = 0; + /* Zero means that the file event source + * hasn't been registerd with the Tcl + * notifier yet. */ + +/* + * The following structure is what is added to the Tcl event queue when + * file handlers are ready to fire. + */ + +typedef struct FileHandlerEvent { + Tcl_Event header; /* Information that is standard for + * all events. */ + Tcl_File file; /* File descriptor that is ready. Used + * to find the FileHandler structure for + * the file (can't point directly to the + * FileHandler structure because it could + * go away while the event is queued). */ +} FileHandlerEvent; + +/* + * For each timer callback that's pending (either regular or "modal"), + * there is one record of the following type. The normal handlers + * (created by Tcl_CreateTimerHandler) are chained together in a + * list sorted by time (earliest event first). + */ + +typedef struct TimerHandler { + Tcl_Time time; /* When timer is to fire. */ + Tcl_TimerProc *proc; /* Procedure to call. */ + ClientData clientData; /* Argument to pass to proc. */ + Tcl_TimerToken token; /* Identifies event so it can be + * deleted. Not used in modal + * timeouts. */ + struct TimerHandler *nextPtr; /* Next event in queue, or NULL for + * end of queue. */ +} TimerHandler; + +static TimerHandler *firstTimerHandlerPtr = NULL; + /* First event in queue. */ +static int timerEventSourceCreated = 0; /* 0 means that the timer event source + * hasn't yet been registered with the + * Tcl notifier. */ + +/* + * The information below describes a stack of modal timeouts managed by + * Tcl_CreateModalTimer and Tcl_DeleteModalTimer. Only the first element + * in the list is used at any given time. + */ + +static TimerHandler *firstModalHandlerPtr = NULL; + +/* + * The following structure is what's added to the Tcl event queue when + * timer handlers are ready to fire. + */ + +typedef struct TimerEvent { + Tcl_Event header; /* Information that is standard for + * all events. */ + Tcl_Time time; /* All timer events that specify this + * time or earlier are ready + * to fire. */ +} TimerEvent; + +/* + * There is one of the following structures for each of the + * handlers declared in a call to Tcl_DoWhenIdle. All of the + * currently-active handlers are linked together into a list. + */ + +typedef struct IdleHandler { + Tcl_IdleProc (*proc); /* Procedure to call. */ + ClientData clientData; /* Value to pass to proc. */ + int generation; /* Used to distinguish older handlers from + * recently-created ones. */ + struct IdleHandler *nextPtr;/* Next in list of active handlers. */ +} IdleHandler; + +static IdleHandler *idleList = NULL; + /* First in list of all idle handlers. */ +static IdleHandler *lastIdlePtr = NULL; + /* Last in list (or NULL for empty list). */ +static int idleGeneration = 0; /* Used to fill in the "generation" fields + * of IdleHandler structures. Increments + * each time Tcl_DoOneEvent starts calling + * idle handlers, so that all old handlers + * can be called without calling any of the + * new ones created by old ones. */ + +/* + * The data structure below is used by the "after" command to remember + * the command to be executed later. All of the pending "after" commands + * for an interpreter are linked together in a list. + */ + +typedef struct AfterInfo { + struct AfterAssocData *assocPtr; + /* Pointer to the "tclAfter" assocData for + * the interp in which command will be + * executed. */ + char *command; /* Command to execute. Malloc'ed, so must + * be freed when structure is deallocated. */ + int id; /* Integer identifier for command; used to + * cancel it. */ + Tcl_TimerToken token; /* Used to cancel the "after" command. NULL + * means that the command is run as an + * idle handler rather than as a timer + * handler. NULL means this is an "after + * idle" handler rather than a + * timer handler. */ + struct AfterInfo *nextPtr; /* Next in list of all "after" commands for + * this interpreter. */ +} AfterInfo; + +/* + * One of the following structures is associated with each interpreter + * for which an "after" command has ever been invoked. A pointer to + * this structure is stored in the AssocData for the "tclAfter" key. + */ + +typedef struct AfterAssocData { + Tcl_Interp *interp; /* The interpreter for which this data is + * registered. */ + AfterInfo *firstAfterPtr; /* First in list of all "after" commands + * still pending for this interpreter, or + * NULL if none. */ +} AfterAssocData; + +/* + * The data structure below is used to report background errors. One + * such structure is allocated for each error; it holds information + * about the interpreter and the error until bgerror can be invoked + * later as an idle handler. + */ + +typedef struct BgError { + Tcl_Interp *interp; /* Interpreter in which error occurred. NULL + * means this error report has been cancelled + * (a previous report generated a break). */ + char *errorMsg; /* The error message (interp->result when + * the error occurred). Malloc-ed. */ + char *errorInfo; /* Value of the errorInfo variable + * (malloc-ed). */ + char *errorCode; /* Value of the errorCode variable + * (malloc-ed). */ + struct BgError *nextPtr; /* Next in list of all pending error + * reports for this interpreter, or NULL + * for end of list. */ +} BgError; + +/* + * One of the structures below is associated with the "tclBgError" + * assoc data for each interpreter. It keeps track of the head and + * tail of the list of pending background errors for the interpreter. + */ + +typedef struct ErrAssocData { + BgError *firstBgPtr; /* First in list of all background errors + * waiting to be processed for this + * interpreter (NULL if none). */ + BgError *lastBgPtr; /* Last in list of all background errors + * waiting to be processed for this + * interpreter (NULL if none). */ +} ErrAssocData; + +/* + * For each exit handler created with a call to Tcl_CreateExitHandler + * there is a structure of the following type: + */ + +typedef struct ExitHandler { + Tcl_ExitProc *proc; /* Procedure to call when process exits. */ + ClientData clientData; /* One word of information to pass to proc. */ + struct ExitHandler *nextPtr;/* Next in list of all exit handlers for + * this application, or NULL for end of list. */ +} ExitHandler; + +static ExitHandler *firstExitPtr = NULL; + /* First in list of all exit handlers for + * application. */ + +/* + * Structures of the following type are used during the execution + * of Tcl_WaitForFile, to keep track of the file and timeout. + */ + +typedef struct FileWait { + Tcl_File file; /* File to wait on. */ + int mask; /* Conditions to wait for (TCL_READABLE, + * etc.) */ + int timeout; /* Original "timeout" argument to + * Tcl_WaitForFile. */ + Tcl_Time abortTime; /* Time at which to abort the wait. */ + int present; /* Conditions present on the file during + * the last time through the event loop. */ + int done; /* Non-zero means we're done: either one of + * the desired conditions is present or the + * timeout period has elapsed. */ +} FileWait; + +/* + * The following variable is a "secret" indication to Tcl_Exit that + * it should dump out the state of memory before exiting. If the + * value is non-NULL, it gives the name of the file in which to + * dump memory usage information. + */ + +char *tclMemDumpFileName = NULL; + +/* + * Prototypes for procedures referenced only in this file: + */ + +static void AfterCleanupProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp)); +static void AfterProc _ANSI_ARGS_((ClientData clientData)); +static void BgErrorDeleteProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp)); +static void FileHandlerCheckProc _ANSI_ARGS_(( + ClientData clientData, int flags)); +static int FileHandlerEventProc _ANSI_ARGS_((Tcl_Event *evPtr, + int flags)); +static void FileHandlerExitProc _ANSI_ARGS_((ClientData data)); +static void FileHandlerSetupProc _ANSI_ARGS_(( + ClientData clientData, int flags)); +static void FreeAfterPtr _ANSI_ARGS_((AfterInfo *afterPtr)); +static AfterInfo * GetAfterEvent _ANSI_ARGS_((AfterAssocData *assocPtr, + char *string)); +static void HandleBgErrors _ANSI_ARGS_((ClientData clientData)); +static void TimerHandlerCheckProc _ANSI_ARGS_(( + ClientData clientData, int flags)); +static int TimerHandlerEventProc _ANSI_ARGS_((Tcl_Event *evPtr, + int flags)); +static void TimerHandlerExitProc _ANSI_ARGS_((ClientData data)); +static void TimerHandlerSetupProc _ANSI_ARGS_(( + ClientData clientData, int flags)); +static char * VwaitVarProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *name1, char *name2, + int flags)); + +/* + *-------------------------------------------------------------- + * + * Tcl_CreateFileHandler -- + * + * Arrange for a given procedure to be invoked whenever + * a given file becomes readable or writable. + * + * Results: + * None. + * + * Side effects: + * From now on, whenever the I/O channel given by file becomes + * ready in the way indicated by mask, proc will be invoked. + * See the manual entry for details on the calling sequence + * to proc. If file is already registered then the old mask + * and proc and clientData values will be replaced with + * new ones. + * + *-------------------------------------------------------------- + */ + +void +Tcl_CreateFileHandler(file, mask, proc, clientData) + Tcl_File file; /* Handle of stream to watch. */ + int mask; /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, and TCL_EXCEPTION: + * indicates conditions under which + * proc should be called. */ + Tcl_FileProc *proc; /* Procedure to call for each + * selected event. */ + ClientData clientData; /* Arbitrary data to pass to proc. */ +{ + register FileHandler *filePtr; + + if (!fileEventSourceCreated) { + fileEventSourceCreated = 1; + Tcl_CreateEventSource(FileHandlerSetupProc, FileHandlerCheckProc, + (ClientData) NULL); + Tcl_CreateExitHandler(FileHandlerExitProc, (ClientData) NULL); + } + + /* + * Make sure the file isn't already registered. Create a + * new record in the normal case where there's no existing + * record. + */ + + for (filePtr = firstFileHandlerPtr; filePtr != NULL; + filePtr = filePtr->nextPtr) { + if (filePtr->file == file) { + break; + } + } + if (filePtr == NULL) { + filePtr = (FileHandler *) ckalloc(sizeof(FileHandler)); + filePtr->file = file; + filePtr->nextPtr = firstFileHandlerPtr; + firstFileHandlerPtr = filePtr; + } + + /* + * The remainder of the initialization below is done regardless + * of whether or not this is a new record or a modification of + * an old one. + */ + + filePtr->mask = mask; + filePtr->readyMask = 0; + filePtr->proc = proc; + filePtr->clientData = clientData; +} + +/* + *-------------------------------------------------------------- + * + * Tcl_DeleteFileHandler -- + * + * Cancel a previously-arranged callback arrangement for + * a file. + * + * Results: + * None. + * + * Side effects: + * If a callback was previously registered on file, remove it. + * + *-------------------------------------------------------------- + */ + +void +Tcl_DeleteFileHandler(file) + Tcl_File file; /* Stream id for which to remove + * callback procedure. */ +{ + FileHandler *filePtr, *prevPtr; + + /* + * Find the entry for the given file (and return if there + * isn't one). + */ + + for (prevPtr = NULL, filePtr = firstFileHandlerPtr; ; + prevPtr = filePtr, filePtr = filePtr->nextPtr) { + if (filePtr == NULL) { + return; + } + if (filePtr->file == file) { + break; + } + } + + /* + * Clean up information in the callback record. + */ + + if (prevPtr == NULL) { + firstFileHandlerPtr = filePtr->nextPtr; + } else { + prevPtr->nextPtr = filePtr->nextPtr; + } + ckfree((char *) filePtr); +} + +/* + *---------------------------------------------------------------------- + * + * FileHandlerExitProc -- + * + * Cleanup procedure to delete the file event source during exit + * cleanup. + * + * Results: + * None. + * + * Side effects: + * Destroys the file event source. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +FileHandlerExitProc(clientData) + ClientData clientData; /* Not used. */ +{ + Tcl_DeleteEventSource(FileHandlerSetupProc, FileHandlerCheckProc, + (ClientData) NULL); +} + +/* + *---------------------------------------------------------------------- + * + * FileHandlerSetupProc -- + * + * This procedure is part of the "event source" for file handlers. + * It is invoked by Tcl_DoOneEvent before it calls select (or + * whatever it uses to wait). + * + * Results: + * None. + * + * Side effects: + * Tells the notifier which files should be waited for. + * + *---------------------------------------------------------------------- + */ + +static void +FileHandlerSetupProc(clientData, flags) + ClientData clientData; /* Not used. */ + int flags; /* Flags passed to Tk_DoOneEvent: + * if it doesn't include + * TCL_FILE_EVENTS then we do + * nothing. */ +{ + FileHandler *filePtr; + + if (!(flags & TCL_FILE_EVENTS)) { + return; + } + for (filePtr = firstFileHandlerPtr; filePtr != NULL; + filePtr = filePtr->nextPtr) { + if (filePtr->mask != 0) { + Tcl_WatchFile(filePtr->file, filePtr->mask); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * FileHandlerCheckProc -- + * + * This procedure is the second part of the "event source" for + * file handlers. It is invoked by Tcl_DoOneEvent after it calls + * select (or whatever it uses to wait for events). + * + * Results: + * None. + * + * Side effects: + * Makes entries on the Tcl event queue for each file that is + * now ready. + * + *---------------------------------------------------------------------- + */ + +static void +FileHandlerCheckProc(clientData, flags) + ClientData clientData; /* Not used. */ + int flags; /* Flags passed to Tk_DoOneEvent: + * if it doesn't include + * TCL_FILE_EVENTS then we do + * nothing. */ +{ + FileHandler *filePtr; + FileHandlerEvent *fileEvPtr; + + if (!(flags & TCL_FILE_EVENTS)) { + return; + } + for (filePtr = firstFileHandlerPtr; filePtr != NULL; + filePtr = filePtr->nextPtr) { + if (filePtr->mask != 0) { + filePtr->readyMask = Tcl_FileReady(filePtr->file, filePtr->mask); + if (filePtr->readyMask != 0) { + fileEvPtr = (FileHandlerEvent *) ckalloc( + sizeof(FileHandlerEvent)); + fileEvPtr->header.proc = FileHandlerEventProc; + fileEvPtr->file = filePtr->file; + Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL); + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * FileHandlerEventProc -- + * + * This procedure is called by Tcl_DoOneEvent when a file event + * reaches the front of the event queue. This procedure is responsible + * for actually handling the event by invoking the callback for the + * file handler. + * + * Results: + * Returns 1 if the event was handled, meaning it should be removed + * from the queue. Returns 0 if the event was not handled, meaning + * it should stay on the queue. The only time the event isn't + * handled is if the TCL_FILE_EVENTS flag bit isn't set. + * + * Side effects: + * Whatever the file handler's callback procedure does + * + *---------------------------------------------------------------------- + */ + +static int +FileHandlerEventProc(evPtr, flags) + Tcl_Event *evPtr; /* Event to service. */ + int flags; /* Flags that indicate what events to + * handle, such as TCL_FILE_EVENTS. */ +{ + FileHandler *filePtr; + FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) evPtr; + int mask; + + if (!(flags & TCL_FILE_EVENTS)) { + return 0; + } + + /* + * Search through the file handlers to find the one whose handle matches + * the event. We do this rather than keeping a pointer to the file + * handler directly in the event, so that the handler can be deleted + * while the event is queued without leaving a dangling pointer. + */ + + for (filePtr = firstFileHandlerPtr; filePtr != NULL; + filePtr = filePtr->nextPtr) { + if (filePtr->file != fileEvPtr->file) { + continue; + } + + /* + * The code is tricky for two reasons: + * 1. The file handler's desired events could have changed + * since the time when the event was queued, so AND the + * ready mask with the desired mask. + * 2. The file could have been closed and re-opened since + * the time when the event was queued. This is why the + * ready mask is stored in the file handler rather than + * the queued event: it will be zeroed when a new + * file handler is created for the newly opened file. + */ + + mask = filePtr->readyMask & filePtr->mask; + filePtr->readyMask = 0; + if (mask != 0) { + (*filePtr->proc)(filePtr->clientData, mask); + } + break; + } + return 1; +} + +/* + *-------------------------------------------------------------- + * + * Tcl_CreateTimerHandler -- + * + * Arrange for a given procedure to be invoked at a particular + * time in the future. + * + * Results: + * The return value is a token for the timer event, which + * may be used to delete the event before it fires. + * + * Side effects: + * When milliseconds have elapsed, proc will be invoked + * exactly once. + * + *-------------------------------------------------------------- + */ + +Tcl_TimerToken +Tcl_CreateTimerHandler(milliseconds, proc, clientData) + int milliseconds; /* How many milliseconds to wait + * before invoking proc. */ + Tcl_TimerProc *proc; /* Procedure to invoke. */ + ClientData clientData; /* Arbitrary data to pass to proc. */ +{ + register TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr; + static int id = 0; + + if (!timerEventSourceCreated) { + timerEventSourceCreated = 1; + Tcl_CreateEventSource(TimerHandlerSetupProc, TimerHandlerCheckProc, + (ClientData) NULL); + Tcl_CreateExitHandler(TimerHandlerExitProc, (ClientData) NULL); + } + + timerHandlerPtr = (TimerHandler *) ckalloc(sizeof(TimerHandler)); + + /* + * Compute when the event should fire. + */ + + TclpGetTime(&timerHandlerPtr->time); + timerHandlerPtr->time.sec += milliseconds/1000; + timerHandlerPtr->time.usec += (milliseconds%1000)*1000; + if (timerHandlerPtr->time.usec >= 1000000) { + timerHandlerPtr->time.usec -= 1000000; + timerHandlerPtr->time.sec += 1; + } + + /* + * Fill in other fields for the event. + */ + + timerHandlerPtr->proc = proc; + timerHandlerPtr->clientData = clientData; + id++; + timerHandlerPtr->token = (Tcl_TimerToken) id; + + /* + * Add the event to the queue in the correct position + * (ordered by event firing time). + */ + + for (tPtr2 = firstTimerHandlerPtr, prevPtr = NULL; tPtr2 != NULL; + prevPtr = tPtr2, tPtr2 = tPtr2->nextPtr) { + if ((tPtr2->time.sec > timerHandlerPtr->time.sec) + || ((tPtr2->time.sec == timerHandlerPtr->time.sec) + && (tPtr2->time.usec > timerHandlerPtr->time.usec))) { + break; + } + } + timerHandlerPtr->nextPtr = tPtr2; + if (prevPtr == NULL) { + firstTimerHandlerPtr = timerHandlerPtr; + } else { + prevPtr->nextPtr = timerHandlerPtr; + } + return timerHandlerPtr->token; +} + +/* + *-------------------------------------------------------------- + * + * Tcl_DeleteTimerHandler -- + * + * Delete a previously-registered timer handler. + * + * Results: + * None. + * + * Side effects: + * Destroy the timer callback identified by TimerToken, + * so that its associated procedure will not be called. + * If the callback has already fired, or if the given + * token doesn't exist, then nothing happens. + * + *-------------------------------------------------------------- + */ + +void +Tcl_DeleteTimerHandler(token) + Tcl_TimerToken token; /* Result previously returned by + * Tcl_DeleteTimerHandler. */ +{ + register TimerHandler *timerHandlerPtr, *prevPtr; + + for (timerHandlerPtr = firstTimerHandlerPtr, prevPtr = NULL; + timerHandlerPtr != NULL; prevPtr = timerHandlerPtr, + timerHandlerPtr = timerHandlerPtr->nextPtr) { + if (timerHandlerPtr->token != token) { + continue; + } + if (prevPtr == NULL) { + firstTimerHandlerPtr = timerHandlerPtr->nextPtr; + } else { + prevPtr->nextPtr = timerHandlerPtr->nextPtr; + } + ckfree((char *) timerHandlerPtr); + return; + } +} + +/* + *-------------------------------------------------------------- + * + * Tcl_CreateModalTimeout -- + * + * Arrange for a given procedure to be invoked at a particular + * time in the future, independently of all other timer events. + * + * Results: + * None. + * + * Side effects: + * When milliseconds have elapsed, proc will be invoked + * exactly once. + * + *-------------------------------------------------------------- + */ + +void +Tcl_CreateModalTimeout(milliseconds, proc, clientData) + int milliseconds; /* How many milliseconds to wait + * before invoking proc. */ + Tcl_TimerProc *proc; /* Procedure to invoke. */ + ClientData clientData; /* Arbitrary data to pass to proc. */ +{ + TimerHandler *timerHandlerPtr; + + if (!timerEventSourceCreated) { + timerEventSourceCreated = 1; + Tcl_CreateEventSource(TimerHandlerSetupProc, TimerHandlerCheckProc, + (ClientData) NULL); + Tcl_CreateExitHandler(TimerHandlerExitProc, (ClientData) NULL); + } + + timerHandlerPtr = (TimerHandler *) ckalloc(sizeof(TimerHandler)); + + /* + * Compute when the timeout should fire and fill in the other fields + * of the handler. + */ + + TclpGetTime(&timerHandlerPtr->time); + timerHandlerPtr->time.sec += milliseconds/1000; + timerHandlerPtr->time.usec += (milliseconds%1000)*1000; + if (timerHandlerPtr->time.usec >= 1000000) { + timerHandlerPtr->time.usec -= 1000000; + timerHandlerPtr->time.sec += 1; + } + timerHandlerPtr->proc = proc; + timerHandlerPtr->clientData = clientData; + + /* + * Push the handler on the top of the modal stack. + */ + + timerHandlerPtr->nextPtr = firstModalHandlerPtr; + firstModalHandlerPtr = timerHandlerPtr; +} + +/* + *-------------------------------------------------------------- + * + * Tcl_DeleteModalTimeout -- + * + * Remove the topmost modal timer handler from the stack of + * modal handlers. + * + * Results: + * None. + * + * Side effects: + * Destroys the topmost modal timeout handler, which must + * match proc and clientData. + * + *-------------------------------------------------------------- + */ + +void +Tcl_DeleteModalTimeout(proc, clientData) + Tcl_TimerProc *proc; /* Callback procedure for the timeout. */ + ClientData clientData; /* Arbitrary data to pass to proc. */ +{ + TimerHandler *timerHandlerPtr; + + timerHandlerPtr = firstModalHandlerPtr; + firstModalHandlerPtr = timerHandlerPtr->nextPtr; + if ((timerHandlerPtr->proc != proc) + || (timerHandlerPtr->clientData != clientData)) { + panic("Tcl_DeleteModalTimeout found timeout stack corrupted"); + } + ckfree((char *) timerHandlerPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TimerHandlerSetupProc -- + * + * This procedure is part of the "event source" for timers. + * It is invoked by Tcl_DoOneEvent before it calls select (or + * whatever it uses to wait). + * + * Results: + * None. + * + * Side effects: + * Tells the notifier how long to sleep if it decides to block. + * + *---------------------------------------------------------------------- + */ + +static void +TimerHandlerSetupProc(clientData, flags) + ClientData clientData; /* Not used. */ + int flags; /* Flags passed to Tk_DoOneEvent: + * if it doesn't include + * TCL_TIMER_EVENTS then we only + * consider modal timers. */ +{ + TimerHandler *timerHandlerPtr, *tPtr2; + Tcl_Time blockTime; + + /* + * Find the timer handler (regular or modal) that fires first. + */ + + timerHandlerPtr = firstTimerHandlerPtr; + if (!(flags & TCL_TIMER_EVENTS)) { + timerHandlerPtr = NULL; + } + if (timerHandlerPtr != NULL) { + tPtr2 = firstModalHandlerPtr; + if (tPtr2 != NULL) { + if ((timerHandlerPtr->time.sec > tPtr2->time.sec) + || ((timerHandlerPtr->time.sec == tPtr2->time.sec) + && (timerHandlerPtr->time.usec > tPtr2->time.usec))) { + timerHandlerPtr = tPtr2; + } + } + } else { + timerHandlerPtr = firstModalHandlerPtr; + } + if (timerHandlerPtr == NULL) { + return; + } + + TclpGetTime(&blockTime); + blockTime.sec = timerHandlerPtr->time.sec - blockTime.sec; + blockTime.usec = timerHandlerPtr->time.usec - blockTime.usec; + if (blockTime.usec < 0) { + blockTime.sec -= 1; + blockTime.usec += 1000000; + } + if (blockTime.sec < 0) { + blockTime.sec = 0; + blockTime.usec = 0; + } + Tcl_SetMaxBlockTime(&blockTime); +} + +/* + *---------------------------------------------------------------------- + * + * TimerHandlerCheckProc -- + * + * This procedure is the second part of the "event source" for + * file handlers. It is invoked by Tcl_DoOneEvent after it calls + * select (or whatever it uses to wait for events). + * + * Results: + * None. + * + * Side effects: + * Makes entries on the Tcl event queue for each file that is + * now ready. + * + *---------------------------------------------------------------------- + */ + +static void +TimerHandlerCheckProc(clientData, flags) + ClientData clientData; /* Not used. */ + int flags; /* Flags passed to Tk_DoOneEvent: + * if it doesn't include + * TCL_TIMER_EVENTS then we only + * consider modal timeouts. */ +{ + TimerHandler *timerHandlerPtr; + TimerEvent *timerEvPtr; + int triggered, gotTime; + Tcl_Time curTime; + + triggered = 0; + gotTime = 0; + timerHandlerPtr = firstTimerHandlerPtr; + if ((flags & TCL_TIMER_EVENTS) && (timerHandlerPtr != NULL)) { + TclpGetTime(&curTime); + gotTime = 1; + if ((timerHandlerPtr->time.sec < curTime.sec) + || ((timerHandlerPtr->time.sec == curTime.sec) + && (timerHandlerPtr->time.usec <= curTime.usec))) { + triggered = 1; + } + } + timerHandlerPtr = firstModalHandlerPtr; + if (timerHandlerPtr != NULL) { + if (!gotTime) { + TclpGetTime(&curTime); + } + if ((timerHandlerPtr->time.sec < curTime.sec) + || ((timerHandlerPtr->time.sec == curTime.sec) + && (timerHandlerPtr->time.usec <= curTime.usec))) { + triggered = 1; + } + } + if (triggered) { + timerEvPtr = (TimerEvent *) ckalloc(sizeof(TimerEvent)); + timerEvPtr->header.proc = TimerHandlerEventProc; + timerEvPtr->time.sec = curTime.sec; + timerEvPtr->time.usec = curTime.usec; + Tcl_QueueEvent((Tcl_Event *) timerEvPtr, TCL_QUEUE_TAIL); + } +} + +/* + *---------------------------------------------------------------------- + * + * TimerHandlerExitProc -- + * + * Callback invoked during exit cleanup to destroy the timer event + * source. + * + * Results: + * None. + * + * Side effects: + * Destroys the timer event source. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +TimerHandlerExitProc(clientData) + ClientData clientData; /* Not used. */ +{ + Tcl_DeleteEventSource(TimerHandlerSetupProc, TimerHandlerCheckProc, + (ClientData) NULL); +} + +/* + *---------------------------------------------------------------------- + * + * TimerHandlerEventProc -- + * + * This procedure is called by Tcl_DoOneEvent when a timer event + * reaches the front of the event queue. This procedure handles + * the event by invoking the callbacks for all timers that are + * ready. + * + * Results: + * Returns 1 if the event was handled, meaning it should be removed + * from the queue. Returns 0 if the event was not handled, meaning + * it should stay on the queue. The only time the event isn't + * handled is if the TCL_TIMER_EVENTS flag bit isn't set. + * + * Side effects: + * Whatever the timer handler callback procedures do. + * + *---------------------------------------------------------------------- + */ + +static int +TimerHandlerEventProc(evPtr, flags) + Tcl_Event *evPtr; /* Event to service. */ + int flags; /* Flags that indicate what events to + * handle, such as TCL_FILE_EVENTS. */ +{ + TimerHandler *timerHandlerPtr; + TimerEvent *timerEvPtr = (TimerEvent *) evPtr; + + /* + * Invoke the current modal timeout first, if there is one and + * it has triggered. + */ + + timerHandlerPtr = firstModalHandlerPtr; + if (firstModalHandlerPtr != NULL) { + if ((timerHandlerPtr->time.sec < timerEvPtr->time.sec) + || ((timerHandlerPtr->time.sec == timerEvPtr->time.sec) + && (timerHandlerPtr->time.usec <= timerEvPtr->time.usec))) { + (*timerHandlerPtr->proc)(timerHandlerPtr->clientData); + } + } + + /* + * Invoke any normal timers that have fired. + */ + + if (!(flags & TCL_TIMER_EVENTS)) { + return 1; + } + + while (1) { + timerHandlerPtr = firstTimerHandlerPtr; + if (timerHandlerPtr == NULL) { + break; + } + if ((timerHandlerPtr->time.sec > timerEvPtr->time.sec) + || ((timerHandlerPtr->time.sec == timerEvPtr->time.sec) + && (timerHandlerPtr->time.usec >= timerEvPtr->time.usec))) { + break; + } + + /* + * Remove the handler from the queue before invoking it, + * to avoid potential reentrancy problems. + */ + + firstTimerHandlerPtr = timerHandlerPtr->nextPtr; + (*timerHandlerPtr->proc)(timerHandlerPtr->clientData); + ckfree((char *) timerHandlerPtr); + } + return 1; +} + +/* + *-------------------------------------------------------------- + * + * Tcl_DoWhenIdle -- + * + * Arrange for proc to be invoked the next time the system is + * idle (i.e., just before the next time that Tcl_DoOneEvent + * would have to wait for something to happen). + * + * Results: + * None. + * + * Side effects: + * Proc will eventually be called, with clientData as argument. + * See the manual entry for details. + * + *-------------------------------------------------------------- + */ + +void +Tcl_DoWhenIdle(proc, clientData) + Tcl_IdleProc *proc; /* Procedure to invoke. */ + ClientData clientData; /* Arbitrary value to pass to proc. */ +{ + register IdleHandler *idlePtr; + + idlePtr = (IdleHandler *) ckalloc(sizeof(IdleHandler)); + idlePtr->proc = proc; + idlePtr->clientData = clientData; + idlePtr->generation = idleGeneration; + idlePtr->nextPtr = NULL; + if (lastIdlePtr == NULL) { + idleList = idlePtr; + } else { + lastIdlePtr->nextPtr = idlePtr; + } + lastIdlePtr = idlePtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CancelIdleCall -- + * + * If there are any when-idle calls requested to a given procedure + * with given clientData, cancel all of them. + * + * Results: + * None. + * + * Side effects: + * If the proc/clientData combination were on the when-idle list, + * they are removed so that they will never be called. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_CancelIdleCall(proc, clientData) + Tcl_IdleProc *proc; /* Procedure that was previously registered. */ + ClientData clientData; /* Arbitrary value to pass to proc. */ +{ + register IdleHandler *idlePtr, *prevPtr; + IdleHandler *nextPtr; + + for (prevPtr = NULL, idlePtr = idleList; idlePtr != NULL; + prevPtr = idlePtr, idlePtr = idlePtr->nextPtr) { + while ((idlePtr->proc == proc) + && (idlePtr->clientData == clientData)) { + nextPtr = idlePtr->nextPtr; + ckfree((char *) idlePtr); + idlePtr = nextPtr; + if (prevPtr == NULL) { + idleList = idlePtr; + } else { + prevPtr->nextPtr = idlePtr; + } + if (idlePtr == NULL) { + lastIdlePtr = prevPtr; + return; + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TclIdlePending -- + * + * This function is called by the notifier subsystem to determine + * whether there are any idle handlers currently scheduled. + * + * Results: + * Returns 0 if the idle list is empty, otherwise it returns 1. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclIdlePending() +{ + return (idleList == NULL) ? 0 : 1; +} + +/* + *---------------------------------------------------------------------- + * + * TclServiceIdle -- + * + * This procedure is invoked by the notifier when it becomes idle. + * + * Results: + * The return value is 1 if the procedure actually found an idle + * handler to invoke. If no handler was found then 0 is returned. + * + * Side effects: + * Invokes all pending idle handlers. + * + *---------------------------------------------------------------------- + */ + +int +TclServiceIdle() +{ + IdleHandler *idlePtr; + int oldGeneration; + int foundIdle; + + if (idleList == NULL) { + return 0; + } + + foundIdle = 0; + oldGeneration = idleGeneration; + idleGeneration++; + + /* + * The code below is trickier than it may look, for the following + * reasons: + * + * 1. New handlers can get added to the list while the current + * one is being processed. If new ones get added, we don't + * want to process them during this pass through the list (want + * to check for other work to do first). This is implemented + * using the generation number in the handler: new handlers + * will have a different generation than any of the ones currently + * on the list. + * 2. The handler can call Tcl_DoOneEvent, so we have to remove + * the handler from the list before calling it. Otherwise an + * infinite loop could result. + * 3. Tcl_CancelIdleCall can be called to remove an element from + * the list while a handler is executing, so the list could + * change structure during the call. + */ + + for (idlePtr = idleList; + ((idlePtr != NULL) + && ((oldGeneration - idlePtr->generation) >= 0)); + idlePtr = idleList) { + idleList = idlePtr->nextPtr; + if (idleList == NULL) { + lastIdlePtr = NULL; + } + foundIdle = 1; + (*idlePtr->proc)(idlePtr->clientData); + ckfree((char *) idlePtr); + } + + return foundIdle; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_BackgroundError -- + * + * This procedure is invoked to handle errors that occur in Tcl + * commands that are invoked in "background" (e.g. from event or + * timer bindings). + * + * Results: + * None. + * + * Side effects: + * The command "bgerror" is invoked later as an idle handler to + * process the error, passing it the error message. If that fails, + * then an error message is output on stderr. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_BackgroundError(interp) + Tcl_Interp *interp; /* Interpreter in which an error has + * occurred. */ +{ + BgError *errPtr; + char *varValue; + ErrAssocData *assocPtr; + + /* + * The Tcl_AddErrorInfo call below (with an empty string) ensures that + * errorInfo gets properly set. It's needed in cases where the error + * came from a utility procedure like Tcl_GetVar instead of Tcl_Eval; + * in these cases errorInfo still won't have been set when this + * procedure is called. + */ + + Tcl_AddErrorInfo(interp, ""); + errPtr = (BgError *) ckalloc(sizeof(BgError)); + errPtr->interp = interp; + errPtr->errorMsg = (char *) ckalloc((unsigned) (strlen(interp->result) + + 1)); + strcpy(errPtr->errorMsg, interp->result); + varValue = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); + if (varValue == NULL) { + varValue = errPtr->errorMsg; + } + errPtr->errorInfo = (char *) ckalloc((unsigned) (strlen(varValue) + 1)); + strcpy(errPtr->errorInfo, varValue); + varValue = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY); + if (varValue == NULL) { + varValue = ""; + } + errPtr->errorCode = (char *) ckalloc((unsigned) (strlen(varValue) + 1)); + strcpy(errPtr->errorCode, varValue); + errPtr->nextPtr = NULL; + + assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp, "tclBgError", + (Tcl_InterpDeleteProc **) NULL); + if (assocPtr == NULL) { + + /* + * This is the first time a background error has occurred in + * this interpreter. Create associated data to keep track of + * pending error reports. + */ + + assocPtr = (ErrAssocData *) ckalloc(sizeof(ErrAssocData)); + assocPtr->firstBgPtr = NULL; + assocPtr->lastBgPtr = NULL; + Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc, + (ClientData) assocPtr); + } + if (assocPtr->firstBgPtr == NULL) { + assocPtr->firstBgPtr = errPtr; + Tcl_DoWhenIdle(HandleBgErrors, (ClientData) assocPtr); + } else { + assocPtr->lastBgPtr->nextPtr = errPtr; + } + assocPtr->lastBgPtr = errPtr; + Tcl_ResetResult(interp); +} + +/* + *---------------------------------------------------------------------- + * + * HandleBgErrors -- + * + * This procedure is invoked as an idle handler to process all of + * the accumulated background errors. + * + * Results: + * None. + * + * Side effects: + * Depends on what actions "bgerror" takes for the errors. + * + *---------------------------------------------------------------------- + */ + +static void +HandleBgErrors(clientData) + ClientData clientData; /* Pointer to ErrAssocData structure. */ +{ + Tcl_Interp *interp; + char *command; + char *argv[2]; + int code; + BgError *errPtr; + ErrAssocData *assocPtr = (ErrAssocData *) clientData; + Tcl_Channel errChannel; + + while (assocPtr->firstBgPtr != NULL) { + interp = assocPtr->firstBgPtr->interp; + if (interp == NULL) { + goto doneWithReport; + } + + /* + * Restore important state variables to what they were at + * the time the error occurred. + */ + + Tcl_SetVar(interp, "errorInfo", assocPtr->firstBgPtr->errorInfo, + TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "errorCode", assocPtr->firstBgPtr->errorCode, + TCL_GLOBAL_ONLY); + + /* + * Create and invoke the bgerror command. + */ + + argv[0] = "bgerror"; + argv[1] = assocPtr->firstBgPtr->errorMsg; + command = Tcl_Merge(2, argv); + Tcl_AllowExceptions(interp); + Tcl_Preserve((ClientData) interp); + code = Tcl_GlobalEval(interp, command); + ckfree(command); + if (code == TCL_ERROR) { + + /* + * We have to get the error output channel at the latest possible + * time, because the eval (above) might have changed the channel. + */ + + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel != (Tcl_Channel) NULL) { + if (strcmp(interp->result, + "\"bgerror\" is an invalid command name or ambiguous abbreviation") + == 0) { + Tcl_Write(errChannel, assocPtr->firstBgPtr->errorInfo, -1); + Tcl_Write(errChannel, "\n", -1); + } else { + Tcl_Write(errChannel, + "bgerror failed to handle background error.\n", + -1); + Tcl_Write(errChannel, " Original error: ", -1); + Tcl_Write(errChannel, assocPtr->firstBgPtr->errorMsg, + -1); + Tcl_Write(errChannel, "\n", -1); + Tcl_Write(errChannel, " Error in bgerror: ", -1); + Tcl_Write(errChannel, interp->result, -1); + Tcl_Write(errChannel, "\n", -1); + } + Tcl_Flush(errChannel); + } + } else if (code == TCL_BREAK) { + + /* + * Break means cancel any remaining error reports for this + * interpreter. + */ + + for (errPtr = assocPtr->firstBgPtr; errPtr != NULL; + errPtr = errPtr->nextPtr) { + if (errPtr->interp == interp) { + errPtr->interp = NULL; + } + } + } + + Tcl_Release((ClientData) interp); + + /* + * Discard the command and the information about the error report. + */ + + doneWithReport: + ckfree(assocPtr->firstBgPtr->errorMsg); + ckfree(assocPtr->firstBgPtr->errorInfo); + ckfree(assocPtr->firstBgPtr->errorCode); + errPtr = assocPtr->firstBgPtr->nextPtr; + ckfree((char *) assocPtr->firstBgPtr); + assocPtr->firstBgPtr = errPtr; + } + assocPtr->lastBgPtr = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * BgErrorDeleteProc -- + * + * This procedure is associated with the "tclBgError" assoc data + * for an interpreter; it is invoked when the interpreter is + * deleted in order to free the information assoicated with any + * pending error reports. + * + * Results: + * None. + * + * Side effects: + * Background error information is freed: if there were any + * pending error reports, they are cancelled. + * + *---------------------------------------------------------------------- + */ + +static void +BgErrorDeleteProc(clientData, interp) + ClientData clientData; /* Pointer to ErrAssocData structure. */ + Tcl_Interp *interp; /* Interpreter being deleted. */ +{ + ErrAssocData *assocPtr = (ErrAssocData *) clientData; + BgError *errPtr; + + while (assocPtr->firstBgPtr != NULL) { + errPtr = assocPtr->firstBgPtr; + assocPtr->firstBgPtr = errPtr->nextPtr; + ckfree(errPtr->errorMsg); + ckfree(errPtr->errorInfo); + ckfree(errPtr->errorCode); + ckfree((char *) errPtr); + } + ckfree((char *) assocPtr); + Tcl_CancelIdleCall(HandleBgErrors, (ClientData) assocPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateExitHandler -- + * + * Arrange for a given procedure to be invoked just before the + * application exits. + * + * Results: + * None. + * + * Side effects: + * Proc will be invoked with clientData as argument when the + * application exits. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_CreateExitHandler(proc, clientData) + Tcl_ExitProc *proc; /* Procedure to invoke. */ + ClientData clientData; /* Arbitrary value to pass to proc. */ +{ + ExitHandler *exitPtr; + + exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler)); + exitPtr->proc = proc; + exitPtr->clientData = clientData; + exitPtr->nextPtr = firstExitPtr; + firstExitPtr = exitPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteExitHandler -- + * + * This procedure cancels an existing exit handler matching proc + * and clientData, if such a handler exits. + * + * Results: + * None. + * + * Side effects: + * If there is an exit handler corresponding to proc and clientData + * then it is cancelled; if no such handler exists then nothing + * happens. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteExitHandler(proc, clientData) + Tcl_ExitProc *proc; /* Procedure that was previously registered. */ + ClientData clientData; /* Arbitrary value to pass to proc. */ +{ + ExitHandler *exitPtr, *prevPtr; + + for (prevPtr = NULL, exitPtr = firstExitPtr; exitPtr != NULL; + prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) { + if ((exitPtr->proc == proc) + && (exitPtr->clientData == clientData)) { + if (prevPtr == NULL) { + firstExitPtr = exitPtr->nextPtr; + } else { + prevPtr->nextPtr = exitPtr->nextPtr; + } + ckfree((char *) exitPtr); + return; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Exit -- + * + * This procedure is called to terminate the application. + * + * Results: + * None. + * + * Side effects: + * All existing exit handlers are invoked, then the application + * ends. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_Exit(status) + int status; /* Exit status for application; typically + * 0 for normal return, 1 for error return. */ +{ + ExitHandler *exitPtr; + + for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) { + /* + * Be careful to remove the handler from the list before invoking + * its callback. This protects us against double-freeing if the + * callback should call Tcl_DeleteExitHandler on itself. + */ + + firstExitPtr = exitPtr->nextPtr; + (*exitPtr->proc)(exitPtr->clientData); + ckfree((char *) exitPtr); + } +#ifdef TCL_MEM_DEBUG + if (tclMemDumpFileName != NULL) { + Tcl_DumpActiveMemory(tclMemDumpFileName); + } +#endif + + TclPlatformExit(status); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AfterCmd -- + * + * This procedure is invoked to process the "after" 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_AfterCmd(clientData, interp, argc, argv) + ClientData clientData; /* Points to the "tclAfter" assocData for + * this interpreter, or NULL if the assocData + * hasn't been created yet.*/ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + /* + * The variable below is used to generate unique identifiers for + * after commands. This id can wrap around, which can potentially + * cause problems. However, there are not likely to be problems + * in practice, because after commands can only be requested to + * about a month in the future, and wrap-around is unlikely to + * occur in less than about 1-10 years. Thus it's unlikely that + * any old ids will still be around when wrap-around occurs. + */ + + static int nextId = 1; + int ms; + AfterInfo *afterPtr; + AfterAssocData *assocPtr = (AfterAssocData *) clientData; + Tcl_CmdInfo cmdInfo; + size_t length; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * Create the "after" information associated for this interpreter, + * if it doesn't already exist. Associate it with the command too, + * so that it will be passed in as the ClientData argument in the + * future. + */ + + if (assocPtr == NULL) { + assocPtr = (AfterAssocData *) ckalloc(sizeof(AfterAssocData)); + assocPtr->interp = interp; + assocPtr->firstAfterPtr = NULL; + Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc, + (ClientData) assocPtr); + cmdInfo.proc = Tcl_AfterCmd; + cmdInfo.clientData = (ClientData) assocPtr; + cmdInfo.deleteProc = NULL; + cmdInfo.deleteData = (ClientData) assocPtr; + Tcl_SetCommandInfo(interp, argv[0], &cmdInfo); + } + + /* + * Parse the command. + */ + + length = strlen(argv[1]); + if (isdigit(UCHAR(argv[1][0]))) { + if (Tcl_GetInt(interp, argv[1], &ms) != TCL_OK) { + return TCL_ERROR; + } + if (ms < 0) { + ms = 0; + } + if (argc == 2) { + Tcl_Sleep(ms); + return TCL_OK; + } + afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo))); + afterPtr->assocPtr = assocPtr; + if (argc == 3) { + afterPtr->command = (char *) ckalloc((unsigned) + (strlen(argv[2]) + 1)); + strcpy(afterPtr->command, argv[2]); + } else { + afterPtr->command = Tcl_Concat(argc-2, argv+2); + } + afterPtr->id = nextId; + nextId += 1; + afterPtr->token = Tcl_CreateTimerHandler(ms, AfterProc, + (ClientData) afterPtr); + afterPtr->nextPtr = assocPtr->firstAfterPtr; + assocPtr->firstAfterPtr = afterPtr; + sprintf(interp->result, "after#%d", afterPtr->id); + } else if (strncmp(argv[1], "cancel", length) == 0) { + char *arg; + + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " cancel id|command\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 3) { + arg = argv[2]; + } else { + arg = Tcl_Concat(argc-2, argv+2); + } + for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; + afterPtr = afterPtr->nextPtr) { + if (strcmp(afterPtr->command, arg) == 0) { + break; + } + } + if (afterPtr == NULL) { + afterPtr = GetAfterEvent(assocPtr, arg); + } + if (arg != argv[2]) { + ckfree(arg); + } + if (afterPtr != NULL) { + if (afterPtr->token != NULL) { + Tcl_DeleteTimerHandler(afterPtr->token); + } else { + Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr); + } + FreeAfterPtr(afterPtr); + } + } else if ((strncmp(argv[1], "idle", length) == 0) + && (length >= 2)) { + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " idle script script ...\"", (char *) NULL); + return TCL_ERROR; + } + afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo))); + afterPtr->assocPtr = assocPtr; + if (argc == 3) { + afterPtr->command = (char *) ckalloc((unsigned) + (strlen(argv[2]) + 1)); + strcpy(afterPtr->command, argv[2]); + } else { + afterPtr->command = Tcl_Concat(argc-2, argv+2); + } + afterPtr->id = nextId; + nextId += 1; + afterPtr->token = NULL; + afterPtr->nextPtr = assocPtr->firstAfterPtr; + assocPtr->firstAfterPtr = afterPtr; + Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr); + sprintf(interp->result, "after#%d", afterPtr->id); + } else if ((strncmp(argv[1], "info", length) == 0) + && (length >= 2)) { + if (argc == 2) { + char buffer[30]; + + for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; + afterPtr = afterPtr->nextPtr) { + if (assocPtr->interp == interp) { + sprintf(buffer, "after#%d", afterPtr->id); + Tcl_AppendElement(interp, buffer); + } + } + return TCL_OK; + } + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " info ?id?\"", (char *) NULL); + return TCL_ERROR; + } + afterPtr = GetAfterEvent(assocPtr, argv[2]); + if (afterPtr == NULL) { + Tcl_AppendResult(interp, "event \"", argv[2], + "\" doesn't exist", (char *) NULL); + return TCL_ERROR; + } + Tcl_AppendElement(interp, afterPtr->command); + Tcl_AppendElement(interp, + (afterPtr->token == NULL) ? "idle" : "timer"); + } else { + Tcl_AppendResult(interp, "bad argument \"", argv[1], + "\": must be cancel, idle, info, or a number", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * GetAfterEvent -- + * + * This procedure parses an "after" id such as "after#4" and + * returns a pointer to the AfterInfo structure. + * + * Results: + * The return value is either a pointer to an AfterInfo structure, + * if one is found that corresponds to "string" and is for interp, + * or NULL if no corresponding after event can be found. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static AfterInfo * +GetAfterEvent(assocPtr, string) + AfterAssocData *assocPtr; /* Points to "after"-related information for + * this interpreter. */ + char *string; /* Textual identifier for after event, such + * as "after#6". */ +{ + AfterInfo *afterPtr; + int id; + char *end; + + if (strncmp(string, "after#", 6) != 0) { + return NULL; + } + string += 6; + id = strtoul(string, &end, 10); + if ((end == string) || (*end != 0)) { + return NULL; + } + for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; + afterPtr = afterPtr->nextPtr) { + if (afterPtr->id == id) { + return afterPtr; + } + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * AfterProc -- + * + * Timer callback to execute commands registered with the + * "after" command. + * + * Results: + * None. + * + * Side effects: + * Executes whatever command was specified. If the command + * returns an error, then the command "bgerror" is invoked + * to process the error; if bgerror fails then information + * about the error is output on stderr. + * + *---------------------------------------------------------------------- + */ + +static void +AfterProc(clientData) + ClientData clientData; /* Describes command to execute. */ +{ + AfterInfo *afterPtr = (AfterInfo *) clientData; + AfterAssocData *assocPtr = afterPtr->assocPtr; + AfterInfo *prevPtr; + int result; + Tcl_Interp *interp; + + /* + * First remove the callback from our list of callbacks; otherwise + * someone could delete the callback while it's being executed, which + * could cause a core dump. + */ + + if (assocPtr->firstAfterPtr == afterPtr) { + assocPtr->firstAfterPtr = afterPtr->nextPtr; + } else { + for (prevPtr = assocPtr->firstAfterPtr; prevPtr->nextPtr != afterPtr; + prevPtr = prevPtr->nextPtr) { + /* Empty loop body. */ + } + prevPtr->nextPtr = afterPtr->nextPtr; + } + + /* + * Execute the callback. + */ + + interp = assocPtr->interp; + Tcl_Preserve((ClientData) interp); + result = Tcl_GlobalEval(interp, afterPtr->command); + if (result != TCL_OK) { + Tcl_AddErrorInfo(interp, "\n (\"after\" script)"); + Tcl_BackgroundError(interp); + } + Tcl_Release((ClientData) interp); + + /* + * Free the memory for the callback. + */ + + ckfree(afterPtr->command); + ckfree((char *) afterPtr); +} + +/* + *---------------------------------------------------------------------- + * + * FreeAfterPtr -- + * + * This procedure removes an "after" command from the list of + * those that are pending and frees its resources. This procedure + * does *not* cancel the timer handler; if that's needed, the + * caller must do it. + * + * Results: + * None. + * + * Side effects: + * The memory associated with afterPtr is released. + * + *---------------------------------------------------------------------- + */ + +static void +FreeAfterPtr(afterPtr) + AfterInfo *afterPtr; /* Command to be deleted. */ +{ + AfterInfo *prevPtr; + AfterAssocData *assocPtr = afterPtr->assocPtr; + + if (assocPtr->firstAfterPtr == afterPtr) { + assocPtr->firstAfterPtr = afterPtr->nextPtr; + } else { + for (prevPtr = assocPtr->firstAfterPtr; prevPtr->nextPtr != afterPtr; + prevPtr = prevPtr->nextPtr) { + /* Empty loop body. */ + } + prevPtr->nextPtr = afterPtr->nextPtr; + } + ckfree(afterPtr->command); + ckfree((char *) afterPtr); +} + +/* + *---------------------------------------------------------------------- + * + * AfterCleanupProc -- + * + * This procedure is invoked whenever an interpreter is deleted + * to cleanup the AssocData for "tclAfter". + * + * Results: + * None. + * + * Side effects: + * After commands are removed. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +AfterCleanupProc(clientData, interp) + ClientData clientData; /* Points to AfterAssocData for the + * interpreter. */ + Tcl_Interp *interp; /* Interpreter that is being deleted. */ +{ + AfterAssocData *assocPtr = (AfterAssocData *) clientData; + AfterInfo *afterPtr; + + while (assocPtr->firstAfterPtr != NULL) { + afterPtr = assocPtr->firstAfterPtr; + assocPtr->firstAfterPtr = afterPtr->nextPtr; + if (afterPtr->token != NULL) { + Tcl_DeleteTimerHandler(afterPtr->token); + } else { + Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr); + } + ckfree(afterPtr->command); + ckfree((char *) afterPtr); + } + ckfree((char *) assocPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_VwaitCmd -- + * + * This procedure is invoked to process the "vwait" 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_VwaitCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int done, foundEvent; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " name\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_TraceVar(interp, argv[1], + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + VwaitVarProc, (ClientData) &done) != TCL_OK) { + return TCL_ERROR; + }; + done = 0; + foundEvent = 1; + while (!done && foundEvent) { + foundEvent = Tcl_DoOneEvent(0); + } + Tcl_UntraceVar(interp, argv[1], + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + VwaitVarProc, (ClientData) &done); + + /* + * Clear out the interpreter's result, since it may have been set + * by event handlers. + */ + + Tcl_ResetResult(interp); + if (!foundEvent) { + Tcl_AppendResult(interp, "can't wait for variable \"", argv[1], + "\": would wait forever", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + + /* ARGSUSED */ +static char * +VwaitVarProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Pointer to integer to set to 1. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *name1; /* Name of variable. */ + char *name2; /* Second part of variable name. */ + int flags; /* Information about what happened. */ +{ + int *donePtr = (int *) clientData; + + *donePtr = 1; + return (char *) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UpdateCmd -- + * + * This procedure is invoked to process the "update" 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_UpdateCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int flags = 0; /* Initialization needed only to stop + * compiler warnings. */ + + if (argc == 1) { + flags = TCL_ALL_EVENTS|TCL_DONT_WAIT; + } else if (argc == 2) { + if (strncmp(argv[1], "idletasks", strlen(argv[1])) != 0) { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be idletasks", (char *) NULL); + return TCL_ERROR; + } + flags = TCL_IDLE_EVENTS|TCL_DONT_WAIT; + } else { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " ?idletasks?\"", (char *) NULL); + return TCL_ERROR; + } + + while (Tcl_DoOneEvent(flags) != 0) { + /* Empty loop body */ + } + + /* + * Must clear the interpreter's result because event handlers could + * have executed commands. + */ + + Tcl_ResetResult(interp); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclWaitForFile -- + * + * This procedure waits synchronously for a file to become readable + * or writable, with an optional timeout. + * + * Results: + * The return value is an OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, and TCL_EXCEPTION, indicating the conditions + * that are present on file at the time of the return. This + * procedure will not return until either "timeout" milliseconds + * have elapsed or at least one of the conditions given by mask + * has occurred for file (a return value of 0 means that a timeout + * occurred). No normal events will be serviced during the + * execution of this procedure. + * + * Side effects: + * Time passes. + * + *---------------------------------------------------------------------- + */ + +int +TclWaitForFile(file, mask, timeout) + Tcl_File file; /* Handle for file on which to wait. */ + int mask; /* What to wait for: OR'ed combination of + * TCL_READABLE, TCL_WRITABLE, and + * TCL_EXCEPTION. */ + int timeout; /* Maximum amount of time to wait for one + * of the conditions in mask to occur, in + * milliseconds. A value of 0 means don't + * wait at all, and a value of -1 means + * wait forever. */ +{ + Tcl_Time abortTime, now, blockTime; + int present; + + /* + * If there is a non-zero finite timeout, compute the time when + * we give up. + */ + + if (timeout > 0) { + TclpGetTime(&now); + abortTime.sec = now.sec + timeout/1000; + abortTime.usec = now.usec + (timeout%1000)*1000; + if (abortTime.usec >= 1000000) { + abortTime.usec -= 1000000; + abortTime.sec += 1; + } + } + + /* + * Loop in a mini-event loop of our own, waiting for either the + * file to become ready or a timeout to occur. + */ + + while (1) { + Tcl_WatchFile(file, mask); + if (timeout > 0) { + blockTime.sec = abortTime.sec - now.sec; + blockTime.usec = abortTime.usec - now.usec; + if (blockTime.usec < 0) { + blockTime.sec -= 1; + blockTime.usec += 1000000; + } + if (blockTime.sec < 0) { + blockTime.sec = 0; + blockTime.usec = 0; + } + Tcl_WaitForEvent(&blockTime); + } else if (timeout == 0) { + blockTime.sec = 0; + blockTime.usec = 0; + Tcl_WaitForEvent(&blockTime); + } else { + Tcl_WaitForEvent((Tcl_Time *) NULL); + } + present = Tcl_FileReady(file, mask); + if (present != 0) { + break; + } + if (timeout == 0) { + break; + } + TclpGetTime(&now); + if ((abortTime.sec < now.sec) + || ((abortTime.sec == now.sec) + && (abortTime.usec <= now.usec))) { + break; + } + } + return present; +} diff --git a/tcl7.3/tclExpr.c b/tcl7.6/generic/tclExpr.c similarity index 86% rename from tcl7.3/tclExpr.c rename to tcl7.6/generic/tclExpr.c index b42929c..c11bb3f 100644 --- a/tcl7.3/tclExpr.c +++ b/tcl7.6/generic/tclExpr.c @@ -7,34 +7,18 @@ * 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. + * Copyright (c) 1987-1994 The Regents of the University of California. + * Copyright (c) 1994 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tclExpr.c 1.92 96/09/06 13:22:44 */ -#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" +# include "../compat/float.h" #else # include #endif @@ -49,8 +33,7 @@ static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclExpr.c,v 1.68 93/10/31 */ #ifndef TCL_GENERIC_ONLY -#include "tclUnix.h" -extern int errno; +#include "tclPort.h" #else #define NO_ERRNO_H #endif @@ -148,38 +131,41 @@ typedef struct { */ #define UNARY_MINUS 28 -#define NOT 29 -#define BIT_NOT 30 +#define UNARY_PLUS 29 +#define NOT 30 +#define BIT_NOT 31 /* * Precedence table. The values for non-operator token types are ignored. */ -int precTable[] = { +static 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 */ + 12, 12, 12, /* MULT, DIVIDE, MOD */ + 11, 11, /* PLUS, MINUS */ + 10, 10, /* LEFT_SHIFT, RIGHT_SHIFT */ + 9, 9, 9, 9, /* LESS, GREATER, LEQ, GEQ */ + 8, 8, /* EQUAL, NEQ */ + 7, /* BIT_AND */ + 6, /* BIT_XOR */ + 5, /* BIT_OR */ + 4, /* AND */ + 3, /* OR */ + 2, /* QUESTY */ + 1, /* COLON */ + 13, 13, 13, 13 /* UNARY_MINUS, UNARY_PLUS, NOT, + * BIT_NOT */ }; /* * Mapping from operator numbers to strings; used for error messages. */ -char *operatorStrings[] = { - "VALUE", "(", ")", "END", "UNKNOWN", "5", "6", "7", +static char *operatorStrings[] = { + "VALUE", "(", ")", ",", "END", "UNKNOWN", "6", "7", "*", "/", "%", "+", "-", "<<", ">>", "<", ">", "<=", ">=", "==", "!=", "&", "^", "|", "&&", "||", "?", ":", - "-", "!", "~" + "-", "+", "!", "~" }; /* @@ -241,8 +227,6 @@ static int ExprBinaryFunc _ANSI_ARGS_((ClientData clientData, 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, @@ -250,6 +234,7 @@ static int ExprIntFunc _ANSI_ARGS_((ClientData clientData, Tcl_Value *resultPtr)); static int ExprLex _ANSI_ARGS_((Tcl_Interp *interp, ExprInfo *infoPtr, Value *valuePtr)); +static int ExprLooksLikeInt _ANSI_ARGS_((char *p)); static void ExprMakeString _ANSI_ARGS_((Tcl_Interp *interp, Value *valuePtr)); static int ExprMathFunc _ANSI_ARGS_((Tcl_Interp *interp, @@ -341,55 +326,59 @@ ExprParseString(interp, string, valuePtr) 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) { + if (ExprLooksLikeInt(string)) { + valuePtr->type = TYPE_INT; + errno = 0; + /* - * This procedure is sometimes called with string in - * interp->result, so we have to clear the result before - * logging an error message. + * 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. */ - - 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; + + for (p = string; isspace(UCHAR(*p)); p++) { + /* Empty loop body. */ + } + if (*p == '-') { + start = p+1; + valuePtr->intValue = -((int)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 (*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; + } else { + return TCL_OK; + } + } + } else { + errno = 0; + valuePtr->doubleValue = strtod(string, &term); + if ((term != string) && (*term == 0)) { + if (errno != 0) { + Tcl_ResetResult(interp); + TclExprFloatError(interp, valuePtr->doubleValue); + return TCL_ERROR; + } + valuePtr->type = TYPE_DOUBLE; + return TCL_OK; } - valuePtr->type = TYPE_DOUBLE; - return TCL_OK; } } @@ -463,67 +452,38 @@ ExprLex(interp, infoPtr, valuePtr) /* * 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. + * 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. */ 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. - */ - + if (ExprLooksLikeInt(p)) { 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. - */ - + valuePtr->intValue = strtoul(p, &term, 0); if (errno == ERANGE) { interp->result = "integer value too large to represent"; - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", interp->result, - (char *) NULL); + 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; + } else { + errno = 0; + valuePtr->doubleValue = strtod(p, &term); + if (term != p) { + if (errno != 0) { + TclExprFloatError(interp, valuePtr->doubleValue); + return TCL_ERROR; + } + infoPtr->token = VALUE; + infoPtr->expr = term; + valuePtr->type = TYPE_DOUBLE; + return TCL_OK; + } } } @@ -801,6 +761,9 @@ ExprGetValue(interp, infoPtr, prec, valuePtr) if (infoPtr->token == MINUS) { infoPtr->token = UNARY_MINUS; } + if (infoPtr->token == PLUS) { + infoPtr->token = UNARY_PLUS; + } if (infoPtr->token >= UNARY_MINUS) { /* @@ -813,45 +776,54 @@ ExprGetValue(interp, infoPtr, prec, 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; + if (!iPtr->noEval) { + 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 { - valuePtr->intValue = 0; + badType = valuePtr->type; + goto illegalType; + } + break; + case UNARY_PLUS: + if ((valuePtr->type != TYPE_INT) + && (valuePtr->type != TYPE_DOUBLE)) { + 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; } - 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; + 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) { @@ -897,8 +869,18 @@ ExprGetValue(interp, infoPtr, prec, valuePtr) valuePtr->intValue = valuePtr->doubleValue != 0; valuePtr->type = TYPE_INT; } else if (valuePtr->type == TYPE_STRING) { - badType = TYPE_STRING; - goto illegalType; + if (!iPtr->noEval) { + badType = TYPE_STRING; + goto illegalType; + } + + /* + * Must set valuePtr->intValue to avoid referencing + * uninitialized memory in the "if" below; the actual + * value doesn't matter, since it will be ignored. + */ + + valuePtr->intValue = 0; } if (((operator == AND) && !valuePtr->intValue) || ((operator == OR) && valuePtr->intValue)) { @@ -906,11 +888,24 @@ ExprGetValue(interp, infoPtr, prec, valuePtr) result = ExprGetValue(interp, infoPtr, precTable[operator], &value2); iPtr->noEval--; + if (result != TCL_OK) { + goto done; + } + if (operator == OR) { + valuePtr->intValue = 1; + } + continue; } else if (operator == QUESTY) { + /* + * Special note: ?: operators must associate right to + * left. To make this happen, use a precedence one lower + * than QUESTY when calling ExprGetValue recursively. + */ + if (valuePtr->intValue != 0) { valuePtr->pv.next = valuePtr->pv.buffer; - result = ExprGetValue(interp, infoPtr, precTable[operator], - valuePtr); + result = ExprGetValue(interp, infoPtr, + precTable[QUESTY] - 1, valuePtr); if (result != TCL_OK) { goto done; } @@ -919,13 +914,13 @@ ExprGetValue(interp, infoPtr, prec, valuePtr) } value2.pv.next = value2.pv.buffer; iPtr->noEval++; - result = ExprGetValue(interp, infoPtr, precTable[operator], - &value2); + result = ExprGetValue(interp, infoPtr, + precTable[QUESTY] - 1, &value2); iPtr->noEval--; } else { iPtr->noEval++; - result = ExprGetValue(interp, infoPtr, precTable[operator], - &value2); + result = ExprGetValue(interp, infoPtr, + precTable[QUESTY] - 1, &value2); iPtr->noEval--; if (result != TCL_OK) { goto done; @@ -934,9 +929,13 @@ ExprGetValue(interp, infoPtr, prec, valuePtr) goto syntaxError; } valuePtr->pv.next = valuePtr->pv.buffer; - result = ExprGetValue(interp, infoPtr, precTable[operator], - valuePtr); + result = ExprGetValue(interp, infoPtr, + precTable[QUESTY] - 1, valuePtr); + if (result != TCL_OK) { + goto done; + } } + continue; } else { result = ExprGetValue(interp, infoPtr, precTable[operator], &value2); @@ -954,6 +953,10 @@ ExprGetValue(interp, infoPtr, prec, valuePtr) goto syntaxError; } + if (iPtr->noEval) { + continue; + } + /* * At this point we've got two values and an operator. Check * to make sure that the particular data types are appropriate @@ -1066,16 +1069,13 @@ ExprGetValue(interp, infoPtr, prec, valuePtr) } /* - * 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. + * Carry out the function of the specified operator. */ switch (operator) { case MULT: if (valuePtr->type == TYPE_INT) { - valuePtr->intValue *= value2.intValue; + valuePtr->intValue = valuePtr->intValue * value2.intValue; } else { valuePtr->doubleValue *= value2.doubleValue; } @@ -1083,7 +1083,9 @@ ExprGetValue(interp, infoPtr, prec, valuePtr) case DIVIDE: case MOD: if (valuePtr->type == TYPE_INT) { - int divisor, quot, rem, negative; + long divisor, quot, rem; + int negative; + if (value2.intValue == 0) { divideByZero: interp->result = "divide by zero"; @@ -1127,14 +1129,14 @@ ExprGetValue(interp, infoPtr, prec, valuePtr) break; case PLUS: if (valuePtr->type == TYPE_INT) { - valuePtr->intValue += value2.intValue; + valuePtr->intValue = valuePtr->intValue + value2.intValue; } else { valuePtr->doubleValue += value2.doubleValue; } break; case MINUS: if (valuePtr->type == TYPE_INT) { - valuePtr->intValue -= value2.intValue; + valuePtr->intValue = valuePtr->intValue - value2.intValue; } else { valuePtr->doubleValue -= value2.doubleValue; } @@ -1403,7 +1405,7 @@ ExprTopLevel(interp, string, valuePtr) * IEEE floating-point error. */ - ExprFloatError(interp, valuePtr->doubleValue); + TclExprFloatError(interp, valuePtr->doubleValue); return TCL_ERROR; } return TCL_OK; @@ -1446,7 +1448,7 @@ Tcl_ExprLong(interp, string, ptr) if (value.type == TYPE_INT) { *ptr = value.intValue; } else if (value.type == TYPE_DOUBLE) { - *ptr = value.doubleValue; + *ptr = (long) value.doubleValue; } else { interp->result = "expression didn't have numeric value"; result = TCL_ERROR; @@ -1548,7 +1550,7 @@ Tcl_ExprString(interp, string) } else { if (value.pv.buffer != value.staticSpace) { interp->result = value.pv.buffer; - interp->freeProc = (Tcl_FreeProc *) free; + interp->freeProc = TCL_DYNAMIC; value.pv.buffer = value.staticSpace; } else { Tcl_SetResult(interp, value.pv.buffer, TCL_VOLATILE); @@ -1655,8 +1657,8 @@ ExprMathFunc(interp, infoPtr, valuePtr) 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; + char *p, *funcName, savedChar; + int i, result; /* * Find the end of the math function's name and lookup the MathFunc @@ -1669,7 +1671,10 @@ ExprMathFunc(interp, infoPtr, valuePtr) } infoPtr->expr = p; result = ExprLex(interp, infoPtr, valuePtr); - if ((result != TCL_OK) || (infoPtr->token != OPEN_PAREN)) { + if (result != TCL_OK) { + return TCL_ERROR; + } + if (infoPtr->token != OPEN_PAREN) { goto syntaxError; } savedChar = *p; @@ -1722,7 +1727,7 @@ ExprMathFunc(interp, infoPtr, valuePtr) } else { if (mathFuncPtr->argTypes[i] == TCL_INT) { args[i].type = TCL_INT; - args[i].intValue = valuePtr->doubleValue; + args[i].intValue = (long) valuePtr->doubleValue; } else { args[i].type = TCL_DOUBLE; args[i].doubleValue = valuePtr->doubleValue; @@ -1755,6 +1760,12 @@ ExprMathFunc(interp, infoPtr, valuePtr) } } } + if (iPtr->noEval) { + valuePtr->type = TYPE_INT; + valuePtr->intValue = 0; + infoPtr->token = VALUE; + return TCL_OK; + } /* * Invoke the function and copy its result back into valuePtr. @@ -1786,7 +1797,7 @@ ExprMathFunc(interp, infoPtr, valuePtr) /* *---------------------------------------------------------------------- * - * ExprFloatError -- + * TclExprFloatError -- * * This procedure is called when an error occurs during a * floating-point operation. It reads errno and sets @@ -1801,8 +1812,8 @@ ExprMathFunc(interp, infoPtr, valuePtr) *---------------------------------------------------------------------- */ -static void -ExprFloatError(interp, value) +void +TclExprFloatError(interp, value) Tcl_Interp *interp; /* Where to store error message. */ double value; /* Value returned after error; used to * distinguish underflows from overflows. */ @@ -1860,13 +1871,13 @@ ExprUnaryFunc(clientData, interp, args, resultPtr) Tcl_Value *args; Tcl_Value *resultPtr; { - double (*func)() = (double (*)()) clientData; + double (*func) _ANSI_ARGS_((double)) = (double (*)_ANSI_ARGS_((double))) clientData; errno = 0; resultPtr->type = TCL_DOUBLE; resultPtr->doubleValue = (*func)(args[0].doubleValue); if (errno != 0) { - ExprFloatError(interp, resultPtr->doubleValue); + TclExprFloatError(interp, resultPtr->doubleValue); return TCL_ERROR; } return TCL_OK; @@ -1881,13 +1892,14 @@ ExprBinaryFunc(clientData, interp, args, resultPtr) Tcl_Value *args; Tcl_Value *resultPtr; { - double (*func)() = (double (*)()) clientData; + double (*func) _ANSI_ARGS_((double, double)) + = (double (*)_ANSI_ARGS_((double, double))) clientData; errno = 0; resultPtr->type = TCL_DOUBLE; resultPtr->doubleValue = (*func)(args[0].doubleValue, args[1].doubleValue); if (errno != 0) { - ExprFloatError(interp, resultPtr->doubleValue); + TclExprFloatError(interp, resultPtr->doubleValue); return TCL_ERROR; } return TCL_OK; @@ -1968,7 +1980,7 @@ ExprIntFunc(clientData, interp, args, resultPtr) goto tooLarge; } } - resultPtr->intValue = args[0].doubleValue; + resultPtr->intValue = (long) args[0].doubleValue; } return TCL_OK; } @@ -1993,13 +2005,57 @@ ExprRoundFunc(clientData, interp, args, resultPtr) interp->result, (char *) NULL); return TCL_ERROR; } - resultPtr->intValue = (args[0].doubleValue - 0.5); + resultPtr->intValue = (long) (args[0].doubleValue - 0.5); } else { if (args[0].doubleValue >= (((double) LONG_MAX + 0.5))) { goto tooLarge; } - resultPtr->intValue = (args[0].doubleValue + 0.5); + resultPtr->intValue = (long) (args[0].doubleValue + 0.5); } } return TCL_OK; } + +/* + *---------------------------------------------------------------------- + * + * ExprLooksLikeInt -- + * + * This procedure decides whether the leading characters of a + * string look like an integer or something else (such as a + * floating-point number or string). + * + * Results: + * The return value is 1 if the leading characters of p look + * like a valid Tcl integer. If they look like a floating-point + * number (e.g. "e01" or "2.4"), or if they don't look like a + * number at all, then 0 is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ExprLooksLikeInt(p) + char *p; /* Pointer to string. */ +{ + while (isspace(UCHAR(*p))) { + p++; + } + if ((*p == '+') || (*p == '-')) { + p++; + } + if (!isdigit(UCHAR(*p))) { + return 0; + } + p++; + while (isdigit(UCHAR(*p))) { + p++; + } + if ((*p != '.') && (*p != 'e') && (*p != 'E')) { + return 1; + } + return 0; +} diff --git a/tcl7.6/generic/tclFCmd.c b/tcl7.6/generic/tclFCmd.c new file mode 100644 index 0000000..3c43fc4 --- /dev/null +++ b/tcl7.6/generic/tclFCmd.c @@ -0,0 +1,710 @@ +/* + * tclFCmd.c + * + * This file implements the generic portion of file manipulation + * subcommands of the "file" command. + * + * Copyright (c) 1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclFCmd.c 1.12 96/10/08 17:25:34 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * Declarations for local procedures defined in this file: + */ + +static int CopyRenameOneFile _ANSI_ARGS_((Tcl_Interp *interp, + char *source, char *dest, int copyFlag, + int force)); +static char * FileBasename _ANSI_ARGS_((Tcl_Interp *interp, + char *path, Tcl_DString *bufferPtr)); +static int FileCopyRename _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv, int copyFlag)); +static int FileForceOption _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv, int *forcePtr)); + +/* + *--------------------------------------------------------------------------- + * + * TclFileRenameCmd + * + * This procedure implements the "rename" subcommand of the "file" + * command. Filename arguments need to be translated to native + * format before being passed to platform-specific code that + * implements rename functionality. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *--------------------------------------------------------------------------- + */ + +int +TclFileRenameCmd(interp, argc, argv) + Tcl_Interp *interp; /* Interp for error reporting. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings passed to Tcl_FileCmd. */ +{ + return FileCopyRename(interp, argc, argv, 0); +} + +/* + *--------------------------------------------------------------------------- + * + * TclFileCopyCmd + * + * This procedure implements the "copy" subcommand of the "file" + * command. Filename arguments need to be translated to native + * format before being passed to platform-specific code that + * implements copy functionality. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *--------------------------------------------------------------------------- + */ + +int +TclFileCopyCmd(interp, argc, argv) + Tcl_Interp *interp; /* Used for error reporting */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings passed to Tcl_FileCmd. */ +{ + return FileCopyRename(interp, argc, argv, 1); +} + +/* + *--------------------------------------------------------------------------- + * + * FileCopyRename -- + * + * Performs the work of TclFileRenameCmd and TclFileCopyCmd. + * See comments for those procedures. + * + * Results: + * See above. + * + * Side effects: + * See above. + * + *--------------------------------------------------------------------------- + */ + +static int +FileCopyRename(interp, argc, argv, copyFlag) + Tcl_Interp *interp; /* Used for error reporting. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings passed to Tcl_FileCmd. */ + int copyFlag; /* If non-zero, copy source(s). Otherwise, + * rename them. */ +{ + int i, result, force; + struct stat statBuf; + Tcl_DString targetBuffer; + char *target; + + i = FileForceOption(interp, argc - 2, argv + 2, &force); + if (i < 0) { + return TCL_ERROR; + } + i += 2; + if ((argc - i) < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ", argv[1], " ?options? source ?source ...? target\"", + (char *) NULL); + return TCL_ERROR; + } + + /* + * If target doesn't exist or isn't a directory, try the copy/rename. + * More than 2 arguments is only valid if the target is an existing + * directory. + */ + + target = Tcl_TranslateFileName(interp, argv[argc - 1], &targetBuffer); + if (target == NULL) { + return TCL_ERROR; + } + + result = TCL_OK; + + /* + * Call stat() so that if target is a symlink that points to a directory + * we will put the sources in that directory instead of overwriting the + * symlink. + */ + + if ((stat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) { + if ((argc - i) > 2) { + errno = ENOTDIR; + Tcl_PosixError(interp); + Tcl_AppendResult(interp, "error ", + ((copyFlag) ? "copying" : "renaming"), ": target \"", + argv[argc - 1], "\" is not a directory", (char *) NULL); + result = TCL_ERROR; + } else { + /* + * Even though already have target == translated(argv[i+1]), + * pass the original argument down, so if there's an error, the + * error message will reflect the original arguments. + */ + + result = CopyRenameOneFile(interp, argv[i], argv[i + 1], copyFlag, + force); + } + Tcl_DStringFree(&targetBuffer); + return result; + } + + /* + * Move each source file into target directory. Extract the basename + * from each source, and append it to the end of the target path. + */ + + for ( ; i < argc - 1; i++) { + char *jargv[2]; + char *source, *newFileName; + Tcl_DString sourceBuffer, newFileNameBuffer; + + source = FileBasename(interp, argv[i], &sourceBuffer); + if (source == NULL) { + result = TCL_ERROR; + break; + } + jargv[0] = argv[argc - 1]; + jargv[1] = source; + Tcl_DStringInit(&newFileNameBuffer); + newFileName = Tcl_JoinPath(2, jargv, &newFileNameBuffer); + result = CopyRenameOneFile(interp, argv[i], newFileName, copyFlag, + force); + Tcl_DStringFree(&sourceBuffer); + Tcl_DStringFree(&newFileNameBuffer); + + if (result == TCL_ERROR) { + break; + } + } + Tcl_DStringFree(&targetBuffer); + return result; +} + +/* + *--------------------------------------------------------------------------- + * + * TclFileMakeDirsCmd + * + * This procedure implements the "mkdir" subcommand of the "file" + * command. Filename arguments need to be translated to native + * format before being passed to platform-specific code that + * implements mkdir functionality. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ +int +TclFileMakeDirsCmd(interp, argc, argv) + Tcl_Interp *interp; /* Used for error reporting. */ + int argc; /* Number of arguments */ + char **argv; /* Argument strings passed to Tcl_FileCmd. */ +{ + Tcl_DString nameBuffer, targetBuffer; + char *errfile; + int result, i, j, pargc; + char **pargv; + struct stat statBuf; + + pargv = NULL; + errfile = NULL; + Tcl_DStringInit(&nameBuffer); + Tcl_DStringInit(&targetBuffer); + + result = TCL_OK; + for (i = 2; i < argc; i++) { + char *name = Tcl_TranslateFileName(interp, argv[i], &nameBuffer); + if (name == NULL) { + result = TCL_ERROR; + break; + } + + Tcl_SplitPath(name, &pargc, &pargv); + if (pargc == 0) { + errno = ENOENT; + errfile = argv[i]; + break; + } + for (j = 0; j < pargc; j++) { + char *target = Tcl_JoinPath(j + 1, pargv, &targetBuffer); + + /* + * Call stat() so that if target is a symlink that points to a + * directory we will create subdirectories in that directory. + */ + + if (stat(target, &statBuf) == 0) { + if (!S_ISDIR(statBuf.st_mode)) { + errno = EEXIST; + errfile = target; + goto done; + } + } else if ((errno != ENOENT) + || (TclpCreateDirectory(target) != TCL_OK)) { + errfile = target; + goto done; + } + Tcl_DStringFree(&targetBuffer); + } + ckfree((char *) pargv); + pargv = NULL; + Tcl_DStringFree(&nameBuffer); + } + + done: + if (errfile != NULL) { + Tcl_AppendResult(interp, "can't create directory \"", + errfile, "\": ", Tcl_PosixError(interp), (char *) NULL); + result = TCL_ERROR; + } + + Tcl_DStringFree(&nameBuffer); + Tcl_DStringFree(&targetBuffer); + if (pargv != NULL) { + ckfree((char *) pargv); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclFileDeleteCmd + * + * This procedure implements the "delete" subcommand of the "file" + * command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +TclFileDeleteCmd(interp, argc, argv) + Tcl_Interp *interp; /* Used for error reporting */ + int argc; /* Number of arguments */ + char **argv; /* Argument strings passed to Tcl_FileCmd. */ +{ + Tcl_DString nameBuffer, errorBuffer; + int i, force, result; + char *errfile; + + i = FileForceOption(interp, argc - 2, argv + 2, &force); + if (i < 0) { + return TCL_ERROR; + } + i += 2; + if ((argc - i) < 1) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ", argv[1], " ?options? file ?file ...?\"", (char *) NULL); + return TCL_ERROR; + } + + errfile = NULL; + result = TCL_OK; + Tcl_DStringInit(&errorBuffer); + Tcl_DStringInit(&nameBuffer); + + for ( ; i < argc; i++) { + struct stat statBuf; + char *name; + + errfile = argv[i]; + Tcl_DStringSetLength(&nameBuffer, 0); + name = Tcl_TranslateFileName(interp, argv[i], &nameBuffer); + if (name == NULL) { + result = TCL_ERROR; + goto done; + } + + /* + * Call lstat() to get info so can delete symbolic link itself. + */ + + if (lstat(name, &statBuf) != 0) { + /* + * Trying to delete a file that does not exist is not + * considered an error, just a no-op + */ + + if (errno != ENOENT) { + result = TCL_ERROR; + } + } else if (S_ISDIR(statBuf.st_mode)) { + result = TclpRemoveDirectory(name, force, &errorBuffer); + if (result != TCL_OK) { + if ((force == 0) && (errno == EEXIST)) { + Tcl_AppendResult(interp, "error deleting \"", argv[i], + "\": directory not empty", (char *) NULL); + Tcl_PosixError(interp); + goto done; + } + + /* + * If possible, use the untranslated name for the file. + */ + + errfile = Tcl_DStringValue(&errorBuffer); + if (strcmp(name, errfile) == 0) { + errfile = argv[i]; + } + } + } else { + result = TclpDeleteFile(name); + } + + if (result == TCL_ERROR) { + break; + } + } + if (result != TCL_OK) { + Tcl_AppendResult(interp, "error deleting \"", errfile, + "\": ", Tcl_PosixError(interp), (char *) NULL); + } + done: + Tcl_DStringFree(&errorBuffer); + Tcl_DStringFree(&nameBuffer); + return result; +} + +/* + *--------------------------------------------------------------------------- + * + * CopyRenameOneFile + * + * Copies or renames specified source file or directory hierarchy + * to the specified target. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Target is overwritten if the force flag is set. Attempting to + * copy/rename a file onto a directory or a directory onto a file + * will always result in an error. + * + *---------------------------------------------------------------------- + */ + +static int +CopyRenameOneFile(interp, source, target, copyFlag, force) + Tcl_Interp *interp; /* Used for error reporting. */ + char *source; /* Pathname of file to copy. May need to + * be translated. */ + char *target; /* Pathname of file to create/overwrite. + * May need to be translated. */ + int copyFlag; /* If non-zero, copy files. Otherwise, + * rename them. */ + int force; /* If non-zero, overwrite target file if it + * exists. Otherwise, error if target already + * exists. */ +{ + int result; + Tcl_DString sourcePath, targetPath, errorBuffer; + char *targetName, *sourceName, *errfile; + struct stat sourceStatBuf, targetStatBuf; + + sourceName = Tcl_TranslateFileName(interp, source, &sourcePath); + if (sourceName == NULL) { + return TCL_ERROR; + } + targetName = Tcl_TranslateFileName(interp, target, &targetPath); + if (targetName == NULL) { + Tcl_DStringFree(&sourcePath); + return TCL_ERROR; + } + + errfile = NULL; + result = TCL_ERROR; + Tcl_DStringInit(&errorBuffer); + + /* + * We want to copy/rename links and not the files they point to, so we + * use lstat(). If target is a link, we also want to replace the + * link and not the file it points to, so we also use lstat() on the + * target. + */ + + if (lstat(sourceName, &sourceStatBuf) != 0) { + errfile = source; + goto done; + } + if (lstat(targetName, &targetStatBuf) != 0) { + if (errno != ENOENT) { + errfile = target; + goto done; + } + } else { + if (force == 0) { + errno = EEXIST; + errfile = target; + goto done; + } + + /* + * Prevent copying or renaming a file onto itself. Under Windows, + * stat always returns 0 for st_ino. However, the Windows-specific + * code knows how to deal with copying or renaming a file on top of + * itself. It might be a good idea to write a stat that worked. + */ + + if ((sourceStatBuf.st_ino != 0) && (targetStatBuf.st_ino != 0)) { + if ((sourceStatBuf.st_ino == targetStatBuf.st_ino) && + (sourceStatBuf.st_dev == targetStatBuf.st_dev)) { + result = TCL_OK; + goto done; + } + } + + /* + * Prevent copying/renaming a file onto a directory and + * vice-versa. This is a policy decision based on the fact that + * existing implementations of copy and rename on all platforms + * also prevent this. + */ + + if (S_ISDIR(sourceStatBuf.st_mode) + && !S_ISDIR(targetStatBuf.st_mode)) { + errno = EISDIR; + Tcl_AppendResult(interp, "can't overwrite file \"", target, + "\" with directory \"", source, "\"", (char *) NULL); + goto done; + } + if (!S_ISDIR(sourceStatBuf.st_mode) + && S_ISDIR(targetStatBuf.st_mode)) { + errno = EISDIR; + Tcl_AppendResult(interp, "can't overwrite directory \"", target, + "\" with file \"", source, "\"", (char *) NULL); + goto done; + } + } + + if (copyFlag == 0) { + result = TclpRenameFile(sourceName, targetName); + if (result == TCL_OK) { + goto done; + } + + if (errno == EINVAL) { + Tcl_AppendResult(interp, "error renaming \"", source, "\" to \"", + target, "\": trying to rename a volume or ", + "move a directory into itself", (char *) NULL); + goto done; + } else if (errno != EXDEV) { + errfile = target; + goto done; + } + + /* + * The rename failed because the move was across file systems. + * Fall through to copy file and then remove original. Note that + * the low-level TclpRenameFile is allowed to implement + * cross-filesystem moves itself. + */ + } + + if (S_ISDIR(sourceStatBuf.st_mode)) { + result = TclpCopyDirectory(sourceName, targetName, &errorBuffer); + if (result != TCL_OK) { + errfile = Tcl_DStringValue(&errorBuffer); + if (strcmp(errfile, sourceName) == 0) { + errfile = source; + } else if (strcmp(errfile, targetName) == 0) { + errfile = target; + } + } + } else { + result = TclpCopyFile(sourceName, targetName); + if (result != TCL_OK) { + /* + * Well, there really shouldn't be a problem with source, + * because up there we checked to see if it was ok to copy it. + */ + + errfile = target; + } + } + if ((copyFlag == 0) && (result == TCL_OK)) { + if (S_ISDIR(sourceStatBuf.st_mode)) { + result = TclpRemoveDirectory(sourceName, 1, &errorBuffer); + if (result != TCL_OK) { + errfile = Tcl_DStringValue(&errorBuffer); + if (strcmp(errfile, sourceName) == 0) { + errfile = source; + } + } + } else { + result = TclpDeleteFile(sourceName); + if (result != TCL_OK) { + errfile = source; + } + } + if (result != TCL_OK) { + Tcl_AppendResult(interp, "can't unlink \"", errfile, "\": ", + Tcl_PosixError(interp), (char *) NULL); + errfile = NULL; + } + } + + done: + if (errfile != NULL) { + Tcl_AppendResult(interp, + ((copyFlag) ? "error copying \"" : "error renaming \""), + source, (char *) NULL); + if (errfile != source) { + Tcl_AppendResult(interp, "\" to \"", target, (char *) NULL); + if (errfile != target) { + Tcl_AppendResult(interp, "\": \"", errfile, (char *) NULL); + } + } + Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp), + (char *) NULL); + } + Tcl_DStringFree(&errorBuffer); + Tcl_DStringFree(&sourcePath); + Tcl_DStringFree(&targetPath); + return result; +} + +/* + *--------------------------------------------------------------------------- + * + * FileForceOption -- + * + * Helps parse command line options for file commands that take + * the "-force" and "--" options. + * + * Results: + * The return value is how many arguments from argv were consumed + * by this function, or -1 if there was an error parsing the + * options. If an error occurred, an error message is left in + * interp->result. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static int +FileForceOption(interp, argc, argv, forcePtr) + Tcl_Interp *interp; /* Interp, for error return. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. First command line + option, if it exists, begins at */ + int *forcePtr; /* If the "-force" was specified, *forcePtr + * is filled with 1, otherwise with 0. */ +{ + int force, i; + + force = 0; + for (i = 0; i < argc; i++) { + if (argv[i][0] != '-') { + break; + } + if (strcmp(argv[i], "-force") == 0) { + force = 1; + } else if (strcmp(argv[i], "--") == 0) { + i++; + break; + } else { + Tcl_AppendResult(interp, "bad option \"", argv[i], + "\": should be -force or --", (char *)NULL); + return -1; + } + } + *forcePtr = force; + return i; +} +/* + *--------------------------------------------------------------------------- + * + * FileBasename -- + * + * Given a path in either tcl format (with / separators), or in the + * platform-specific format for the current platform, return all the + * characters in the path after the last directory separator. But, + * if path is the root directory, returns no characters. + * + * Results: + * Appends the string that represents the basename to the end of + * the specified initialized DString, returning a pointer to the + * resulting string. If there is an error, an error message is left + * in interp, NULL is returned, and the Tcl_DString is unmodified. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static char * +FileBasename(interp, path, bufferPtr) + Tcl_Interp *interp; /* Interp, for error return. */ + char *path; /* Path whose basename to extract. */ + Tcl_DString *bufferPtr; /* Initialized DString that receives + * basename. */ +{ + int argc; + char **argv; + + Tcl_SplitPath(path, &argc, &argv); + if (argc == 0) { + Tcl_DStringInit(bufferPtr); + } else { + if ((argc == 1) && (*path == '~')) { + Tcl_DString buffer; + + ckfree((char *) argv); + path = Tcl_TranslateFileName(interp, path, &buffer); + if (path == NULL) { + return NULL; + } + Tcl_SplitPath(path, &argc, &argv); + Tcl_DStringFree(&buffer); + } + Tcl_DStringInit(bufferPtr); + + /* + * Return the last component, unless it is the only component, and it + * is the root of an absolute path. + */ + + if (argc > 0) { + if ((argc > 1) + || (Tcl_GetPathType(argv[0]) == TCL_PATH_RELATIVE)) { + Tcl_DStringAppend(bufferPtr, argv[argc - 1], -1); + } + } + } + ckfree((char *) argv); + return Tcl_DStringValue(bufferPtr); +} diff --git a/tcl7.6/generic/tclFHandle.c b/tcl7.6/generic/tclFHandle.c new file mode 100644 index 0000000..2b9ca64 --- /dev/null +++ b/tcl7.6/generic/tclFHandle.c @@ -0,0 +1,259 @@ +/* + * tclFHandle.c -- + * + * This file contains functions for manipulating Tcl file handles. + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclFHandle.c 1.9 96/07/01 15:41:26 + */ + +#include "tcl.h" +#include "tclInt.h" +#include "tclPort.h" + +/* + * The FileHashKey structure is used to associate the OS file handle and type + * with the corresponding notifier data in a FileHandle. + */ + +typedef struct FileHashKey { + int type; /* File handle type. */ + ClientData osHandle; /* Platform specific OS file handle. */ +} FileHashKey; + +typedef struct FileHandle { + FileHashKey key; /* Hash key for a given file. */ + ClientData data; /* Platform specific notifier data. */ + Tcl_FileFreeProc *proc; /* Callback to invoke when file is freed. */ +} FileHandle; + +/* + * Static variables used in this file: + */ + +static Tcl_HashTable fileTable; /* Hash table containing file handles. */ +static int initialized = 0; /* 1 if this module has been initialized. */ + +/* + * Static procedures used in this file: + */ + +static void FileExitProc _ANSI_ARGS_((ClientData clientData)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetFile -- + * + * This function retrieves the file handle associated with a + * platform specific file handle of the given type. It creates + * a new file handle if needed. + * + * Results: + * Returns the file handle associated with the file descriptor. + * + * Side effects: + * Initializes the file handle table if necessary. + * + *---------------------------------------------------------------------- + */ + +Tcl_File +Tcl_GetFile(osHandle, type) + ClientData osHandle; /* Platform specific file handle. */ + int type; /* Type of file handle. */ +{ + FileHashKey key; + Tcl_HashEntry *entryPtr; + int new; + + if (!initialized) { + Tcl_InitHashTable(&fileTable, sizeof(FileHashKey)/sizeof(int)); + Tcl_CreateExitHandler(FileExitProc, 0); + initialized = 1; + } + key.osHandle = osHandle; + key.type = type; + entryPtr = Tcl_CreateHashEntry(&fileTable, (char *) &key, &new); + if (new) { + FileHandle *newHandlePtr; + newHandlePtr = (FileHandle *) ckalloc(sizeof(FileHandle)); + newHandlePtr->key = key; + newHandlePtr->data = NULL; + newHandlePtr->proc = NULL; + Tcl_SetHashValue(entryPtr, newHandlePtr); + } + + return (Tcl_File) Tcl_GetHashValue(entryPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FreeFile -- + * + * Deallocates an entry in the file handle table. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_FreeFile(handle) + Tcl_File handle; +{ + Tcl_HashEntry *entryPtr; + FileHandle *handlePtr = (FileHandle *) handle; + + /* + * Invoke free procedure, then delete the handle. + */ + + if (handlePtr->proc) { + (*handlePtr->proc)(handlePtr->data); + } + + /* + * Tcl_File structures may be freed as a result of running the + * channel table exit handler. The file table is freed by the file + * table exit handler, which may run before the channel table exit + * handler. The file table exit handler sets the "initialized" + * variable back to zero, so that the Tcl_FreeFile (when invoked + * from the channel table exit handler) can notice that the file + * table has already been destroyed. Otherwise, accessing a + * deleted hash table would cause a panic. + */ + + if (initialized) { + entryPtr = Tcl_FindHashEntry(&fileTable, (char *) &handlePtr->key); + if (entryPtr) { + Tcl_DeleteHashEntry(entryPtr); + } + } + ckfree((char *) handlePtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetFileInfo -- + * + * This function retrieves the platform specific file data and + * type from the file handle. + * + * Results: + * If typePtr is not NULL, sets *typePtr to the type of the file. + * Returns the platform specific file data. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +ClientData +Tcl_GetFileInfo(handle, typePtr) + Tcl_File handle; + int *typePtr; +{ + FileHandle *handlePtr = (FileHandle *) handle; + + if (typePtr) { + *typePtr = handlePtr->key.type; + } + return handlePtr->key.osHandle; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetNotifierData -- + * + * This function is used by the notifier to associate platform + * specific notifier information and a deletion procedure with + * a file handle. + * + * Results: + * None. + * + * Side effects: + * Updates the data and delProc slots in the file handle. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetNotifierData(handle, proc, data) + Tcl_File handle; + Tcl_FileFreeProc *proc; + ClientData data; +{ + FileHandle *handlePtr = (FileHandle *) handle; + handlePtr->proc = proc; + handlePtr->data = data; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetNotifierData -- + * + * This function is used by the notifier to retrieve the platform + * specific notifier information associated with a file handle. + * + * Results: + * Returns the data stored in a file handle by a previous call to + * Tcl_SetNotifierData, and places a pointer to the free proc + * in the location referred to by procPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +ClientData +Tcl_GetNotifierData(handle, procPtr) + Tcl_File handle; + Tcl_FileFreeProc **procPtr; +{ + FileHandle *handlePtr = (FileHandle *) handle; + if (procPtr != NULL) { + *procPtr = handlePtr->proc; + } + return handlePtr->data; +} + +/* + *---------------------------------------------------------------------- + * + * FileExitProc -- + * + * This function an exit handler that frees any memory allocated + * for the file handle table. + * + * Results: + * None. + * + * Side effects: + * Cleans up the file handle table. + * + *---------------------------------------------------------------------- + */ + +static void +FileExitProc(clientData) + ClientData clientData; /* Not used. */ +{ + Tcl_DeleteHashTable(&fileTable); + initialized = 0; +} diff --git a/tcl7.6/generic/tclFileName.c b/tcl7.6/generic/tclFileName.c new file mode 100644 index 0000000..548fcb0 --- /dev/null +++ b/tcl7.6/generic/tclFileName.c @@ -0,0 +1,1602 @@ +/* + * tclFileName.c -- + * + * This file contains routines for converting file names betwen + * native and network form. + * + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclFileName.c 1.24 96/08/21 12:49:02 + */ + +#include "tclInt.h" +#include "tclPort.h" +#include "tclRegexp.h" + +/* + * This variable indicates whether the cleanup procedure has been + * registered for this file yet. + */ + +static int initialized = 0; + +/* + * The following regular expression matches the root portion of a Windows + * absolute or volume relative path. It will match both UNC and drive relative + * paths. + */ + +#define WIN_ROOT_PATTERN "^(([a-zA-Z]:)|[/\\][/\\]+([^/\\]+)[/\\]+([^/\\]+)|([/\\]))([/\\])*" + +/* + * The following regular expression matches the root portion of a Macintosh + * absolute path. It will match degenerate Unix-style paths, tilde paths, + * Unix-style paths, and Mac paths. + */ + +#define MAC_ROOT_PATTERN "^((/+([.][.]?/+)*([.][.]?)?)|(~[^:/]*)(/[^:]*)?|(~[^:]*)(:.*)?|/+([.][.]?/+)*([^:/]+)(/[^:]*)?|([^:]+):.*)$" + +/* + * The following variables are used to hold precompiled regular expressions + * for use in filename matching. + */ + +static regexp *winRootPatternPtr = NULL; +static regexp *macRootPatternPtr = NULL; + +/* + * The following variable is set in the TclPlatformInit call to one + * of: TCL_PLATFORM_UNIX, TCL_PLATFORM_MAC, or TCL_PLATFORM_WINDOWS. + */ + +TclPlatformType tclPlatform = TCL_PLATFORM_UNIX; + +/* + * Prototypes for local procedures defined in this file: + */ + +static char * DoTildeSubst _ANSI_ARGS_((Tcl_Interp *interp, + char *user, Tcl_DString *resultPtr)); +static char * ExtractWinRoot _ANSI_ARGS_((char *path, + Tcl_DString *resultPtr, int offset)); +static void FileNameCleanup _ANSI_ARGS_((ClientData clientData)); +static int SkipToChar _ANSI_ARGS_((char **stringPtr, + char *match)); +static char * SplitMacPath _ANSI_ARGS_((char *path, + Tcl_DString *bufPtr)); +static char * SplitWinPath _ANSI_ARGS_((char *path, + Tcl_DString *bufPtr)); +static char * SplitUnixPath _ANSI_ARGS_((char *path, + Tcl_DString *bufPtr)); + +/* + *---------------------------------------------------------------------- + * + * FileNameCleanup -- + * + * This procedure is a Tcl_ExitProc used to clean up the static + * data structures used in this file. + * + * Results: + * None. + * + * Side effects: + * Deallocates storage used by the procedures in this file. + * + *---------------------------------------------------------------------- + */ + +static void +FileNameCleanup(clientData) + ClientData clientData; /* Not used. */ +{ + if (winRootPatternPtr != NULL) { + ckfree((char *)winRootPatternPtr); + } + if (macRootPatternPtr != NULL) { + ckfree((char *)macRootPatternPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * ExtractWinRoot -- + * + * Matches the root portion of a Windows path and appends it + * to the specified Tcl_DString. + * + * Results: + * Returns the position in the path immediately after the root + * including any trailing slashes. + * Appends a cleaned up version of the root to the Tcl_DString + * at the specified offest. + * + * Side effects: + * Modifies the specified Tcl_DString. + * + *---------------------------------------------------------------------- + */ + +static char * +ExtractWinRoot(path, resultPtr, offset) + char *path; /* Path to parse. */ + Tcl_DString *resultPtr; /* Buffer to hold result. */ + int offset; /* Offset in buffer where result should be + * stored. */ +{ + int length; + + /* + * Initialize the path name parser for Windows path names. + */ + + if (winRootPatternPtr == NULL) { + winRootPatternPtr = TclRegComp(WIN_ROOT_PATTERN); + if (!initialized) { + Tcl_CreateExitHandler(FileNameCleanup, NULL); + initialized = 1; + } + } + + /* + * Match the root portion of a Windows path name. + */ + + if (!TclRegExec(winRootPatternPtr, path, path)) { + return path; + } + + Tcl_DStringSetLength(resultPtr, offset); + + if (winRootPatternPtr->startp[2] != NULL) { + Tcl_DStringAppend(resultPtr, winRootPatternPtr->startp[2], 2); + if (winRootPatternPtr->startp[6] != NULL) { + Tcl_DStringAppend(resultPtr, "/", 1); + } + } else if (winRootPatternPtr->startp[4] != NULL) { + Tcl_DStringAppend(resultPtr, "//", 2); + length = winRootPatternPtr->endp[3] + - winRootPatternPtr->startp[3]; + Tcl_DStringAppend(resultPtr, winRootPatternPtr->startp[3], length); + Tcl_DStringAppend(resultPtr, "/", 1); + length = winRootPatternPtr->endp[4] + - winRootPatternPtr->startp[4]; + Tcl_DStringAppend(resultPtr, winRootPatternPtr->startp[4], length); + } else { + Tcl_DStringAppend(resultPtr, "/", 1); + } + return winRootPatternPtr->endp[0]; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetPathType -- + * + * Determines whether a given path is relative to the current + * directory, relative to the current volume, or absolute. + * + * Results: + * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or + * TCL_PATH_VOLUME_RELATIVE. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_PathType +Tcl_GetPathType(path) + char *path; +{ + Tcl_PathType type = TCL_PATH_ABSOLUTE; + + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + /* + * Paths that begin with / or ~ are absolute. + */ + + if ((path[0] != '/') && (path[0] != '~')) { + type = TCL_PATH_RELATIVE; + } + break; + + case TCL_PLATFORM_MAC: + if (path[0] == ':') { + type = TCL_PATH_RELATIVE; + } else if (path[0] != '~') { + + /* + * Since we have eliminated the easy cases, use the + * root pattern to look for the other types. + */ + + if (!macRootPatternPtr) { + macRootPatternPtr = TclRegComp(MAC_ROOT_PATTERN); + if (!initialized) { + Tcl_CreateExitHandler(FileNameCleanup, NULL); + initialized = 1; + } + } + if (!TclRegExec(macRootPatternPtr, path, path) + || (macRootPatternPtr->startp[2] != NULL)) { + type = TCL_PATH_RELATIVE; + } + } + break; + + case TCL_PLATFORM_WINDOWS: + if (path[0] != '~') { + + /* + * Since we have eliminated the easy cases, check for + * drive relative paths using the regular expression. + */ + + if (!winRootPatternPtr) { + winRootPatternPtr = TclRegComp(WIN_ROOT_PATTERN); + if (!initialized) { + Tcl_CreateExitHandler(FileNameCleanup, NULL); + initialized = 1; + } + } + if (TclRegExec(winRootPatternPtr, path, path)) { + if (winRootPatternPtr->startp[5] + || (winRootPatternPtr->startp[2] + && !(winRootPatternPtr->startp[6]))) { + type = TCL_PATH_VOLUME_RELATIVE; + } + } else { + type = TCL_PATH_RELATIVE; + } + } + break; + } + return type; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SplitPath -- + * + * Split a path into a list of path components. The first element + * of the list will have the same path type as the original path. + * + * Results: + * Returns a standard Tcl result. The interpreter result contains + * a list of path components. + * *argvPtr will be filled in with the address of an array + * whose elements point to the elements of path, 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 path elements. + * The caller must eventually free this memory by calling ckfree() + * on *argvPtr. Note: *argvPtr and *argcPtr are only modified + * if the procedure returns normally. + * + * Side effects: + * Allocates memory. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SplitPath(path, argcPtr, argvPtr) + char *path; /* Pointer to string containing a path. */ + int *argcPtr; /* Pointer to location to fill in with + * the number of elements in the path. */ + char ***argvPtr; /* Pointer to place to store pointer to array + * of pointers to path elements. */ +{ + int i, size; + char *p; + Tcl_DString buffer; + Tcl_DStringInit(&buffer); + + /* + * Perform platform specific splitting. These routines will leave the + * result in the specified buffer. Individual elements are terminated + * with a null character. + */ + + p = NULL; /* Needed only to prevent gcc warnings. */ + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + p = SplitUnixPath(path, &buffer); + break; + + case TCL_PLATFORM_WINDOWS: + p = SplitWinPath(path, &buffer); + break; + + case TCL_PLATFORM_MAC: + p = SplitMacPath(path, &buffer); + break; + } + + /* + * Compute the number of elements in the result. + */ + + size = Tcl_DStringLength(&buffer); + *argcPtr = 0; + for (i = 0; i < size; i++) { + if (p[i] == '\0') { + (*argcPtr)++; + } + } + + /* + * Allocate a buffer large enough to hold the contents of the + * DString plus the argv pointers and the terminating NULL pointer. + */ + + *argvPtr = (char **) ckalloc((unsigned) + ((((*argcPtr) + 1) * sizeof(char *)) + size)); + + /* + * Position p after the last argv pointer and copy the contents of + * the DString. + */ + + p = (char *) &(*argvPtr)[(*argcPtr) + 1]; + memcpy((VOID *) p, (VOID *) Tcl_DStringValue(&buffer), (size_t) size); + + /* + * Now set up the argv pointers. + */ + + for (i = 0; i < *argcPtr; i++) { + (*argvPtr)[i] = p; + while ((*p++) != '\0') {} + } + (*argvPtr)[i] = NULL; + + Tcl_DStringFree(&buffer); +} + +/* + *---------------------------------------------------------------------- + * + * SplitUnixPath -- + * + * This routine is used by Tcl_SplitPath to handle splitting + * Unix paths. + * + * Results: + * Stores a null separated array of strings in the specified + * Tcl_DString. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +SplitUnixPath(path, bufPtr) + char *path; /* Pointer to string containing a path. */ + Tcl_DString *bufPtr; /* Pointer to DString to use for the result. */ +{ + int length; + char *p, *elementStart; + + /* + * Deal with the root directory as a special case. + */ + + if (path[0] == '/') { + Tcl_DStringAppend(bufPtr, "/", 2); + p = path+1; + } else { + p = path; + } + + /* + * Split on slashes. Embedded elements that start with tilde will be + * prefixed with "./" so they are not affected by tilde substitution. + */ + + for (;;) { + elementStart = p; + while ((*p != '\0') && (*p != '/')) { + p++; + } + length = p - elementStart; + if (length > 0) { + if ((elementStart[0] == '~') && (elementStart != path)) { + Tcl_DStringAppend(bufPtr, "./", 2); + } + Tcl_DStringAppend(bufPtr, elementStart, length); + Tcl_DStringAppend(bufPtr, "", 1); + } + if (*p++ == '\0') { + break; + } + } + return Tcl_DStringValue(bufPtr); +} + +/* + *---------------------------------------------------------------------- + * + * SplitWinPath -- + * + * This routine is used by Tcl_SplitPath to handle splitting + * Windows paths. + * + * Results: + * Stores a null separated array of strings in the specified + * Tcl_DString. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +SplitWinPath(path, bufPtr) + char *path; /* Pointer to string containing a path. */ + Tcl_DString *bufPtr; /* Pointer to DString to use for the result. */ +{ + int length; + char *p, *elementStart; + + p = ExtractWinRoot(path, bufPtr, 0); + + /* + * Terminate the root portion, if we matched something. + */ + + if (p != path) { + Tcl_DStringAppend(bufPtr, "", 1); + } + + /* + * Split on slashes. Embedded elements that start with tilde will be + * prefixed with "./" so they are not affected by tilde substitution. + */ + + do { + elementStart = p; + while ((*p != '\0') && (*p != '/') && (*p != '\\')) { + p++; + } + length = p - elementStart; + if (length > 0) { + if ((elementStart[0] == '~') && (elementStart != path)) { + Tcl_DStringAppend(bufPtr, "./", 2); + } + Tcl_DStringAppend(bufPtr, elementStart, length); + Tcl_DStringAppend(bufPtr, "", 1); + } + } while (*p++ != '\0'); + + return Tcl_DStringValue(bufPtr); +} + +/* + *---------------------------------------------------------------------- + * + * SplitMacPath -- + * + * This routine is used by Tcl_SplitPath to handle splitting + * Macintosh paths. + * + * Results: + * Returns a newly allocated argv array. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +SplitMacPath(path, bufPtr) + char *path; /* Pointer to string containing a path. */ + Tcl_DString *bufPtr; /* Pointer to DString to use for the result. */ +{ + int isMac = 0; /* 1 if is Mac-style, 0 if Unix-style path. */ + int i, length; + char *p, *elementStart; + + /* + * Initialize the path name parser for Macintosh path names. + */ + + if (macRootPatternPtr == NULL) { + macRootPatternPtr = TclRegComp(MAC_ROOT_PATTERN); + if (!initialized) { + Tcl_CreateExitHandler(FileNameCleanup, NULL); + initialized = 1; + } + } + + /* + * Match the root portion of a Mac path name. + */ + + i = 0; /* Needed only to prevent gcc warnings. */ + if (TclRegExec(macRootPatternPtr, path, path) == 1) { + /* + * Treat degenerate absolute paths like / and /../.. as + * Mac relative file names for lack of anything else to do. + */ + + if (macRootPatternPtr->startp[2] != NULL) { + Tcl_DStringAppend(bufPtr, ":", 1); + Tcl_DStringAppend(bufPtr, path, macRootPatternPtr->endp[0] + - macRootPatternPtr->startp[0] + 1); + return Tcl_DStringValue(bufPtr); + } + + if (macRootPatternPtr->startp[5] != NULL) { + + /* + * Unix-style tilde prefixed paths. + */ + + isMac = 0; + i = 5; + } else if (macRootPatternPtr->startp[7] != NULL) { + + /* + * Mac-style tilde prefixed paths. + */ + + isMac = 1; + i = 7; + } else if (macRootPatternPtr->startp[10] != NULL) { + + /* + * Normal Unix style paths. + */ + + isMac = 0; + i = 10; + } else if (macRootPatternPtr->startp[12] != NULL) { + + /* + * Normal Mac style paths. + */ + + isMac = 1; + i = 12; + } + + length = macRootPatternPtr->endp[i] + - macRootPatternPtr->startp[i]; + + /* + * Append the element and terminate it with a : and a null. Note that + * we are forcing the DString to contain an extra null at the end. + */ + + Tcl_DStringAppend(bufPtr, macRootPatternPtr->startp[i], length); + Tcl_DStringAppend(bufPtr, ":", 2); + p = macRootPatternPtr->endp[i]; + } else { + isMac = (strchr(path, ':') != NULL); + p = path; + } + + if (isMac) { + + /* + * p is pointing at the first colon in the path. There + * will always be one, since this is a Mac-style path. + */ + + elementStart = p++; + while ((p = strchr(p, ':')) != NULL) { + length = p - elementStart; + if (length == 1) { + while (*p == ':') { + Tcl_DStringAppend(bufPtr, "::", 3); + elementStart = p++; + } + } else { + /* + * If this is a simple component, drop the leading colon. + */ + + if ((elementStart[1] != '~') + && (strchr(elementStart+1, '/') == NULL)) { + elementStart++; + length--; + } + Tcl_DStringAppend(bufPtr, elementStart, length); + Tcl_DStringAppend(bufPtr, "", 1); + elementStart = p++; + } + } + if (elementStart[1] != '\0' || elementStart == path) { + if ((elementStart[1] != '~') && (elementStart[1] != '\0') + && (strchr(elementStart+1, '/') == NULL)) { + elementStart++; + } + Tcl_DStringAppend(bufPtr, elementStart, -1); + Tcl_DStringAppend(bufPtr, "", 1); + } + } else { + + /* + * Split on slashes, suppress extra /'s, and convert .. to ::. + */ + + for (;;) { + elementStart = p; + while ((*p != '\0') && (*p != '/')) { + p++; + } + length = p - elementStart; + if (length > 0) { + if ((length == 1) && (elementStart[0] == '.')) { + Tcl_DStringAppend(bufPtr, ":", 2); + } else if ((length == 2) && (elementStart[0] == '.') + && (elementStart[1] == '.')) { + Tcl_DStringAppend(bufPtr, "::", 3); + } else { + if (*elementStart == '~') { + Tcl_DStringAppend(bufPtr, ":", 1); + } + Tcl_DStringAppend(bufPtr, elementStart, length); + Tcl_DStringAppend(bufPtr, "", 1); + } + } + if (*p++ == '\0') { + break; + } + } + } + return Tcl_DStringValue(bufPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_JoinPath -- + * + * Combine a list of paths in a platform specific manner. + * + * Results: + * Appends the joined path to the end of the specified + * returning a pointer to the resulting string. Note that + * the Tcl_DString must already be initialized. + * + * Side effects: + * Modifies the Tcl_DString. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_JoinPath(argc, argv, resultPtr) + int argc; + char **argv; + Tcl_DString *resultPtr; /* Pointer to previously initialized DString. */ +{ + int oldLength, length, i, needsSep; + Tcl_DString buffer; + char *p, c, *dest; + + Tcl_DStringInit(&buffer); + oldLength = Tcl_DStringLength(resultPtr); + + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + for (i = 0; i < argc; i++) { + p = argv[i]; + /* + * If the path is absolute, reset the result buffer. + * Consume any duplicate leading slashes or a ./ in + * front of a tilde prefixed path that isn't at the + * beginning of the path. + */ + + if (*p == '/') { + Tcl_DStringSetLength(resultPtr, oldLength); + Tcl_DStringAppend(resultPtr, "/", 1); + while (*p == '/') { + p++; + } + } else if (*p == '~') { + Tcl_DStringSetLength(resultPtr, oldLength); + } else if ((Tcl_DStringLength(resultPtr) != oldLength) + && (p[0] == '.') && (p[1] == '/') + && (p[2] == '~')) { + p += 2; + } + + if (*p == '\0') { + continue; + } + + /* + * Append a separator if needed. + */ + + length = Tcl_DStringLength(resultPtr); + if ((length != oldLength) + && (Tcl_DStringValue(resultPtr)[length-1] != '/')) { + Tcl_DStringAppend(resultPtr, "/", 1); + length++; + } + + /* + * Append the element, eliminating duplicate and trailing + * slashes. + */ + + Tcl_DStringSetLength(resultPtr, (int) (length + strlen(p))); + dest = Tcl_DStringValue(resultPtr) + length; + for (; *p != '\0'; p++) { + if (*p == '/') { + while (p[1] == '/') { + p++; + } + if (p[1] != '\0') { + *dest++ = '/'; + } + } else { + *dest++ = *p; + } + } + length = dest - Tcl_DStringValue(resultPtr); + Tcl_DStringSetLength(resultPtr, length); + } + break; + + case TCL_PLATFORM_WINDOWS: + /* + * Iterate over all of the components. If a component is + * absolute, then reset the result and start building the + * path from the current component on. + */ + + for (i = 0; i < argc; i++) { + p = ExtractWinRoot(argv[i], resultPtr, oldLength); + length = Tcl_DStringLength(resultPtr); + + /* + * If the pointer didn't move, then this is a relative path + * or a tilde prefixed path. + */ + + if (p == argv[i]) { + /* + * Remove the ./ from tilde prefixed elements unless + * it is the first component. + */ + + if ((length != oldLength) + && (p[0] == '.') + && ((p[1] == '/') || (p[1] == '\\')) + && (p[2] == '~')) { + p += 2; + } else if (*p == '~') { + Tcl_DStringSetLength(resultPtr, oldLength); + length = oldLength; + } + } + + if (*p != '\0') { + /* + * Check to see if we need to append a separator. + */ + + + if (length != oldLength) { + c = Tcl_DStringValue(resultPtr)[length-1]; + if ((c != '/') && (c != ':')) { + Tcl_DStringAppend(resultPtr, "/", 1); + } + } + + /* + * Append the element, eliminating duplicate and + * trailing slashes. + */ + + length = Tcl_DStringLength(resultPtr); + Tcl_DStringSetLength(resultPtr, (int) (length + strlen(p))); + dest = Tcl_DStringValue(resultPtr) + length; + for (; *p != '\0'; p++) { + if ((*p == '/') || (*p == '\\')) { + while ((p[1] == '/') || (p[1] == '\\')) { + p++; + } + if (p[1] != '\0') { + *dest++ = '/'; + } + } else { + *dest++ = *p; + } + } + length = dest - Tcl_DStringValue(resultPtr); + Tcl_DStringSetLength(resultPtr, length); + } + } + break; + + case TCL_PLATFORM_MAC: + needsSep = 1; + for (i = 0; i < argc; i++) { + Tcl_DStringSetLength(&buffer, 0); + p = SplitMacPath(argv[i], &buffer); + if ((*p != ':') && (*p != '\0') + && (strchr(p, ':') != NULL)) { + Tcl_DStringSetLength(resultPtr, oldLength); + length = strlen(p); + Tcl_DStringAppend(resultPtr, p, length); + needsSep = 0; + p += length+1; + } + + /* + * Now append the rest of the path elements, skipping + * : unless it is the first element of the path, and + * watching out for :: et al. so we don't end up with + * too many colons in the result. + */ + + for (; *p != '\0'; p += length+1) { + if (p[0] == ':' && p[1] == '\0') { + if (Tcl_DStringLength(resultPtr) != oldLength) { + p++; + } else { + needsSep = 0; + } + } else { + c = p[1]; + if (*p == ':') { + if (!needsSep) { + p++; + } + } else { + if (needsSep) { + Tcl_DStringAppend(resultPtr, ":", 1); + } + } + needsSep = (c == ':') ? 0 : 1; + } + length = strlen(p); + Tcl_DStringAppend(resultPtr, p, length); + } + } + break; + + } + Tcl_DStringFree(&buffer); + return Tcl_DStringValue(resultPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_TranslateFileName -- + * + * Converts a file name into a form usable by the native system + * interfaces. If the name starts with a tilde, it will 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 + * name, then an error message is left in interp->result + * and the return value is NULL. The result will be stored + * in bufferPtr; the caller must call Tcl_DStringFree(bufferPtr) + * to free the name if the return value was not NULL. + * + * Side effects: + * Information may be left in bufferPtr. + * + *---------------------------------------------------------------------- */ + +char * +Tcl_TranslateFileName(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 "~" (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. */ +{ + register char *p; + + /* + * Handle tilde substitutions, if needed. + */ + + if (name[0] == '~') { + int argc, length; + char **argv; + Tcl_DString temp; + + Tcl_SplitPath(name, &argc, &argv); + + /* + * Strip the trailing ':' off of a Mac path + * before passing the user name to DoTildeSubst. + */ + + if (tclPlatform == TCL_PLATFORM_MAC) { + length = strlen(argv[0]); + argv[0][length-1] = '\0'; + } + + Tcl_DStringInit(&temp); + argv[0] = DoTildeSubst(interp, argv[0]+1, &temp); + if (argv[0] == NULL) { + Tcl_DStringFree(&temp); + ckfree((char *)argv); + return NULL; + } + Tcl_DStringInit(bufferPtr); + Tcl_JoinPath(argc, argv, bufferPtr); + Tcl_DStringFree(&temp); + ckfree((char*)argv); + } else { + Tcl_DStringInit(bufferPtr); + Tcl_JoinPath(1, &name, bufferPtr); + } + + /* + * Convert forward slashes to backslashes in Windows paths because + * some system interfaces don't accept forward slashes. + */ + + if (tclPlatform == TCL_PLATFORM_WINDOWS) { + for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) { + if (*p == '/') { + *p = '\\'; + } + } + } + return Tcl_DStringValue(bufferPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclGetExtension -- + * + * This function returns a pointer to the beginning of the + * extension part of a file name. + * + * Results: + * Returns a pointer into name which indicates where the extension + * starts. If there is no extension, returns NULL. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +TclGetExtension(name) + char *name; /* File name to parse. */ +{ + char *p, *lastSep; + + /* + * First find the last directory separator. + */ + + lastSep = NULL; /* Needed only to prevent gcc warnings. */ + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + lastSep = strrchr(name, '/'); + break; + + case TCL_PLATFORM_MAC: + if (strchr(name, ':') == NULL) { + lastSep = strrchr(name, '/'); + } else { + lastSep = strrchr(name, ':'); + } + break; + + case TCL_PLATFORM_WINDOWS: + lastSep = NULL; + for (p = name; *p != '\0'; p++) { + if (strchr("/\\:", *p) != NULL) { + lastSep = p; + } + } + break; + } + p = strrchr(name, '.'); + if ((p != NULL) && (lastSep != NULL) + && (lastSep > p)) { + p = NULL; + } + + /* + * Back up to the first period in a series of contiguous dots. + * This is needed so foo..o will be split on the first dot. + */ + + if (p != NULL) { + while ((p > name) && *(p-1) == '.') { + p--; + } + } + return p; +} + +/* + *---------------------------------------------------------------------- + * + * DoTildeSubst -- + * + * Given a string following a tilde, this routine returns the + * corresponding home directory. + * + * Results: + * The result is a pointer to a static string containing the home + * directory in native format. If there was an error in processing + * the substitution, then an error message is left in interp->result + * and the return value is NULL. On success, the results are appended + * to resultPtr, and the contents of resultPtr are returned. + * + * Side effects: + * Information may be left in resultPtr. + * + *---------------------------------------------------------------------- + */ + +static char * +DoTildeSubst(interp, user, resultPtr) + Tcl_Interp *interp; /* Interpreter in which to store error + * message (if necessary). */ + char *user; /* Name of user whose home directory should be + * substituted, or "" for current user. */ + Tcl_DString *resultPtr; /* May be used to hold result. Must not hold + * anything at the time of the call, and need + * not even be initialized. */ +{ + char *dir; + + if (*user == '\0') { + dir = TclGetEnv("HOME"); + if (dir == NULL) { + if (interp) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "couldn't find HOME environment ", + "variable to expand path", (char *) NULL); + } + return NULL; + } + Tcl_JoinPath(1, &dir, resultPtr); + } else { + if (TclGetUserHome(user, resultPtr) == NULL) { + if (interp) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "user \"", user, "\" doesn't exist", + (char *) NULL); + } + return NULL; + } + } + return resultPtr->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, noComplain, firstArg; + char c; + int result = TCL_OK; + Tcl_DString buffer; + char *separators, *head, *tail; + + 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) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?switches? name ?name ...?\"", (char *) NULL); + return TCL_ERROR; + } + + Tcl_DStringInit(&buffer); + separators = NULL; /* Needed only to prevent gcc warnings. */ + for (i = firstArg; i < argc; i++) { + head = tail = ""; + + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + separators = "/"; + break; + case TCL_PLATFORM_WINDOWS: + separators = "/\\:"; + break; + case TCL_PLATFORM_MAC: + separators = (strchr(argv[i], ':') == NULL) ? "/" : ":"; + break; + } + + Tcl_DStringSetLength(&buffer, 0); + + /* + * Perform tilde substitution, if needed. + */ + + if (argv[i][0] == '~') { + char *p; + + /* + * Find the first path separator after the tilde. + */ + + for (tail = argv[i]; *tail != '\0'; tail++) { + if (*tail == '\\') { + if (strchr(separators, tail[1]) != NULL) { + break; + } + } else if (strchr(separators, *tail) != NULL) { + break; + } + } + + /* + * Determine the home directory for the specified user. Note that + * we don't allow special characters in the user name. + */ + + c = *tail; + *tail = '\0'; + p = strpbrk(argv[i]+1, "\\[]*?{}"); + if (p == NULL) { + head = DoTildeSubst(interp, argv[i]+1, &buffer); + } else { + if (!noComplain) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "globbing characters not ", + "supported in user names", (char *) NULL); + } + head = NULL; + } + *tail = c; + if (head == NULL) { + if (noComplain) { + Tcl_ResetResult(interp); + continue; + } else { + result = TCL_ERROR; + goto done; + } + } + if (head != Tcl_DStringValue(&buffer)) { + Tcl_DStringAppend(&buffer, head, -1); + } + } else { + tail = argv[i]; + } + + result = TclDoGlob(interp, separators, &buffer, tail); + if (result != TCL_OK) { + if (noComplain) { + Tcl_ResetResult(interp); + continue; + } else { + goto done; + } + } + } + + 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); + result = TCL_ERROR; + } +done: + Tcl_DStringFree(&buffer); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * SkipToChar -- + * + * This function traverses a glob pattern looking for the next + * unquoted occurance of the specified character at the same braces + * nesting level. + * + * Results: + * Updates stringPtr to point to the matching character, or to + * the end of the string if nothing matched. The return value + * is 1 if a match was found at the top level, otherwise it is 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +SkipToChar(stringPtr, match) + char **stringPtr; /* Pointer string to check. */ + char *match; /* Pointer to character to find. */ +{ + int quoted, level; + register char *p; + + quoted = 0; + level = 0; + + for (p = *stringPtr; *p != '\0'; p++) { + if (quoted) { + quoted = 0; + continue; + } + if ((level == 0) && (*p == *match)) { + *stringPtr = p; + return 1; + } + if (*p == '{') { + level++; + } else if (*p == '}') { + level--; + } else if (*p == '\\') { + quoted = 1; + } + } + *stringPtr = p; + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclDoGlob -- + * + * 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. The directory and + * remainder are assumed to be native format paths. + * + * 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. + * + *---------------------------------------------------------------------- + */ + +int +TclDoGlob(interp, separators, headPtr, tail) + Tcl_Interp *interp; /* Interpreter to use for error reporting + * (e.g. unmatched brace). */ + char *separators; /* String containing separator characters + * that should be used to identify globbing + * boundaries. */ + Tcl_DString *headPtr; /* Completely expanded prefix. */ + char *tail; /* The unexpanded remainder of the path. */ +{ + int level, baseLength, quoted, count; + int result = TCL_OK; + char *p, *openBrace, *closeBrace, *name, savedChar; + char lastChar = 0; + int length = Tcl_DStringLength(headPtr); + + if (length > 0) { + lastChar = Tcl_DStringValue(headPtr)[length-1]; + } + + /* + * Consume any leading directory separators, leaving tail pointing + * just past the last initial separator. + */ + + count = 0; + name = tail; + for (; *tail != '\0'; tail++) { + if ((*tail == '\\') && (strchr(separators, tail[1]) != NULL)) { + tail++; + } else if (strchr(separators, *tail) == NULL) { + break; + } + count++; + } + + /* + * Deal with path separators. On the Mac, we have to watch out + * for multiple separators, since they are special in Mac-style + * paths. + */ + + switch (tclPlatform) { + case TCL_PLATFORM_MAC: + if (*separators == '/') { + if (((length == 0) && (count == 0)) + || ((length > 0) && (lastChar != ':'))) { + Tcl_DStringAppend(headPtr, ":", 1); + } + } else { + if (count == 0) { + if ((length > 0) && (lastChar != ':')) { + Tcl_DStringAppend(headPtr, ":", 1); + } + } else { + if (lastChar == ':') { + count--; + } + while (count-- > 0) { + Tcl_DStringAppend(headPtr, ":", 1); + } + } + } + break; + case TCL_PLATFORM_WINDOWS: + /* + * If this is a drive relative path, add the colon and the + * trailing slash if needed. Otherwise add the slash if + * this is the first absolute element, or a later relative + * element. Add an extra slash if this is a UNC path. + */ + + if (*name == ':') { + Tcl_DStringAppend(headPtr, ":", 1); + if (count > 1) { + Tcl_DStringAppend(headPtr, "/", 1); + } + } else if ((*tail != '\0') + && (((length > 0) + && (strchr(separators, lastChar) == NULL)) + || ((length == 0) && (count > 0)))) { + Tcl_DStringAppend(headPtr, "/", 1); + if ((length == 0) && (count > 1)) { + Tcl_DStringAppend(headPtr, "/", 1); + } + } + + break; + case TCL_PLATFORM_UNIX: + /* + * Add a separator if this is the first absolute element, or + * a later relative element. + */ + + if ((*tail != '\0') + && (((length > 0) + && (strchr(separators, lastChar) == NULL)) + || ((length == 0) && (count > 0)))) { + Tcl_DStringAppend(headPtr, "/", 1); + } + break; + } + + /* + * Look for the first matching pair of braces or the first + * directory separator that is not inside a pair of braces. + */ + + openBrace = closeBrace = NULL; + level = 0; + quoted = 0; + for (p = tail; *p != '\0'; p++) { + if (quoted) { + quoted = 0; + } else if (*p == '\\') { + quoted = 1; + if (strchr(separators, p[1]) != NULL) { + break; /* Quoted directory separator. */ + } + } else if (strchr(separators, *p) != NULL) { + break; /* Unquoted directory separator. */ + } else if (*p == '{') { + openBrace = p; + p++; + if (SkipToChar(&p, "}")) { + closeBrace = p; /* Balanced braces. */ + break; + } + Tcl_ResetResult(interp); + interp->result = "unmatched open-brace in file name"; + return TCL_ERROR; + } else if (*p == '}') { + Tcl_ResetResult(interp); + interp->result = "unmatched close-brace in file name"; + return TCL_ERROR; + } + } + + /* + * Substitute the alternate patterns from the braces and recurse. + */ + + if (openBrace != NULL) { + char *element; + Tcl_DString newName; + Tcl_DStringInit(&newName); + + /* + * For each element within in the outermost pair of braces, + * append the element and the remainder to the fixed portion + * before the first brace and recursively call TclDoGlob. + */ + + Tcl_DStringAppend(&newName, tail, openBrace-tail); + baseLength = Tcl_DStringLength(&newName); + length = Tcl_DStringLength(headPtr); + *closeBrace = '\0'; + for (p = openBrace; p != closeBrace; ) { + p++; + element = p; + SkipToChar(&p, ","); + Tcl_DStringSetLength(headPtr, length); + Tcl_DStringSetLength(&newName, baseLength); + Tcl_DStringAppend(&newName, element, p-element); + Tcl_DStringAppend(&newName, closeBrace+1, -1); + result = TclDoGlob(interp, separators, + headPtr, Tcl_DStringValue(&newName)); + if (result != TCL_OK) { + break; + } + } + *closeBrace = '}'; + Tcl_DStringFree(&newName); + return result; + } + + /* + * At this point, there are no more brace substitutions to perform on + * this path component. The variable p is pointing at a quoted or + * unquoted directory separator or the end of the string. So we need + * to check for special globbing characters in the current pattern. + */ + + savedChar = *p; + *p = '\0'; + + if (strpbrk(tail, "*[]?\\") != NULL) { + *p = savedChar; + /* + * Look for matching files in the current directory. The + * implementation of this function is platform specific, but may + * recursively call TclDoGlob. For each file that matches, it will + * add the match onto the interp->result, or call TclDoGlob if there + * are more characters to be processed. + */ + + return TclMatchFiles(interp, separators, headPtr, tail, p); + } + *p = savedChar; + Tcl_DStringAppend(headPtr, tail, p-tail); + if (*p != '\0') { + return TclDoGlob(interp, separators, headPtr, p); + } + + /* + * There are no more wildcards in the pattern and no more unprocessed + * characters in the tail, so now we can construct the path and verify + * the existence of the file. + */ + + switch (tclPlatform) { + case TCL_PLATFORM_MAC: + if (strchr(Tcl_DStringValue(headPtr), ':') == NULL) { + Tcl_DStringAppend(headPtr, ":", 1); + } + name = Tcl_DStringValue(headPtr); + if (access(name, F_OK) == 0) { + if ((name[1] != '\0') && (strchr(name+1, ':') == NULL)) { + Tcl_AppendElement(interp, name+1); + } else { + Tcl_AppendElement(interp, name); + } + } + break; + case TCL_PLATFORM_WINDOWS: { + int exists; + /* + * We need to convert slashes to backslashes before checking + * for the existence of the file. Once we are done, we need + * to convert the slashes back. + */ + + if (Tcl_DStringLength(headPtr) == 0) { + if (((*name == '\\') && (name[1] == '/' || name[1] == '\\')) + || (*name == '/')) { + Tcl_DStringAppend(headPtr, "\\", 1); + } else { + Tcl_DStringAppend(headPtr, ".", 1); + } + } else { + for (p = Tcl_DStringValue(headPtr); *p != '\0'; p++) { + if (*p == '/') { + *p = '\\'; + } + } + } + name = Tcl_DStringValue(headPtr); + exists = (access(name, F_OK) == 0); + for (p = name; *p != '\0'; p++) { + if (*p == '\\') { + *p = '/'; + } + } + if (exists) { + Tcl_AppendElement(interp, name); + } + break; + } + case TCL_PLATFORM_UNIX: + if (Tcl_DStringLength(headPtr) == 0) { + if ((*name == '\\' && name[1] == '/') || (*name == '/')) { + Tcl_DStringAppend(headPtr, "/", 1); + } else { + Tcl_DStringAppend(headPtr, ".", 1); + } + } + name = Tcl_DStringValue(headPtr); + if (access(name, F_OK) == 0) { + Tcl_AppendElement(interp, name); + } + break; + } + + return TCL_OK; +} diff --git a/tcl7.3/tclGet.c b/tcl7.6/generic/tclGet.c similarity index 72% rename from tcl7.3/tclGet.c rename to tcl7.6/generic/tclGet.c index fe280e6..9e208b9 100644 --- a/tcl7.3/tclGet.c +++ b/tcl7.6/generic/tclGet.c @@ -6,31 +6,17 @@ * booleans, doing syntax checking along the way. * * Copyright (c) 1990-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tclGet.c 1.24 96/02/15 11:42:47 */ -#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" +#include "tclPort.h" + /* *---------------------------------------------------------------------- @@ -67,23 +53,40 @@ Tcl_GetInt(interp, string, intPtr) * to handle sign characters; it won't in some implementations. */ + errno = 0; for (p = string; isspace(UCHAR(*p)); p++) { /* Empty loop body. */ } if (*p == '-') { - i = -strtoul(p+1, &end, 0); + p++; + i = -(int)strtoul(p, &end, 0); } else if (*p == '+') { - i = strtoul(p+1, &end, 0); + p++; + i = strtoul(p, &end, 0); } else { i = strtoul(p, &end, 0); } + if (end == p) { + badInteger: + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "expected integer but got \"", string, + "\"", (char *) NULL); + } + return TCL_ERROR; + } + if (errno == ERANGE) { + if (interp != (Tcl_Interp *) NULL) { + interp->result = "integer value too large to represent"; + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", + interp->result, (char *) NULL); + } + return TCL_ERROR; + } 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; + if (*end != 0) { + goto badInteger; } *intPtr = i; return TCL_OK; @@ -119,14 +122,28 @@ Tcl_GetDouble(interp, string, doublePtr) char *end; double d; + errno = 0; d = strtod(string, &end); - while ((*end != '\0') && isspace(UCHAR(*end))) { + if (end == string) { + badDouble: + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, + "expected floating-point number but got \"", + string, "\"", (char *) NULL); + } + return TCL_ERROR; + } + if (errno != 0) { + if (interp != (Tcl_Interp *) NULL) { + TclExprFloatError(interp, d); + } + return TCL_ERROR; + } + 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; + if (*end != 0) { + goto badDouble; } *doublePtr = d; return TCL_OK; @@ -161,9 +178,9 @@ Tcl_GetBoolean(interp, string, boolPtr) int *boolPtr; /* Place to store converted result, which * will be 0 or 1. */ { - char c; - char lowerCase[10]; - int i, length; + int i; + char lowerCase[10], c; + size_t length; /* * Convert the input string to all lower-case. @@ -175,7 +192,7 @@ Tcl_GetBoolean(interp, string, boolPtr) break; } if ((c >= 'A') && (c <= 'Z')) { - c += 'a' - 'A'; + c += (char) ('a' - 'A'); } lowerCase[i] = c; } @@ -200,10 +217,15 @@ Tcl_GetBoolean(interp, string, boolPtr) *boolPtr = 1; } else if (strncmp(lowerCase, "off", length) == 0) { *boolPtr = 0; + } else { + goto badBoolean; } } else { - Tcl_AppendResult(interp, "expected boolean value but got \"", - string, "\"", (char *) NULL); + badBoolean: + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "expected boolean value but got \"", + string, "\"", (char *) NULL); + } return TCL_ERROR; } return TCL_OK; diff --git a/tcl7.6/generic/tclGetDate.y b/tcl7.6/generic/tclGetDate.y new file mode 100644 index 0000000..a4d027c --- /dev/null +++ b/tcl7.6/generic/tclGetDate.y @@ -0,0 +1,935 @@ +/* + * tclGetDate.y -- + * + * Contains yacc grammar for parsing date and time strings + * based on getdate.y. + * + * Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans. + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclGetDate.y 1.28 96/10/12 17:06:01 + */ + +%{ +/* + * tclDate.c -- + * + * This file is generated from a yacc grammar defined in + * the file tclGetDate.y + * + * Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans. + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCSID + */ + +#include "tclInt.h" +#include "tclPort.h" + +#ifdef MAC_TCL +# define EPOCH 1904 +# define START_OF_TIME 1904 +# define END_OF_TIME 2039 +#else +# define EPOCH 1970 +# define START_OF_TIME 1902 +# define END_OF_TIME 2037 +#endif + +#define HOUR(x) ((int) (60 * x)) +#define SECSPERDAY (24L * 60L * 60L) + + +/* + * An entry in the lexical lookup table. + */ +typedef struct _TABLE { + char *name; + int type; + time_t value; +} TABLE; + + +/* + * Daylight-savings mode: on, off, or not yet known. + */ +typedef enum _DSTMODE { + DSTon, DSToff, DSTmaybe +} DSTMODE; + +/* + * Meridian: am, pm, or 24-hour style. + */ +typedef enum _MERIDIAN { + MERam, MERpm, MER24 +} MERIDIAN; + + +/* + * Global variables. We could get rid of most of these by using a good + * union as the yacc stack. (This routine was originally written before + * yacc had the %union construct.) Maybe someday; right now we only use + * the %union very rarely. + */ +static char *yyInput; +static DSTMODE yyDSTmode; +static time_t yyDayOrdinal; +static time_t yyDayNumber; +static int yyHaveDate; +static int yyHaveDay; +static int yyHaveRel; +static int yyHaveTime; +static int yyHaveZone; +static time_t yyTimezone; +static time_t yyDay; +static time_t yyHour; +static time_t yyMinutes; +static time_t yyMonth; +static time_t yySeconds; +static time_t yyYear; +static MERIDIAN yyMeridian; +static time_t yyRelMonth; +static time_t yyRelSeconds; + + +/* + * Prototypes of internal functions. + */ +static void +yyerror _ANSI_ARGS_((char *s)); + +static time_t +ToSeconds _ANSI_ARGS_((time_t Hours, + time_t Minutes, + time_t Seconds, + MERIDIAN Meridian)); + +static int +Convert _ANSI_ARGS_((time_t Month, + time_t Day, + time_t Year, + time_t Hours, + time_t Minutes, + time_t Seconds, + MERIDIAN Meridia, + DSTMODE DSTmode, + time_t *TimePtr)); + +static time_t +DSTcorrect _ANSI_ARGS_((time_t Start, + time_t Future)); + +static time_t +RelativeDate _ANSI_ARGS_((time_t Start, + time_t DayOrdinal, + time_t DayNumber)); + +static int +RelativeMonth _ANSI_ARGS_((time_t Start, + time_t RelMonth, + time_t *TimePtr)); +static int +LookupWord _ANSI_ARGS_((char *buff)); + +static int +yylex _ANSI_ARGS_((void)); + +int +yyparse _ANSI_ARGS_((void)); +%} + +%union { + time_t Number; + enum _MERIDIAN Meridian; +} + +%token tAGO tDAY tDAYZONE tID tMERIDIAN tMINUTE_UNIT tMONTH tMONTH_UNIT +%token tSEC_UNIT tSNUMBER tUNUMBER tZONE tEPOCH tDST + +%type tDAY tDAYZONE tMINUTE_UNIT tMONTH tMONTH_UNIT tDST +%type tSEC_UNIT tSNUMBER tUNUMBER tZONE +%type tMERIDIAN o_merid + +%% + +spec : /* NULL */ + | spec item + ; + +item : time { + yyHaveTime++; + } + | zone { + yyHaveZone++; + } + | date { + yyHaveDate++; + } + | day { + yyHaveDay++; + } + | rel { + yyHaveRel++; + } + | number + ; + +time : tUNUMBER tMERIDIAN { + yyHour = $1; + yyMinutes = 0; + yySeconds = 0; + yyMeridian = $2; + } + | tUNUMBER ':' tUNUMBER o_merid { + yyHour = $1; + yyMinutes = $3; + yySeconds = 0; + yyMeridian = $4; + } + | tUNUMBER ':' tUNUMBER tSNUMBER { + yyHour = $1; + yyMinutes = $3; + yyMeridian = MER24; + yyDSTmode = DSToff; + yyTimezone = - ($4 % 100 + ($4 / 100) * 60); + } + | tUNUMBER ':' tUNUMBER ':' tUNUMBER o_merid { + yyHour = $1; + yyMinutes = $3; + yySeconds = $5; + yyMeridian = $6; + } + | tUNUMBER ':' tUNUMBER ':' tUNUMBER tSNUMBER { + yyHour = $1; + yyMinutes = $3; + yySeconds = $5; + yyMeridian = MER24; + yyDSTmode = DSToff; + yyTimezone = - ($6 % 100 + ($6 / 100) * 60); + } + ; + +zone : tZONE tDST { + yyTimezone = $1; + yyDSTmode = DSTon; + } + | tZONE { + yyTimezone = $1; + yyDSTmode = DSToff; + } + | tDAYZONE { + yyTimezone = $1; + yyDSTmode = DSTon; + } + ; + +day : tDAY { + yyDayOrdinal = 1; + yyDayNumber = $1; + } + | tDAY ',' { + yyDayOrdinal = 1; + yyDayNumber = $1; + } + | tUNUMBER tDAY { + yyDayOrdinal = $1; + yyDayNumber = $2; + } + ; + +date : tUNUMBER '/' tUNUMBER { + yyMonth = $1; + yyDay = $3; + } + | tUNUMBER '/' tUNUMBER '/' tUNUMBER { + yyMonth = $1; + yyDay = $3; + yyYear = $5; + } + | tMONTH tUNUMBER { + yyMonth = $1; + yyDay = $2; + } + | tMONTH tUNUMBER ',' tUNUMBER { + yyMonth = $1; + yyDay = $2; + yyYear = $4; + } + | tUNUMBER tMONTH { + yyMonth = $2; + yyDay = $1; + } + | tEPOCH { + yyMonth = 1; + yyDay = 1; + yyYear = EPOCH; + } + | tUNUMBER tMONTH tUNUMBER { + yyMonth = $2; + yyDay = $1; + yyYear = $3; + } + ; + +rel : relunit tAGO { + yyRelSeconds = -yyRelSeconds; + yyRelMonth = -yyRelMonth; + } + | relunit + ; + +relunit : tUNUMBER tMINUTE_UNIT { + yyRelSeconds += $1 * $2 * 60L; + } + | tSNUMBER tMINUTE_UNIT { + yyRelSeconds += $1 * $2 * 60L; + } + | tMINUTE_UNIT { + yyRelSeconds += $1 * 60L; + } + | tSNUMBER tSEC_UNIT { + yyRelSeconds += $1; + } + | tUNUMBER tSEC_UNIT { + yyRelSeconds += $1; + } + | tSEC_UNIT { + yyRelSeconds++; + } + | tSNUMBER tMONTH_UNIT { + yyRelMonth += $1 * $2; + } + | tUNUMBER tMONTH_UNIT { + yyRelMonth += $1 * $2; + } + | tMONTH_UNIT { + yyRelMonth += $1; + } + ; + +number : tUNUMBER + { + if (yyHaveTime && yyHaveDate && !yyHaveRel) { + yyYear = $1; + } else { + yyHaveTime++; + if ($1 < 100) { + yyHour = 0; + yyMinutes = $1; + } else { + yyHour = $1 / 100; + yyMinutes = $1 % 100; + } + yySeconds = 0; + yyMeridian = MER24; + } + } +; + +o_merid : /* NULL */ { + $$ = MER24; + } + | tMERIDIAN { + $$ = $1; + } + ; + +%% + +/* + * Month and day table. + */ +static TABLE MonthDayTable[] = { + { "january", tMONTH, 1 }, + { "february", tMONTH, 2 }, + { "march", tMONTH, 3 }, + { "april", tMONTH, 4 }, + { "may", tMONTH, 5 }, + { "june", tMONTH, 6 }, + { "july", tMONTH, 7 }, + { "august", tMONTH, 8 }, + { "september", tMONTH, 9 }, + { "sept", tMONTH, 9 }, + { "october", tMONTH, 10 }, + { "november", tMONTH, 11 }, + { "december", tMONTH, 12 }, + { "sunday", tDAY, 0 }, + { "monday", tDAY, 1 }, + { "tuesday", tDAY, 2 }, + { "tues", tDAY, 2 }, + { "wednesday", tDAY, 3 }, + { "wednes", tDAY, 3 }, + { "thursday", tDAY, 4 }, + { "thur", tDAY, 4 }, + { "thurs", tDAY, 4 }, + { "friday", tDAY, 5 }, + { "saturday", tDAY, 6 }, + { NULL } +}; + +/* + * Time units table. + */ +static TABLE UnitsTable[] = { + { "year", tMONTH_UNIT, 12 }, + { "month", tMONTH_UNIT, 1 }, + { "fortnight", tMINUTE_UNIT, 14 * 24 * 60 }, + { "week", tMINUTE_UNIT, 7 * 24 * 60 }, + { "day", tMINUTE_UNIT, 1 * 24 * 60 }, + { "hour", tMINUTE_UNIT, 60 }, + { "minute", tMINUTE_UNIT, 1 }, + { "min", tMINUTE_UNIT, 1 }, + { "second", tSEC_UNIT, 1 }, + { "sec", tSEC_UNIT, 1 }, + { NULL } +}; + +/* + * Assorted relative-time words. + */ +static TABLE OtherTable[] = { + { "tomorrow", tMINUTE_UNIT, 1 * 24 * 60 }, + { "yesterday", tMINUTE_UNIT, -1 * 24 * 60 }, + { "today", tMINUTE_UNIT, 0 }, + { "now", tMINUTE_UNIT, 0 }, + { "last", tUNUMBER, -1 }, + { "this", tMINUTE_UNIT, 0 }, + { "next", tUNUMBER, 2 }, +#if 0 + { "first", tUNUMBER, 1 }, +/* { "second", tUNUMBER, 2 }, */ + { "third", tUNUMBER, 3 }, + { "fourth", tUNUMBER, 4 }, + { "fifth", tUNUMBER, 5 }, + { "sixth", tUNUMBER, 6 }, + { "seventh", tUNUMBER, 7 }, + { "eighth", tUNUMBER, 8 }, + { "ninth", tUNUMBER, 9 }, + { "tenth", tUNUMBER, 10 }, + { "eleventh", tUNUMBER, 11 }, + { "twelfth", tUNUMBER, 12 }, +#endif + { "ago", tAGO, 1 }, + { "epoch", tEPOCH, 0 }, + { NULL } +}; + +/* + * The timezone table. (Note: This table was modified to not use any floating + * point constants to work around an SGI compiler bug). + */ +static TABLE TimezoneTable[] = { + { "gmt", tZONE, HOUR( 0) }, /* Greenwich Mean */ + { "ut", tZONE, HOUR( 0) }, /* Universal (Coordinated) */ + { "utc", tZONE, HOUR( 0) }, + { "wet", tZONE, HOUR( 0) } , /* Western European */ + { "bst", tDAYZONE, HOUR( 0) }, /* British Summer */ + { "wat", tZONE, HOUR( 1) }, /* West Africa */ + { "at", tZONE, HOUR( 2) }, /* Azores */ +#if 0 + /* For completeness. BST is also British Summer, and GST is + * also Guam Standard. */ + { "bst", tZONE, HOUR( 3) }, /* Brazil Standard */ + { "gst", tZONE, HOUR( 3) }, /* Greenland Standard */ +#endif + { "nft", tZONE, HOUR( 7/2) }, /* Newfoundland */ + { "nst", tZONE, HOUR( 7/2) }, /* Newfoundland Standard */ + { "ndt", tDAYZONE, HOUR( 7/2) }, /* Newfoundland Daylight */ + { "ast", tZONE, HOUR( 4) }, /* Atlantic Standard */ + { "adt", tDAYZONE, HOUR( 4) }, /* Atlantic Daylight */ + { "est", tZONE, HOUR( 5) }, /* Eastern Standard */ + { "edt", tDAYZONE, HOUR( 5) }, /* Eastern Daylight */ + { "cst", tZONE, HOUR( 6) }, /* Central Standard */ + { "cdt", tDAYZONE, HOUR( 6) }, /* Central Daylight */ + { "mst", tZONE, HOUR( 7) }, /* Mountain Standard */ + { "mdt", tDAYZONE, HOUR( 7) }, /* Mountain Daylight */ + { "pst", tZONE, HOUR( 8) }, /* Pacific Standard */ + { "pdt", tDAYZONE, HOUR( 8) }, /* Pacific Daylight */ + { "yst", tZONE, HOUR( 9) }, /* Yukon Standard */ + { "ydt", tDAYZONE, HOUR( 9) }, /* Yukon Daylight */ + { "hst", tZONE, HOUR(10) }, /* Hawaii Standard */ + { "hdt", tDAYZONE, HOUR(10) }, /* Hawaii Daylight */ + { "cat", tZONE, HOUR(10) }, /* Central Alaska */ + { "ahst", tZONE, HOUR(10) }, /* Alaska-Hawaii Standard */ + { "nt", tZONE, HOUR(11) }, /* Nome */ + { "idlw", tZONE, HOUR(12) }, /* International Date Line West */ + { "cet", tZONE, -HOUR( 1) }, /* Central European */ + { "met", tZONE, -HOUR( 1) }, /* Middle European */ + { "mewt", tZONE, -HOUR( 1) }, /* Middle European Winter */ + { "mest", tDAYZONE, -HOUR( 1) }, /* Middle European Summer */ + { "swt", tZONE, -HOUR( 1) }, /* Swedish Winter */ + { "sst", tDAYZONE, -HOUR( 1) }, /* Swedish Summer */ + { "fwt", tZONE, -HOUR( 1) }, /* French Winter */ + { "fst", tDAYZONE, -HOUR( 1) }, /* French Summer */ + { "eet", tZONE, -HOUR( 2) }, /* Eastern Europe, USSR Zone 1 */ + { "bt", tZONE, -HOUR( 3) }, /* Baghdad, USSR Zone 2 */ + { "it", tZONE, -HOUR( 7/2) }, /* Iran */ + { "zp4", tZONE, -HOUR( 4) }, /* USSR Zone 3 */ + { "zp5", tZONE, -HOUR( 5) }, /* USSR Zone 4 */ + { "ist", tZONE, -HOUR(11/2) }, /* Indian Standard */ + { "zp6", tZONE, -HOUR( 6) }, /* USSR Zone 5 */ +#if 0 + /* For completeness. NST is also Newfoundland Stanard, nad SST is + * also Swedish Summer. */ + { "nst", tZONE, -HOUR(13/2) }, /* North Sumatra */ + { "sst", tZONE, -HOUR( 7) }, /* South Sumatra, USSR Zone 6 */ +#endif /* 0 */ + { "wast", tZONE, -HOUR( 7) }, /* West Australian Standard */ + { "wadt", tDAYZONE, -HOUR( 7) }, /* West Australian Daylight */ + { "jt", tZONE, -HOUR(15/2) }, /* Java (3pm in Cronusland!) */ + { "cct", tZONE, -HOUR( 8) }, /* China Coast, USSR Zone 7 */ + { "jst", tZONE, -HOUR( 9) }, /* Japan Standard, USSR Zone 8 */ + { "cast", tZONE, -HOUR(19/2) }, /* Central Australian Standard */ + { "cadt", tDAYZONE, -HOUR(19/2) }, /* Central Australian Daylight */ + { "east", tZONE, -HOUR(10) }, /* Eastern Australian Standard */ + { "eadt", tDAYZONE, -HOUR(10) }, /* Eastern Australian Daylight */ + { "gst", tZONE, -HOUR(10) }, /* Guam Standard, USSR Zone 9 */ + { "nzt", tZONE, -HOUR(12) }, /* New Zealand */ + { "nzst", tZONE, -HOUR(12) }, /* New Zealand Standard */ + { "nzdt", tDAYZONE, -HOUR(12) }, /* New Zealand Daylight */ + { "idle", tZONE, -HOUR(12) }, /* International Date Line East */ + /* ADDED BY Marco Nijdam */ + { "dst", tDST, HOUR( 0) }, /* DST on (hour is ignored) */ + /* End ADDED */ + { NULL } +}; + +/* + * Military timezone table. + */ +static TABLE MilitaryTable[] = { + { "a", tZONE, HOUR( 1) }, + { "b", tZONE, HOUR( 2) }, + { "c", tZONE, HOUR( 3) }, + { "d", tZONE, HOUR( 4) }, + { "e", tZONE, HOUR( 5) }, + { "f", tZONE, HOUR( 6) }, + { "g", tZONE, HOUR( 7) }, + { "h", tZONE, HOUR( 8) }, + { "i", tZONE, HOUR( 9) }, + { "k", tZONE, HOUR( 10) }, + { "l", tZONE, HOUR( 11) }, + { "m", tZONE, HOUR( 12) }, + { "n", tZONE, HOUR(- 1) }, + { "o", tZONE, HOUR(- 2) }, + { "p", tZONE, HOUR(- 3) }, + { "q", tZONE, HOUR(- 4) }, + { "r", tZONE, HOUR(- 5) }, + { "s", tZONE, HOUR(- 6) }, + { "t", tZONE, HOUR(- 7) }, + { "u", tZONE, HOUR(- 8) }, + { "v", tZONE, HOUR(- 9) }, + { "w", tZONE, HOUR(-10) }, + { "x", tZONE, HOUR(-11) }, + { "y", tZONE, HOUR(-12) }, + { "z", tZONE, HOUR( 0) }, + { NULL } +}; + + +/* + * Dump error messages in the bit bucket. + */ +static void +yyerror(s) + char *s; +{ +} + + +static time_t +ToSeconds(Hours, Minutes, Seconds, Meridian) + time_t Hours; + time_t Minutes; + time_t Seconds; + MERIDIAN Meridian; +{ + if (Minutes < 0 || Minutes > 59 || Seconds < 0 || Seconds > 59) + return -1; + switch (Meridian) { + case MER24: + if (Hours < 0 || Hours > 23) + return -1; + return (Hours * 60L + Minutes) * 60L + Seconds; + case MERam: + if (Hours < 1 || Hours > 12) + return -1; + return ((Hours % 12) * 60L + Minutes) * 60L + Seconds; + case MERpm: + if (Hours < 1 || Hours > 12) + return -1; + return (((Hours % 12) + 12) * 60L + Minutes) * 60L + Seconds; + } + return -1; /* Should never be reached */ +} + + +static int +Convert(Month, Day, Year, Hours, Minutes, Seconds, Meridian, DSTmode, TimePtr) + time_t Month; + time_t Day; + time_t Year; + time_t Hours; + time_t Minutes; + time_t Seconds; + MERIDIAN Meridian; + DSTMODE DSTmode; + time_t *TimePtr; +{ + static int DaysInMonth[12] = { + 31, 0, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 + }; + time_t tod; + time_t Julian; + int i; + + if (Year < 0) + Year = -Year; + if (Year < 100) + Year += 1900; + DaysInMonth[1] = Year % 4 == 0 && (Year % 100 != 0 || Year % 400 == 0) + ? 29 : 28; + if (Month < 1 || Month > 12 + || Year < START_OF_TIME || Year > END_OF_TIME + || Day < 1 || Day > DaysInMonth[(int)--Month]) + return -1; + + for (Julian = Day - 1, i = 0; i < Month; i++) + Julian += DaysInMonth[i]; + if (Year >= EPOCH) { + for (i = EPOCH; i < Year; i++) + Julian += 365 + (i % 4 == 0); + } else { + for (i = Year; i < EPOCH; i++) + Julian -= 365 + (i % 4 == 0); + } + Julian *= SECSPERDAY; + Julian += yyTimezone * 60L; + if ((tod = ToSeconds(Hours, Minutes, Seconds, Meridian)) < 0) + return -1; + Julian += tod; + if (DSTmode == DSTon + || (DSTmode == DSTmaybe && TclpGetDate(&Julian, 0)->tm_isdst)) + Julian -= 60 * 60; + *TimePtr = Julian; + return 0; +} + + +static time_t +DSTcorrect(Start, Future) + time_t Start; + time_t Future; +{ + time_t StartDay; + time_t FutureDay; + + StartDay = (TclpGetDate(&Start, 0)->tm_hour + 1) % 24; + FutureDay = (TclpGetDate(&Future, 0)->tm_hour + 1) % 24; + return (Future - Start) + (StartDay - FutureDay) * 60L * 60L; +} + + +static time_t +RelativeDate(Start, DayOrdinal, DayNumber) + time_t Start; + time_t DayOrdinal; + time_t DayNumber; +{ + struct tm *tm; + time_t now; + + now = Start; + tm = TclpGetDate(&now, 0); + now += SECSPERDAY * ((DayNumber - tm->tm_wday + 7) % 7); + now += 7 * SECSPERDAY * (DayOrdinal <= 0 ? DayOrdinal : DayOrdinal - 1); + return DSTcorrect(Start, now); +} + + +static int +RelativeMonth(Start, RelMonth, TimePtr) + time_t Start; + time_t RelMonth; + time_t *TimePtr; +{ + struct tm *tm; + time_t Month; + time_t Year; + time_t Julian; + + if (RelMonth == 0) { + *TimePtr = 0; + return 0; + } + tm = TclpGetDate(&Start, 0); + Month = 12 * tm->tm_year + tm->tm_mon + RelMonth; + Year = Month / 12; + Month = Month % 12 + 1; + if (Convert(Month, (time_t)tm->tm_mday, Year, + (time_t)tm->tm_hour, (time_t)tm->tm_min, (time_t)tm->tm_sec, + MER24, DSTmaybe, &Julian) < 0) + return -1; + *TimePtr = DSTcorrect(Start, Julian); + return 0; +} + + +static int +LookupWord(buff) + char *buff; +{ + register char *p; + register char *q; + register TABLE *tp; + int i; + int abbrev; + + /* + * Make it lowercase. + */ + for (p = buff; *p; p++) { + if (isupper(UCHAR(*p))) { + *p = (char) tolower(UCHAR(*p)); + } + } + + if (strcmp(buff, "am") == 0 || strcmp(buff, "a.m.") == 0) { + yylval.Meridian = MERam; + return tMERIDIAN; + } + if (strcmp(buff, "pm") == 0 || strcmp(buff, "p.m.") == 0) { + yylval.Meridian = MERpm; + return tMERIDIAN; + } + + /* + * See if we have an abbreviation for a month. + */ + if (strlen(buff) == 3) { + abbrev = 1; + } else if (strlen(buff) == 4 && buff[3] == '.') { + abbrev = 1; + buff[3] = '\0'; + } else { + abbrev = 0; + } + + for (tp = MonthDayTable; tp->name; tp++) { + if (abbrev) { + if (strncmp(buff, tp->name, 3) == 0) { + yylval.Number = tp->value; + return tp->type; + } + } else if (strcmp(buff, tp->name) == 0) { + yylval.Number = tp->value; + return tp->type; + } + } + + for (tp = TimezoneTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + yylval.Number = tp->value; + return tp->type; + } + } + + for (tp = UnitsTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + yylval.Number = tp->value; + return tp->type; + } + } + + /* + * Strip off any plural and try the units table again. + */ + i = strlen(buff) - 1; + if (buff[i] == 's') { + buff[i] = '\0'; + for (tp = UnitsTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + yylval.Number = tp->value; + return tp->type; + } + } + } + + for (tp = OtherTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + yylval.Number = tp->value; + return tp->type; + } + } + + /* + * Military timezones. + */ + if (buff[1] == '\0' && isalpha(UCHAR(*buff))) { + for (tp = MilitaryTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + yylval.Number = tp->value; + return tp->type; + } + } + } + + /* + * Drop out any periods and try the timezone table again. + */ + for (i = 0, p = q = buff; *q; q++) + if (*q != '.') + *p++ = *q; + else + i++; + *p = '\0'; + if (i) + for (tp = TimezoneTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + yylval.Number = tp->value; + return tp->type; + } + } + + return tID; +} + + +static int +yylex() +{ + register char c; + register char *p; + char buff[20]; + int Count; + int sign; + + for ( ; ; ) { + while (isspace((unsigned char) (*yyInput))) { + yyInput++; + } + + if (isdigit(c = *yyInput) || c == '-' || c == '+') { + if (c == '-' || c == '+') { + sign = c == '-' ? -1 : 1; + if (!isdigit(*++yyInput)) { + /* + * skip the '-' sign + */ + continue; + } + } else { + sign = 0; + } + for (yylval.Number = 0; isdigit(c = *yyInput++); ) { + yylval.Number = 10 * yylval.Number + c - '0'; + } + yyInput--; + if (sign < 0) { + yylval.Number = -yylval.Number; + } + return sign ? tSNUMBER : tUNUMBER; + } + if (isalpha(UCHAR(c))) { + for (p = buff; isalpha(c = *yyInput++) || c == '.'; ) { + if (p < &buff[sizeof buff - 1]) { + *p++ = c; + } + } + *p = '\0'; + yyInput--; + return LookupWord(buff); + } + if (c != '(') { + return *yyInput++; + } + Count = 0; + do { + c = *yyInput++; + if (c == '\0') { + return c; + } else if (c == '(') { + Count++; + } else if (c == ')') { + Count--; + } + } while (Count > 0); + } +} + +/* + * Specify zone is of -50000 to force GMT. (This allows BST to work). + */ + +int +TclGetDate(p, now, zone, timePtr) + char *p; + unsigned long now; + long zone; + unsigned long *timePtr; +{ + struct tm *tm; + time_t Start; + time_t Time; + time_t tod; + + yyInput = p; + tm = TclpGetDate((time_t *) &now, 0); + yyYear = tm->tm_year; + yyMonth = tm->tm_mon + 1; + yyDay = tm->tm_mday; + yyTimezone = zone; + if (zone == -50000) { + yyDSTmode = DSToff; /* assume GMT */ + yyTimezone = 0; + } else { + yyDSTmode = DSTmaybe; + } + yyHour = 0; + yyMinutes = 0; + yySeconds = 0; + yyMeridian = MER24; + yyRelSeconds = 0; + yyRelMonth = 0; + yyHaveDate = 0; + yyHaveDay = 0; + yyHaveRel = 0; + yyHaveTime = 0; + yyHaveZone = 0; + + if (yyparse() || yyHaveTime > 1 || yyHaveZone > 1 || yyHaveDate > 1 || + yyHaveDay > 1) { + return -1; + } + + if (yyHaveDate || yyHaveTime || yyHaveDay) { + if (Convert(yyMonth, yyDay, yyYear, yyHour, yyMinutes, yySeconds, + yyMeridian, yyDSTmode, &Start) < 0) + return -1; + } + else { + Start = now; + if (!yyHaveRel) + Start -= ((tm->tm_hour * 60L) + tm->tm_min * 60L) + tm->tm_sec; + } + + Start += yyRelSeconds; + if (RelativeMonth(Start, yyRelMonth, &Time) < 0) { + return -1; + } + Start += Time; + + if (yyHaveDay && !yyHaveDate) { + tod = RelativeDate(Start, yyDayOrdinal, yyDayNumber); + Start += tod; + } + + *timePtr = Start; + return 0; +} diff --git a/tcl7.3/tclHash.c b/tcl7.6/generic/tclHash.c similarity index 95% rename from tcl7.3/tclHash.c rename to tcl7.6/generic/tclHash.c index 1c4ac37..41de0b2 100644 --- a/tcl7.3/tclHash.c +++ b/tcl7.6/generic/tclHash.c @@ -5,30 +5,14 @@ * applications. * * Copyright (c) 1991-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1994 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tclHash.c 1.15 96/02/15 11:50:23 */ -#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" /* diff --git a/tcl7.3/tclHistory.c b/tcl7.6/generic/tclHistory.c similarity index 93% rename from tcl7.3/tclHistory.c rename to tcl7.6/generic/tclHistory.c index 5a4cada..c0cfd1f 100644 --- a/tcl7.3/tclHistory.c +++ b/tcl7.6/generic/tclHistory.c @@ -7,31 +7,16 @@ * history substitutions. * * Copyright (c) 1990-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tclHistory.c 1.40 96/02/15 11:50:24 */ -#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" +#include "tclPort.h" /* * This history stuff is mostly straightforward, except for one thing @@ -156,7 +141,8 @@ InitHistory(iPtr) * Tcl_RecordAndEval -- * * This procedure adds its command argument to the current list of - * recorded events and then executes the command by calling Tcl_Eval. + * recorded events and then executes the command by calling + * Tcl_Eval. * * Results: * The return value is a standard Tcl return value, the result of @@ -177,9 +163,10 @@ 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. */ + int flags; /* Additional flags. TCL_NO_EVAL means + * only record: don't execute command. + * TCL_EVAL_GLOBAL means use Tcl_GlobalEval + * instead of Tcl_Eval. */ { register Interp *iPtr = (Interp *) interp; register HistoryEvent *eventPtr; @@ -218,7 +205,7 @@ Tcl_RecordAndEval(interp, cmd, flags) length--; } MakeSpace(eventPtr, length + 1); - strncpy(eventPtr->command, cmd, length); + strncpy(eventPtr->command, cmd, (size_t) length); eventPtr->command[length] = 0; /* @@ -230,11 +217,15 @@ Tcl_RecordAndEval(interp, cmd, flags) */ result = TCL_OK; - if (flags != TCL_NO_EVAL) { + if (!(flags & TCL_NO_EVAL)) { iPtr->historyFirst = cmd; iPtr->revDisables = 0; - iPtr->evalFlags = flags | TCL_RECORD_BOUNDS; - result = Tcl_Eval(interp, cmd); + iPtr->evalFlags = (flags & ~TCL_EVAL_GLOBAL) | TCL_RECORD_BOUNDS; + if (flags & TCL_EVAL_GLOBAL) { + result = Tcl_GlobalEval(interp, cmd); + } else { + result = Tcl_Eval(interp, cmd); + } } iPtr->revDisables = 1; return result; @@ -267,8 +258,8 @@ Tcl_HistoryCmd(dummy, interp, argc, argv) { register Interp *iPtr = (Interp *) interp; register HistoryEvent *eventPtr; - int length; - char c; + size_t length; + int c; if (iPtr->numEvents == 0) { InitHistory(iPtr); @@ -323,7 +314,7 @@ Tcl_HistoryCmd(dummy, interp, argc, argv) return TCL_ERROR; } } - MakeSpace(eventPtr, strlen(argv[2]) + 1); + MakeSpace(eventPtr, (int) strlen(argv[2]) + 1); strcpy(eventPtr->command, argv[2]); return TCL_OK; } else if ((c == 'e') && (strncmp(argv[1], "event", length)) == 0) { @@ -511,7 +502,7 @@ Tcl_HistoryCmd(dummy, interp, argc, argv) } RevResult(iPtr, words); iPtr->result = words; - iPtr->freeProc = (Tcl_FreeProc *) free; + iPtr->freeProc = TCL_DYNAMIC; return TCL_OK; } @@ -778,20 +769,16 @@ DoRevs(iPtr) count = revPtr->firstIndex - bytesSeen; if (count > 0) { - strncpy(p, eventPtr->command + bytesSeen, count); + strncpy(p, eventPtr->command + bytesSeen, (size_t) count); p += count; } - strncpy(p, revPtr->newBytes, revPtr->newSize); + strncpy(p, revPtr->newBytes, (size_t) 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); /* @@ -876,7 +863,7 @@ GetEvent(iPtr, string) break; } eventPtr = &iPtr->events[index]; - if ((strncmp(eventPtr->command, string, length) == 0) + if ((strncmp(eventPtr->command, string, (size_t) length) == 0) || Tcl_StringMatch(eventPtr->command, string)) { return eventPtr; } @@ -954,7 +941,7 @@ SubsAndEval(iPtr, cmd, old, new) strcpy(dst, cmd); break; } - strncpy(dst, cmd, src-cmd); + strncpy(dst, cmd, (size_t) (src-cmd)); dst += src-cmd; strcpy(dst, new); dst += newLength; @@ -1085,7 +1072,7 @@ GetWords(iPtr, command, words) *dst = ' '; dst++; } - strncpy(dst, start, (end-start)); + strncpy(dst, start, (size_t) (end-start)); dst += end-start; } *dst = 0; @@ -1104,6 +1091,6 @@ GetWords(iPtr, command, words) error: Tcl_AppendResult((Tcl_Interp *) iPtr, "bad word selector \"", words, - "\": should be num-num or pattern", (char *) NULL); + "\": should be num-num or pattern", (char *) NULL); return NULL; } diff --git a/tcl7.6/generic/tclIO.c b/tcl7.6/generic/tclIO.c new file mode 100644 index 0000000..dfca281 --- /dev/null +++ b/tcl7.6/generic/tclIO.c @@ -0,0 +1,5512 @@ +/* + * tclIO.c -- + * + * This file provides the generic portions (those that are the same on + * all platforms and for all channel types) of Tcl's IO facilities. + * + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclIO.c 1.240 96/09/27 10:00:58 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * Make sure that both EAGAIN and EWOULDBLOCK are defined. This does not + * compile on systems where neither is defined. We want both defined so + * that we can test safely for both. In the code we still have to test for + * both because there may be systems on which both are defined and have + * different values. + */ + +#if ((!defined(EWOULDBLOCK)) && (defined(EAGAIN))) +# define EWOULDBLOCK EAGAIN +#endif +#if ((!defined(EAGAIN)) && (defined(EWOULDBLOCK))) +# define EAGAIN EWOULDBLOCK +#endif +#if ((!defined(EAGAIN)) && (!defined(EWOULDBLOCK))) + error one of EWOULDBLOCK or EAGAIN must be defined +#endif + +/* + * struct ChannelBuffer: + * + * Buffers data being sent to or from a channel. + */ + +typedef struct ChannelBuffer { + int nextAdded; /* The next position into which a character + * will be put in the buffer. */ + int nextRemoved; /* Position of next byte to be removed + * from the buffer. */ + int bufSize; /* How big is the buffer? */ + struct ChannelBuffer *nextPtr; + /* Next buffer in chain. */ + char buf[4]; /* Placeholder for real buffer. The real + * buffer occuppies this space + bufSize-4 + * bytes. This must be the last field in + * the structure. */ +} ChannelBuffer; + +#define CHANNELBUFFER_HEADER_SIZE (sizeof(ChannelBuffer) - 4) + +/* + * The following defines the *default* buffer size for channels. + */ + +#define CHANNELBUFFER_DEFAULT_SIZE (1024 * 4) + +/* + * Structure to record a close callback. One such record exists for + * each close callback registered for a channel. + */ + +typedef struct CloseCallback { + Tcl_CloseProc *proc; /* The procedure to call. */ + ClientData clientData; /* Arbitrary one-word data to pass + * to the callback. */ + struct CloseCallback *nextPtr; /* For chaining close callbacks. */ +} CloseCallback; + +/* + * Forward declaration of Channel; being used in struct EventScriptRecord, + * below. + */ + +typedef struct Channel *ChanPtr; + +/* + * The following structure describes the information saved from a call to + * "fileevent". This is used later when the event being waited for to + * invoke the saved script in the interpreter designed in this record. + */ + +typedef struct EventScriptRecord { + struct Channel *chanPtr; /* The channel for which this script is + * registered. This is used only when an + * error occurs during evaluation of the + * script, to delete the handler. */ + char *script; /* Script to invoke. */ + Tcl_Interp *interp; /* In what interpreter to invoke script? */ + int mask; /* Events must overlap current mask for the + * stored script to be invoked. */ + struct EventScriptRecord *nextPtr; + /* Next in chain of records. */ +} EventScriptRecord; + +/* + * Forward declaration of ChannelHandler; being used in struct Channel, + * below. + */ + +typedef struct ChannelHandler *ChannelHandlerPtr; + +/* + * struct Channel: + * + * One of these structures is allocated for each open channel. It contains data + * specific to the channel but which belongs to the generic part of the Tcl + * channel mechanism, and it points at an instance specific (and type + * specific) * instance data, and at a channel type structure. + */ + +typedef struct Channel { + char *channelName; /* The name of the channel instance in Tcl + * commands. Storage is owned by the generic IO + * code, is dynamically allocated. */ + int flags; /* ORed combination of the flags defined + * below. */ + Tcl_EolTranslation inputTranslation; + /* What translation to apply for end of line + * sequences on input? */ + Tcl_EolTranslation outputTranslation; + /* What translation to use for generating + * end of line sequences in output? */ + int inEofChar; /* If nonzero, use this as a signal of EOF + * on input. */ + int outEofChar; /* If nonzero, append this to the channel + * when it is closed if it is open for + * writing. */ + int unreportedError; /* Non-zero if an error report was deferred + * because it happened in the background. The + * value is the POSIX error code. */ + ClientData instanceData; /* Instance specific data. */ + Tcl_ChannelType *typePtr; /* Pointer to channel type structure. */ + int refCount; /* How many interpreters hold references to + * this IO channel? */ + CloseCallback *closeCbPtr; /* Callbacks registered to be called when the + * channel is closed. */ + ChannelBuffer *curOutPtr; /* Current output buffer being filled. */ + ChannelBuffer *outQueueHead;/* Points at first buffer in output queue. */ + ChannelBuffer *outQueueTail;/* Points at last buffer in output queue. */ + + ChannelBuffer *saveInBufPtr;/* Buffer saved for input queue - eliminates + * need to allocate a new buffer for "gets" + * that crosses buffer boundaries. */ + ChannelBuffer *inQueueHead; /* Points at first buffer in input queue. */ + ChannelBuffer *inQueueTail; /* Points at last buffer in input queue. */ + + struct ChannelHandler *chPtr;/* List of channel handlers registered + * for this channel. */ + int interestMask; /* Mask of all events this channel has + * handlers for. */ + struct Channel *nextChanPtr;/* Next in list of channels currently open. */ + EventScriptRecord *scriptRecordPtr; + /* Chain of all scripts registered for + * event handlers ("fileevent") on this + * channel. */ + int bufSize; /* What size buffers to allocate? */ +} Channel; + +/* + * Values for the flags field in Channel. Any ORed combination of the + * following flags can be stored in the field. These flags record various + * options and state bits about the channel. In addition to the flags below, + * the channel can also have TCL_READABLE (1<<1) and TCL_WRITABLE (1<<2) set. + */ + +#define CHANNEL_NONBLOCKING (1<<3) /* Channel is currently in + * nonblocking mode. */ +#define CHANNEL_LINEBUFFERED (1<<4) /* Output to the channel must be + * flushed after every newline. */ +#define CHANNEL_UNBUFFERED (1<<5) /* Output to the channel must always + * be flushed immediately. */ +#define BUFFER_READY (1<<6) /* Current output buffer (the + * curOutPtr field in the + * channel structure) should be + * output as soon as possible event + * though it may not be full. */ +#define BG_FLUSH_SCHEDULED (1<<7) /* A background flush of the + * queued output buffers has been + * scheduled. */ +#define CHANNEL_CLOSED (1<<8) /* Channel has been closed. No + * further Tcl-level IO on the + * channel is allowed. */ +#define CHANNEL_EOF (1<<9) /* EOF occurred on this channel. + * This bit is cleared before every + * input operation. */ +#define CHANNEL_STICKY_EOF (1<<10) /* EOF occurred on this channel because + * we saw the input eofChar. This bit + * prevents clearing of the EOF bit + * before every input operation. */ +#define CHANNEL_BLOCKED (1<<11) /* EWOULDBLOCK or EAGAIN occurred + * on this channel. This bit is + * cleared before every input or + * output operation. */ +#define INPUT_SAW_CR (1<<12) /* Channel is in CRLF eol input + * translation mode and the last + * byte seen was a "\r". */ +#define CHANNEL_DEAD (1<<13) /* The channel has been closed by + * the exit handler (on exit) but + * not deallocated. When any IO + * operation sees this flag on a + * channel, it does not call driver + * level functions to avoid referring + * to deallocated data. */ + +/* + * For each channel handler registered in a call to Tcl_CreateChannelHandler, + * there is one record of the following type. All of records for a specific + * channel are chained together in a singly linked list which is stored in + * the channel structure. + */ + +typedef struct ChannelHandler { + Channel *chanPtr; /* The channel structure for this channel. */ + int mask; /* Mask of desired events. */ + Tcl_ChannelProc *proc; /* Procedure to call in the type of + * Tcl_CreateChannelHandler. */ + ClientData clientData; /* Argument to pass to procedure. */ + struct ChannelHandler *nextPtr; + /* Next one in list of registered handlers. */ +} ChannelHandler; + +/* + * This structure keeps track of the current ChannelHandler being invoked in + * the current invocation of ChannelHandlerEventProc. There is a potential + * problem if a ChannelHandler is deleted while it is the current one, since + * ChannelHandlerEventProc needs to look at the nextPtr field. To handle this + * problem, structures of the type below indicate the next handler to be + * processed for any (recursively nested) dispatches in progress. The + * nextHandlerPtr field is updated if the handler being pointed to is deleted. + * The nextPtr field is used to chain together all recursive invocations, so + * that Tcl_DeleteChannelHandler can find all the recursively nested + * invocations of ChannelHandlerEventProc and compare the handler being + * deleted against the NEXT handler to be invoked in that invocation; when it + * finds such a situation, Tcl_DeleteChannelHandler updates the nextHandlerPtr + * field of the structure to the next handler. + */ + +typedef struct NextChannelHandler { + ChannelHandler *nextHandlerPtr; /* The next handler to be invoked in + * this invocation. */ + struct NextChannelHandler *nestedHandlerPtr; + /* Next nested invocation of + * ChannelHandlerEventProc. */ +} NextChannelHandler; + +/* + * This variable holds the list of nested ChannelHandlerEventProc invocations. + */ + +static NextChannelHandler *nestedHandlerPtr = (NextChannelHandler *) NULL; + +/* + * List of all channels currently open. + */ + +static Channel *firstChanPtr = (Channel *) NULL; + +/* + * Has a channel exit handler been created yet? + */ + +static int channelExitHandlerCreated = 0; + +/* + * Has the channel event source been created and registered with the + * notifier? + */ + +static int channelEventSourceCreated = 0; + +/* + * The following structure describes the event that is added to the Tcl + * event queue by the channel handler check procedure. + */ + +typedef struct ChannelHandlerEvent { + Tcl_Event header; /* Standard header for all events. */ + Channel *chanPtr; /* The channel that is ready. */ + int readyMask; /* Events that have occurred. */ +} ChannelHandlerEvent; + +/* + * Static variables to hold channels for stdin, stdout and stderr. + */ + +static Tcl_Channel stdinChannel = NULL; +static int stdinInitialized = 0; +static Tcl_Channel stdoutChannel = NULL; +static int stdoutInitialized = 0; +static Tcl_Channel stderrChannel = NULL; +static int stderrInitialized = 0; + +/* + * Static functions in this file: + */ + +static int ChannelEventDeleteProc _ANSI_ARGS_(( + Tcl_Event *evPtr, ClientData clientData)); +static void ChannelEventSourceExitProc _ANSI_ARGS_(( + ClientData data)); +static int ChannelHandlerEventProc _ANSI_ARGS_(( + Tcl_Event *evPtr, int flags)); +static void ChannelHandlerCheckProc _ANSI_ARGS_(( + ClientData clientData, int flags)); +static void ChannelHandlerSetupProc _ANSI_ARGS_(( + ClientData clientData, int flags)); +static void ChannelEventScriptInvoker _ANSI_ARGS_(( + ClientData clientData, int flags)); +static void CheckForStdChannelsBeingClosed _ANSI_ARGS_(( + Tcl_Channel chan)); +static void CleanupChannelHandlers _ANSI_ARGS_(( + Tcl_Interp *interp, Channel *chanPtr)); +static int CloseChannel _ANSI_ARGS_((Tcl_Interp *interp, + Channel *chanPtr, int errorCode)); +static void CloseChannelsOnExit _ANSI_ARGS_((ClientData data)); +static int CopyAndTranslateBuffer _ANSI_ARGS_(( + Channel *chanPtr, char *result, int space)); +static void CreateScriptRecord _ANSI_ARGS_(( + Tcl_Interp *interp, Channel *chanPtr, + int mask, char *script)); +static void DeleteChannelTable _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp)); +static void DeleteScriptRecord _ANSI_ARGS_((Tcl_Interp *interp, + Channel *chanPtr, int mask)); +static void DiscardInputQueued _ANSI_ARGS_(( + Channel *chanPtr, int discardSavedBuffers)); +static void DiscardOutputQueued _ANSI_ARGS_(( + Channel *chanPtr)); +static int FlushChannel _ANSI_ARGS_((Tcl_Interp *interp, + Channel *chanPtr, int calledFromAsyncFlush)); +static void FlushEventProc _ANSI_ARGS_((ClientData clientData, + int mask)); +static Tcl_HashTable *GetChannelTable _ANSI_ARGS_((Tcl_Interp *interp)); +static int GetEOL _ANSI_ARGS_((Channel *chanPtr)); +static int GetInput _ANSI_ARGS_((Channel *chanPtr)); +static void RecycleBuffer _ANSI_ARGS_((Channel *chanPtr, + ChannelBuffer *bufPtr, int mustDiscard)); +static void ReturnScriptRecord _ANSI_ARGS_((Tcl_Interp *interp, + Channel *chanPtr, int mask)); +static int ScanBufferForEOL _ANSI_ARGS_((Channel *chanPtr, + ChannelBuffer *bufPtr, + Tcl_EolTranslation translation, int eofChar, + int *bytesToEOLPtr, int *crSeenPtr)); +static int ScanInputForEOL _ANSI_ARGS_((Channel *chanPtr, + int *bytesQueuedPtr)); +static void WaitForChannel _ANSI_ARGS_((Channel *chanPtr, + int mask, int timeOut)); + +/* + *---------------------------------------------------------------------- + * + * TclFindFileChannel -- + * + * Finds a channel given two Tcl_Files. + * + * Results: + * The Tcl_Channel found. Also returns nonzero in fileUsedPtr output + * parameter if it finds that the Tcl_File is already used in another + * channel. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +TclFindFileChannel(inFile, outFile, fileUsedPtr) + Tcl_File inFile, outFile; /* Channel has these Tcl_Files. */ + int *fileUsedPtr; +{ + Channel *chanPtr; + Tcl_File chanIn, chanOut; + + *fileUsedPtr = 0; + for (chanPtr = firstChanPtr; + chanPtr != (Channel *) NULL; + chanPtr = chanPtr->nextChanPtr) { + chanIn = Tcl_GetChannelFile((Tcl_Channel) chanPtr, TCL_READABLE); + chanOut = Tcl_GetChannelFile((Tcl_Channel) chanPtr, TCL_WRITABLE); + if ((chanIn == (Tcl_File) NULL) && (chanOut == (Tcl_File) NULL)) { + continue; + } + if ((chanIn == inFile) && (chanOut == outFile)) { + return (Tcl_Channel) chanPtr; + } + if ((inFile != (Tcl_File) NULL) && (chanIn == inFile)) { + *fileUsedPtr = 1; + return (Tcl_Channel) NULL; + } + if ((outFile != (Tcl_File) NULL) && (chanOut == outFile)) { + *fileUsedPtr = 1; + return (Tcl_Channel) NULL; + } + } + return (Tcl_Channel) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetStdChannel -- + * + * This function is used to change the channels that are used + * for stdin/stdout/stderr in new interpreters. + * + * Results: + * None + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetStdChannel(channel, type) + Tcl_Channel channel; + int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */ +{ + switch (type) { + case TCL_STDIN: + stdinInitialized = 1; + stdinChannel = channel; + break; + case TCL_STDOUT: + stdoutInitialized = 1; + stdoutChannel = channel; + break; + case TCL_STDERR: + stderrInitialized = 1; + stderrChannel = channel; + break; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetStdChannel -- + * + * Returns the specified standard channel. + * + * Results: + * Returns the specified standard channel, or NULL. + * + * Side effects: + * May cause the creation of a standard channel and the underlying + * file. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_GetStdChannel(type) + int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */ +{ + Tcl_Channel channel = NULL; + + /* + * If the channels were not created yet, create them now and + * store them in the static variables. Note that we need to set + * stdinInitialized before calling TclGetDefaultStdChannel in order + * to avoid recursive loops when TclGetDefaultStdChannel calls + * Tcl_CreateChannel. + */ + + switch (type) { + case TCL_STDIN: + if (!stdinInitialized) { + stdinChannel = TclGetDefaultStdChannel(TCL_STDIN); + stdinInitialized = 1; + + /* + * Artificially bump the refcount to ensure that the channel + * is only closed on exit. + * + * NOTE: Must only do this if stdinChannel is not NULL. It + * can be NULL in situations where Tcl is unable to connect + * to the standard input. + */ + + if (stdinChannel != (Tcl_Channel) NULL) { + (void) Tcl_RegisterChannel((Tcl_Interp *) NULL, + stdinChannel); + } + } + channel = stdinChannel; + break; + case TCL_STDOUT: + if (!stdoutInitialized) { + stdoutChannel = TclGetDefaultStdChannel(TCL_STDOUT); + stdoutInitialized = 1; + + /* + * Artificially bump the refcount to ensure that the channel + * is only closed on exit. + * + * NOTE: Must only do this if stdoutChannel is not NULL. It + * can be NULL in situations where Tcl is unable to connect + * to the standard output. + */ + + if (stdoutChannel != (Tcl_Channel) NULL) { + (void) Tcl_RegisterChannel((Tcl_Interp *) NULL, + stdoutChannel); + } + } + channel = stdoutChannel; + break; + case TCL_STDERR: + if (!stderrInitialized) { + stderrChannel = TclGetDefaultStdChannel(TCL_STDERR); + stderrInitialized = 1; + + /* + * Artificially bump the refcount to ensure that the channel + * is only closed on exit. + * + * NOTE: Must only do this if stderrChannel is not NULL. It + * can be NULL in situations where Tcl is unable to connect + * to the standard error. + */ + + if (stderrChannel != (Tcl_Channel) NULL) { + (void) Tcl_RegisterChannel((Tcl_Interp *) NULL, + stderrChannel); + } + } + channel = stderrChannel; + break; + } + return channel; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateCloseHandler + * + * Creates a close callback which will be called when the channel is + * closed. + * + * Results: + * None. + * + * Side effects: + * Causes the callback to be called in the future when the channel + * will be closed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_CreateCloseHandler(chan, proc, clientData) + Tcl_Channel chan; /* The channel for which to create the + * close callback. */ + Tcl_CloseProc *proc; /* The callback routine to call when the + * channel will be closed. */ + ClientData clientData; /* Arbitrary data to pass to the + * close callback. */ +{ + Channel *chanPtr; + CloseCallback *cbPtr; + + chanPtr = (Channel *) chan; + + cbPtr = (CloseCallback *) ckalloc((unsigned) sizeof(CloseCallback)); + cbPtr->proc = proc; + cbPtr->clientData = clientData; + + cbPtr->nextPtr = chanPtr->closeCbPtr; + chanPtr->closeCbPtr = cbPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteCloseHandler -- + * + * Removes a callback that would have been called on closing + * the channel. If there is no matching callback then this + * function has no effect. + * + * Results: + * None. + * + * Side effects: + * The callback will not be called in the future when the channel + * is eventually closed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteCloseHandler(chan, proc, clientData) + Tcl_Channel chan; /* The channel for which to cancel the + * close callback. */ + Tcl_CloseProc *proc; /* The procedure for the callback to + * remove. */ + ClientData clientData; /* The callback data for the callback + * to remove. */ +{ + Channel *chanPtr; + CloseCallback *cbPtr, *cbPrevPtr; + + chanPtr = (Channel *) chan; + for (cbPtr = chanPtr->closeCbPtr, cbPrevPtr = (CloseCallback *) NULL; + cbPtr != (CloseCallback *) NULL; + cbPtr = cbPtr->nextPtr) { + if ((cbPtr->proc == proc) && (cbPtr->clientData == clientData)) { + if (cbPrevPtr == (CloseCallback *) NULL) { + chanPtr->closeCbPtr = cbPtr->nextPtr; + } else { + cbPrevPtr = cbPtr->nextPtr; + } + ckfree((char *) cbPtr); + break; + } else { + cbPrevPtr = cbPtr; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * CloseChannelsOnExit -- + * + * Closes all the existing channels, on exit. This routine is called + * during exit processing. + * + * Results: + * None. + * + * Side effects: + * Closes all channels. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +CloseChannelsOnExit(clientData) + ClientData clientData; /* NULL - unused. */ +{ + Channel *chanPtr; /* Iterates over open channels. */ + Channel *nextChanPtr; /* Iterates over open channels. */ + + + for (chanPtr = firstChanPtr; chanPtr != (Channel *) NULL; + chanPtr = nextChanPtr) { + nextChanPtr = chanPtr->nextChanPtr; + + /* + * Set the channel back into blocking mode to ensure that we wait + * for all data to flush out. + */ + + (void) Tcl_SetChannelOption(NULL, (Tcl_Channel) chanPtr, + "-blocking", "on"); + + if (chanPtr->refCount <= 0) { + + /* + * Close it only if the refcount indicates that the channel is not + * referenced from any interpreter. If it is, that interpreter will + * close the channel when it gets destroyed. + */ + + Tcl_Close((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr); + } else { + + /* + * The refcount is greater than zero, so flush the channel. + */ + + Tcl_Flush((Tcl_Channel) chanPtr); + + /* + * And close the OS level handles using the driver function: + */ + + (chanPtr->typePtr->closeProc) (chanPtr->instanceData, + (Tcl_Interp *) NULL); + + /* + * Finally, we clean up the fields in the channel data structure + * since all of them have been deleted already. We mark the + * channel with CHANNEL_DEAD to prevent any further IO operations + * on it. + */ + + chanPtr->instanceData = (ClientData) NULL; + chanPtr->flags |= CHANNEL_DEAD; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * GetChannelTable -- + * + * Gets and potentially initializes the channel table for an + * interpreter. If it is initializing the table it also inserts + * channels for stdin, stdout and stderr if the interpreter is + * trusted. + * + * Results: + * A pointer to the hash table created, for use by the caller. + * + * Side effects: + * Initializes the channel table for an interpreter. May create + * channels for stdin, stdout and stderr. + * + *---------------------------------------------------------------------- + */ + +static Tcl_HashTable * +GetChannelTable(interp) + Tcl_Interp *interp; +{ + Tcl_HashTable *hTblPtr; /* Hash table of channels. */ + Tcl_Channel stdinChan, stdoutChan, stderrChan; + + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable)); + Tcl_InitHashTable(hTblPtr, TCL_STRING_KEYS); + + (void) Tcl_SetAssocData(interp, "tclIO", + (Tcl_InterpDeleteProc *) DeleteChannelTable, + (ClientData) hTblPtr); + + /* + * If the interpreter is trusted (not "safe"), insert channels + * for stdin, stdout and stderr (possibly creating them in the + * process). + */ + + if (Tcl_IsSafe(interp) == 0) { + stdinChan = Tcl_GetStdChannel(TCL_STDIN); + if (stdinChan != NULL) { + Tcl_RegisterChannel(interp, stdinChan); + } + stdoutChan = Tcl_GetStdChannel(TCL_STDOUT); + if (stdoutChan != NULL) { + Tcl_RegisterChannel(interp, stdoutChan); + } + stderrChan = Tcl_GetStdChannel(TCL_STDERR); + if (stderrChan != NULL) { + Tcl_RegisterChannel(interp, stderrChan); + } + } + + } + return hTblPtr; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteChannelTable -- + * + * Deletes the channel table for an interpreter, closing any open + * channels whose refcount reaches zero. This procedure is invoked + * when an interpreter is deleted, via the AssocData cleanup + * mechanism. + * + * Results: + * None. + * + * Side effects: + * Deletes the hash table of channels. May close channels. May flush + * output on closed channels. Removes any channeEvent handlers that were + * registered in this interpreter. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteChannelTable(clientData, interp) + ClientData clientData; /* The per-interpreter data structure. */ + Tcl_Interp *interp; /* The interpreter being deleted. */ +{ + Tcl_HashTable *hTblPtr; /* The hash table. */ + Tcl_HashSearch hSearch; /* Search variable. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + Channel *chanPtr; /* Channel being deleted. */ + EventScriptRecord *sPtr, *prevPtr, *nextPtr; + /* Variables to loop over all channel events + * registered, to delete the ones that refer + * to the interpreter being deleted. */ + + /* + * Delete all the registered channels - this will close channels whose + * refcount reaches zero. + */ + + hTblPtr = (Tcl_HashTable *) clientData; + for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch)) { + + chanPtr = (Channel *) Tcl_GetHashValue(hPtr); + + /* + * Remove any fileevents registered in this interpreter. + */ + + for (sPtr = chanPtr->scriptRecordPtr, + prevPtr = (EventScriptRecord *) NULL; + sPtr != (EventScriptRecord *) NULL; + sPtr = nextPtr) { + nextPtr = sPtr->nextPtr; + if (sPtr->interp == interp) { + if (prevPtr == (EventScriptRecord *) NULL) { + chanPtr->scriptRecordPtr = nextPtr; + } else { + prevPtr->nextPtr = nextPtr; + } + + Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, + ChannelEventScriptInvoker, (ClientData) sPtr); + + Tcl_EventuallyFree((ClientData) sPtr->script, TCL_DYNAMIC); + ckfree((char *) sPtr); + } else { + prevPtr = sPtr; + } + } + + /* + * Cannot call Tcl_UnregisterChannel because that procedure calls + * Tcl_GetAssocData to get the channel table, which might already + * be inaccessible from the interpreter structure. Instead, we + * emulate the behavior of Tcl_UnregisterChannel directly here. + */ + + Tcl_DeleteHashEntry(hPtr); + chanPtr->refCount--; + if (chanPtr->refCount <= 0) { + if (!(chanPtr->flags & BG_FLUSH_SCHEDULED)) { + Tcl_Close(interp, (Tcl_Channel) chanPtr); + } + } + } + Tcl_DeleteHashTable(hTblPtr); + ckfree((char *) hTblPtr); +} + +/* + *---------------------------------------------------------------------- + * + * CheckForStdChannelsBeingClosed -- + * + * Perform special handling for standard channels being closed. When + * given a standard channel, if the refcount is now 1, it means that + * the last reference to the standard channel is being explicitly + * closed. Now bump the refcount artificially down to 0, to ensure the + * normal handling of channels being closed will occur. Also reset the + * static pointer to the channel to NULL, to avoid dangling references. + * + * Results: + * None. + * + * Side effects: + * Manipulates the refcount on standard channels. May smash the global + * static pointer to a standard channel. + * + *---------------------------------------------------------------------- + */ + +static void +CheckForStdChannelsBeingClosed(chan) + Tcl_Channel chan; +{ + Channel *chanPtr = (Channel *) chan; + + if ((chan == stdinChannel) && (stdinInitialized)) { + if (chanPtr->refCount < 2) { + chanPtr->refCount = 0; + stdinChannel = NULL; + return; + } + } else if ((chan == stdoutChannel) && (stdoutInitialized)) { + if (chanPtr->refCount < 2) { + chanPtr->refCount = 0; + stdoutChannel = NULL; + return; + } + } else if ((chan == stderrChannel) && (stderrInitialized)) { + if (chanPtr->refCount < 2) { + chanPtr->refCount = 0; + stderrChannel = NULL; + return; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UnregisterChannel -- + * + * Deletes the hash entry for a channel associated with an interpreter. + * If the interpreter given as argument is NULL, it only decrements the + * reference count. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Deletes the hash entry for a channel associated with an interpreter. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_UnregisterChannel(interp, chan) + Tcl_Interp *interp; /* Interpreter in which channel is defined. */ + Tcl_Channel chan; /* Channel to delete. */ +{ + Tcl_HashTable *hTblPtr; /* Hash table of channels. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + Channel *chanPtr; /* The real IO channel. */ + + chanPtr = (Channel *) chan; + + if (interp != (Tcl_Interp *) NULL) { + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + return TCL_OK; + } + hPtr = Tcl_FindHashEntry(hTblPtr, chanPtr->channelName); + if (hPtr == (Tcl_HashEntry *) NULL) { + return TCL_OK; + } + if ((Channel *) Tcl_GetHashValue(hPtr) != chanPtr) { + return TCL_OK; + } + Tcl_DeleteHashEntry(hPtr); + + /* + * Remove channel handlers that refer to this interpreter, so that they + * will not be present if the actual close is delayed and more events + * happen on the channel. This may occur if the channel is shared + * between several interpreters, or if the channel has async + * flushing active. + */ + + CleanupChannelHandlers(interp, chanPtr); + } + + chanPtr->refCount--; + + /* + * Perform special handling for standard channels being closed. If the + * refCount is now 1 it means that the last reference to the standard + * channel is being explicitly closed, so bump the refCount down + * artificially to 0. This will ensure that the channel is actually + * closed, below. Also set the static pointer to NULL for the channel. + */ + + CheckForStdChannelsBeingClosed(chan); + + /* + * If the refCount reached zero, close the actual channel. + */ + + if (chanPtr->refCount <= 0) { + + /* + * Ensure that if there is another buffer, it gets flushed + * whether or not we are doing a background flush. + */ + + if ((chanPtr->curOutPtr != NULL) && + (chanPtr->curOutPtr->nextAdded > + chanPtr->curOutPtr->nextRemoved)) { + chanPtr->flags |= BUFFER_READY; + } + chanPtr->flags |= CHANNEL_CLOSED; + if (!(chanPtr->flags & BG_FLUSH_SCHEDULED)) { + if (Tcl_Close(interp, chan) != TCL_OK) { + return TCL_ERROR; + } + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RegisterChannel -- + * + * Adds an already-open channel to the channel table of an interpreter. + * If the interpreter passed as argument is NULL, it only increments + * the channel refCount. + * + * Results: + * None. + * + * Side effects: + * May increment the reference count of a channel. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_RegisterChannel(interp, chan) + Tcl_Interp *interp; /* Interpreter in which to add the channel. */ + Tcl_Channel chan; /* The channel to add to this interpreter + * channel table. */ +{ + Tcl_HashTable *hTblPtr; /* Hash table of channels. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + int new; /* Is the hash entry new or does it exist? */ + Channel *chanPtr; /* The actual channel. */ + + chanPtr = (Channel *) chan; + + if (chanPtr->channelName == (char *) NULL) { + panic("Tcl_RegisterChannel: channel without name"); + } + if (interp != (Tcl_Interp *) NULL) { + hTblPtr = GetChannelTable(interp); + hPtr = Tcl_CreateHashEntry(hTblPtr, chanPtr->channelName, &new); + if (new == 0) { + if (chan == (Tcl_Channel) Tcl_GetHashValue(hPtr)) { + return; + } + panic("Tcl_RegisterChannel: duplicate channel names"); + } + Tcl_SetHashValue(hPtr, (ClientData) chanPtr); + } + chanPtr->refCount++; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetChannel -- + * + * Finds an existing Tcl_Channel structure by name in a given + * interpreter. This function is public because it is used by + * channel-type-specific functions. + * + * Results: + * A Tcl_Channel or NULL on failure. If failed, interp->result + * contains an error message. It also returns, in modePtr, the + * modes in which the channel is opened. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_GetChannel(interp, chanName, modePtr) + Tcl_Interp *interp; /* Interpreter in which to find or create + * the channel. */ + char *chanName; /* The name of the channel. */ + int *modePtr; /* Where to store the mode in which the + * channel was opened? Will contain an ORed + * combination of TCL_READABLE and + * TCL_WRITABLE, if non-NULL. */ +{ + Channel *chanPtr; /* The actual channel. */ + Tcl_HashTable *hTblPtr; /* Hash table of channels. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + char *name; /* Translated name. */ + + /* + * Substitute "stdin", etc. Note that even though we immediately + * find the channel using Tcl_GetStdChannel, we still need to look + * it up in the specified interpreter to ensure that it is present + * in the channel table. Otherwise, safe interpreters would always + * have access to the standard channels. + */ + + name = chanName; + if ((chanName[0] == 's') && (chanName[1] == 't')) { + chanPtr = NULL; + if (strcmp(chanName, "stdin") == 0) { + chanPtr = (Channel *)Tcl_GetStdChannel(TCL_STDIN); + } else if (strcmp(chanName, "stdout") == 0) { + chanPtr = (Channel *)Tcl_GetStdChannel(TCL_STDOUT); + } else if (strcmp(chanName, "stderr") == 0) { + chanPtr = (Channel *)Tcl_GetStdChannel(TCL_STDERR); + } + if (chanPtr != NULL) { + name = chanPtr->channelName; + } + } + + hTblPtr = GetChannelTable(interp); + hPtr = Tcl_FindHashEntry(hTblPtr, name); + if (hPtr == (Tcl_HashEntry *) NULL) { + Tcl_AppendResult(interp, "can not find channel named \"", + chanName, "\"", (char *) NULL); + return NULL; + } + + chanPtr = (Channel *) Tcl_GetHashValue(hPtr); + if (modePtr != NULL) { + *modePtr = (chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)); + } + + return (Tcl_Channel) chanPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateChannel -- + * + * Creates a new entry in the hash table for a Tcl_Channel + * record. + * + * Results: + * Returns the new Tcl_Channel. + * + * Side effects: + * Creates a new Tcl_Channel instance and inserts it into the + * hash table. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_CreateChannel(typePtr, chanName, instanceData, mask) + Tcl_ChannelType *typePtr; /* The channel type record. */ + char *chanName; /* Name of channel to record. */ + ClientData instanceData; /* Instance specific data. */ + int mask; /* TCL_READABLE & TCL_WRITABLE to indicate + * if the channel is readable, writable. */ +{ + Channel *chanPtr; /* The channel structure newly created. */ + + chanPtr = (Channel *) ckalloc((unsigned) sizeof(Channel)); + + if (chanName != (char *) NULL) { + chanPtr->channelName = ckalloc((unsigned) (strlen(chanName) + 1)); + strcpy(chanPtr->channelName, chanName); + } else { + panic("Tcl_CreateChannel: NULL channel name"); + } + + chanPtr->flags = mask; + + /* + * Set the channel up initially in AUTO input translation mode to + * accept "\n", "\r" and "\r\n". Output translation mode is set to + * a platform specific default value. The eofChar is set to 0 for both + * input and output, so that Tcl does not look for an in-file EOF + * indicator (e.g. ^Z) and does not append an EOF indicator to files. + */ + + chanPtr->inputTranslation = TCL_TRANSLATE_AUTO; + chanPtr->outputTranslation = TCL_PLATFORM_TRANSLATION; + chanPtr->inEofChar = 0; + chanPtr->outEofChar = 0; + + chanPtr->unreportedError = 0; + chanPtr->instanceData = instanceData; + chanPtr->typePtr = typePtr; + chanPtr->refCount = 0; + chanPtr->closeCbPtr = (CloseCallback *) NULL; + chanPtr->curOutPtr = (ChannelBuffer *) NULL; + chanPtr->outQueueHead = (ChannelBuffer *) NULL; + chanPtr->outQueueTail = (ChannelBuffer *) NULL; + chanPtr->saveInBufPtr = (ChannelBuffer *) NULL; + chanPtr->inQueueHead = (ChannelBuffer *) NULL; + chanPtr->inQueueTail = (ChannelBuffer *) NULL; + chanPtr->chPtr = (ChannelHandler *) NULL; + chanPtr->interestMask = 0; + chanPtr->scriptRecordPtr = (EventScriptRecord *) NULL; + chanPtr->bufSize = CHANNELBUFFER_DEFAULT_SIZE; + + /* + * Link the channel into the list of all channels; create an on-exit + * handler if there is not one already, to close off all the channels + * in the list on exit. + */ + + chanPtr->nextChanPtr = firstChanPtr; + firstChanPtr = chanPtr; + + if (!channelExitHandlerCreated) { + channelExitHandlerCreated = 1; + Tcl_CreateExitHandler(CloseChannelsOnExit, (ClientData) NULL); + } + + /* + * Install this channel in the first empty standard channel slot, if + * the channel was previously closed explicitly. + */ + + if ((stdinChannel == NULL) && (stdinInitialized == 1)) { + Tcl_SetStdChannel((Tcl_Channel)chanPtr, TCL_STDIN); + Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr); + } else if ((stdoutChannel == NULL) && (stdoutInitialized == 1)) { + Tcl_SetStdChannel((Tcl_Channel)chanPtr, TCL_STDOUT); + Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr); + } else if ((stderrChannel == NULL) && (stderrInitialized == 1)) { + Tcl_SetStdChannel((Tcl_Channel)chanPtr, TCL_STDERR); + Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr); + } + return (Tcl_Channel) chanPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetChannelMode -- + * + * Computes a mask indicating whether the channel is open for + * reading and writing. + * + * Results: + * An OR-ed combination of TCL_READABLE and TCL_WRITABLE. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetChannelMode(chan) + Tcl_Channel chan; /* The channel for which the mode is + * being computed. */ +{ + Channel *chanPtr; /* The actual channel. */ + + chanPtr = (Channel *) chan; + return (chanPtr->flags & (TCL_READABLE | TCL_WRITABLE)); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetChannelName -- + * + * Returns the string identifying the channel name. + * + * Results: + * The string containing the channel name. This memory is + * owned by the generic layer and should not be modified by + * the caller. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_GetChannelName(chan) + Tcl_Channel chan; /* The channel for which to return the name. */ +{ + Channel *chanPtr; /* The actual channel. */ + + chanPtr = (Channel *) chan; + return chanPtr->channelName; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetChannelType -- + * + * Given a channel structure, returns the channel type structure. + * + * Results: + * Returns a pointer to the channel type structure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_ChannelType * +Tcl_GetChannelType(chan) + Tcl_Channel chan; /* The channel to return type for. */ +{ + Channel *chanPtr; /* The actual channel. */ + + chanPtr = (Channel *) chan; + return chanPtr->typePtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetChannelFile -- + * + * Returns a file associated with a channel. + * + * Results: + * The file or NULL if failed (e.g. the channel is not open for the + * requested direction). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_File +Tcl_GetChannelFile(chan, direction) + Tcl_Channel chan; /* The channel to get file from. */ + int direction; /* TCL_WRITABLE or TCL_READABLE. */ +{ + Channel *chanPtr; /* The actual channel. */ + + chanPtr = (Channel *) chan; + return (chanPtr->typePtr->getFileProc) (chanPtr->instanceData, direction); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetChannelInstanceData -- + * + * Returns the client data associated with a channel. + * + * Results: + * The client data. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +ClientData +Tcl_GetChannelInstanceData(chan) + Tcl_Channel chan; /* Channel for which to return client data. */ +{ + Channel *chanPtr; /* The actual channel. */ + + chanPtr = (Channel *) chan; + return chanPtr->instanceData; +} + +/* + *---------------------------------------------------------------------- + * + * RecycleBuffer -- + * + * Helper function to recycle input and output buffers. Ensures + * that two input buffers are saved (one in the input queue and + * another in the saveInBufPtr field) and that curOutPtr is set + * to a buffer. Only if these conditions are met is the buffer + * freed to the OS. + * + * Results: + * None. + * + * Side effects: + * May free a buffer to the OS. + * + *---------------------------------------------------------------------- + */ + +static void +RecycleBuffer(chanPtr, bufPtr, mustDiscard) + Channel *chanPtr; /* Channel for which to recycle buffers. */ + ChannelBuffer *bufPtr; /* The buffer to recycle. */ + int mustDiscard; /* If nonzero, free the buffer to the + * OS, always. */ +{ + /* + * Do we have to free the buffer to the OS? + */ + + if (mustDiscard) { + ckfree((char *) bufPtr); + return; + } + + /* + * Only save buffers for the input queue if the channel is readable. + */ + + if (chanPtr->flags & TCL_READABLE) { + if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) { + chanPtr->inQueueHead = bufPtr; + chanPtr->inQueueTail = bufPtr; + goto keepit; + } + if (chanPtr->saveInBufPtr == (ChannelBuffer *) NULL) { + chanPtr->saveInBufPtr = bufPtr; + goto keepit; + } + } + + /* + * Only save buffers for the output queue if the channel is writable. + */ + + if (chanPtr->flags & TCL_WRITABLE) { + if (chanPtr->curOutPtr == (ChannelBuffer *) NULL) { + chanPtr->curOutPtr = bufPtr; + goto keepit; + } + } + + /* + * If we reached this code we return the buffer to the OS. + */ + + ckfree((char *) bufPtr); + return; + +keepit: + bufPtr->nextRemoved = 0; + bufPtr->nextAdded = 0; + bufPtr->nextPtr = (ChannelBuffer *) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * DiscardOutputQueued -- + * + * Discards all output queued in the output queue of a channel. + * + * Results: + * None. + * + * Side effects: + * Recycles buffers. + * + *---------------------------------------------------------------------- + */ + +static void +DiscardOutputQueued(chanPtr) + Channel *chanPtr; /* The channel for which to discard output. */ +{ + ChannelBuffer *bufPtr; + + while (chanPtr->outQueueHead != (ChannelBuffer *) NULL) { + bufPtr = chanPtr->outQueueHead; + chanPtr->outQueueHead = bufPtr->nextPtr; + RecycleBuffer(chanPtr, bufPtr, 0); + } + chanPtr->outQueueHead = (ChannelBuffer *) NULL; + chanPtr->outQueueTail = (ChannelBuffer *) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * FlushChannel -- + * + * This function flushes as much of the queued output as is possible + * now. If calledFromAsyncFlush is nonzero, it is being called in an + * event handler to flush channel output asynchronously. + * + * Results: + * 0 if successful, else the error code that was returned by the + * channel type operation. + * + * Side effects: + * May produce output on a channel. May block indefinitely if the + * channel is synchronous. May schedule an async flush on the channel. + * May recycle memory for buffers in the output queue. + * + *---------------------------------------------------------------------- + */ + +static int +FlushChannel(interp, chanPtr, calledFromAsyncFlush) + Tcl_Interp *interp; /* For error reporting during close. */ + Channel *chanPtr; /* The channel to flush on. */ + int calledFromAsyncFlush; /* If nonzero then we are being + * called from an asynchronous + * flush callback. */ +{ + ChannelBuffer *bufPtr; /* Iterates over buffered output + * queue. */ + int toWrite; /* Amount of output data in current + * buffer available to be written. */ + int written; /* Amount of output data actually + * written in current round. */ + int errorCode; /* Stores POSIX error codes from + * channel driver operations. */ + Tcl_File outFile; /* The contained Tcl_File for output + * on this channel. Used for waiting + * for the channel to become writable, + * or to schedule an async flush. */ + + errorCode = 0; + + /* + * Prevent writing on a dead channel -- a channel that has been closed + * but not yet deallocated. This can occur if the exit handler for the + * channel deallocation runs before all channels are deregistered in + * all interpreters. + */ + + if (chanPtr->flags & CHANNEL_DEAD) { + Tcl_SetErrno(EINVAL); + return -1; + } + + /* + * Loop over the queued buffers and attempt to flush as + * much as possible of the queued output to the channel. + */ + + while (1) { + + /* + * If the queue is empty and there is a ready current buffer, OR if + * the current buffer is full, then move the current buffer to the + * queue. + */ + + if (((chanPtr->curOutPtr != (ChannelBuffer *) NULL) && + (chanPtr->curOutPtr->nextAdded == chanPtr->curOutPtr->bufSize)) + || ((chanPtr->flags & BUFFER_READY) && + (chanPtr->outQueueHead == (ChannelBuffer *) NULL))) { + chanPtr->flags &= (~(BUFFER_READY)); + chanPtr->curOutPtr->nextPtr = (ChannelBuffer *) NULL; + if (chanPtr->outQueueHead == (ChannelBuffer *) NULL) { + chanPtr->outQueueHead = chanPtr->curOutPtr; + } else { + chanPtr->outQueueTail->nextPtr = chanPtr->curOutPtr; + } + chanPtr->outQueueTail = chanPtr->curOutPtr; + chanPtr->curOutPtr = (ChannelBuffer *) NULL; + } + bufPtr = chanPtr->outQueueHead; + + /* + * If we are not being called from an async flush and an async + * flush is active, we just return without producing any output. + */ + + if ((!calledFromAsyncFlush) && + (chanPtr->flags & BG_FLUSH_SCHEDULED)) { + return 0; + } + + /* + * If the output queue is still empty, break out of the while loop. + */ + + if (bufPtr == (ChannelBuffer *) NULL) { + break; /* Out of the "while (1)". */ + } + + /* + * Produce the output on the channel. + */ + + toWrite = bufPtr->nextAdded - bufPtr->nextRemoved; + written = (chanPtr->typePtr->outputProc) (chanPtr->instanceData, + bufPtr->buf + bufPtr->nextRemoved, toWrite, &errorCode); + + /* + * If the write failed completely attempt to start the asynchronous + * flush mechanism and break out of this loop - do not attempt to + * write any more output at this time. + */ + + if (written < 0) { + + /* + * If the last attempt to write was interrupted, simply retry. + */ + + if (errorCode == EINTR) { + errorCode = 0; + continue; + } + + /* + * If we would have blocked, attempt to set up an asynchronous + * background flushing for this channel if the channel is + * nonblocking, or block until more output can be written if + * the channel is blocking. + */ + + if ((errorCode == EWOULDBLOCK) || (errorCode == EAGAIN)) { + outFile = Tcl_GetChannelFile((Tcl_Channel) chanPtr, + TCL_WRITABLE); + if (outFile == (Tcl_File) NULL) { + WaitForChannel(chanPtr, TCL_WRITABLE, -1); + } else if (chanPtr->flags & CHANNEL_NONBLOCKING) { + if (!(chanPtr->flags & BG_FLUSH_SCHEDULED)) { + Tcl_CreateFileHandler(outFile, TCL_WRITABLE, + FlushEventProc, (ClientData) chanPtr); + } + chanPtr->flags |= BG_FLUSH_SCHEDULED; + errorCode = 0; + break; /* Out of the "while (1)" loop. */ + } else { + + /* + * If the device driver did not emulate blocking behavior + * then we must do it it here. + */ + + WaitForChannel(chanPtr, TCL_WRITABLE, -1); + errorCode = 0; + continue; + } + } + + /* + * Decide whether to report the error upwards or defer it. If + * we got an error during async flush we discard all queued + * output. + */ + + if (calledFromAsyncFlush) { + if (chanPtr->unreportedError == 0) { + chanPtr->unreportedError = errorCode; + } + } else { + Tcl_SetErrno(errorCode); + } + + /* + * When we get an error we throw away all the output + * currently queued. + */ + + DiscardOutputQueued(chanPtr); + continue; + } + + bufPtr->nextRemoved += written; + + /* + * If this buffer is now empty, recycle it. + */ + + if (bufPtr->nextRemoved == bufPtr->nextAdded) { + chanPtr->outQueueHead = bufPtr->nextPtr; + if (chanPtr->outQueueHead == (ChannelBuffer *) NULL) { + chanPtr->outQueueTail = (ChannelBuffer *) NULL; + } + RecycleBuffer(chanPtr, bufPtr, 0); + } + } /* Closes "while (1)". */ + + /* + * If the queue became empty and we have an asynchronous flushing + * mechanism active, cancel the asynchronous flushing. + */ + + if ((chanPtr->outQueueHead == (ChannelBuffer *) NULL) && + (chanPtr->flags & BG_FLUSH_SCHEDULED)) { + chanPtr->flags &= (~(BG_FLUSH_SCHEDULED)); + outFile = Tcl_GetChannelFile((Tcl_Channel) chanPtr, TCL_WRITABLE); + if (outFile != (Tcl_File) NULL) { + Tcl_DeleteFileHandler(outFile); + } + } + + /* + * If the channel is flagged as closed, delete it when the refCount + * drops to zero, the output queue is empty and there is no output + * in the current output buffer. + */ + + if ((chanPtr->flags & CHANNEL_CLOSED) && (chanPtr->refCount <= 0) && + (chanPtr->outQueueHead == (ChannelBuffer *) NULL) && + ((chanPtr->curOutPtr == (ChannelBuffer *) NULL) || + (chanPtr->curOutPtr->nextAdded == + chanPtr->curOutPtr->nextRemoved))) { + return CloseChannel(interp, chanPtr, errorCode); + } + return errorCode; +} + +/* + *---------------------------------------------------------------------- + * + * CloseChannel -- + * + * Utility procedure to close a channel and free its associated + * resources. + * + * Results: + * 0 on success or a POSIX error code if the operation failed. + * + * Side effects: + * May close the actual channel; may free memory. + * + *---------------------------------------------------------------------- + */ + +static int +CloseChannel(interp, chanPtr, errorCode) + Tcl_Interp *interp; /* For error reporting. */ + Channel *chanPtr; /* The channel to close. */ + int errorCode; /* Status of operation so far. */ +{ + int result = 0; /* Of calling driver close + * operation. */ + Channel *prevChanPtr; /* Preceding channel in list of + * all channels - used to splice a + * channel out of the list on close. */ + + if (chanPtr == NULL) { + return 0; + } + + /* + * No more input can be consumed so discard any leftover input. + */ + + DiscardInputQueued(chanPtr, 1); + + /* + * Discard a leftover buffer in the current output buffer field. + */ + + if (chanPtr->curOutPtr != (ChannelBuffer *) NULL) { + ckfree((char *) chanPtr->curOutPtr); + chanPtr->curOutPtr = (ChannelBuffer *) NULL; + } + + /* + * The caller guarantees that there are no more buffers + * queued for output. + */ + + if (chanPtr->outQueueHead != (ChannelBuffer *) NULL) { + panic("TclFlush, closed channel: queued output left"); + } + + /* + * If the EOF character is set in the channel, append that to the + * output device. + */ + + if ((chanPtr->outEofChar != 0) && (chanPtr->flags & TCL_WRITABLE)) { + int dummy; + char c; + + c = (char) chanPtr->outEofChar; + (chanPtr->typePtr->outputProc) (chanPtr->instanceData, &c, 1, &dummy); + } + + /* + * Remove TCL_READABLE and TCL_WRITABLE from chanPtr->flags, so + * that close callbacks can not do input or output (assuming they + * squirreled the channel away in their clientData). This also + * prevents infinite loops if the callback calls any C API that + * could call FlushChannel. + */ + + chanPtr->flags &= (~(TCL_READABLE|TCL_WRITABLE)); + + /* + * Splice this channel out of the list of all channels. + */ + + if (chanPtr == firstChanPtr) { + firstChanPtr = chanPtr->nextChanPtr; + } else { + for (prevChanPtr = firstChanPtr; + (prevChanPtr != (Channel *) NULL) && + (prevChanPtr->nextChanPtr != chanPtr); + prevChanPtr = prevChanPtr->nextChanPtr) { + /* Empty loop body. */ + } + if (prevChanPtr == (Channel *) NULL) { + panic("FlushChannel: damaged channel list"); + } + prevChanPtr->nextChanPtr = chanPtr->nextChanPtr; + } + + /* + * OK, close the channel itself. + */ + + result = (chanPtr->typePtr->closeProc) (chanPtr->instanceData, interp); + + if (chanPtr->channelName != (char *) NULL) { + ckfree(chanPtr->channelName); + } + + /* + * If we are being called synchronously, report either + * any latent error on the channel or the current error. + */ + + if (chanPtr->unreportedError != 0) { + errorCode = chanPtr->unreportedError; + } + if (errorCode == 0) { + errorCode = result; + if (errorCode != 0) { + Tcl_SetErrno(errorCode); + } + } + + Tcl_EventuallyFree((ClientData) chanPtr, TCL_DYNAMIC); + + return errorCode; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Close -- + * + * Closes a channel. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Closes the channel if this is the last reference. + * + * NOTE: + * Tcl_Close removes the channel as far as the user is concerned. + * However, it may continue to exist for a while longer if it has + * a background flush scheduled. The device itself is eventually + * closed and the channel record removed, in CloseChannel, above. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_Close(interp, chan) + Tcl_Interp *interp; /* Interpreter for errors. */ + Tcl_Channel chan; /* The channel being closed. Must + * not be referenced in any + * interpreter. */ +{ + ChannelHandler *chPtr, *chNext; /* Iterate over channel handlers. */ + CloseCallback *cbPtr; /* Iterate over close callbacks + * for this channel. */ + EventScriptRecord *ePtr, *eNextPtr; /* Iterate over eventscript records. */ + Channel *chanPtr; /* The real IO channel. */ + int result; /* Of calling FlushChannel. */ + + + /* + * Perform special handling for standard channels being closed. If the + * refCount is now 1 it means that the last reference to the standard + * channel is being explicitly closed, so bump the refCount down + * artificially to 0. This will ensure that the channel is actually + * closed, below. Also set the static pointer to NULL for the channel. + */ + + CheckForStdChannelsBeingClosed(chan); + + chanPtr = (Channel *) chan; + if (chanPtr->refCount > 0) { + panic("called Tcl_Close on channel with refCount > 0"); + } + + /* + * Remove all the channel handler records attached to the channel + * itself. + */ + + for (chPtr = chanPtr->chPtr; + chPtr != (ChannelHandler *) NULL; + chPtr = chNext) { + chNext = chPtr->nextPtr; + ckfree((char *) chPtr); + } + chanPtr->chPtr = (ChannelHandler *) NULL; + + /* + * Must set the interest mask now to 0, otherwise infinite loops + * will occur if Tcl_DoOneEvent is called before the channel is + * finally deleted in FlushChannel. This can happen if the channel + * has a background flush active. + */ + + chanPtr->interestMask = 0; + + /* + * Remove any EventScript records for this channel. + */ + + for (ePtr = chanPtr->scriptRecordPtr; + ePtr != (EventScriptRecord *) NULL; + ePtr = eNextPtr) { + eNextPtr = ePtr->nextPtr; + Tcl_EventuallyFree((ClientData)ePtr->script, TCL_DYNAMIC); + ckfree((char *) ePtr); + } + chanPtr->scriptRecordPtr = (EventScriptRecord *) NULL; + + /* + * Invoke the registered close callbacks and delete their records. + */ + + while (chanPtr->closeCbPtr != (CloseCallback *) NULL) { + cbPtr = chanPtr->closeCbPtr; + chanPtr->closeCbPtr = cbPtr->nextPtr; + (cbPtr->proc) (cbPtr->clientData); + ckfree((char *) cbPtr); + } + + /* + * And remove any events for this channel from the event queue. + */ + + Tcl_DeleteEvents(ChannelEventDeleteProc, (ClientData) chanPtr); + + /* + * Ensure that the last output buffer will be flushed. + */ + + if ((chanPtr->curOutPtr != (ChannelBuffer *) NULL) && + (chanPtr->curOutPtr->nextAdded > chanPtr->curOutPtr->nextRemoved)) { + chanPtr->flags |= BUFFER_READY; + } + + /* + * The call to FlushChannel will flush any queued output and invoke + * the close function of the channel driver, or it will set up the + * channel to be flushed and closed asynchronously. + */ + + chanPtr->flags |= CHANNEL_CLOSED; + result = FlushChannel(interp, chanPtr, 0); + if (result != 0) { + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ChannelEventDeleteProc -- + * + * This procedure returns 1 if the event passed in is for the + * channel passed in as the second argument. This procedure is + * used as a filter for events to delete in a call to + * Tcl_DeleteEvents in CloseChannel. + * + * Results: + * 1 if matching, 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ChannelEventDeleteProc(evPtr, clientData) + Tcl_Event *evPtr; /* The event to check for a match. */ + ClientData clientData; /* The channel to check for. */ +{ + ChannelHandlerEvent *cEvPtr; + Channel *chanPtr; + + if (evPtr->proc != ChannelHandlerEventProc) { + return 0; + } + cEvPtr = (ChannelHandlerEvent *) evPtr; + chanPtr = (Channel *) clientData; + if (cEvPtr->chanPtr != chanPtr) { + return 0; + } + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Write -- + * + * Puts a sequence of characters into an output buffer, may queue the + * buffer for output if it gets full, and also remembers whether the + * current buffer is ready e.g. if it contains a newline and we are in + * line buffering mode. + * + * Results: + * The number of bytes written or -1 in case of error. If -1, + * Tcl_GetErrno will return the error code. + * + * Side effects: + * May buffer up output and may cause output to be produced on the + * channel. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Write(chan, srcPtr, slen) + Tcl_Channel chan; /* The channel to buffer output for. */ + char *srcPtr; /* Output to buffer. */ + int slen; /* Its length. Negative means + * the output is null terminated + * and we must compute its length. */ +{ + Channel *chanPtr; /* The actual channel. */ + ChannelBuffer *outBufPtr; /* Current output buffer. */ + int foundNewline; /* Did we find a newline in output? */ + char *dPtr, *sPtr; /* Search variables for newline. */ + int crsent; /* In CRLF eol translation mode, + * remember the fact that a CR was + * output to the channel without + * its following NL. */ + int i; /* Loop index for newline search. */ + int destCopied; /* How many bytes were used in this + * destination buffer to hold the + * output? */ + int totalDestCopied; /* How many bytes total were + * copied to the channel buffer? */ + int srcCopied; /* How many bytes were copied from + * the source string? */ + char *destPtr; /* Where in line to copy to? */ + + chanPtr = (Channel *) chan; + + /* + * Check for unreported error. + */ + + if (chanPtr->unreportedError != 0) { + Tcl_SetErrno(chanPtr->unreportedError); + chanPtr->unreportedError = 0; + return -1; + } + + /* + * If the channel is not open for writing punt. + */ + + if (!(chanPtr->flags & TCL_WRITABLE)) { + Tcl_SetErrno(EACCES); + return -1; + } + + /* + * If length passed is negative, assume that the output is null terminated + * and compute its length. + */ + + if (slen < 0) { + slen = strlen(srcPtr); + } + + /* + * If we are in network (or windows) translation mode, record the fact + * that we have not yet sent a CR to the channel. + */ + + crsent = 0; + + /* + * Loop filling buffers and flushing them until all output has been + * consumed. + */ + + srcCopied = 0; + totalDestCopied = 0; + + while (slen > 0) { + + /* + * Make sure there is a current output buffer to accept output. + */ + + if (chanPtr->curOutPtr == (ChannelBuffer *) NULL) { + chanPtr->curOutPtr = (ChannelBuffer *) ckalloc((unsigned) + (CHANNELBUFFER_HEADER_SIZE + chanPtr->bufSize)); + chanPtr->curOutPtr->nextAdded = 0; + chanPtr->curOutPtr->nextRemoved = 0; + chanPtr->curOutPtr->bufSize = chanPtr->bufSize; + chanPtr->curOutPtr->nextPtr = (ChannelBuffer *) NULL; + } + + outBufPtr = chanPtr->curOutPtr; + + destCopied = outBufPtr->bufSize - outBufPtr->nextAdded; + if (destCopied > slen) { + destCopied = slen; + } + + destPtr = outBufPtr->buf + outBufPtr->nextAdded; + switch (chanPtr->outputTranslation) { + case TCL_TRANSLATE_LF: + srcCopied = destCopied; + memcpy((VOID *) destPtr, (VOID *) srcPtr, (size_t) destCopied); + break; + case TCL_TRANSLATE_CR: + srcCopied = destCopied; + memcpy((VOID *) destPtr, (VOID *) srcPtr, (size_t) destCopied); + for (dPtr = destPtr; dPtr < destPtr + destCopied; dPtr++) { + if (*dPtr == '\n') { + *dPtr = '\r'; + } + } + break; + case TCL_TRANSLATE_CRLF: + for (srcCopied = 0, dPtr = destPtr, sPtr = srcPtr; + dPtr < destPtr + destCopied; + dPtr++, sPtr++, srcCopied++) { + if (*sPtr == '\n') { + if (crsent) { + *dPtr = '\n'; + crsent = 0; + } else { + *dPtr = '\r'; + crsent = 1; + sPtr--, srcCopied--; + } + } else { + *dPtr = *sPtr; + } + } + break; + case TCL_TRANSLATE_AUTO: + panic("Tcl_Write: AUTO output translation mode not supported"); + default: + panic("Tcl_Write: unknown output translation mode"); + } + + /* + * The current buffer is ready for output if it is full, or if it + * contains a newline and this channel is line-buffered, or if it + * contains any output and this channel is unbuffered. + */ + + outBufPtr->nextAdded += destCopied; + if (!(chanPtr->flags & BUFFER_READY)) { + if (outBufPtr->nextAdded == outBufPtr->bufSize) { + chanPtr->flags |= BUFFER_READY; + } else if (chanPtr->flags & CHANNEL_LINEBUFFERED) { + for (sPtr = srcPtr, i = 0, foundNewline = 0; + (i < srcCopied) && (!foundNewline); + i++, sPtr++) { + if (*sPtr == '\n') { + foundNewline = 1; + break; + } + } + if (foundNewline) { + chanPtr->flags |= BUFFER_READY; + } + } else if (chanPtr->flags & CHANNEL_UNBUFFERED) { + chanPtr->flags |= BUFFER_READY; + } + } + + totalDestCopied += srcCopied; + srcPtr += srcCopied; + slen -= srcCopied; + + if (chanPtr->flags & BUFFER_READY) { + if (FlushChannel(NULL, chanPtr, 0) != 0) { + return -1; + } + } + } /* Closes "while" */ + + return totalDestCopied; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Flush -- + * + * Flushes output data on a channel. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May flush output queued on this channel. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Flush(chan) + Tcl_Channel chan; /* The Channel to flush. */ +{ + int result; /* Of calling FlushChannel. */ + Channel *chanPtr; /* The actual channel. */ + + chanPtr = (Channel *) chan; + + /* + * Check for unreported error. + */ + + if (chanPtr->unreportedError != 0) { + Tcl_SetErrno(chanPtr->unreportedError); + chanPtr->unreportedError = 0; + return TCL_ERROR; + } + + /* + * If the channel is not open for writing punt. + */ + + if (!(chanPtr->flags & TCL_WRITABLE)) { + Tcl_SetErrno(EACCES); + return TCL_ERROR; + } + + /* + * Force current output buffer to be output also. + */ + + if ((chanPtr->curOutPtr != (ChannelBuffer *) NULL) && + (chanPtr->curOutPtr->nextAdded > 0)) { + chanPtr->flags |= BUFFER_READY; + } + + result = FlushChannel(NULL, chanPtr, 0); + if (result != 0) { + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * DiscardInputQueued -- + * + * Discards any input read from the channel but not yet consumed + * by Tcl reading commands. + * + * Results: + * None. + * + * Side effects: + * May discard input from the channel. If discardLastBuffer is zero, + * leaves one buffer in place for back-filling. + * + *---------------------------------------------------------------------- + */ + +static void +DiscardInputQueued(chanPtr, discardSavedBuffers) + Channel *chanPtr; /* Channel on which to discard + * the queued input. */ + int discardSavedBuffers; /* If non-zero, discard all buffers including + * last one. */ +{ + ChannelBuffer *bufPtr, *nxtPtr; /* Loop variables. */ + + bufPtr = chanPtr->inQueueHead; + chanPtr->inQueueHead = (ChannelBuffer *) NULL; + chanPtr->inQueueTail = (ChannelBuffer *) NULL; + for (; bufPtr != (ChannelBuffer *) NULL; bufPtr = nxtPtr) { + nxtPtr = bufPtr->nextPtr; + RecycleBuffer(chanPtr, bufPtr, discardSavedBuffers); + } + + /* + * If discardSavedBuffers is nonzero, must also discard any previously + * saved buffer in the saveInBufPtr field. + */ + + if (discardSavedBuffers) { + if (chanPtr->saveInBufPtr != (ChannelBuffer *) NULL) { + ckfree((char *) chanPtr->saveInBufPtr); + chanPtr->saveInBufPtr = (ChannelBuffer *) NULL; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * GetInput -- + * + * Reads input data from a device or file into an input buffer. + * + * Results: + * A Posix error code or 0. + * + * Side effects: + * Reads from the underlying device. + * + *---------------------------------------------------------------------- + */ + +static int +GetInput(chanPtr) + Channel *chanPtr; /* Channel to read input from. */ +{ + int toRead; /* How much to read? */ + int result; /* Of calling driver. */ + int nread; /* How much was read from channel? */ + ChannelBuffer *bufPtr; /* New buffer to add to input queue. */ + + /* + * Prevent reading from a dead channel -- a channel that has been closed + * but not yet deallocated, which can happen if the exit handler for + * channel cleanup has run but the channel is still registered in some + * interpreter. + */ + + if (chanPtr->flags & CHANNEL_DEAD) { + Tcl_SetErrno(EINVAL); + return -1; + } + + /* + * See if we can fill an existing buffer. If we can, read only + * as much as will fit in it. Otherwise allocate a new buffer, + * add it to the input queue and attempt to fill it to the max. + */ + + if ((chanPtr->inQueueTail != (ChannelBuffer *) NULL) && + (chanPtr->inQueueTail->nextAdded < chanPtr->inQueueTail->bufSize)) { + bufPtr = chanPtr->inQueueTail; + toRead = bufPtr->bufSize - bufPtr->nextAdded; + } else { + if (chanPtr->saveInBufPtr != (ChannelBuffer *) NULL) { + bufPtr = chanPtr->saveInBufPtr; + chanPtr->saveInBufPtr = (ChannelBuffer *) NULL; + } else { + bufPtr = (ChannelBuffer *) ckalloc( + ((unsigned) CHANNELBUFFER_HEADER_SIZE + chanPtr->bufSize)); + bufPtr->bufSize = chanPtr->bufSize; + } + bufPtr->nextRemoved = 0; + bufPtr->nextAdded = 0; + toRead = bufPtr->bufSize; + if (chanPtr->inQueueTail == (ChannelBuffer *) NULL) { + chanPtr->inQueueHead = bufPtr; + } else { + chanPtr->inQueueTail->nextPtr = bufPtr; + } + chanPtr->inQueueTail = bufPtr; + bufPtr->nextPtr = (ChannelBuffer *) NULL; + } + + while (1) { + + /* + * If EOF is set, we should avoid calling the driver because on some + * platforms it is impossible to read from a device after EOF. + */ + + if (chanPtr->flags & CHANNEL_EOF) { + break; + } + nread = (chanPtr->typePtr->inputProc) (chanPtr->instanceData, + bufPtr->buf + bufPtr->nextAdded, toRead, &result); + if (nread == 0) { + chanPtr->flags |= CHANNEL_EOF; + break; + } else if (nread < 0) { + if ((result == EWOULDBLOCK) || (result == EAGAIN)) { + chanPtr->flags |= CHANNEL_BLOCKED; + result = EAGAIN; + if (chanPtr->flags & CHANNEL_NONBLOCKING) { + Tcl_SetErrno(result); + return result; + } else { + + /* + * If the device driver did not emulate blocking behavior + * then we have to do it here. + */ + + WaitForChannel(chanPtr, TCL_READABLE, -1); + } + } else { + Tcl_SetErrno(result); + return result; + } + } else { + bufPtr->nextAdded += nread; + + /* + * If we get a short read, signal up that we may be BLOCKED. We + * should avoid calling the driver because on some platforms we + * will block in the low level reading code even though the + * channel is set into nonblocking mode. + */ + + if (nread < toRead) { + chanPtr->flags |= CHANNEL_BLOCKED; + } + break; + } + } + + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * CopyAndTranslateBuffer -- + * + * Copy at most one buffer of input to the result space, doing + * eol translations according to mode in effect currently. + * + * Results: + * Number of characters (as opposed to bytes) copied. May return + * zero if no input is available to be translated. + * + * Side effects: + * Consumes buffered input. May deallocate one buffer. + * + *---------------------------------------------------------------------- + */ + +static int +CopyAndTranslateBuffer(chanPtr, result, space) + Channel *chanPtr; /* The channel from which to read input. */ + char *result; /* Where to store the copied input. */ + int space; /* How many bytes are available in result + * to store the copied input? */ +{ + int bytesInBuffer; /* How many bytes are available to be + * copied in the current input buffer? */ + int copied; /* How many characters were already copied + * into the destination space? */ + ChannelBuffer *bufPtr; /* The buffer from which to copy bytes. */ + char curByte; /* The byte we are currently translating. */ + int i; /* Iterates over the copied input looking + * for the input eofChar. */ + + /* + * If there is no input at all, return zero. The invariant is that either + * there is no buffer in the queue, or if the first buffer is empty, it + * is also the last buffer (and thus there is no input in the queue). + * Note also that if the buffer is empty, we leave it in the queue. + */ + + if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) { + return 0; + } + bufPtr = chanPtr->inQueueHead; + bytesInBuffer = bufPtr->nextAdded - bufPtr->nextRemoved; + if (bytesInBuffer < space) { + space = bytesInBuffer; + } + copied = 0; + switch (chanPtr->inputTranslation) { + case TCL_TRANSLATE_LF: + + if (space == 0) { + return 0; + } + + /* + * Copy the current chunk into the result buffer. + */ + + memcpy((VOID *) result, + (VOID *)(bufPtr->buf + bufPtr->nextRemoved), + (size_t) space); + bufPtr->nextRemoved += space; + copied = space; + break; + + case TCL_TRANSLATE_CR: + + if (space == 0) { + return 0; + } + + /* + * Copy the current chunk into the result buffer, then + * replace all \r with \n. + */ + + memcpy((VOID *) result, + (VOID *)(bufPtr->buf + bufPtr->nextRemoved), + (size_t) space); + bufPtr->nextRemoved += space; + for (copied = 0; copied < space; copied++) { + if (result[copied] == '\r') { + result[copied] = '\n'; + } + } + break; + + case TCL_TRANSLATE_CRLF: + + /* + * If there is a held-back "\r" at EOF, produce it now. + */ + + if (space == 0) { + if ((chanPtr->flags & (INPUT_SAW_CR | CHANNEL_EOF)) == + (INPUT_SAW_CR | CHANNEL_EOF)) { + result[0] = '\r'; + chanPtr->flags &= (~(INPUT_SAW_CR)); + return 1; + } + return 0; + } + + /* + * Copy the current chunk and replace "\r\n" with "\n" + * (but not standalone "\r"!). + */ + + for (copied = 0; + (copied < space) && + (bufPtr->nextRemoved < bufPtr->nextAdded); + copied++) { + curByte = bufPtr->buf[bufPtr->nextRemoved]; + bufPtr->nextRemoved++; + if (curByte == '\r') { + if (chanPtr->flags & INPUT_SAW_CR) { + result[copied] = '\r'; + } else { + chanPtr->flags |= INPUT_SAW_CR; + copied--; + } + } else if (curByte == '\n') { + chanPtr->flags &= (~(INPUT_SAW_CR)); + result[copied] = '\n'; + } else { + if (chanPtr->flags & INPUT_SAW_CR) { + chanPtr->flags &= (~(INPUT_SAW_CR)); + result[copied] = '\r'; + copied++; + } + result[copied] = curByte; + } + } + break; + + case TCL_TRANSLATE_AUTO: + + if (space == 0) { + return 0; + } + + /* + * Loop over the current buffer, converting "\r" and "\r\n" + * to "\n". + */ + + for (copied = 0; + (copied < space) && + (bufPtr->nextRemoved < bufPtr->nextAdded); ) { + curByte = bufPtr->buf[bufPtr->nextRemoved]; + bufPtr->nextRemoved++; + if (curByte == '\r') { + result[copied] = '\n'; + copied++; + if (bufPtr->nextRemoved < bufPtr->nextAdded) { + if (bufPtr->buf[bufPtr->nextRemoved] == '\n') { + bufPtr->nextRemoved++; + } + chanPtr->flags &= (~(INPUT_SAW_CR)); + } else { + chanPtr->flags |= INPUT_SAW_CR; + } + } else { + if (curByte == '\n') { + if (!(chanPtr->flags & INPUT_SAW_CR)) { + result[copied] = '\n'; + copied++; + } + } else { + result[copied] = curByte; + copied++; + } + chanPtr->flags &= (~(INPUT_SAW_CR)); + } + } + break; + + default: + panic("unknown eol translation mode"); + } + + /* + * If an in-stream EOF character is set for this channel,, check that + * the input we copied so far does not contain the EOF char. If it does, + * copy only up to and excluding that character. + */ + + if (chanPtr->inEofChar != 0) { + for (i = 0; i < copied; i++) { + if (result[i] == (char) chanPtr->inEofChar) { + break; + } + } + if (i < copied) { + + /* + * Set sticky EOF so that no further input is presented + * to the caller. + */ + + chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); + + /* + * Reset the start of valid data in the input buffer to the + * position of the eofChar, so that subsequent reads will + * encounter it immediately. First we set it to the position + * of the last byte consumed if all result bytes were the + * product of one input byte; since it is possible that "\r\n" + * contracted to "\n" in the result, we have to search back + * from that position until we find the eofChar, because it + * is possible that its actual position in the buffer is n + * bytes further back (n is the number of "\r\n" sequences + * that were contracted to "\n" in the result). + */ + + bufPtr->nextRemoved -= (copied - i); + while ((bufPtr->nextRemoved > 0) && + (bufPtr->buf[bufPtr->nextRemoved] != + (char) chanPtr->inEofChar)) { + bufPtr->nextRemoved--; + } + copied = i; + } + } + + /* + * If the current buffer is empty recycle it. + */ + + if (bufPtr->nextRemoved == bufPtr->nextAdded) { + chanPtr->inQueueHead = bufPtr->nextPtr; + if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) { + chanPtr->inQueueTail = (ChannelBuffer *) NULL; + } + RecycleBuffer(chanPtr, bufPtr, 0); + } + + /* + * Return the number of characters copied into the result buffer. + * This may be different from the number of bytes consumed, because + * of EOL translations. + */ + + return copied; +} + +/* + *---------------------------------------------------------------------- + * + * ScanBufferForEOL -- + * + * Scans one buffer for EOL according to the specified EOL + * translation mode. If it sees the input eofChar for the channel + * it stops also. + * + * Results: + * TRUE if EOL is found, FALSE otherwise. Also sets output parameter + * bytesToEOLPtr to the number of bytes so far to EOL, and crSeenPtr + * to whether a "\r" was seen. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ScanBufferForEOL(chanPtr, bufPtr, translation, eofChar, bytesToEOLPtr, + crSeenPtr) + Channel *chanPtr; + ChannelBuffer *bufPtr; /* Buffer to scan for EOL. */ + Tcl_EolTranslation translation; /* Translation mode to use. */ + int eofChar; /* EOF char to look for. */ + int *bytesToEOLPtr; /* Running counter. */ + int *crSeenPtr; /* Has "\r" been seen? */ +{ + char *rPtr; /* Iterates over input string. */ + char *sPtr; /* Where to stop search? */ + int EOLFound; + int bytesToEOL; + + for (EOLFound = 0, rPtr = bufPtr->buf + bufPtr->nextRemoved, + sPtr = bufPtr->buf + bufPtr->nextAdded, + bytesToEOL = *bytesToEOLPtr; + (!EOLFound) && (rPtr < sPtr); + rPtr++) { + switch (translation) { + case TCL_TRANSLATE_AUTO: + if ((*rPtr == (char) eofChar) && (eofChar != 0)) { + chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); + EOLFound = 1; + } else if (*rPtr == '\n') { + + /* + * CopyAndTranslateBuffer wants to know the length + * of the result, not the input. The input is one + * larger because "\r\n" shrinks to "\n". + */ + + if (!(*crSeenPtr)) { + bytesToEOL++; + EOLFound = 1; + } else { + + /* + * This is a lf at the begining of a buffer + * where the previous buffer ended in a cr. + * Consume this lf because we've already emitted + * the newline for this crlf sequence. ALSO, if + * bytesToEOL is 0 (which means that we are at the + * first character of the scan), unset the + * INPUT_SAW_CR flag in the channel, because we + * already handled it; leaving it set would cause + * CopyAndTranslateBuffer to potentially consume + * another lf if one follows the current byte. + */ + + bufPtr->nextRemoved++; + *crSeenPtr = 0; + chanPtr->flags &= (~(INPUT_SAW_CR)); + } + } else if (*rPtr == '\r') { + bytesToEOL++; + EOLFound = 1; + } else { + *crSeenPtr = 0; + bytesToEOL++; + } + break; + case TCL_TRANSLATE_LF: + if ((*rPtr == (char) eofChar) && (eofChar != 0)) { + chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); + EOLFound = 1; + } else { + if (*rPtr == '\n') { + EOLFound = 1; + } + bytesToEOL++; + } + break; + case TCL_TRANSLATE_CR: + if ((*rPtr == (char) eofChar) && (eofChar != 0)) { + chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); + EOLFound = 1; + } else { + if (*rPtr == '\r') { + EOLFound = 1; + } + bytesToEOL++; + } + break; + case TCL_TRANSLATE_CRLF: + if ((*rPtr == (char) eofChar) && (eofChar != 0)) { + chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); + EOLFound = 1; + } else if (*rPtr == '\n') { + + /* + * CopyAndTranslateBuffer wants to know the length + * of the result, not the input. The input is one + * larger because crlf shrinks to lf. + */ + + if (*crSeenPtr) { + EOLFound = 1; + } else { + bytesToEOL++; + } + } else { + if (*rPtr == '\r') { + *crSeenPtr = 1; + } else { + *crSeenPtr = 0; + } + bytesToEOL++; + } + break; + default: + panic("unknown eol translation mode"); + } + } + + *bytesToEOLPtr = bytesToEOL; + return EOLFound; +} + +/* + *---------------------------------------------------------------------- + * + * ScanInputForEOL -- + * + * Scans queued input for chanPtr for an end of line (according to the + * current EOL translation mode) and returns the number of bytes + * upto and including the end of line, or -1 if none was found. + * + * Results: + * Count of bytes upto and including the end of line if one is present + * or -1 if none was found. Also returns in an output parameter the + * number of bytes queued if no end of line was found. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ScanInputForEOL(chanPtr, bytesQueuedPtr) + Channel *chanPtr; /* Channel for which to scan queued + * input for end of line. */ + int *bytesQueuedPtr; /* Where to store the number of bytes + * currently queued if no end of line + * was found. */ +{ + ChannelBuffer *bufPtr; /* Iterates over queued buffers. */ + int bytesToEOL; /* How many bytes to end of line? */ + int EOLFound; /* Did we find an end of line? */ + int crSeen; /* Did we see a "\r" in CRLF mode? */ + + *bytesQueuedPtr = 0; + bytesToEOL = 0; + EOLFound = 0; + for (bufPtr = chanPtr->inQueueHead, + crSeen = (chanPtr->flags & INPUT_SAW_CR) ? 1 : 0; + (!EOLFound) && (bufPtr != (ChannelBuffer *) NULL); + bufPtr = bufPtr->nextPtr) { + EOLFound = ScanBufferForEOL(chanPtr, bufPtr, chanPtr->inputTranslation, + chanPtr->inEofChar, &bytesToEOL, &crSeen); + } + + if (EOLFound == 0) { + *bytesQueuedPtr = bytesToEOL; + return -1; + } + return bytesToEOL; +} + +/* + *---------------------------------------------------------------------- + * + * GetEOL -- + * + * Accumulate input into the channel input buffer queue until an + * end of line has been seen. + * + * Results: + * Number of bytes buffered or -1 on failure. + * + * Side effects: + * Consumes input from the channel. + * + *---------------------------------------------------------------------- + */ + +static int +GetEOL(chanPtr) + Channel *chanPtr; /* Channel to queue input on. */ +{ + int result; /* Of getting another buffer from the + * channel. */ + int bytesToEOL; /* How many bytes in buffer up to and + * including the end of line? */ + int bytesQueued; /* How many bytes are queued currently + * in the input chain of the channel? */ + + while (1) { + bytesToEOL = ScanInputForEOL(chanPtr, &bytesQueued); + if (bytesToEOL > 0) { + chanPtr->flags &= (~(CHANNEL_BLOCKED)); + return bytesToEOL; + } + if (chanPtr->flags & CHANNEL_EOF) { + /* + * Boundary case where cr was at the end of the previous buffer + * and this buffer just has a newline. At EOF our caller wants + * to see -1 for the line length. + */ + return (bytesQueued == 0) ? -1 : bytesQueued ; + } + if (chanPtr->flags & CHANNEL_BLOCKED) { + if (chanPtr->flags & CHANNEL_NONBLOCKING) { + return -1; + } + chanPtr->flags &= (~(CHANNEL_BLOCKED)); + } + result = GetInput(chanPtr); + if (result != 0) { + if (result == EAGAIN) { + chanPtr->flags |= CHANNEL_BLOCKED; + } + return -1; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Read -- + * + * Reads a given number of characters from a channel. + * + * Results: + * The number of characters read, or -1 on error. Use Tcl_GetErrno() + * to retrieve the error code for the error that occurred. + * + * Side effects: + * May cause input to be buffered. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Read(chan, bufPtr, toRead) + Tcl_Channel chan; /* The channel from which to read. */ + char *bufPtr; /* Where to store input read. */ + int toRead; /* Maximum number of characters to read. */ +{ + Channel *chanPtr; /* The real IO channel. */ + int copied; /* How many characters were copied into + * the result string? */ + int copiedNow; /* How many characters were copied from + * the current input buffer? */ + int result; /* Of calling GetInput. */ + + chanPtr = (Channel *) chan; + + /* + * Check for unreported error. + */ + + if (chanPtr->unreportedError != 0) { + Tcl_SetErrno(chanPtr->unreportedError); + chanPtr->unreportedError = 0; + return -1; + } + + /* + * Punt if the channel is not opened for reading. + */ + + if (!(chanPtr->flags & TCL_READABLE)) { + Tcl_SetErrno(EACCES); + return -1; + } + + /* + * If we have not encountered a sticky EOF, clear the EOF bit. Either + * way clear the BLOCKED bit. We want to discover these anew during + * each operation. + */ + + if (!(chanPtr->flags & CHANNEL_STICKY_EOF)) { + chanPtr->flags &= (~(CHANNEL_EOF)); + } + chanPtr->flags &= (~(CHANNEL_BLOCKED)); + + for (copied = 0; copied < toRead; copied += copiedNow) { + copiedNow = CopyAndTranslateBuffer(chanPtr, bufPtr + copied, + toRead - copied); + if (copiedNow == 0) { + if (chanPtr->flags & CHANNEL_EOF) { + return copied; + } + if (chanPtr->flags & CHANNEL_BLOCKED) { + if (chanPtr->flags & CHANNEL_NONBLOCKING) { + return copied; + } + chanPtr->flags &= (~(CHANNEL_BLOCKED)); + } + result = GetInput(chanPtr); + if (result != 0) { + if (result == EAGAIN) { + return copied; + } + return -1; + } + } + } + chanPtr->flags &= (~(CHANNEL_BLOCKED)); + return copied; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Gets -- + * + * Reads a complete line of input from the channel. + * + * Results: + * Length of line read or -1 if error, EOF or blocked. If -1, use + * Tcl_GetErrno() to retrieve the POSIX error code for the + * error or condition that occurred. + * + * Side effects: + * May flush output on the channel. May cause input to be + * consumed from the channel. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Gets(chan, lineRead) + Tcl_Channel chan; /* Channel from which to read. */ + Tcl_DString *lineRead; /* The characters of the line read + * (excluding the terminating newline if + * present) will be appended to this + * DString. The caller must have initialized + * it and is responsible for managing the + * storage. */ +{ + Channel *chanPtr; /* The channel to read from. */ + char *buf; /* Points into DString where data + * will be stored. */ + int offset; /* Offset from start of DString at + * which to append the line just read. */ + int copiedTotal; /* Accumulates total length of input copied. */ + int copiedNow; /* How many bytes were copied from the + * current input buffer? */ + int lineLen; /* Length of line read, including the + * translated newline. If this is zero + * and neither EOF nor BLOCKED is set, + * the current line is empty. */ + + chanPtr = (Channel *) chan; + + /* + * Check for unreported error. + */ + + if (chanPtr->unreportedError != 0) { + Tcl_SetErrno(chanPtr->unreportedError); + chanPtr->unreportedError = 0; + return -1; + } + + /* + * Punt if the channel is not opened for reading. + */ + + if (!(chanPtr->flags & TCL_READABLE)) { + Tcl_SetErrno(EACCES); + return -1; + } + + /* + * If we have not encountered a sticky EOF, clear the EOF bit + * (sticky EOF is set if we have seen the input eofChar, to prevent + * reading beyond the eofChar). Also, always clear the BLOCKED bit. + * We want to discover these conditions anew in each operation. + */ + + if (!(chanPtr->flags & CHANNEL_STICKY_EOF)) { + chanPtr->flags &= (~(CHANNEL_EOF)); + } + chanPtr->flags &= (~(CHANNEL_BLOCKED)); + lineLen = GetEOL(chanPtr); + if (lineLen < 0) { + return -1; + } + if (lineLen == 0) { + if (chanPtr->flags & (CHANNEL_EOF | CHANNEL_BLOCKED)) { + return -1; + } + return 0; + } + offset = Tcl_DStringLength(lineRead); + Tcl_DStringSetLength(lineRead, lineLen + offset); + buf = Tcl_DStringValue(lineRead) + offset; + + for (copiedTotal = 0; copiedTotal < lineLen; copiedTotal += copiedNow) { + copiedNow = CopyAndTranslateBuffer(chanPtr, buf + copiedTotal, + lineLen - copiedTotal); + } + if ((copiedTotal > 0) && (buf[copiedTotal - 1] == '\n')) { + copiedTotal--; + } + Tcl_DStringSetLength(lineRead, copiedTotal + offset); + return copiedTotal; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Seek -- + * + * Implements seeking on Tcl Channels. This is a public function + * so that other C facilities may be implemented on top of it. + * + * Results: + * The new access point or -1 on error. If error, use Tcl_GetErrno() + * to retrieve the POSIX error code for the error that occurred. + * + * Side effects: + * May flush output on the channel. May discard queued input. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Seek(chan, offset, mode) + Tcl_Channel chan; /* The channel on which to seek. */ + int offset; /* Offset to seek to. */ + int mode; /* Relative to which location to seek? */ +{ + Channel *chanPtr; /* The real IO channel. */ + ChannelBuffer *bufPtr; /* Iterates over queued input + * and output buffers. */ + int inputBuffered, outputBuffered; + int result; /* Of device driver operations. */ + int curPos; /* Position on the device. */ + int wasAsync; /* Was the channel nonblocking before the + * seek operation? If so, must restore to + * nonblocking mode after the seek. */ + Tcl_File outFile; /* Used to cancel async flushes for + * this channel. */ + + + chanPtr = (Channel *) chan; + + /* + * Check for unreported error. + */ + + if (chanPtr->unreportedError != 0) { + Tcl_SetErrno(chanPtr->unreportedError); + chanPtr->unreportedError = 0; + return -1; + } + + /* + * Disallow seek on channels that are open for neither writing nor + * reading (e.g. socket server channels). + */ + + if (!(chanPtr->flags & (TCL_WRITABLE|TCL_READABLE))) { + Tcl_SetErrno(EACCES); + return -1; + } + + /* + * Disallow seek on dead channels -- channels that have been closed but + * not yet been deallocated. Such channels can be found if the exit + * handler for channel cleanup has run but the channel is still + * registered in an interpreter. + */ + + if (chanPtr->flags & CHANNEL_DEAD) { + Tcl_SetErrno(EINVAL); + return -1; + } + + /* + * Disallow seek on channels whose type does not have a seek procedure + * defined. This means that the channel does not support seeking. + */ + + if (chanPtr->typePtr->seekProc == (Tcl_DriverSeekProc *) NULL) { + Tcl_SetErrno(EINVAL); + return -1; + } + + /* + * Compute how much input and output is buffered. If both input and + * output is buffered, cannot compute the current position. + */ + + for (bufPtr = chanPtr->inQueueHead, inputBuffered = 0; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + inputBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved); + } + for (bufPtr = chanPtr->outQueueHead, outputBuffered = 0; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + outputBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved); + } + if ((chanPtr->curOutPtr != (ChannelBuffer *) NULL) && + (chanPtr->curOutPtr->nextAdded > chanPtr->curOutPtr->nextRemoved)) { + chanPtr->flags |= BUFFER_READY; + outputBuffered += + (chanPtr->curOutPtr->nextAdded - chanPtr->curOutPtr->nextRemoved); + } + if ((inputBuffered != 0) && (outputBuffered != 0)) { + Tcl_SetErrno(EFAULT); + return -1; + } + + /* + * If we are seeking relative to the current position, compute the + * corrected offset taking into account the amount of unread input. + */ + + if (mode == SEEK_CUR) { + offset -= inputBuffered; + } + + /* + * Discard any queued input - this input should not be read after + * the seek. + */ + + DiscardInputQueued(chanPtr, 0); + + /* + * Reset EOF and BLOCKED flags. We invalidate them by moving the + * access point. Also clear CR related flags. + */ + + chanPtr->flags &= + (~(CHANNEL_EOF | CHANNEL_STICKY_EOF | CHANNEL_BLOCKED | INPUT_SAW_CR)); + + /* + * If the channel is in asynchronous output mode, switch it back + * to synchronous mode and cancel any async flush that may be + * scheduled. After the flush, the channel will be put back into + * asynchronous output mode. + */ + + wasAsync = 0; + if (chanPtr->flags & CHANNEL_NONBLOCKING) { + wasAsync = 1; + result = 0; + if (chanPtr->typePtr->blockModeProc != NULL) { + result = (chanPtr->typePtr->blockModeProc) (chanPtr->instanceData, + TCL_MODE_BLOCKING); + } + if (result != 0) { + Tcl_SetErrno(result); + return -1; + } + chanPtr->flags &= (~(CHANNEL_NONBLOCKING)); + if (chanPtr->flags & BG_FLUSH_SCHEDULED) { + chanPtr->flags &= (~(BG_FLUSH_SCHEDULED)); + outFile = Tcl_GetChannelFile((Tcl_Channel) chanPtr, TCL_WRITABLE); + if (outFile != (Tcl_File) NULL) { + Tcl_DeleteFileHandler(outFile); + } + } + } + + /* + * If the flush fails we cannot recover the original position. In + * that case the seek is not attempted because we do not know where + * the access position is - instead we return the error. FlushChannel + * has already called Tcl_SetErrno() to report the error upwards. + * If the flush succeeds we do the seek also. + */ + + if (FlushChannel(NULL, chanPtr, 0) != 0) { + curPos = -1; + } else { + + /* + * Now seek to the new position in the channel as requested by the + * caller. + */ + + curPos = (chanPtr->typePtr->seekProc) (chanPtr->instanceData, + (long) offset, mode, &result); + if (curPos == -1) { + Tcl_SetErrno(result); + } + } + + /* + * Restore to nonblocking mode if that was the previous behavior. + * + * NOTE: Even if there was an async flush active we do not restore + * it now because we already flushed all the queued output, above. + */ + + if (wasAsync) { + chanPtr->flags |= CHANNEL_NONBLOCKING; + result = 0; + if (chanPtr->typePtr->blockModeProc != NULL) { + result = (chanPtr->typePtr->blockModeProc) (chanPtr->instanceData, + TCL_MODE_NONBLOCKING); + } + if (result != 0) { + Tcl_SetErrno(result); + return -1; + } + } + + return curPos; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Tell -- + * + * Returns the position of the next character to be read/written on + * this channel. + * + * Results: + * A nonnegative integer on success, -1 on failure. If failed, + * use Tcl_GetErrno() to retrieve the POSIX error code for the + * error that occurred. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Tell(chan) + Tcl_Channel chan; /* The channel to return pos for. */ +{ + Channel *chanPtr; /* The actual channel to tell on. */ + ChannelBuffer *bufPtr; /* Iterates over queued input + * and output buffers. */ + int inputBuffered, outputBuffered; + int result; /* Of calling device driver. */ + int curPos; /* Position on device. */ + + chanPtr = (Channel *) chan; + + /* + * Check for unreported error. + */ + + if (chanPtr->unreportedError != 0) { + Tcl_SetErrno(chanPtr->unreportedError); + chanPtr->unreportedError = 0; + return -1; + } + + /* + * Disallow tell on dead channels -- channels that have been closed but + * not yet been deallocated. Such channels can be found if the exit + * handler for channel cleanup has run but the channel is still + * registered in an interpreter. + */ + + if (chanPtr->flags & CHANNEL_DEAD) { + Tcl_SetErrno(EINVAL); + return -1; + } + + /* + * Disallow tell on channels that are open for neither + * writing nor reading (e.g. socket server channels). + */ + + if (!(chanPtr->flags & (TCL_WRITABLE|TCL_READABLE))) { + Tcl_SetErrno(EACCES); + return -1; + } + + /* + * Disallow tell on channels whose type does not have a seek procedure + * defined. This means that the channel does not support seeking. + */ + + if (chanPtr->typePtr->seekProc == (Tcl_DriverSeekProc *) NULL) { + Tcl_SetErrno(EINVAL); + return -1; + } + + /* + * Compute how much input and output is buffered. If both input and + * output is buffered, cannot compute the current position. + */ + + for (bufPtr = chanPtr->inQueueHead, inputBuffered = 0; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + inputBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved); + } + for (bufPtr = chanPtr->outQueueHead, outputBuffered = 0; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + outputBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved); + } + if (chanPtr->curOutPtr != (ChannelBuffer *) NULL) { + outputBuffered += + (chanPtr->curOutPtr->nextAdded - chanPtr->curOutPtr->nextRemoved); + } + if ((inputBuffered != 0) && (outputBuffered != 0)) { + Tcl_SetErrno(EFAULT); + return -1; + } + + /* + * Get the current position in the device and compute the position + * where the next character will be read or written. + */ + + curPos = (chanPtr->typePtr->seekProc) (chanPtr->instanceData, + (long) 0, SEEK_CUR, &result); + if (curPos == -1) { + Tcl_SetErrno(result); + return -1; + } + if (inputBuffered != 0) { + return (curPos - inputBuffered); + } + return (curPos + outputBuffered); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Eof -- + * + * Returns 1 if the channel is at EOF, 0 otherwise. + * + * Results: + * 1 or 0, always. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Eof(chan) + Tcl_Channel chan; /* Does this channel have EOF? */ +{ + Channel *chanPtr; /* The real channel structure. */ + + chanPtr = (Channel *) chan; + return ((chanPtr->flags & CHANNEL_STICKY_EOF) || + ((chanPtr->flags & CHANNEL_EOF) && (Tcl_InputBuffered(chan) == 0))) + ? 1 : 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_InputBlocked -- + * + * Returns 1 if input is blocked on this channel, 0 otherwise. + * + * Results: + * 0 or 1, always. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_InputBlocked(chan) + Tcl_Channel chan; /* Is this channel blocked? */ +{ + Channel *chanPtr; /* The real channel structure. */ + + chanPtr = (Channel *) chan; + return (chanPtr->flags & CHANNEL_BLOCKED) ? 1 : 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_InputBuffered -- + * + * Returns the number of bytes of input currently buffered in the + * internal buffer of a channel. + * + * Results: + * The number of input bytes buffered, or zero if the channel is not + * open for reading. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_InputBuffered(chan) + Tcl_Channel chan; /* The channel to query. */ +{ + Channel *chanPtr; + int bytesBuffered; + ChannelBuffer *bufPtr; + + chanPtr = (Channel *) chan; + for (bytesBuffered = 0, bufPtr = chanPtr->inQueueHead; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + bytesBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved); + } + return bytesBuffered; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetChannelBufferSize -- + * + * Sets the size of buffers to allocate to store input or output + * in the channel. The size must be between 10 bytes and 1 MByte. + * + * Results: + * None. + * + * Side effects: + * Sets the size of buffers subsequently allocated for this channel. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetChannelBufferSize(chan, sz) + Tcl_Channel chan; /* The channel whose buffer size + * to set. */ + int sz; /* The size to set. */ +{ + Channel *chanPtr; + + if (sz < 10) { + sz = CHANNELBUFFER_DEFAULT_SIZE; + } + + /* + * Allow only buffers that are smaller than one megabyte. + */ + + if (sz > (1024 * 1024)) { + sz = CHANNELBUFFER_DEFAULT_SIZE; + } + + chanPtr = (Channel *) chan; + chanPtr->bufSize = sz; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetChannelBufferSize -- + * + * Retrieves the size of buffers to allocate for this channel. + * + * Results: + * The size. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetChannelBufferSize(chan) + Tcl_Channel chan; /* The channel for which to find the + * buffer size. */ +{ + Channel *chanPtr; + + chanPtr = (Channel *) chan; + return chanPtr->bufSize; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetChannelOption -- + * + * Gets a mode associated with an IO channel. If the optionName arg + * is non NULL, retrieves the value of that option. If the optionName + * arg is NULL, retrieves a list of alternating option names and + * values for the given channel. + * + * Results: + * A standard Tcl result. Also sets the supplied DString to the + * string value of the option(s) returned. + * + * Side effects: + * The string returned by this function is in static storage and + * may be reused at any time subsequent to the call. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetChannelOption(chan, optionName, dsPtr) + Tcl_Channel chan; /* Channel on which to get option. */ + char *optionName; /* Option to get. */ + Tcl_DString *dsPtr; /* Where to store value(s). */ +{ + Channel *chanPtr; /* The real IO channel. */ + size_t len; /* Length of optionName string. */ + char optionVal[128]; /* Buffer for sprintf. */ + + chanPtr = (Channel *) chan; + + /* + * Disallow options on dead channels -- channels that have been closed but + * not yet been deallocated. Such channels can be found if the exit + * handler for channel cleanup has run but the channel is still + * registered in an interpreter. + */ + + if (chanPtr->flags & CHANNEL_DEAD) { + Tcl_SetErrno(EINVAL); + return TCL_ERROR; + } + + /* + * If the optionName is NULL it means that we want a list of all + * options and values. + */ + + if (optionName == (char *) NULL) { + len = 0; + } else { + len = strlen(optionName); + } + + if ((len == 0) || ((len > 2) && (optionName[1] == 'b') && + (strncmp(optionName, "-blocking", len) == 0))) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-blocking"); + } + Tcl_DStringAppendElement(dsPtr, + (chanPtr->flags & CHANNEL_NONBLOCKING) ? "0" : "1"); + if (len > 0) { + return TCL_OK; + } + } + if ((len == 0) || ((len > 7) && (optionName[1] == 'b') && + (strncmp(optionName, "-buffering", len) == 0))) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-buffering"); + } + if (chanPtr->flags & CHANNEL_LINEBUFFERED) { + Tcl_DStringAppendElement(dsPtr, "line"); + } else if (chanPtr->flags & CHANNEL_UNBUFFERED) { + Tcl_DStringAppendElement(dsPtr, "none"); + } else { + Tcl_DStringAppendElement(dsPtr, "full"); + } + if (len > 0) { + return TCL_OK; + } + } + if ((len == 0) || ((len > 7) && (optionName[1] == 'b') && + (strncmp(optionName, "-buffersize", len) == 0))) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-buffersize"); + } + sprintf(optionVal, "%d", chanPtr->bufSize); + Tcl_DStringAppendElement(dsPtr, optionVal); + if (len > 0) { + return TCL_OK; + } + } + if ((len == 0) || + ((len > 1) && (optionName[1] == 'e') && + (strncmp(optionName, "-eofchar", len) == 0))) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-eofchar"); + } + if (((chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)) == + (TCL_READABLE|TCL_WRITABLE)) && (len == 0)) { + Tcl_DStringStartSublist(dsPtr); + } + if (chanPtr->flags & TCL_READABLE) { + if (chanPtr->inEofChar == 0) { + Tcl_DStringAppendElement(dsPtr, ""); + } else { + char buf[4]; + + sprintf(buf, "%c", chanPtr->inEofChar); + Tcl_DStringAppendElement(dsPtr, buf); + } + } + if (chanPtr->flags & TCL_WRITABLE) { + if (chanPtr->outEofChar == 0) { + Tcl_DStringAppendElement(dsPtr, ""); + } else { + char buf[4]; + + sprintf(buf, "%c", chanPtr->outEofChar); + Tcl_DStringAppendElement(dsPtr, buf); + } + } + if (((chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)) == + (TCL_READABLE|TCL_WRITABLE)) && (len == 0)) { + Tcl_DStringEndSublist(dsPtr); + } + if (len > 0) { + return TCL_OK; + } + } + if ((len == 0) || + ((len > 1) && (optionName[1] == 't') && + (strncmp(optionName, "-translation", len) == 0))) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-translation"); + } + if (((chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)) == + (TCL_READABLE|TCL_WRITABLE)) && (len == 0)) { + Tcl_DStringStartSublist(dsPtr); + } + if (chanPtr->flags & TCL_READABLE) { + if (chanPtr->inputTranslation == TCL_TRANSLATE_AUTO) { + Tcl_DStringAppendElement(dsPtr, "auto"); + } else if (chanPtr->inputTranslation == TCL_TRANSLATE_CR) { + Tcl_DStringAppendElement(dsPtr, "cr"); + } else if (chanPtr->inputTranslation == TCL_TRANSLATE_CRLF) { + Tcl_DStringAppendElement(dsPtr, "crlf"); + } else { + Tcl_DStringAppendElement(dsPtr, "lf"); + } + } + if (chanPtr->flags & TCL_WRITABLE) { + if (chanPtr->outputTranslation == TCL_TRANSLATE_AUTO) { + Tcl_DStringAppendElement(dsPtr, "auto"); + } else if (chanPtr->outputTranslation == TCL_TRANSLATE_CR) { + Tcl_DStringAppendElement(dsPtr, "cr"); + } else if (chanPtr->outputTranslation == TCL_TRANSLATE_CRLF) { + Tcl_DStringAppendElement(dsPtr, "crlf"); + } else { + Tcl_DStringAppendElement(dsPtr, "lf"); + } + } + if (((chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)) == + (TCL_READABLE|TCL_WRITABLE)) && (len == 0)) { + Tcl_DStringEndSublist(dsPtr); + } + if (len > 0) { + return TCL_OK; + } + } + if (chanPtr->typePtr->getOptionProc != (Tcl_DriverGetOptionProc *) NULL) { + return (chanPtr->typePtr->getOptionProc) (chanPtr->instanceData, + optionName, dsPtr); + } + if (len == 0) { + return TCL_OK; + } + Tcl_SetErrno(EINVAL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetChannelOption -- + * + * Sets an option on a channel. + * + * Results: + * A standard Tcl result. Also sets interp->result on error if + * interp is not NULL. + * + * Side effects: + * May modify an option on a device. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SetChannelOption(interp, chan, optionName, newValue) + Tcl_Interp *interp; /* For error reporting - can be NULL. */ + Tcl_Channel chan; /* Channel on which to set mode. */ + char *optionName; /* Which option to set? */ + char *newValue; /* New value for option. */ +{ + int result; /* Result of channel type operation. */ + int newMode; /* New (numeric) mode to sert. */ + Channel *chanPtr; /* The real IO channel. */ + size_t len; /* Length of optionName string. */ + int argc; + char **argv; + Tcl_File outFile; /* Used to cancel async flush. */ + + chanPtr = (Channel *) chan; + + /* + * Disallow options on dead channels -- channels that have been closed but + * not yet been deallocated. Such channels can be found if the exit + * handler for channel cleanup has run but the channel is still + * registered in an interpreter. + */ + + if (chanPtr->flags & CHANNEL_DEAD) { + Tcl_SetErrno(EINVAL); + return -1; + } + + len = strlen(optionName); + + if ((len > 2) && (optionName[1] == 'b') && + (strncmp(optionName, "-blocking", len) == 0)) { + if (Tcl_GetBoolean(interp, newValue, &newMode) == TCL_ERROR) { + return TCL_ERROR; + } + if (newMode) { + newMode = TCL_MODE_BLOCKING; + } else { + newMode = TCL_MODE_NONBLOCKING; + } + result = 0; + if (chanPtr->typePtr->blockModeProc != NULL) { + result = (chanPtr->typePtr->blockModeProc) (chanPtr->instanceData, + newMode); + } + if (result != 0) { + Tcl_SetErrno(result); + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "error setting blocking mode: ", + Tcl_PosixError(interp), (char *) NULL); + } + return TCL_ERROR; + } + if (newMode == TCL_MODE_BLOCKING) { + chanPtr->flags &= (~(CHANNEL_NONBLOCKING | BG_FLUSH_SCHEDULED)); + outFile = Tcl_GetChannelFile((Tcl_Channel) chanPtr, TCL_WRITABLE); + if (outFile != (Tcl_File) NULL) { + Tcl_DeleteFileHandler(outFile); + } + } else { + chanPtr->flags |= CHANNEL_NONBLOCKING; + } + return TCL_OK; + } + + if ((len > 7) && (optionName[1] == 'b') && + (strncmp(optionName, "-buffering", len) == 0)) { + len = strlen(newValue); + if ((newValue[0] == 'f') && (strncmp(newValue, "full", len) == 0)) { + chanPtr->flags &= + (~(CHANNEL_UNBUFFERED|CHANNEL_LINEBUFFERED)); + } else if ((newValue[0] == 'l') && + (strncmp(newValue, "line", len) == 0)) { + chanPtr->flags &= (~(CHANNEL_UNBUFFERED)); + chanPtr->flags |= CHANNEL_LINEBUFFERED; + } else if ((newValue[0] == 'n') && + (strncmp(newValue, "none", len) == 0)) { + chanPtr->flags &= (~(CHANNEL_LINEBUFFERED)); + chanPtr->flags |= CHANNEL_UNBUFFERED; + } else { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "bad value for -buffering: ", + "must be one of full, line, or none", + (char *) NULL); + return TCL_ERROR; + } + } + return TCL_OK; + } + + if ((len > 7) && (optionName[1] == 'b') && + (strncmp(optionName, "-buffersize", len) == 0)) { + chanPtr->bufSize = atoi(newValue); + if ((chanPtr->bufSize < 10) || (chanPtr->bufSize > (1024 * 1024))) { + chanPtr->bufSize = CHANNELBUFFER_DEFAULT_SIZE; + } + return TCL_OK; + } + + if ((len > 1) && (optionName[1] == 'e') && + (strncmp(optionName, "-eofchar", len) == 0)) { + if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) { + return TCL_ERROR; + } + if (argc == 0) { + chanPtr->inEofChar = 0; + chanPtr->outEofChar = 0; + } else if (argc == 1) { + if (chanPtr->flags & TCL_WRITABLE) { + chanPtr->outEofChar = (int) argv[0][0]; + } + if (chanPtr->flags & TCL_READABLE) { + chanPtr->inEofChar = (int) argv[0][0]; + } + } else if (argc != 2) { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, + "bad value for -eofchar: should be a list of one or", + " two elements", (char *) NULL); + } + ckfree((char *) argv); + return TCL_ERROR; + } else { + if (chanPtr->flags & TCL_READABLE) { + chanPtr->inEofChar = (int) argv[0][0]; + } + if (chanPtr->flags & TCL_WRITABLE) { + chanPtr->outEofChar = (int) argv[1][0]; + } + } + if (argv != (char **) NULL) { + ckfree((char *) argv); + } + return TCL_OK; + } + + if ((len > 1) && (optionName[1] == 't') && + (strncmp(optionName, "-translation", len) == 0)) { + if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) { + return TCL_ERROR; + } + if (argc == 1) { + if (chanPtr->flags & TCL_READABLE) { + chanPtr->flags &= (~(INPUT_SAW_CR)); + if (strcmp(argv[0], "auto") == 0) { + chanPtr->inputTranslation = TCL_TRANSLATE_AUTO; + } else if (strcmp(argv[0], "binary") == 0) { + chanPtr->inEofChar = 0; + chanPtr->inputTranslation = TCL_TRANSLATE_LF; + } else if (strcmp(argv[0], "lf") == 0) { + chanPtr->inputTranslation = TCL_TRANSLATE_LF; + } else if (strcmp(argv[0], "cr") == 0) { + chanPtr->inputTranslation = TCL_TRANSLATE_CR; + } else if (strcmp(argv[0], "crlf") == 0) { + chanPtr->inputTranslation = TCL_TRANSLATE_CRLF; + } else if (strcmp(argv[0], "platform") == 0) { + chanPtr->inputTranslation = TCL_PLATFORM_TRANSLATION; + } else { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, + "bad value for -translation: ", + "must be one of auto, binary, cr, lf, crlf,", + " or platform", (char *) NULL); + } + ckfree((char *) argv); + return TCL_ERROR; + } + } + if (chanPtr->flags & TCL_WRITABLE) { + if (strcmp(argv[0], "auto") == 0) { + /* + * This is a hack to get TCP sockets to produce output + * in CRLF mode if they are being set into AUTO mode. + * A better solution for achieving this effect will be + * coded later. + */ + + if (strcmp(chanPtr->typePtr->typeName, "tcp") == 0) { + chanPtr->outputTranslation = TCL_TRANSLATE_CRLF; + } else { + chanPtr->outputTranslation = TCL_PLATFORM_TRANSLATION; + } + } else if (strcmp(argv[0], "binary") == 0) { + chanPtr->outEofChar = 0; + chanPtr->outputTranslation = TCL_TRANSLATE_LF; + } else if (strcmp(argv[0], "lf") == 0) { + chanPtr->outputTranslation = TCL_TRANSLATE_LF; + } else if (strcmp(argv[0], "cr") == 0) { + chanPtr->outputTranslation = TCL_TRANSLATE_CR; + } else if (strcmp(argv[0], "crlf") == 0) { + chanPtr->outputTranslation = TCL_TRANSLATE_CRLF; + } else if (strcmp(argv[0], "platform") == 0) { + chanPtr->outputTranslation = TCL_PLATFORM_TRANSLATION; + } else { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, + "bad value for -translation: ", + "must be one of auto, binary, cr, lf, crlf,", + " or platform", (char *) NULL); + } + ckfree((char *) argv); + return TCL_ERROR; + } + } + } else if (argc != 2) { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, + "bad value for -translation: must be a one or two", + " element list", (char *) NULL); + } + ckfree((char *) argv); + return TCL_ERROR; + } else { + if (chanPtr->flags & TCL_READABLE) { + if (argv[0][0] == '\0') { + /* Empty body. */ + } else if (strcmp(argv[0], "auto") == 0) { + chanPtr->flags &= (~(INPUT_SAW_CR)); + chanPtr->inputTranslation = TCL_TRANSLATE_AUTO; + } else if (strcmp(argv[0], "binary") == 0) { + chanPtr->inEofChar = 0; + chanPtr->flags &= (~(INPUT_SAW_CR)); + chanPtr->inputTranslation = TCL_TRANSLATE_LF; + } else if (strcmp(argv[0], "lf") == 0) { + chanPtr->flags &= (~(INPUT_SAW_CR)); + chanPtr->inputTranslation = TCL_TRANSLATE_LF; + } else if (strcmp(argv[0], "cr") == 0) { + chanPtr->flags &= (~(INPUT_SAW_CR)); + chanPtr->inputTranslation = TCL_TRANSLATE_CR; + } else if (strcmp(argv[0], "crlf") == 0) { + chanPtr->flags &= (~(INPUT_SAW_CR)); + chanPtr->inputTranslation = TCL_TRANSLATE_CRLF; + } else if (strcmp(argv[0], "platform") == 0) { + chanPtr->flags &= (~(INPUT_SAW_CR)); + chanPtr->inputTranslation = TCL_PLATFORM_TRANSLATION; + } else { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, + "bad value for -translation: ", + "must be one of auto, binary, cr, lf, crlf,", + " or platform", (char *) NULL); + } + ckfree((char *) argv); + return TCL_ERROR; + } + } + if (chanPtr->flags & TCL_WRITABLE) { + if (argv[1][0] == '\0') { + /* Empty body. */ + } else if (strcmp(argv[1], "auto") == 0) { + /* + * This is a hack to get TCP sockets to produce output + * in CRLF mode if they are being set into AUTO mode. + * A better solution for achieving this effect will be + * coded later. + */ + + if (strcmp(chanPtr->typePtr->typeName, "tcp") == 0) { + chanPtr->outputTranslation = TCL_TRANSLATE_CRLF; + } else { + chanPtr->outputTranslation = TCL_PLATFORM_TRANSLATION; + } + } else if (strcmp(argv[1], "binary") == 0) { + chanPtr->outEofChar = 0; + chanPtr->outputTranslation = TCL_TRANSLATE_LF; + } else if (strcmp(argv[1], "lf") == 0) { + chanPtr->outputTranslation = TCL_TRANSLATE_LF; + } else if (strcmp(argv[1], "cr") == 0) { + chanPtr->outputTranslation = TCL_TRANSLATE_CR; + } else if (strcmp(argv[1], "crlf") == 0) { + chanPtr->outputTranslation = TCL_TRANSLATE_CRLF; + } else if (strcmp(argv[1], "platform") == 0) { + chanPtr->outputTranslation = TCL_PLATFORM_TRANSLATION; + } else { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, + "bad value for -translation: ", + "must be one of auto, binary, cr, lf, crlf,", + " or platform", (char *) NULL); + } + ckfree((char *) argv); + return TCL_ERROR; + } + } + } + ckfree((char *) argv); + return TCL_OK; + } + + if (chanPtr->typePtr->setOptionProc != (Tcl_DriverSetOptionProc *) NULL) { + return (chanPtr->typePtr->setOptionProc) (chanPtr->instanceData, + interp, optionName, newValue); + } + + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "bad option \"", optionName, + "\": should be -blocking, -buffering, -buffersize, ", + "-eofchar, -translation, ", + "or channel type specific option", + (char *) NULL); + } + + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * CleanupChannelHandlers -- + * + * Removes channel handlers that refer to the supplied interpreter, + * so that if the actual channel is not closed now, these handlers + * will not run on subsequent events on the channel. This would be + * erroneous, because the interpreter no longer has a reference to + * this channel. + * + * Results: + * None. + * + * Side effects: + * Removes channel handlers. + * + *---------------------------------------------------------------------- + */ + +static void +CleanupChannelHandlers(interp, chanPtr) + Tcl_Interp *interp; + Channel *chanPtr; +{ + EventScriptRecord *sPtr, *prevPtr, *nextPtr; + + /* + * Remove fileevent records on this channel that refer to the + * given interpreter. + */ + + for (sPtr = chanPtr->scriptRecordPtr, + prevPtr = (EventScriptRecord *) NULL; + sPtr != (EventScriptRecord *) NULL; + sPtr = nextPtr) { + nextPtr = sPtr->nextPtr; + if (sPtr->interp == interp) { + if (prevPtr == (EventScriptRecord *) NULL) { + chanPtr->scriptRecordPtr = nextPtr; + } else { + prevPtr->nextPtr = nextPtr; + } + + Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, + ChannelEventScriptInvoker, (ClientData) sPtr); + + Tcl_EventuallyFree((ClientData) sPtr->script, TCL_DYNAMIC); + ckfree((char *) sPtr); + } else { + prevPtr = sPtr; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * WaitForChannel -- + * + * This procedure waits synchronously for a channel to become readable + * or writable, with an optional timeout. + * + * Results: + * None. + * + * Side effects: + * Time passes. + * + *---------------------------------------------------------------------- + */ + +static void +WaitForChannel(chanPtr, mask, timeout) + Channel *chanPtr; /* Handle for channel to wait for. */ + int mask; /* What to wait for: OR'ed combination of + * TCL_READABLE, TCL_WRITABLE, and + * TCL_EXCEPTION. */ + int timeout; /* Maximum amount of time to wait for one + * of the conditions in mask to occur, in + * milliseconds. A value of 0 means don't + * wait at all, and a value of -1 means + * wait forever. */ +{ + Tcl_Time abortTime, now, blockTime; + int present; + + /* + * If there is a non-zero finite timeout, compute the time when + * we give up. + */ + + if (timeout > 0) { + TclpGetTime(&now); + abortTime.sec = now.sec + timeout/1000; + abortTime.usec = now.usec + (timeout%1000)*1000; + if (abortTime.usec >= 1000000) { + abortTime.usec -= 1000000; + abortTime.sec += 1; + } + } + + /* + * Loop in a mini-event loop of our own, waiting for either the + * file to become ready or a timeout to occur. + */ + + while (1) { + (chanPtr->typePtr->watchChannelProc) (chanPtr->instanceData, mask); + if (timeout > 0) { + blockTime.sec = abortTime.sec - now.sec; + blockTime.usec = abortTime.usec - now.usec; + if (blockTime.usec < 0) { + blockTime.sec -= 1; + blockTime.usec += 1000000; + } + if (blockTime.sec < 0) { + blockTime.sec = 0; + blockTime.usec = 0; + } + Tcl_WaitForEvent(&blockTime); + } else if (timeout == 0) { + blockTime.sec = 0; + blockTime.usec = 0; + Tcl_WaitForEvent(&blockTime); + } else { + Tcl_WaitForEvent((Tcl_Time *) NULL); + } + present = (chanPtr->typePtr->channelReadyProc) (chanPtr->instanceData, + mask); + if (present != 0) { + break; + } + if (timeout == 0) { + break; + } + TclpGetTime(&now); + if ((abortTime.sec < now.sec) + || ((abortTime.sec == now.sec) + && (abortTime.usec <= now.usec))) { + break; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * ChannelEventSourceExitProc -- + * + * This procedure is called during exit cleanup to delete the channel + * event source. It deletes the event source for channels. + * + * Results: + * None. + * + * Side effects: + * Destroys the channel event source. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +ChannelEventSourceExitProc(clientData) + ClientData clientData; /* Not used. */ +{ + Tcl_DeleteEventSource(ChannelHandlerSetupProc, ChannelHandlerCheckProc, + (ClientData) NULL); + channelEventSourceCreated = 0; +} + +/* + *---------------------------------------------------------------------- + * + * ChannelHandlerSetupProc -- + * + * This procedure is part of the event source for channel handlers. + * It is invoked by Tcl_DoOneEvent before it waits for events. The + * job of this procedure is to provide information to Tcl_DoOneEvent + * on how to wait for events (what files to watch). + * + * Results: + * None. + * + * Side effects: + * Tells the notifier what channels to watch. + * + *---------------------------------------------------------------------- + */ + +static void +ChannelHandlerSetupProc(clientData, flags) + ClientData clientData; /* Not used. */ + int flags; /* Flags passed to Tk_DoOneEvent: + * if it doesn't include + * TCL_FILE_EVENTS then we do + * nothing. */ +{ + Tcl_Time dontBlock; + Channel *chanPtr, *nextChanPtr; + + if (!(flags & TCL_FILE_EVENTS)) { + return; + } + + dontBlock.sec = 0; dontBlock.usec = 0; + + for (chanPtr = firstChanPtr; chanPtr != (Channel *) NULL; + chanPtr = nextChanPtr) { + nextChanPtr = chanPtr->nextChanPtr; + if (chanPtr->interestMask & TCL_READABLE) { + if ((!(chanPtr->flags & CHANNEL_BLOCKED)) && + (chanPtr->inQueueHead != (ChannelBuffer *) NULL) && + (chanPtr->inQueueHead->nextRemoved < + chanPtr->inQueueHead->nextAdded)) { + Tcl_SetMaxBlockTime(&dontBlock); + } else if (chanPtr->flags & TCL_READABLE) { + (chanPtr->typePtr->watchChannelProc) (chanPtr->instanceData, + TCL_READABLE); + } + } + if ((chanPtr->interestMask & TCL_WRITABLE) && + (chanPtr->flags & TCL_WRITABLE)) { + (chanPtr->typePtr->watchChannelProc) (chanPtr->instanceData, + TCL_WRITABLE); + } + if ((chanPtr->interestMask & TCL_EXCEPTION) && + (chanPtr->flags & (TCL_READABLE | TCL_WRITABLE))) { + (chanPtr->typePtr->watchChannelProc) (chanPtr->instanceData, + TCL_EXCEPTION); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * ChannelHandlerCheckProc -- + * + * This procedure is the second part (of three) of the event source + * for channels. It is invoked by Tcl_DoOneEvent after the wait for + * events is over. The job of this procedure is to test each channel + * to see if it is ready now, and if so, to create events and put them + * on the Tcl event queue. + * + * Results: + * None. + * + * Side effects: + * Makes entries on the Tcl event queue for each channel that is + * ready now. + * + *---------------------------------------------------------------------- + */ + +static void +ChannelHandlerCheckProc(clientData, flags) + ClientData clientData; /* Not used. */ + int flags; /* Flags passed to Tk_DoOneEvent: + * if it doesn't include + * TCL_FILE_EVENTS then we do + * nothing. */ +{ + Channel *chanPtr, *nextChanPtr; + ChannelHandlerEvent *ePtr; + int readyMask; + + if (!(flags & TCL_FILE_EVENTS)) { + return; + } + + for (chanPtr = firstChanPtr; + chanPtr != (Channel *) NULL; + chanPtr = nextChanPtr) { + nextChanPtr = chanPtr->nextChanPtr; + + readyMask = 0; + + /* + * Check for readability. + */ + + if (chanPtr->interestMask & TCL_READABLE) { + + /* + * The channel is considered ready for reading if there is input + * buffered AND the last attempt to read from the channel did not + * return EWOULDBLOCK, OR if the underlying file is ready. + * + * NOTE that the input queue may contain empty buffers, hence the + * special check to see if the first input buffer is empty. The + * invariant is that if there is an empty buffer in the queue + * there is only one buffer in the queue, hence an empty first + * buffer indicates that there is no input queued. + */ + + if ((!(chanPtr->flags & CHANNEL_BLOCKED)) && + ((chanPtr->inQueueHead != (ChannelBuffer *) NULL) && + (chanPtr->inQueueHead->nextRemoved < + chanPtr->inQueueHead->nextAdded))) { + readyMask |= TCL_READABLE; + } else { + readyMask |= (chanPtr->typePtr->channelReadyProc) + (chanPtr->instanceData, TCL_READABLE); + } + } + + /* + * Check for writability. + */ + + if (chanPtr->interestMask & TCL_WRITABLE) { + + /* + * The channel is considered ready for writing if there is no + * output buffered waiting to be written to the device, AND the + * underlying file is ready. + */ + + if ((chanPtr->outQueueHead == (ChannelBuffer *) NULL) && + (chanPtr->flags & TCL_WRITABLE)) { + readyMask |= (chanPtr->typePtr->channelReadyProc) + (chanPtr->instanceData, TCL_WRITABLE); + } + } + + /* + * Check for exceptions. + */ + + if (chanPtr->interestMask & TCL_EXCEPTION) { + readyMask |= (chanPtr->typePtr->channelReadyProc) + (chanPtr->instanceData, TCL_EXCEPTION); + } + + /* + * If there are any events for this channel, put a notice into the + * Tcl event queue. + */ + + if (readyMask != 0) { + ePtr = (ChannelHandlerEvent *) ckalloc((unsigned) + sizeof(ChannelHandlerEvent)); + ePtr->header.proc = ChannelHandlerEventProc; + ePtr->chanPtr = chanPtr; + ePtr->readyMask = readyMask; + Tcl_QueueEvent((Tcl_Event *) ePtr, TCL_QUEUE_TAIL); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * FlushEventProc -- + * + * This routine dispatches a background flush event. + * + * Errors that occur during the write operation are stored + * inside the channel structure for future reporting by the next + * operation that uses this channel. + * + * Results: + * None. + * + * Side effects: + * Causes production of output on a channel. + * + *---------------------------------------------------------------------- + */ + +static void +FlushEventProc(clientData, mask) + ClientData clientData; /* Channel to produce output on. */ + int mask; /* Not used. */ +{ + (void) FlushChannel(NULL, (Channel *) clientData, 1); +} + +/* + *---------------------------------------------------------------------- + * + * ChannelHandlerEventProc -- + * + * This procedure is called by Tcl_DoOneEvent when a channel event + * reaches the front of the event queue. This procedure is responsible + * for actually handling the event by invoking the callback for the + * channel handler. + * + * Results: + * Returns 1 if the event was handled, meaning that it should be + * removed from the queue. Returns 0 if the event was not handled + * meaning that it should stay in the queue. The only time the event + * will not be handled is if the TCL_FILE_EVENTS flag bit is not + * set in the flags passed. + * + * NOTE: If the handler is deleted between the time the event is added + * to the queue and the time it reaches the head of the queue, the + * event is silently discarded (i.e. we return 1). + * + * Side effects: + * Whatever the channel handler callback procedure does. + * + *---------------------------------------------------------------------- + */ + +static int +ChannelHandlerEventProc(evPtr, flags) + Tcl_Event *evPtr; /* Event to service. */ + int flags; /* Flags that indicate what events to + * handle, such as TCL_FILE_EVENTS. */ +{ + Channel *chanPtr; + ChannelHandler *chPtr; + ChannelHandlerEvent *ePtr; + NextChannelHandler nh; + + if (!(flags & TCL_FILE_EVENTS)) { + return 0; + } + + ePtr = (ChannelHandlerEvent *) evPtr; + chanPtr = ePtr->chanPtr; + + /* + * Add this invocation to the list of recursive invocations of + * ChannelHandlerEventProc. + */ + + nh.nextHandlerPtr = (ChannelHandler *) NULL; + nh.nestedHandlerPtr = nestedHandlerPtr; + nestedHandlerPtr = &nh; + + for (chPtr = chanPtr->chPtr; chPtr != (ChannelHandler *) NULL; ) { + + /* + * If this channel handler is interested in any of the events that + * have occurred on the channel, invoke its procedure. + */ + + if ((chPtr->mask & ePtr->readyMask) != 0) { + nh.nextHandlerPtr = chPtr->nextPtr; + (*(chPtr->proc))(chPtr->clientData, ePtr->readyMask); + chPtr = nh.nextHandlerPtr; + } else { + chPtr = chPtr->nextPtr; + } + } + + nestedHandlerPtr = nh.nestedHandlerPtr; + + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateChannelHandler -- + * + * Arrange for a given procedure to be invoked whenever the + * channel indicated by the chanPtr arg becomes readable or + * writable. + * + * Results: + * None. + * + * Side effects: + * From now on, whenever the I/O channel given by chanPtr becomes + * ready in the way indicated by mask, proc will be invoked. + * See the manual entry for details on the calling sequence + * to proc. If there is already an event handler for chan, proc + * and clientData, then the mask will be updated. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_CreateChannelHandler(chan, mask, proc, clientData) + Tcl_Channel chan; /* The channel to create the handler for. */ + int mask; /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, and TCL_EXCEPTION: + * indicates conditions under which + * proc should be called. Use 0 to + * disable a registered handler. */ + Tcl_ChannelProc *proc; /* Procedure to call for each + * selected event. */ + ClientData clientData; /* Arbitrary data to pass to proc. */ +{ + ChannelHandler *chPtr; + Channel *chanPtr; + + chanPtr = (Channel *) chan; + + /* + * Ensure that the channel event source is registered with the Tcl + * notification mechanism. + */ + + if (!channelEventSourceCreated) { + channelEventSourceCreated = 1; + Tcl_CreateEventSource(ChannelHandlerSetupProc, ChannelHandlerCheckProc, + (ClientData) NULL); + Tcl_CreateExitHandler(ChannelEventSourceExitProc, (ClientData) NULL); + } + + /* + * Check whether this channel handler is not already registered. If + * it is not, create a new record, else reuse existing record (smash + * current values). + */ + + for (chPtr = chanPtr->chPtr; + chPtr != (ChannelHandler *) NULL; + chPtr = chPtr->nextPtr) { + if ((chPtr->chanPtr == chanPtr) && (chPtr->proc == proc) && + (chPtr->clientData == clientData)) { + break; + } + } + if (chPtr == (ChannelHandler *) NULL) { + chPtr = (ChannelHandler *) ckalloc((unsigned) sizeof(ChannelHandler)); + chPtr->mask = 0; + chPtr->proc = proc; + chPtr->clientData = clientData; + chPtr->chanPtr = chanPtr; + chPtr->nextPtr = chanPtr->chPtr; + chanPtr->chPtr = chPtr; + } + + /* + * The remainder of the initialization below is done regardless of + * whether or not this is a new record or a modification of an old + * one. + */ + + chPtr->mask = mask; + + /* + * Recompute the interest mask for the channel - this call may actually + * be disabling an existing handler.. + */ + + chanPtr->interestMask = 0; + for (chPtr = chanPtr->chPtr; + chPtr != (ChannelHandler *) NULL; + chPtr = chPtr->nextPtr) { + chanPtr->interestMask |= chPtr->mask; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteChannelHandler -- + * + * Cancel a previously arranged callback arrangement for an IO + * channel. + * + * Results: + * None. + * + * Side effects: + * If a callback was previously registered for this chan, proc and + * clientData , it is removed and the callback will no longer be called + * when the channel becomes ready for IO. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteChannelHandler(chan, proc, clientData) + Tcl_Channel chan; /* The channel for which to remove the + * callback. */ + Tcl_ChannelProc *proc; /* The procedure in the callback to delete. */ + ClientData clientData; /* The client data in the callback + * to delete. */ + +{ + ChannelHandler *chPtr, *prevChPtr; + Channel *chanPtr; + NextChannelHandler *nhPtr; + + chanPtr = (Channel *) chan; + + /* + * Find the entry and the previous one in the list. + */ + + for (prevChPtr = (ChannelHandler *) NULL, chPtr = chanPtr->chPtr; + chPtr != (ChannelHandler *) NULL; + chPtr = chPtr->nextPtr) { + if ((chPtr->chanPtr == chanPtr) && (chPtr->clientData == clientData) + && (chPtr->proc == proc)) { + break; + } + prevChPtr = chPtr; + } + + /* + * If ChannelHandlerEventProc is about to process this handler, tell it to + * process the next one instead - we are going to delete *this* one. + */ + + for (nhPtr = nestedHandlerPtr; + nhPtr != (NextChannelHandler *) NULL; + nhPtr = nhPtr->nestedHandlerPtr) { + if (nhPtr->nextHandlerPtr == chPtr) { + nhPtr->nextHandlerPtr = chPtr->nextPtr; + } + } + + /* + * If found, splice the entry out of the list. + */ + + if (chPtr == (ChannelHandler *) NULL) { + return; + } + + if (prevChPtr == (ChannelHandler *) NULL) { + chanPtr->chPtr = chPtr->nextPtr; + } else { + prevChPtr->nextPtr = chPtr->nextPtr; + } + ckfree((char *) chPtr); + + /* + * Recompute the interest list for the channel, so that infinite loops + * will not result if Tcl_DeleteChanelHandler is called inside an event. + */ + + chanPtr->interestMask = 0; + for (chPtr = chanPtr->chPtr; + chPtr != (ChannelHandler *) NULL; + chPtr = chPtr->nextPtr) { + chanPtr->interestMask |= chPtr->mask; + } +} + +/* + *---------------------------------------------------------------------- + * + * ReturnScriptRecord -- + * + * Get a script stored for this channel with this interpreter. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Sets interp->result to the script. + * + *---------------------------------------------------------------------- + */ + +static void +ReturnScriptRecord(interp, chanPtr, mask) + Tcl_Interp *interp; /* The interpreter in which the script + * is to be executed. */ + Channel *chanPtr; /* The channel for which the script is + * stored. */ + int mask; /* Events in mask must overlap with events + * for which this script is stored. */ +{ + EventScriptRecord *esPtr; + + for (esPtr = chanPtr->scriptRecordPtr; + esPtr != (EventScriptRecord *) NULL; + esPtr = esPtr->nextPtr) { + if ((esPtr->interp == interp) && (esPtr->mask == mask)) { + interp->result = esPtr->script; + return; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * DeleteScriptRecord -- + * + * Delete a script record for this combination of channel, interp + * and mask. + * + * Results: + * None. + * + * Side effects: + * Deletes a script record and cancels a channel event handler. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteScriptRecord(interp, chanPtr, mask) + Tcl_Interp *interp; /* Interpreter in which script was to be + * executed. */ + Channel *chanPtr; /* The channel for which to delete the + * script record (if any). */ + int mask; /* Events in mask must exactly match mask + * of script to delete. */ +{ + EventScriptRecord *esPtr, *prevEsPtr; + + for (esPtr = chanPtr->scriptRecordPtr, + prevEsPtr = (EventScriptRecord *) NULL; + esPtr != (EventScriptRecord *) NULL; + prevEsPtr = esPtr, esPtr = esPtr->nextPtr) { + if ((esPtr->interp == interp) && (esPtr->mask == mask)) { + if (esPtr == chanPtr->scriptRecordPtr) { + chanPtr->scriptRecordPtr = esPtr->nextPtr; + } else { + prevEsPtr->nextPtr = esPtr->nextPtr; + } + + Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, + ChannelEventScriptInvoker, (ClientData) esPtr); + + Tcl_EventuallyFree((ClientData)esPtr->script, TCL_DYNAMIC); + ckfree((char *) esPtr); + + break; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * CreateScriptRecord -- + * + * Creates a record to store a script to be executed when a specific + * event fires on a specific channel. + * + * Results: + * None. + * + * Side effects: + * Causes the script to be stored for later execution. + * + *---------------------------------------------------------------------- + */ + +static void +CreateScriptRecord(interp, chanPtr, mask, script) + Tcl_Interp *interp; /* Interpreter in which to execute + * the stored script. */ + Channel *chanPtr; /* Channel for which script is to + * be stored. */ + int mask; /* Set of events for which script + * will be invoked. */ + char *script; /* A copy of this script is stored + * in the newly created record. */ +{ + EventScriptRecord *esPtr; + + for (esPtr = chanPtr->scriptRecordPtr; + esPtr != (EventScriptRecord *) NULL; + esPtr = esPtr->nextPtr) { + if ((esPtr->interp == interp) && (esPtr->mask == mask)) { + Tcl_EventuallyFree((ClientData)esPtr->script, TCL_DYNAMIC); + esPtr->script = (char *) NULL; + break; + } + } + if (esPtr == (EventScriptRecord *) NULL) { + esPtr = (EventScriptRecord *) ckalloc((unsigned) + sizeof(EventScriptRecord)); + Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask, + ChannelEventScriptInvoker, (ClientData) esPtr); + esPtr->nextPtr = chanPtr->scriptRecordPtr; + chanPtr->scriptRecordPtr = esPtr; + } + esPtr->chanPtr = chanPtr; + esPtr->interp = interp; + esPtr->mask = mask; + esPtr->script = ckalloc((unsigned) (strlen(script) + 1)); + strcpy(esPtr->script, script); +} + +/* + *---------------------------------------------------------------------- + * + * ChannelEventScriptInvoker -- + * + * Invokes a script scheduled by "fileevent" for when the channel + * becomes ready for IO. This function is invoked by the channel + * handler which was created by the Tcl "fileevent" command. + * + * Results: + * None. + * + * Side effects: + * Whatever the script does. + * + *---------------------------------------------------------------------- + */ + +static void +ChannelEventScriptInvoker(clientData, mask) + ClientData clientData; /* The script+interp record. */ + int mask; /* Not used. */ +{ + Tcl_Interp *interp; /* Interpreter in which to eval the script. */ + Channel *chanPtr; /* The channel for which this handler is + * registered. */ + char *script; /* Script to eval. */ + EventScriptRecord *esPtr; /* The event script + interpreter to eval it + * in. */ + int result; /* Result of call to eval script. */ + + esPtr = (EventScriptRecord *) clientData; + + chanPtr = esPtr->chanPtr; + mask = esPtr->mask; + interp = esPtr->interp; + script = esPtr->script; + + /* + * We must preserve the channel, script and interpreter because each of + * these may be deleted in the evaluation. If an error later occurs, we + * want to have the relevant data around for error reporting and so we + * can safely delete it. + */ + + Tcl_Preserve((ClientData) chanPtr); + Tcl_Preserve((ClientData) script); + Tcl_Preserve((ClientData) interp); + result = Tcl_GlobalEval(esPtr->interp, script); + + /* + * On error, cause a background error and remove the channel handler + * and the script record. + * + * NOTE: Must delete channel handler before causing the background error + * because the background error may want to reinstall the handler. + */ + + if (result != TCL_OK) { + DeleteScriptRecord(interp, chanPtr, mask); + Tcl_BackgroundError(interp); + } + Tcl_Release((ClientData) chanPtr); + Tcl_Release((ClientData) script); + Tcl_Release((ClientData) interp); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FileEventCmd -- + * + * This procedure implements the "fileevent" Tcl command. See the + * user documentation for details on what it does. This command is + * based on the Tk command "fileevent" which in turn is based on work + * contributed by Mark Diekhans. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May create a channel handler for the specified channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_FileEventCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Interpreter in which the channel + * for which to create the handler + * is found. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Channel *chanPtr; /* The channel to create + * the handler for. */ + Tcl_Channel chan; /* The opaque type for the channel. */ + int c; /* First char of mode argument. */ + int mask; /* Mask for events of interest. */ + size_t length; /* Length of mode argument. */ + + /* + * Parse arguments. + */ + + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: must be \"", argv[0], + " channelId event ?script?", (char *) NULL); + return TCL_ERROR; + } + c = argv[2][0]; + length = strlen(argv[2]); + if ((c == 'r') && (strncmp(argv[2], "readable", length) == 0)) { + mask = TCL_READABLE; + } else if ((c == 'w') && (strncmp(argv[2], "writable", length) == 0)) { + mask = TCL_WRITABLE; + } else { + Tcl_AppendResult(interp, "bad event name \"", argv[2], + "\": must be readable or writable", (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(interp, argv[1], NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + + chanPtr = (Channel *) chan; + if ((chanPtr->flags & mask) == 0) { + Tcl_AppendResult(interp, "channel is not ", + (mask == TCL_READABLE) ? "readable" : "writable", + (char *) NULL); + return TCL_ERROR; + } + + /* + * If we are supposed to return the script, do so. + */ + + if (argc == 3) { + ReturnScriptRecord(interp, chanPtr, mask); + return TCL_OK; + } + + /* + * If we are supposed to delete a stored script, do so. + */ + + if (argv[3][0] == 0) { + DeleteScriptRecord(interp, chanPtr, mask); + return TCL_OK; + } + + /* + * Make the script record that will link between the event and the + * script to invoke. This also creates a channel event handler which + * will evaluate the script in the supplied interpreter. + */ + + CreateScriptRecord(interp, chanPtr, mask, argv[3]); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclTestChannelCmd -- + * + * Implements the Tcl "testchannel" debugging command and its + * subcommands. This is part of the testing environment but must be + * in this file instead of tclTest.c because it needs access to the + * fields of struct Channel. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +TclTestChannelCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Interpreter for result. */ + int argc; /* Count of additional args. */ + char **argv; /* Additional arg strings. */ +{ + char *cmdName; /* Sub command. */ + Tcl_HashTable *hTblPtr; /* Hash table of channels. */ + Tcl_HashSearch hSearch; /* Search variable. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + Channel *chanPtr; /* The actual channel. */ + Tcl_Channel chan; /* The opaque type. */ + size_t len; /* Length of subcommand string. */ + int IOQueued; /* How much IO is queued inside channel? */ + ChannelBuffer *bufPtr; /* For iterating over queued IO. */ + char buf[128]; /* For sprintf. */ + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " subcommand ?additional args..?\"", (char *) NULL); + return TCL_ERROR; + } + cmdName = argv[1]; + len = strlen(cmdName); + + chanPtr = (Channel *) NULL; + if (argc > 2) { + chan = Tcl_GetChannel(interp, argv[2], NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + chanPtr = (Channel *) chan; + } + + if ((cmdName[0] == 'i') && (strncmp(cmdName, "info", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " info channelName\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_AppendElement(interp, argv[2]); + Tcl_AppendElement(interp, chanPtr->typePtr->typeName); + if (chanPtr->flags & TCL_READABLE) { + Tcl_AppendElement(interp, "read"); + } else { + Tcl_AppendElement(interp, ""); + } + if (chanPtr->flags & TCL_WRITABLE) { + Tcl_AppendElement(interp, "write"); + } else { + Tcl_AppendElement(interp, ""); + } + if (chanPtr->flags & CHANNEL_NONBLOCKING) { + Tcl_AppendElement(interp, "nonblocking"); + } else { + Tcl_AppendElement(interp, "blocking"); + } + if (chanPtr->flags & CHANNEL_LINEBUFFERED) { + Tcl_AppendElement(interp, "line"); + } else if (chanPtr->flags & CHANNEL_UNBUFFERED) { + Tcl_AppendElement(interp, "none"); + } else { + Tcl_AppendElement(interp, "full"); + } + if (chanPtr->flags & BG_FLUSH_SCHEDULED) { + Tcl_AppendElement(interp, "async_flush"); + } else { + Tcl_AppendElement(interp, ""); + } + if (chanPtr->flags & CHANNEL_EOF) { + Tcl_AppendElement(interp, "eof"); + } else { + Tcl_AppendElement(interp, ""); + } + if (chanPtr->flags & CHANNEL_BLOCKED) { + Tcl_AppendElement(interp, "blocked"); + } else { + Tcl_AppendElement(interp, "unblocked"); + } + if (chanPtr->inputTranslation == TCL_TRANSLATE_AUTO) { + Tcl_AppendElement(interp, "auto"); + if (chanPtr->flags & INPUT_SAW_CR) { + Tcl_AppendElement(interp, "saw_cr"); + } else { + Tcl_AppendElement(interp, ""); + } + } else if (chanPtr->inputTranslation == TCL_TRANSLATE_LF) { + Tcl_AppendElement(interp, "lf"); + Tcl_AppendElement(interp, ""); + } else if (chanPtr->inputTranslation == TCL_TRANSLATE_CR) { + Tcl_AppendElement(interp, "cr"); + Tcl_AppendElement(interp, ""); + } else if (chanPtr->inputTranslation == TCL_TRANSLATE_CRLF) { + Tcl_AppendElement(interp, "crlf"); + if (chanPtr->flags & INPUT_SAW_CR) { + Tcl_AppendElement(interp, "queued_cr"); + } else { + Tcl_AppendElement(interp, ""); + } + } + if (chanPtr->outputTranslation == TCL_TRANSLATE_AUTO) { + Tcl_AppendElement(interp, "auto"); + } else if (chanPtr->outputTranslation == TCL_TRANSLATE_LF) { + Tcl_AppendElement(interp, "lf"); + } else if (chanPtr->outputTranslation == TCL_TRANSLATE_CR) { + Tcl_AppendElement(interp, "cr"); + } else if (chanPtr->outputTranslation == TCL_TRANSLATE_CRLF) { + Tcl_AppendElement(interp, "crlf"); + } + for (IOQueued = 0, bufPtr = chanPtr->inQueueHead; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + IOQueued += bufPtr->nextAdded - bufPtr->nextRemoved; + } + sprintf(buf, "%d", IOQueued); + Tcl_AppendElement(interp, buf); + + IOQueued = 0; + if (chanPtr->curOutPtr != (ChannelBuffer *) NULL) { + IOQueued = chanPtr->curOutPtr->nextAdded - + chanPtr->curOutPtr->nextRemoved; + } + for (bufPtr = chanPtr->outQueueHead; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + IOQueued += (bufPtr->nextAdded - bufPtr->nextRemoved); + } + sprintf(buf, "%d", IOQueued); + Tcl_AppendElement(interp, buf); + + sprintf(buf, "%d", Tcl_Tell((Tcl_Channel) chanPtr)); + Tcl_AppendElement(interp, buf); + + sprintf(buf, "%d", chanPtr->refCount); + Tcl_AppendElement(interp, buf); + + return TCL_OK; + } + + if ((cmdName[0] == 'i') && + (strncmp(cmdName, "inputbuffered", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", + (char *) NULL); + return TCL_ERROR; + } + + for (IOQueued = 0, bufPtr = chanPtr->inQueueHead; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + IOQueued += bufPtr->nextAdded - bufPtr->nextRemoved; + } + sprintf(buf, "%d", IOQueued); + Tcl_AppendResult(interp, buf, (char *) NULL); + return TCL_OK; + } + + if ((cmdName[0] == 'm') && (strncmp(cmdName, "mode", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", + (char *) NULL); + return TCL_ERROR; + } + + if (chanPtr->flags & TCL_READABLE) { + Tcl_AppendElement(interp, "read"); + } else { + Tcl_AppendElement(interp, ""); + } + if (chanPtr->flags & TCL_WRITABLE) { + Tcl_AppendElement(interp, "write"); + } else { + Tcl_AppendElement(interp, ""); + } + return TCL_OK; + } + + if ((cmdName[0] == 'n') && (strncmp(cmdName, "name", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", + (char *) NULL); + return TCL_ERROR; + } + Tcl_AppendResult(interp, chanPtr->channelName, (char *) NULL); + return TCL_OK; + } + + if ((cmdName[0] == 'o') && (strncmp(cmdName, "open", len) == 0)) { + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + return TCL_OK; + } + for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr)); + } + return TCL_OK; + } + + if ((cmdName[0] == 'o') && + (strncmp(cmdName, "outputbuffered", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", + (char *) NULL); + return TCL_ERROR; + } + + IOQueued = 0; + if (chanPtr->curOutPtr != (ChannelBuffer *) NULL) { + IOQueued = chanPtr->curOutPtr->nextAdded - + chanPtr->curOutPtr->nextRemoved; + } + for (bufPtr = chanPtr->outQueueHead; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + IOQueued += (bufPtr->nextAdded - bufPtr->nextRemoved); + } + sprintf(buf, "%d", IOQueued); + Tcl_AppendResult(interp, buf, (char *) NULL); + return TCL_OK; + } + + if ((cmdName[0] == 'q') && + (strncmp(cmdName, "queuedcr", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", + (char *) NULL); + return TCL_ERROR; + } + + Tcl_AppendResult(interp, + (chanPtr->flags & INPUT_SAW_CR) ? "1" : "0", + (char *) NULL); + return TCL_OK; + } + + if ((cmdName[0] == 'r') && (strncmp(cmdName, "readable", len) == 0)) { + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + return TCL_OK; + } + for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + chanPtr = (Channel *) Tcl_GetHashValue(hPtr); + if (chanPtr->flags & TCL_READABLE) { + Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr)); + } + } + return TCL_OK; + } + + if ((cmdName[0] == 'r') && (strncmp(cmdName, "refcount", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", + (char *) NULL); + return TCL_ERROR; + } + + sprintf(buf, "%d", chanPtr->refCount); + Tcl_AppendResult(interp, buf, (char *) NULL); + return TCL_OK; + } + + if ((cmdName[0] == 't') && (strncmp(cmdName, "type", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", + (char *) NULL); + return TCL_ERROR; + } + Tcl_AppendResult(interp, chanPtr->typePtr->typeName, (char *) NULL); + return TCL_OK; + } + + if ((cmdName[0] == 'w') && (strncmp(cmdName, "writable", len) == 0)) { + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + return TCL_OK; + } + for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + chanPtr = (Channel *) Tcl_GetHashValue(hPtr); + if (chanPtr->flags & TCL_WRITABLE) { + Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr)); + } + } + return TCL_OK; + } + + Tcl_AppendResult(interp, "bad option \"", cmdName, "\": should be ", + "info, open, readable, or writable", + (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * TclTestChannelEventCmd -- + * + * This procedure implements the "testchannelevent" command. It is + * used to test the Tcl channel event mechanism. It is present in + * this file instead of tclTest.c because it needs access to the + * internal structure of the channel. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates, deletes and returns channel event handlers. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +TclTestChannelEventCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Channel *chanPtr; + EventScriptRecord *esPtr, *prevEsPtr, *nextEsPtr; + char *cmd; + int index, i, mask, len; + + if ((argc < 3) || (argc > 5)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelName cmd ?arg1? ?arg2?\"", (char *) NULL); + return TCL_ERROR; + } + chanPtr = (Channel *) Tcl_GetChannel(interp, argv[1], NULL); + if (chanPtr == (Channel *) NULL) { + return TCL_ERROR; + } + cmd = argv[2]; + len = strlen(cmd); + if ((cmd[0] == 'a') && (strncmp(cmd, "add", (unsigned) len) == 0)) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelName add eventSpec script\"", (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[3], "readable") == 0) { + mask = TCL_READABLE; + } else if (strcmp(argv[3], "writable") == 0) { + mask = TCL_WRITABLE; + } else { + Tcl_AppendResult(interp, "bad event name \"", argv[3], + "\": must be readable or writable", (char *) NULL); + return TCL_ERROR; + } + + esPtr = (EventScriptRecord *) ckalloc((unsigned) + sizeof(EventScriptRecord)); + esPtr->nextPtr = chanPtr->scriptRecordPtr; + chanPtr->scriptRecordPtr = esPtr; + + esPtr->chanPtr = chanPtr; + esPtr->interp = interp; + esPtr->mask = mask; + esPtr->script = ckalloc((unsigned) (strlen(argv[4]) + 1)); + strcpy(esPtr->script, argv[4]); + + Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask, + ChannelEventScriptInvoker, (ClientData) esPtr); + + return TCL_OK; + } + + if ((cmd[0] == 'd') && (strncmp(cmd, "delete", (unsigned) len) == 0)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelName delete index\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) { + return TCL_ERROR; + } + if (index < 0) { + Tcl_AppendResult(interp, "bad event index: ", argv[3], + ": must be nonnegative", (char *) NULL); + return TCL_ERROR; + } + for (i = 0, esPtr = chanPtr->scriptRecordPtr; + (i < index) && (esPtr != (EventScriptRecord *) NULL); + i++, esPtr = esPtr->nextPtr) { + /* Empty loop body. */ + } + if (esPtr == (EventScriptRecord *) NULL) { + Tcl_AppendResult(interp, "bad event index ", argv[3], + ": out of range", (char *) NULL); + return TCL_ERROR; + } + if (esPtr == chanPtr->scriptRecordPtr) { + chanPtr->scriptRecordPtr = esPtr->nextPtr; + } else { + for (prevEsPtr = chanPtr->scriptRecordPtr; + (prevEsPtr != (EventScriptRecord *) NULL) && + (prevEsPtr->nextPtr != esPtr); + prevEsPtr = prevEsPtr->nextPtr) { + /* Empty loop body. */ + } + if (prevEsPtr == (EventScriptRecord *) NULL) { + panic("TclTestChannelEventCmd: damaged event script list"); + } + prevEsPtr->nextPtr = esPtr->nextPtr; + } + Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, + ChannelEventScriptInvoker, (ClientData) esPtr); + Tcl_EventuallyFree((ClientData)esPtr->script, TCL_DYNAMIC); + ckfree((char *) esPtr); + + return TCL_OK; + } + + if ((cmd[0] == 'l') && (strncmp(cmd, "list", (unsigned) len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelName list\"", (char *) NULL); + return TCL_ERROR; + } + for (esPtr = chanPtr->scriptRecordPtr; + esPtr != (EventScriptRecord *) NULL; + esPtr = esPtr->nextPtr) { + Tcl_AppendElement(interp, + esPtr->mask == TCL_READABLE ? "readable" : "writable"); + Tcl_AppendElement(interp, esPtr->script); + } + return TCL_OK; + } + + if ((cmd[0] == 'r') && (strncmp(cmd, "removeall", (unsigned) len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelName removeall\"", (char *) NULL); + return TCL_ERROR; + } + for (esPtr = chanPtr->scriptRecordPtr; + esPtr != (EventScriptRecord *) NULL; + esPtr = nextEsPtr) { + nextEsPtr = esPtr->nextPtr; + Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, + ChannelEventScriptInvoker, (ClientData) esPtr); + Tcl_EventuallyFree((ClientData)esPtr->script, TCL_DYNAMIC); + ckfree((char *) esPtr); + } + chanPtr->scriptRecordPtr = (EventScriptRecord *) NULL; + return TCL_OK; + } + + Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of ", + "add, delete, list, or removeall", (char *) NULL); + return TCL_ERROR; + +} diff --git a/tcl7.6/generic/tclIOCmd.c b/tcl7.6/generic/tclIOCmd.c new file mode 100644 index 0000000..5ea69a8 --- /dev/null +++ b/tcl7.6/generic/tclIOCmd.c @@ -0,0 +1,1510 @@ +/* + * tclIOCmd.c -- + * + * Contains the definitions of most of the Tcl commands relating to IO. + * + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclIOCmd.c 1.99 96/09/27 10:01:45 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * Return at most this number of bytes in one call to Tcl_Read: + */ + +#define TCL_READ_CHUNK_SIZE 4096 + +/* + * Callback structure for accept callback in a TCP server. + */ + +typedef struct AcceptCallback { + char *script; /* Script to invoke. */ + Tcl_Interp *interp; /* Interpreter in which to run it. */ +} AcceptCallback; + +/* + * Static functions for this file: + */ + +static void AcceptCallbackProc _ANSI_ARGS_((ClientData callbackData, + Tcl_Channel chan, char *address, int port)); +static void RegisterTcpServerInterpCleanup _ANSI_ARGS_((Tcl_Interp *interp, + AcceptCallback *acceptCallbackPtr)); +static void TcpAcceptCallbacksDeleteProc _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp)); +static void TcpServerCloseProc _ANSI_ARGS_((ClientData callbackData)); +static void UnregisterTcpServerInterpCleanupProc _ANSI_ARGS_(( + Tcl_Interp *interp, AcceptCallback *acceptCallbackPtr)); + +/* + *---------------------------------------------------------------------- + * + * 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: + * Produces output on a channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_PutsCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Channel chan; /* The channel to puts on. */ + int i; /* Counter. */ + int newline; /* Add a newline at end? */ + char *channelId; /* Name of channel for puts. */ + int result; /* Result of puts operation. */ + int mode; /* Mode in which channel is opened. */ + + 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? ?channelId? 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)) { + channelId = "stdout"; + } else { + channelId = argv[i]; + i++; + } + chan = Tcl_GetChannel(interp, channelId, &mode); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if ((mode & TCL_WRITABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", channelId, + "\" wasn't opened for writing", (char *) NULL); + return TCL_ERROR; + } + + result = Tcl_Write(chan, argv[i], -1); + if (result < 0) { + goto error; + } + if (newline != 0) { + result = Tcl_Write(chan, "\n", 1); + if (result < 0) { + goto error; + } + } + return TCL_OK; +error: + Tcl_AppendResult(interp, "error writing \"", Tcl_GetChannelName(chan), + "\": ", Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FlushCmd -- + * + * This procedure is called to process the Tcl "flush" command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May cause output to appear on the specified channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_FlushCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Channel chan; /* The channel to flush on. */ + int result; /* Result of call to channel + * level function. */ + int mode; /* Mode in which channel is opened. */ + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelId\"", (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(interp, argv[1], &mode); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if ((mode & TCL_WRITABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", argv[1], + "\" wasn't opened for writing", (char *) NULL); + return TCL_ERROR; + } + + result = Tcl_Flush(chan); + if (result != TCL_OK) { + Tcl_AppendResult(interp, "error flushing \"", Tcl_GetChannelName(chan), + "\": ", Tcl_PosixError(interp), (char *) NULL); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetsCmd -- + * + * This procedure is called to process the Tcl "gets" command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May consume input from channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_GetsCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Channel chan; /* The channel to read from. */ + char *varName; /* Assign to this variable? */ + char buf[128]; /* Buffer to store string + * representation of how long + * a line was read. */ + Tcl_DString ds; /* Dynamic string to hold the + * buffer for the line just read. */ + int lineLen; /* Length of line just read. */ + int mode; /* Mode in which channel is opened. */ + + if ((argc != 2) && (argc != 3)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelId ?varName?\"", (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(interp, argv[1], &mode); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if ((mode & TCL_READABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", argv[1], + "\" wasn't opened for reading", (char *) NULL); + return TCL_ERROR; + } + + if (argc != 3) { + varName = (char *) NULL; + } else { + varName = argv[2]; + } + Tcl_DStringInit(&ds); + lineLen = Tcl_Gets(chan, &ds); + if (lineLen < 0) { + if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) { + Tcl_DStringFree(&ds); + Tcl_AppendResult(interp, "error reading \"", + Tcl_GetChannelName(chan), "\": ", Tcl_PosixError(interp), + (char *) NULL); + return TCL_ERROR; + } + lineLen = -1; + } + if (varName == (char *) NULL) { + Tcl_DStringResult(interp, &ds); + } else { + if (Tcl_SetVar(interp, varName, Tcl_DStringValue(&ds), + TCL_LEAVE_ERR_MSG) == NULL) { + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + Tcl_ResetResult(interp); + sprintf(buf, "%d", lineLen); + Tcl_AppendResult(interp, buf, (char *) NULL); + } + Tcl_DStringFree(&ds); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ReadCmd -- + * + * This procedure is invoked to process the Tcl "read" command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May consume input from channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ReadCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Channel chan; /* The channel to read from. */ + int newline, i; /* Discard newline at end? */ + int toRead; /* How many bytes to read? */ + int toReadNow; /* How many bytes to attempt to + * read in the current iteration? */ + int charactersRead; /* How many characters were read? */ + int charactersReadNow; /* How many characters were read + * in this iteration? */ + int mode; /* Mode in which channel is opened. */ + Tcl_DString ds; /* Used to accumulate the data + * read by Tcl_Read. */ + int bufSize; /* Channel buffer size; used to decide + * in what chunk sizes to read from + * the channel. */ + + if ((argc != 2) && (argc != 3)) { +argerror: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelId ?numBytes?\" or \"", argv[0], + " ?-nonewline? channelId\"", (char *) NULL); + return TCL_ERROR; + } + i = 1; + newline = 0; + if (strcmp(argv[i], "-nonewline") == 0) { + newline = 1; + i++; + } + + if (i == argc) { + goto argerror; + } + + chan = Tcl_GetChannel(interp, argv[i], &mode); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if ((mode & TCL_READABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", argv[i], + "\" wasn't opened for reading", (char *) NULL); + return TCL_ERROR; + } + + i++; /* Consumed channel name. */ + + /* + * Compute how many bytes to read, and see whether the final + * newline should be dropped. + */ + + toRead = INT_MAX; + if (i < argc) { + if (isdigit((unsigned char) (argv[i][0]))) { + if (Tcl_GetInt(interp, argv[i], &toRead) != TCL_OK) { + return TCL_ERROR; + } + } else if (strcmp(argv[i], "nonewline") == 0) { + newline = 1; + } else { + Tcl_AppendResult(interp, "bad argument \"", argv[i], + "\": should be \"nonewline\"", (char *) NULL); + return TCL_ERROR; + } + } + + bufSize = Tcl_GetChannelBufferSize(chan); + Tcl_DStringInit(&ds); + for (charactersRead = 0; charactersRead < toRead; ) { + toReadNow = toRead - charactersRead; + if (toReadNow > bufSize) { + toReadNow = bufSize; + } + Tcl_DStringSetLength(&ds, charactersRead + toReadNow); + charactersReadNow = + Tcl_Read(chan, Tcl_DStringValue(&ds) + charactersRead, toReadNow); + if (charactersReadNow < 0) { + Tcl_DStringFree(&ds); + Tcl_AppendResult(interp, "error reading \"", + Tcl_GetChannelName(chan), "\": ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + + /* + * If we had a short read it means that we have either EOF + * or BLOCKED on the channel, so break out. + */ + + charactersRead += charactersReadNow; + if (charactersReadNow < toReadNow) { + break; /* Out of "for" loop. */ + } + } + + /* + * Tcl_Read does not put a NULL at the end of the string, so we must + * do it here. + */ + + Tcl_DStringSetLength(&ds, charactersRead); + Tcl_DStringResult(interp, &ds); + Tcl_DStringFree(&ds); + + /* + * If requested, remove the last newline in the channel if at EOF. + */ + + if ((charactersRead > 0) && (newline) && + (interp->result[charactersRead-1] == '\n')) { + interp->result[charactersRead-1] = '\0'; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclUnsupported0Cmd -- + * + * This procedure is invoked to process the Tcl "unsupported0" command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May copy a chunk from one channel to another. + * + *---------------------------------------------------------------------- + */ + +int +TclUnsupported0Cmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Interpreter in which both channels + * are defined. */ + int argc; /* How many arguments? */ + char **argv; /* The argument strings. */ +{ + Tcl_Channel inChan, outChan; + int requested; + char *bufPtr; + int actuallyRead, actuallyWritten, totalRead, toReadNow, mode; + + /* + * Assume we want to copy the entire channel. + */ + + requested = INT_MAX; + + if ((argc < 3) || (argc > 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " inChanId outChanId ?chunkSize?\"", (char *) NULL); + return TCL_ERROR; + } + inChan = Tcl_GetChannel(interp, argv[1], &mode); + if (inChan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if ((mode & TCL_READABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", argv[1], + "\" wasn't opened for reading", (char *) NULL); + return TCL_ERROR; + } + outChan = Tcl_GetChannel(interp, argv[2], &mode); + if (outChan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if ((mode & TCL_WRITABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", argv[2], + "\" wasn't opened for writing", (char *) NULL); + return TCL_ERROR; + } + + if (argc == 4) { + if (Tcl_GetInt(interp, argv[3], &requested) != TCL_OK) { + return TCL_ERROR; + } + if (requested < 0) { + requested = INT_MAX; + } + } + + bufPtr = ckalloc((unsigned) TCL_READ_CHUNK_SIZE); + for (totalRead = 0; + requested > 0; + totalRead += actuallyRead, requested -= actuallyRead) { + toReadNow = requested; + if (toReadNow > TCL_READ_CHUNK_SIZE) { + toReadNow = TCL_READ_CHUNK_SIZE; + } + actuallyRead = Tcl_Read(inChan, bufPtr, toReadNow); + if (actuallyRead < 0) { + ckfree(bufPtr); + Tcl_AppendResult(interp, argv[0], ": ", Tcl_GetChannelName(inChan), + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + if (actuallyRead == 0) { + ckfree(bufPtr); + sprintf(interp->result, "%d", totalRead); + return TCL_OK; + } + actuallyWritten = Tcl_Write(outChan, bufPtr, actuallyRead); + if (actuallyWritten < 0) { + ckfree(bufPtr); + Tcl_AppendResult(interp, argv[0], ": ", Tcl_GetChannelName(outChan), + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + } + ckfree(bufPtr); + + sprintf(interp->result, "%d", totalRead); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SeekCmd -- + * + * This procedure is invoked to process the Tcl "seek" command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Moves the position of the access point on the specified channel. + * May flush queued output. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_SeekCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Channel chan; /* The channel to tell on. */ + int offset, mode; /* Where to seek? */ + int result; /* Of calling Tcl_Seek. */ + + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelId offset ?origin?\"", (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(interp, argv[1], NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[2], &offset) != TCL_OK) { + return TCL_ERROR; + } + mode = SEEK_SET; + if (argc == 4) { + size_t length; + int 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; + } + } + + result = Tcl_Seek(chan, offset, mode); + if (result < 0) { + Tcl_AppendResult(interp, "error during seek on \"", + Tcl_GetChannelName(chan), "\": ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_TellCmd -- + * + * This procedure is invoked to process the Tcl "tell" command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_TellCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Channel chan; /* The channel to tell on. */ + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelId\"", (char *) NULL); + return TCL_ERROR; + } + /* + * Try to find a channel with the right name and permissions in + * the IO channel table of this interpreter. + */ + + chan = Tcl_GetChannel(interp, argv[1], NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + sprintf(interp->result, "%d", Tcl_Tell(chan)); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CloseCmd -- + * + * This procedure is invoked to process the Tcl "close" command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May discard queued input; may flush queued output. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_CloseCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Channel chan; /* The channel to close. */ + int len; /* Length of error output. */ + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelId\"", (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(interp, argv[1], NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if (Tcl_UnregisterChannel(interp, chan) != TCL_OK) { + + /* + * If there is an error message and it ends with a newline, remove + * the newline. This is done for command pipeline channels where the + * error output from the subprocesses is stored in interp->result. + * + * NOTE: This is likely to not have any effect on regular error + * messages produced by drivers during the closing of a channel, + * because the Tcl convention is that such error messages do not + * have a terminating newline. + */ + + len = strlen(interp->result); + if ((len > 0) && (interp->result[len - 1] == '\n')) { + interp->result[len - 1] = '\0'; + } + + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FconfigureCmd -- + * + * This procedure is invoked to process the Tcl "fconfigure" command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May modify the behavior of an IO channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_FconfigureCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Channel chan; /* The channel to set a mode on. */ + int result; /* Of Tcl_Set/GetChannelOption. */ + int i; /* Iterate over arg-value pairs. */ + Tcl_DString ds; /* DString to hold result of + * calling Tcl_GetChannelOption. */ + + if ((argc < 2) || (((argc % 2) == 1) && (argc != 3))) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelId ?optionName? ?value? ?optionName value?...\"", + (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(interp, argv[1], NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if (argc == 2) { + Tcl_DStringInit(&ds); + if (Tcl_GetChannelOption(chan, (char *) NULL, &ds) != TCL_OK) { + Tcl_AppendResult(interp, "option retrieval failed", + (char *) NULL); + return TCL_ERROR; + } + Tcl_DStringResult(interp, &ds); + Tcl_DStringFree(&ds); + return TCL_OK; + } + if (argc == 3) { + Tcl_DStringInit(&ds); + if (Tcl_GetChannelOption(chan, argv[2], &ds) != TCL_OK) { + Tcl_DStringFree(&ds); + Tcl_AppendResult(interp, "bad option \"", argv[2], + "\": must be -blocking, -buffering, -buffersize, ", + "-eofchar, -translation, ", + "or a channel type specific option", (char *) NULL); + return TCL_ERROR; + } + Tcl_DStringResult(interp, &ds); + Tcl_DStringFree(&ds); + return TCL_OK; + } + for (i = 3; i < argc; i += 2) { + result = Tcl_SetChannelOption(interp, chan, argv[i-1], argv[i]); + if (result != TCL_OK) { + return result; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_EofCmd -- + * + * This procedure is invoked to process the Tcl "eof" command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Sets interp->result to "0" or "1" depending on whether the + * specified channel has an EOF condition. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_EofCmd(unused, interp, argc, argv) + ClientData unused; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Channel chan; /* The channel to query for EOF. */ + int mode; /* Mode in which channel is opened. */ + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelId\"", (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(interp, argv[1], &mode); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + sprintf(interp->result, "%d", Tcl_Eof(chan) ? 1 : 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. */ +{ +#ifdef MAC_TCL + Tcl_AppendResult(interp, "exec not implemented under Mac OS", + (char *)NULL); + return TCL_ERROR; +#else /* !MAC_TCL */ + int keepNewline, firstWord, background, length, result; + Tcl_Channel chan; + Tcl_DString ds; + int readSoFar, readNow, bufSize; + + /* + * 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. + */ + + background = 0; + if ((argv[argc-1][0] == '&') && (argv[argc-1][1] == 0)) { + argc--; + argv[argc] = NULL; + background = 1; + } + + chan = Tcl_OpenCommandChannel(interp, argc-firstWord, + argv+firstWord, + (background ? 0 : TCL_STDOUT | TCL_STDERR)); + + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + + if (background) { + + /* + * Get the list of PIDs from the pipeline into interp->result and + * detach the PIDs (instead of waiting for them). + */ + + TclGetAndDetachPids(interp, chan); + + if (Tcl_Close(interp, chan) != TCL_OK) { + return TCL_ERROR; + } + return TCL_OK; + } + + if (Tcl_GetChannelFile(chan, TCL_READABLE) != NULL) { +#define EXEC_BUFFER_SIZE 4096 + + Tcl_DStringInit(&ds); + readSoFar = 0; bufSize = 0; + while (1) { + bufSize += EXEC_BUFFER_SIZE; + Tcl_DStringSetLength(&ds, bufSize); + readNow = Tcl_Read(chan, Tcl_DStringValue(&ds) + readSoFar, + EXEC_BUFFER_SIZE); + if (readNow < 0) { + Tcl_DStringFree(&ds); + Tcl_AppendResult(interp, + "error reading output from command: ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + readSoFar += readNow; + if (readNow < EXEC_BUFFER_SIZE) { + break; /* Out of "while (1)" loop. */ + } + } + Tcl_DStringSetLength(&ds, readSoFar); + Tcl_DStringResult(interp, &ds); + Tcl_DStringFree(&ds); + } + + result = Tcl_Close(interp, chan); + + /* + * 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; +#endif /* !MAC_TCL */ +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FblockedCmd -- + * + * This procedure is invoked to process the Tcl "fblocked" command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Sets interp->result to "0" or "1" depending on whether the + * a preceding input operation on the channel would have blocked. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_FblockedCmd(unused, interp, argc, argv) + ClientData unused; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Channel chan; /* The channel to query for blocked. */ + int mode; /* Mode in which channel was opened. */ + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelId\"", (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(interp, argv[1], &mode); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if ((mode & TCL_READABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", argv[1], + "\" wasn't opened for reading", (char *) NULL); + return TCL_ERROR; + } + + sprintf(interp->result, "%d", Tcl_InputBlocked(chan) ? 1 : 0); + 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, prot; + char *modeString; + Tcl_Channel chan; + + 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) { + modeString = "r"; + } else { + modeString = argv[2]; + if (argc == 4) { + if (Tcl_GetInt(interp, argv[3], &prot) != TCL_OK) { + return TCL_ERROR; + } + } + } + + pipeline = 0; + if (argv[1][0] == '|') { + pipeline = 1; + } + + /* + * Open the file or create a process pipeline. + */ + + if (!pipeline) { + chan = Tcl_OpenFileChannel(interp, argv[1], modeString, prot); + } else { + int mode, seekFlag, cmdArgc; + char **cmdArgv; + + if (Tcl_SplitList(interp, argv[1]+1, &cmdArgc, &cmdArgv) != TCL_OK) { + return TCL_ERROR; + } + + mode = TclGetOpenMode(interp, modeString, &seekFlag); + if (mode == -1) { + chan = NULL; + } else { + int flags = TCL_STDERR | TCL_ENFORCE_MODE; + switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) { + case O_RDONLY: + flags |= TCL_STDOUT; + break; + case O_WRONLY: + flags |= TCL_STDIN; + break; + case O_RDWR: + flags |= (TCL_STDIN | TCL_STDOUT); + break; + default: + panic("Tcl_OpenCmd: invalid mode value"); + break; + } + chan = Tcl_OpenCommandChannel(interp, cmdArgc, cmdArgv, flags); + } + ckfree((char *) cmdArgv); + } + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + Tcl_RegisterChannel(interp, chan); + Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TcpAcceptCallbacksDeleteProc -- + * + * Assocdata cleanup routine called when an interpreter is being + * deleted to set the interp field of all the accept callback records + * registered with the interpreter to NULL. This will prevent the + * interpreter from being used in the future to eval accept scripts. + * + * Results: + * None. + * + * Side effects: + * Deallocates memory and sets the interp field of all the accept + * callback records to NULL to prevent this interpreter from being + * used subsequently to eval accept scripts. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +TcpAcceptCallbacksDeleteProc(clientData, interp) + ClientData clientData; /* Data which was passed when the assocdata + * was registered. */ + Tcl_Interp *interp; /* Interpreter being deleted - not used. */ +{ + Tcl_HashTable *hTblPtr; + Tcl_HashEntry *hPtr; + Tcl_HashSearch hSearch; + AcceptCallback *acceptCallbackPtr; + + hTblPtr = (Tcl_HashTable *) clientData; + for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + acceptCallbackPtr = (AcceptCallback *) Tcl_GetHashValue(hPtr); + acceptCallbackPtr->interp = (Tcl_Interp *) NULL; + } + Tcl_DeleteHashTable(hTblPtr); + ckfree((char *) hTblPtr); +} + +/* + *---------------------------------------------------------------------- + * + * RegisterTcpServerInterpCleanup -- + * + * Registers an accept callback record to have its interp + * field set to NULL when the interpreter is deleted. + * + * Results: + * None. + * + * Side effects: + * When, in the future, the interpreter is deleted, the interp + * field of the accept callback data structure will be set to + * NULL. This will prevent attempts to eval the accept script + * in a deleted interpreter. + * + *---------------------------------------------------------------------- + */ + +static void +RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr) + Tcl_Interp *interp; /* Interpreter for which we want to be + * informed of deletion. */ + AcceptCallback *acceptCallbackPtr; + /* The accept callback record whose + * interp field we want set to NULL when + * the interpreter is deleted. */ +{ + Tcl_HashTable *hTblPtr; /* Hash table for accept callback + * records to smash when the interpreter + * will be deleted. */ + Tcl_HashEntry *hPtr; /* Entry for this record. */ + int new; /* Is the entry new? */ + + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, + "tclTCPAcceptCallbacks", + NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable)); + Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS); + (void) Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks", + TcpAcceptCallbacksDeleteProc, (ClientData) hTblPtr); + } + hPtr = Tcl_CreateHashEntry(hTblPtr, (char *) acceptCallbackPtr, &new); + if (!new) { + panic("RegisterTcpServerCleanup: damaged accept record table"); + } + Tcl_SetHashValue(hPtr, (ClientData) acceptCallbackPtr); +} + +/* + *---------------------------------------------------------------------- + * + * UnregisterTcpServerInterpCleanupProc -- + * + * Unregister a previously registered accept callback record. The + * interp field of this record will no longer be set to NULL in + * the future when the interpreter is deleted. + * + * Results: + * None. + * + * Side effects: + * Prevents the interp field of the accept callback record from + * being set to NULL in the future when the interpreter is deleted. + * + *---------------------------------------------------------------------- + */ + +static void +UnregisterTcpServerInterpCleanupProc(interp, acceptCallbackPtr) + Tcl_Interp *interp; /* Interpreter in which the accept callback + * record was registered. */ + AcceptCallback *acceptCallbackPtr; + /* The record for which to delete the + * registration. */ +{ + Tcl_HashTable *hTblPtr; + Tcl_HashEntry *hPtr; + + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, + "tclTCPAcceptCallbacks", NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + return; + } + hPtr = Tcl_FindHashEntry(hTblPtr, (char *) acceptCallbackPtr); + if (hPtr == (Tcl_HashEntry *) NULL) { + return; + } + Tcl_DeleteHashEntry(hPtr); +} + +/* + *---------------------------------------------------------------------- + * + * AcceptCallbackProc -- + * + * This callback is invoked by the TCP channel driver when it + * accepts a new connection from a client on a server socket. + * + * Results: + * None. + * + * Side effects: + * Whatever the script does. + * + *---------------------------------------------------------------------- + */ + +static void +AcceptCallbackProc(callbackData, chan, address, port) + ClientData callbackData; /* The data stored when the callback + * was created in the call to + * Tcl_OpenTcpServer. */ + Tcl_Channel chan; /* Channel for the newly accepted + * connection. */ + char *address; /* Address of client that was + * accepted. */ + int port; /* Port of client that was accepted. */ +{ + AcceptCallback *acceptCallbackPtr; + Tcl_Interp *interp; + char *script; + char portBuf[10]; + int result; + + acceptCallbackPtr = (AcceptCallback *) callbackData; + + /* + * Check if the callback is still valid; the interpreter may have gone + * away, this is signalled by setting the interp field of the callback + * data to NULL. + */ + + if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) { + + script = acceptCallbackPtr->script; + interp = acceptCallbackPtr->interp; + + Tcl_Preserve((ClientData) script); + Tcl_Preserve((ClientData) interp); + + sprintf(portBuf, "%d", port); + Tcl_RegisterChannel(interp, chan); + result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan), + " ", address, " ", portBuf, (char *) NULL); + if (result != TCL_OK) { + Tcl_BackgroundError(interp); + Tcl_UnregisterChannel(interp, chan); + } + Tcl_Release((ClientData) interp); + Tcl_Release((ClientData) script); + } else { + + /* + * The interpreter has been deleted, so there is no useful + * way to utilize the client socket - just close it. + */ + + Tcl_Close((Tcl_Interp *) NULL, chan); + } +} + +/* + *---------------------------------------------------------------------- + * + * TcpServerCloseProc -- + * + * This callback is called when the TCP server channel for which it + * was registered is being closed. It informs the interpreter in + * which the accept script is evaluated (if that interpreter still + * exists) that this channel no longer needs to be informed if the + * interpreter is deleted. + * + * Results: + * None. + * + * Side effects: + * In the future, if the interpreter is deleted this channel will + * no longer be informed. + * + *---------------------------------------------------------------------- + */ + +static void +TcpServerCloseProc(callbackData) + ClientData callbackData; /* The data passed in the call to + * Tcl_CreateCloseHandler. */ +{ + AcceptCallback *acceptCallbackPtr; + /* The actual data. */ + + acceptCallbackPtr = (AcceptCallback *) callbackData; + if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) { + UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp, + acceptCallbackPtr); + } + Tcl_EventuallyFree((ClientData) acceptCallbackPtr->script, TCL_DYNAMIC); + ckfree((char *) acceptCallbackPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SocketCmd -- + * + * This procedure is invoked to process the "socket" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates a socket based channel. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SocketCmd(notUsed, interp, argc, argv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int a, server, port; + char *arg, *copyScript, *host, *script; + char *myaddr = NULL; + int myport = 0; + int async = 0; + Tcl_Channel chan; + AcceptCallback *acceptCallbackPtr; + + server = 0; + script = NULL; + + if (TclHasSockets(interp) != TCL_OK) { + return TCL_ERROR; + } + + for (a = 1; a < argc; a++) { + arg = argv[a]; + if (arg[0] == '-') { + if (strcmp(arg, "-server") == 0) { + if (async == 1) { + Tcl_AppendResult(interp, + "cannot set -async option for server sockets", + (char *) NULL); + return TCL_ERROR; + } + server = 1; + a++; + if (a >= argc) { + Tcl_AppendResult(interp, + "no argument given for -server option", + (char *) NULL); + return TCL_ERROR; + } + script = argv[a]; + } else if (strcmp(arg, "-myaddr") == 0) { + a++; + if (a >= argc) { + Tcl_AppendResult(interp, + "no argument given for -myaddr option", + (char *) NULL); + return TCL_ERROR; + } + myaddr = argv[a]; + } else if (strcmp(arg, "-myport") == 0) { + a++; + if (a >= argc) { + Tcl_AppendResult(interp, + "no argument given for -myport option", + (char *) NULL); + return TCL_ERROR; + } + if (TclSockGetPort(interp, argv[a], "tcp", &myport) + != TCL_OK) { + return TCL_ERROR; + } + } else if (strcmp(arg, "-async") == 0) { + if (server == 1) { + Tcl_AppendResult(interp, + "cannot set -async option for server sockets", + (char *) NULL); + return TCL_ERROR; + } + async = 1; + } else { + Tcl_AppendResult(interp, "bad option \"", arg, + "\", must be -async, -myaddr, -myport, or -server", + (char *) NULL); + return TCL_ERROR; + } + } else { + break; + } + } + if (server) { + host = myaddr; /* NULL implies INADDR_ANY */ + if (myport != 0) { + Tcl_AppendResult(interp, "Option -myport is not valid for servers", + NULL); + return TCL_ERROR; + } + } else if (a < argc) { + host = argv[a]; + a++; + } else { +wrongNumArgs: + Tcl_AppendResult(interp, "wrong # args: should be either:\n", + argv[0], + " ?-myaddr addr? ?-myport myport? ?-async? host port\n", + argv[0], + " -server command ?-myaddr addr? port", + (char *) NULL); + return TCL_ERROR; + } + + if (a == argc-1) { + if (TclSockGetPort(interp, argv[a], "tcp", &port) != TCL_OK) { + return TCL_ERROR; + } + } else { + goto wrongNumArgs; + } + + if (server) { + acceptCallbackPtr = (AcceptCallback *) ckalloc((unsigned) + sizeof(AcceptCallback)); + copyScript = ckalloc((unsigned) strlen(script) + 1); + strcpy(copyScript, script); + acceptCallbackPtr->script = copyScript; + acceptCallbackPtr->interp = interp; + chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc, + (ClientData) acceptCallbackPtr); + if (chan == (Tcl_Channel) NULL) { + ckfree(copyScript); + ckfree((char *) acceptCallbackPtr); + return TCL_ERROR; + } + + /* + * Register with the interpreter to let us know when the + * interpreter is deleted (by having the callback set the + * acceptCallbackPtr->interp field to NULL). This is to + * avoid trying to eval the script in a deleted interpreter. + */ + + RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr); + + /* + * Register a close callback. This callback will inform the + * interpreter (if it still exists) that this channel does not + * need to be informed when the interpreter is deleted. + */ + + Tcl_CreateCloseHandler(chan, TcpServerCloseProc, + (ClientData) acceptCallbackPtr); + } else { + chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + } + Tcl_RegisterChannel(interp, chan); + Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL); + + return TCL_OK; +} diff --git a/tcl7.6/generic/tclIOSock.c b/tcl7.6/generic/tclIOSock.c new file mode 100644 index 0000000..cfc8adb --- /dev/null +++ b/tcl7.6/generic/tclIOSock.c @@ -0,0 +1,96 @@ +/* + * tclIOSock.c -- + * + * Common routines used by all socket based channel types. + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclIOSock.c 1.18 96/08/16 07:09:27 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + *---------------------------------------------------------------------- + * + * TclSockGetPort -- + * + * Maps from a string, which could be a service name, to a port. + * Used by socket creation code to get port numbers and resolve + * registered service names to port numbers. + * + * Results: + * A standard Tcl result. On success, the port number is + * returned in portPtr. On failure, an error message is left in + * interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclSockGetPort(interp, string, proto, portPtr) + Tcl_Interp *interp; + char *string; /* Integer or service name */ + char *proto; /* "tcp" or "udp", typically */ + int *portPtr; /* Return port number */ +{ + struct servent *sp = getservbyname(string, proto); + if (sp != NULL) { + *portPtr = ntohs((unsigned short) sp->s_port); + return TCL_OK; + } + if (Tcl_GetInt(interp, string, portPtr) != TCL_OK) { + return TCL_ERROR; + } + if (*portPtr > 0xFFFF) { + Tcl_AppendResult(interp, "couldn't open socket: port number too high", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclSockMinimumBuffers -- + * + * Ensure minimum buffer sizes (non zero). + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Sets SO_SNDBUF and SO_RCVBUF sizes. + * + *---------------------------------------------------------------------- + */ + +int +TclSockMinimumBuffers(sock, size) + int sock; /* Socket file descriptor */ + int size; /* Minimum buffer size */ +{ + int current; + int len = sizeof(int); + + getsockopt(sock, SOL_SOCKET, SO_SNDBUF, (char *)¤t, (size_t *)&len); + if (current < size) { + len = sizeof(int); + setsockopt(sock, SOL_SOCKET, SO_SNDBUF, (char *)&size, len); + } + len = sizeof(int); + getsockopt(sock, SOL_SOCKET, SO_RCVBUF, (char *)¤t, (size_t *)&len); + if (current < size) { + len = sizeof(int); + setsockopt(sock, SOL_SOCKET, SO_RCVBUF, (char *)&size, len); + } + return TCL_OK; +} diff --git a/tcl7.6/generic/tclIOUtil.c b/tcl7.6/generic/tclIOUtil.c new file mode 100644 index 0000000..ece171c --- /dev/null +++ b/tcl7.6/generic/tclIOUtil.c @@ -0,0 +1,1407 @@ +/* + * tclIOUtil.c -- + * + * This file contains a collection of utility procedures that + * are shared by the platform specific IO drivers. + * + * Parts of this file are based on code contributed by Karl + * Lehenbauer, Mark Diekhans and Peter da Silva. + * + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclIOUtil.c 1.128 96/10/02 12:25:36 + */ + +#include "tclInt.h" +#include "tclPort.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. */ + +/* + * Declarations for local procedures defined in this file: + */ + +static Tcl_File FileForRedirect _ANSI_ARGS_((Tcl_Interp *interp, + char *spec, int atOk, char *arg, char *nextArg, + int flags, int *skipPtr, int *closePtr, + Tcl_DString *namePtr)); + +/* + *---------------------------------------------------------------------- + * + * 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 NULL 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 Tcl_File +FileForRedirect(interp, spec, atOK, arg, nextArg, flags, skipPtr, closePtr, + namePtr) + Tcl_Interp *interp; /* Intepreter to use for error reporting. */ + char *spec; /* Points to character just after + * redirection character. */ + char *arg; /* Pointer to entire argument containing + * spec: used for error reporting. */ + int atOK; /* Non-zero means that '@' notation can be + * used to specify a channel, zero means that + * it isn't. */ + char *nextArg; /* Next argument in argc/argv array, if needed + * for file name or channel name. May be + * NULL. */ + int flags; /* Flags to use for opening file or to + * specify mode for channel. */ + int *skipPtr; /* Filled with 1 if redirection target was + * in spec, 2 if it was in nextArg. */ + int *closePtr; /* Filled with one if the caller should + * close the file when done with it, zero + * otherwise. */ + Tcl_DString *namePtr; /* Pointer to an initialized Tcl_DString that + * is filled with the name of the file that + * was opened. Unmodified if spec refers + * to a channel. */ +{ + int writing = (flags & O_WRONLY); + Tcl_Channel chan; + Tcl_File file; + + *skipPtr = 1; + if ((atOK != 0) && (*spec == '@')) { + spec++; + if (*spec == '\0') { + spec = nextArg; + if (spec == NULL) { + goto badLastArg; + } + *skipPtr = 2; + } + chan = Tcl_GetChannel(interp, spec, NULL); + if (chan == (Tcl_Channel) NULL) { + return NULL; + } + file = Tcl_GetChannelFile(chan, writing ? TCL_WRITABLE : TCL_READABLE); + if (file == NULL) { + Tcl_AppendResult(interp, "channel \"", Tcl_GetChannelName(chan), + "\" wasn't opened for ", + ((writing) ? "writing" : "reading"), (char *) NULL); + return NULL; + } + if (writing) { + + /* + * Be sure to flush output to the file, so that anything + * written by the child appears after stuff we've already + * written. + */ + + Tcl_Flush(chan); + } + } else { + char *name; + + if (*spec == '\0') { + spec = nextArg; + if (spec == NULL) { + goto badLastArg; + } + *skipPtr = 2; + } + name = Tcl_TranslateFileName(interp, spec, namePtr); + if (name != NULL) { + file = TclOpenFile(name, flags); + } else { + file = NULL; + } + if (file == NULL) { + Tcl_AppendResult(interp, "couldn't ", + ((writing) ? "write" : "read"), " file \"", spec, "\": ", + Tcl_PosixError(interp), (char *) NULL); + Tcl_DStringFree(namePtr); + return NULL; + } + *closePtr = 1; + } + return file; + + badLastArg: + Tcl_AppendResult(interp, "can't specify \"", arg, + "\" as last word in command", (char *) NULL); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetOpenMode -- + * + * Description: + * Computes a POSIX mode mask for opening a file, from a given string, + * and also sets a flag to indicate whether the caller should seek to + * EOF after opening the file. + * + * Results: + * On success, returns mode to pass to "open". If an error occurs, the + * returns -1 and if interp is not NULL, sets interp->result to an + * error message. + * + * Side effects: + * Sets the integer referenced by seekFlagPtr to 1 to tell the caller + * to seek to EOF after opening the file. + * + * Special note: + * This code is based on a prototype implementation contributed + * by Mark Diekhans. + * + *---------------------------------------------------------------------- + */ + +int +TclGetOpenMode(interp, string, seekFlagPtr) + Tcl_Interp *interp; /* Interpreter to use for error + * reporting - may be NULL. */ + char *string; /* Mode string, e.g. "r+" or + * "RDONLY CREAT". */ + int *seekFlagPtr; /* Set this to 1 if the caller + * should seek to EOF during the + * opening of the file. */ +{ + 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. + */ + + *seekFlagPtr = 0; + 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; + *seekFlagPtr = 1; + break; + default: + error: + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, + "illegal access mode \"", string, "\"", + (char *) NULL); + } + return -1; + } + if (string[1] == '+') { + mode &= ~(O_RDONLY|O_WRONLY); + mode |= O_RDWR; + if (string[2] != 0) { + goto error; + } + } else if (string[1] != 0) { + goto error; + } + return mode; + } + + /* + * The access modes are specified using a list of POSIX modes + * such as O_CREAT. + * + * IMPORTANT NOTE: We rely on Tcl_SplitList working correctly when + * a NULL interpreter is passed in. + */ + + if (Tcl_SplitList(interp, string, &modeArgc, &modeArgv) != TCL_OK) { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AddErrorInfo(interp, + "\n while processing open access modes \""); + Tcl_AddErrorInfo(interp, string); + Tcl_AddErrorInfo(interp, "\""); + } + return -1; + } + + 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; + *seekFlagPtr = 1; + } 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 + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "access mode \"", flag, + "\" not supported by this system", (char *) NULL); + } + ckfree((char *) modeArgv); + return -1; +#endif + } else if ((c == 'N') && (strcmp(flag, "NONBLOCK") == 0)) { +#if defined(O_NDELAY) || defined(O_NONBLOCK) +# ifdef O_NONBLOCK + mode |= O_NONBLOCK; +# else + mode |= O_NDELAY; +# endif +#else + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "access mode \"", flag, + "\" not supported by this system", (char *) NULL); + } + ckfree((char *) modeArgv); + return -1; +#endif + } else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) { + mode |= O_TRUNC; + } else { + if (interp != (Tcl_Interp *) NULL) { + 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 -1; + } + } + ckfree((char *) modeArgv); + if (!gotRW) { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "access mode must include either", + " RDONLY, WRONLY, or RDWR", (char *) NULL); + } + return -1; + } + return mode; +} + +/* + *---------------------------------------------------------------------- + * + * 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 result; + struct stat statBuf; + char *cmdBuffer = (char *) NULL; + char *oldScriptFile = (char *) NULL; + Interp *iPtr = (Interp *) interp; + Tcl_DString buffer; + char *nativeName = (char *) NULL; + Tcl_Channel chan = (Tcl_Channel) NULL; + + Tcl_ResetResult(interp); + oldScriptFile = iPtr->scriptFile; + iPtr->scriptFile = fileName; + Tcl_DStringInit(&buffer); + nativeName = Tcl_TranslateFileName(interp, fileName, &buffer); + if (nativeName == NULL) { + goto error; + } + + /* + * If Tcl_TranslateFileName didn't already copy the file name, do it + * here. This way we don't depend on fileName staying constant + * throughout the execution of the script (e.g., what if it happens + * to point to a Tcl variable that the script could change?). + */ + + if (nativeName != Tcl_DStringValue(&buffer)) { + Tcl_DStringSetLength(&buffer, 0); + Tcl_DStringAppend(&buffer, nativeName, -1); + nativeName = Tcl_DStringValue(&buffer); + } + if (stat(nativeName, &statBuf) == -1) { + Tcl_SetErrno(errno); + Tcl_AppendResult(interp, "couldn't read file \"", fileName, + "\": ", Tcl_PosixError(interp), (char *) NULL); + goto error; + } + chan = Tcl_OpenFileChannel(interp, nativeName, "r", 0644); + if (chan == (Tcl_Channel) NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "couldn't read file \"", fileName, + "\": ", Tcl_PosixError(interp), (char *) NULL); + goto error; + } + cmdBuffer = (char *) ckalloc((unsigned) statBuf.st_size+1); + result = Tcl_Read(chan, cmdBuffer, statBuf.st_size); + if (result < 0) { + Tcl_Close(interp, chan); + Tcl_AppendResult(interp, "couldn't read file \"", fileName, + "\": ", Tcl_PosixError(interp), (char *) NULL); + goto error; + } + cmdBuffer[result] = 0; + if (Tcl_Close(interp, chan) != TCL_OK) { + goto error; + } + + result = Tcl_Eval(interp, cmdBuffer); + if (result == TCL_RETURN) { + result = TclUpdateReturnInfo(iPtr); + } else 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); + } + iPtr->scriptFile = oldScriptFile; + ckfree(cmdBuffer); + Tcl_DStringFree(&buffer); + return result; + +error: + if (cmdBuffer != (char *) NULL) { + ckfree(cmdBuffer); + } + 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; + int pid; + + for (detPtr = detList, prevPtr = NULL; detPtr != NULL; ) { + pid = (int) Tcl_WaitPid(detPtr->pid, &status, WNOHANG); + if ((pid == 0) || ((pid == -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; + } +} + +/* + *---------------------------------------------------------------------- + * + * TclCleanupChildren -- + * + * 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. + * + *---------------------------------------------------------------------- + */ + +int +TclCleanupChildren(interp, numPids, pidPtr, errorChan) + Tcl_Interp *interp; /* Used for error messages. */ + int numPids; /* Number of entries in pidPtr array. */ + int *pidPtr; /* Array of process ids of children. */ + Tcl_Channel errorChan; /* Channel for file containing stderr output + * from pipeline. NULL means there isn't any + * stderr output. */ +{ + int result = TCL_OK; + int i, pid, abnormalExit, anyErrorInfo; + WAIT_STATUS_TYPE waitStatus; + char *msg; + + abnormalExit = 0; + for (i = 0; i < numPids; i++) { + pid = (int) Tcl_WaitPid(pidPtr[i], (int *) &waitStatus, 0); + if (pid == -1) { + result = TCL_ERROR; + if (interp != (Tcl_Interp *) NULL) { + msg = Tcl_PosixError(interp); + if (errno == ECHILD) { + /* + * This changeup in message suggested by Mark Diekhans + * to remind people that ECHILD errors can occur on + * some systems if SIGCHLD isn't in its default state. + */ + + msg = + "child process lost (is SIGCHLD ignored or trapped?)"; + } + Tcl_AppendResult(interp, "error waiting for process to exit: ", + msg, (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)) { + if (interp != (Tcl_Interp *) NULL) { + sprintf(msg2, "%d", WEXITSTATUS(waitStatus)); + Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2, + (char *) NULL); + } + abnormalExit = 1; + } else if (WIFSIGNALED(waitStatus)) { + if (interp != (Tcl_Interp *) NULL) { + 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)) { + if (interp != (Tcl_Interp *) NULL) { + 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 { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, + "child wait status didn't make sense\n", + (char *) NULL); + } + } + } + } + + /* + * Read the standard error file. If there's anything there, + * then return an error and add the file's contents to the result + * string. + */ + + anyErrorInfo = 0; + if (errorChan != NULL) { + + /* + * Make sure we start at the beginning of the file. + */ + + Tcl_Seek(errorChan, 0L, SEEK_SET); + + if (interp != (Tcl_Interp *) NULL) { + while (1) { +#define BUFFER_SIZE 1000 + char buffer[BUFFER_SIZE+1]; + int count; + + count = Tcl_Read(errorChan, buffer, 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; /* out of the "while (1)" loop. */ + } + buffer[count] = 0; + Tcl_AppendResult(interp, buffer, (char *) NULL); + anyErrorInfo = 1; + } + } + + Tcl_Close((Tcl_Interp *) NULL, errorChan); + } + + /* + * If a child exited abnormally but didn't output any error information + * at all, generate an error message here. + */ + + if (abnormalExit && !anyErrorInfo && (interp != (Tcl_Interp *) NULL)) { + Tcl_AppendResult(interp, "child process exited abnormally", + (char *) NULL); + } + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclCreatePipeline -- + * + * 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 +TclCreatePipeline(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). */ + Tcl_File *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. NULL means command + * specified its own input source. */ + Tcl_File *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. NULL means command specified + * its own output sink. */ + Tcl_File *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 file will still be created + * but it will never get any data. */ +{ +#if defined( MAC_TCL ) + Tcl_AppendResult(interp, + "command pipelines not supported on Macintosh OS", NULL); + return -1; +#else /* !MAC_TCL */ + 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 *inputLiteral = 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. */ + Tcl_File inputFile = NULL; /* If != NULL, gives file to use as input for + * first process in pipeline (specified via < + * or <@). */ + Tcl_DString inputFileName; /* If non-empty, gives name of file that + * corresponds to inputFile. */ + int inputClose = 0; /* If non-zero, then inputFile should be + * closed when cleaning up. */ + Tcl_File outputFile = NULL; /* Writable file for output from last command + * in pipeline (could be file or pipe). NULL + * means use stdout. */ + Tcl_DString outputFileName; /* If non-empty, gives name of file that + * corresponds to outputFile. */ + int outputClose = 0; /* If non-zero, then outputFile should be + * closed when cleaning up. */ + Tcl_File errorFile = NULL; /* Writable file for error output from all + * commands in pipeline. NULL means use + * stderr. */ + Tcl_DString errorFileName; /* If non-empty, gives name of file that + * corresponds to errorFile. */ + int errorClose = 0; /* If non-zero, then errorFile should be + * closed when cleaning up. */ + char *p; + int skip, lastBar, lastArg, i, j, atOK, flags, errorToOutput; + Tcl_DString execBuffer; + Tcl_File pipeIn; + Tcl_File curInFile, curOutFile, curErrFile; + char *curInFileName, *curOutFileName, *curErrFileName; + Tcl_Channel channel; + + if (inPipePtr != NULL) { + *inPipePtr = NULL; + } + if (outPipePtr != NULL) { + *outPipePtr = NULL; + } + if (errFilePtr != NULL) { + *errFilePtr = NULL; + } + + Tcl_DStringInit(&inputFileName); + Tcl_DStringInit(&outputFileName); + Tcl_DStringInit(&errorFileName); + Tcl_DStringInit(&execBuffer); + + pipeIn = NULL; + curInFile = NULL; + curOutFile = NULL; + curErrFile = NULL; + + numPids = 0; + pidPtr = NULL; + + /* + * 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 because + * they'll be used in the second pass to seperate the individual + * child processes. Cannot start the child processes in this pass + * because the redirection symbols may appear anywhere in the + * command line -- e.g., the '<' that specifies the input to the + * entire pipe may appear at the very end of the argument list. + */ + + lastBar = -1; + cmdCount = 1; + for (i = 0; i < argc; i++) { + skip = 0; + p = argv[i]; + switch (*p++) { + case '|': + if (*p == '&') { + p++; + } + if (*p == '\0') { + if ((i == (lastBar + 1)) || (i == (argc - 1))) { + interp->result = "illegal use of | or |& in command"; + goto error; + } + } + lastBar = i; + cmdCount++; + break; + + case '<': + if (inputClose != 0) { + inputClose = 0; + Tcl_DStringFree(&inputFileName); + TclCloseFile(inputFile); + } + if (*p == '<') { + inputFile = NULL; + inputLiteral = p + 1; + skip = 1; + if (*inputLiteral == '\0') { + inputLiteral = argv[i + 1]; + if (inputLiteral == NULL) { + Tcl_AppendResult(interp, "can't specify \"", argv[i], + "\" as last word in command", (char *) NULL); + goto error; + } + skip = 2; + } + } else { + inputLiteral = NULL; + inputFile = FileForRedirect(interp, p, 1, argv[i], + argv[i + 1], O_RDONLY, &skip, &inputClose, + &inputFileName); + if (inputFile == NULL) { + goto error; + } + } + break; + + case '>': + atOK = 1; + flags = O_WRONLY | O_CREAT | O_TRUNC; + errorToOutput = 0; + if (*p == '>') { + p++; + atOK = 0; + flags = O_WRONLY | O_CREAT; + } + if (*p == '&') { + if (errorClose != 0) { + errorClose = 0; + Tcl_DStringFree(&errorFileName); + TclCloseFile(errorFile); + } + errorToOutput = 1; + p++; + } + + if (outputClose != 0) { + outputClose = 0; + Tcl_DStringFree(&outputFileName); + TclCloseFile(outputFile); + } + outputFile = FileForRedirect(interp, p, atOK, argv[i], + argv[i + 1], flags, &skip, &outputClose, + &outputFileName); + if (outputFile == NULL) { + goto error; + } + if (atOK == 0) { + TclSeekFile(outputFile, 0, SEEK_END); + } + if (errorToOutput) { + errorClose = 0; + errorFile = outputFile; + } + break; + + case '2': + if (*p != '>') { + break; + } + p++; + atOK = 1; + flags = O_WRONLY | O_CREAT | O_TRUNC; + if (*p == '>') { + p++; + atOK = 0; + flags = O_WRONLY | O_CREAT; + } + if (errorClose != 0) { + errorClose = 0; + Tcl_DStringFree(&errorFileName); + TclCloseFile(errorFile); + } + errorFile = FileForRedirect(interp, p, atOK, argv[i], + argv[i + 1], flags, &skip, &errorClose, + &errorFileName); + if (errorFile == NULL) { + goto error; + } + if (atOK == 0) { + TclSeekFile(errorFile, 0, SEEK_END); + } + break; + } + + if (skip != 0) { + for (j = i + skip; j < argc; j++) { + argv[j - skip] = argv[j]; + } + argc -= skip; + i -= 1; + } + } + + if (inputFile == NULL) { + if (inputLiteral != NULL) { + /* + * 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. + */ + inputFile = TclCreateTempFile(inputLiteral, &inputFileName); + if (inputFile == NULL) { + Tcl_AppendResult(interp, + "couldn't create input file for command: ", + Tcl_PosixError(interp), (char *) NULL); + goto error; + } + inputClose = 1; + } else if (inPipePtr != NULL) { + /* + * The input for the first process in the pipeline is to + * come from a pipe that can be written from by the caller. + */ + + if (TclCreatePipe(&inputFile, inPipePtr) == 0) { + Tcl_AppendResult(interp, + "couldn't create input pipe for command: ", + Tcl_PosixError(interp), (char *) NULL); + goto error; + } + inputClose = 1; + } else { + /* + * The input for the first process comes from stdin. + */ + + channel = Tcl_GetStdChannel(TCL_STDIN); + if (channel != NULL) { + inputFile = Tcl_GetChannelFile(channel, TCL_READABLE); + } + } + } + + if (outputFile == NULL) { + if (outPipePtr != NULL) { + /* + * Output from the last process in the pipeline is to go to a + * pipe that can be read by the caller. + */ + + if (TclCreatePipe(outPipePtr, &outputFile) == 0) { + Tcl_AppendResult(interp, + "couldn't create output pipe for command: ", + Tcl_PosixError(interp), (char *) NULL); + goto error; + } + outputClose = 1; + } else { + /* + * The output for the last process goes to stdout. + */ + + channel = Tcl_GetStdChannel(TCL_STDOUT); + if (channel) { + outputFile = Tcl_GetChannelFile(channel, TCL_WRITABLE); + } + } + } + + if (errorFile == NULL) { + if (errFilePtr != NULL) { + /* + * 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. + */ + + errorFile = TclCreateTempFile(NULL, &errorFileName); + if (errorFile == NULL) { + Tcl_AppendResult(interp, + "couldn't create error file for command: ", + Tcl_PosixError(interp), (char *) NULL); + goto error; + } + *errFilePtr = errorFile; + } else { + /* + * Errors from the pipeline go to stderr. + */ + + channel = Tcl_GetStdChannel(TCL_STDERR); + if (channel) { + errorFile = Tcl_GetChannelFile(channel, TCL_WRITABLE); + } + } + } + + /* + * Scan through the argc array, creating a process for each + * group of arguments between the "|" characters. + */ + + Tcl_ReapDetachedProcs(); + pidPtr = (int *) ckalloc((unsigned) (cmdCount * sizeof(int))); + + curInFile = inputFile; + curInFileName = Tcl_DStringValue(&inputFileName); + if (curInFileName[0] == '\0') { + curInFileName = NULL; + } + + for (i = 0; i < argc; i = lastArg + 1) { + int joinThisError, pid; + + /* + * Convert the program name into native form. + */ + + argv[i] = Tcl_TranslateFileName(interp, argv[i], &execBuffer); + if (argv[i] == NULL) { + goto error; + } + + /* + * Find the end of the current segment of the pipeline. + */ + + joinThisError = 0; + for (lastArg = i; 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 this is the last segment, use the specified outputFile. + * Otherwise create an intermediate pipe. pipeIn will become the + * curInFile for the next segment of the pipe. + */ + + if (lastArg == argc) { + curOutFile = outputFile; + curOutFileName = Tcl_DStringValue(&outputFileName); + if (curOutFileName[0] == '\0') { + curOutFileName = NULL; + } + } else { + if (TclCreatePipe(&pipeIn, &curOutFile) == 0) { + Tcl_AppendResult(interp, "couldn't create pipe: ", + Tcl_PosixError(interp), (char *) NULL); + goto error; + } + curOutFileName = NULL; + } + + if (joinThisError != 0) { + curErrFile = curOutFile; + curErrFileName = curOutFileName; + } else { + curErrFile = errorFile; + curErrFileName = Tcl_DStringValue(&errorFileName); + if (curErrFileName[0] == '\0') { + curErrFileName = NULL; + } + } + + if (TclpCreateProcess(interp, lastArg - i, argv + i, + curInFile, curOutFile, curErrFile, curInFileName, + curOutFileName, curErrFileName, &pid) != TCL_OK) { + goto error; + } + Tcl_DStringFree(&execBuffer); + + pidPtr[numPids] = pid; + numPids++; + + /* + * Close off our copies of file descriptors that were set up for + * this child, then set up the input for the next child. + */ + + if ((curInFile != NULL) && (curInFile != inputFile)) { + TclCloseFile(curInFile); + } + curInFile = pipeIn; + curInFileName = NULL; + pipeIn = NULL; + + if ((curOutFile != NULL) && (curOutFile != outputFile)) { + TclCloseFile(curOutFile); + } + curOutFile = NULL; + } + + *pidArrayPtr = pidPtr; + + /* + * All done. Cleanup open files lying around and then return. + */ + +cleanup: + Tcl_DStringFree(&inputFileName); + Tcl_DStringFree(&outputFileName); + Tcl_DStringFree(&errorFileName); + Tcl_DStringFree(&execBuffer); + + if (inputClose) { + TclCloseFile(inputFile); + } + if (outputClose) { + TclCloseFile(outputFile); + } + if (errorClose) { + TclCloseFile(errorFile); + } + 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 (pipeIn != NULL) { + TclCloseFile(pipeIn); + } + if ((curOutFile != NULL) && (curOutFile != outputFile)) { + TclCloseFile(curOutFile); + } + if ((curInFile != NULL) && (curInFile != inputFile)) { + TclCloseFile(curInFile); + } + if ((inPipePtr != NULL) && (*inPipePtr != NULL)) { + TclCloseFile(*inPipePtr); + *inPipePtr = NULL; + } + if ((outPipePtr != NULL) && (*outPipePtr != NULL)) { + TclCloseFile(*outPipePtr); + *outPipePtr = NULL; + } + if ((errFilePtr != NULL) && (*errFilePtr != NULL)) { + TclCloseFile(*errFilePtr); + *errFilePtr = NULL; + } + 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; +#endif /* !MAC_TCL */ +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetErrno -- + * + * Gets the current value of the Tcl error code variable. This is + * currently the global variable "errno" but could in the future + * change to something else. + * + * Results: + * The value of the Tcl error code variable. + * + * Side effects: + * None. Note that the value of the Tcl error code variable is + * UNDEFINED if a call to Tcl_SetErrno did not precede this call. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetErrno() +{ + return errno; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetErrno -- + * + * Sets the Tcl error code variable to the supplied value. + * + * Results: + * None. + * + * Side effects: + * Modifies the value of the Tcl error code variable. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetErrno(err) + int err; /* The new value. */ +{ + errno = err; +} + +/* + *---------------------------------------------------------------------- + * + * 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. + * + * 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; + + msg = Tcl_ErrnoMsg(errno); + id = Tcl_ErrnoId(); + Tcl_SetErrorCode(interp, "POSIX", id, msg, (char *) NULL); + return msg; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_OpenCommandChannel -- + * + * Opens an I/O channel to one or more subprocesses specified + * by argc and argv. The flags argument determines the + * disposition of the stdio handles. If the TCL_STDIN flag is + * set then the standard input for the first subprocess will + * be tied to the channel: writing to the channel will provide + * input to the subprocess. If TCL_STDIN is not set, then + * standard input for the first subprocess will be the same as + * this application's standard input. If TCL_STDOUT is set then + * standard output from the last subprocess can be read from the + * channel; otherwise it goes to this application's standard + * output. If TCL_STDERR is set, standard error output for all + * subprocesses is returned to the channel and results in an error + * when the channel is closed; otherwise it goes to this + * application's standard error. If TCL_ENFORCE_MODE is not set, + * then argc and argv can redirect the stdio handles to override + * TCL_STDIN, TCL_STDOUT, and TCL_STDERR; if it is set, then it + * is an error for argc and argv to override stdio channels for + * which TCL_STDIN, TCL_STDOUT, and TCL_STDERR have been set. + * + * Results: + * A new command channel, or NULL on failure with an error + * message left in interp. + * + * Side effects: + * Creates processes, opens pipes. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_OpenCommandChannel(interp, argc, argv, flags) + Tcl_Interp *interp; /* Interpreter for error reporting. Can + * NOT be NULL. */ + int argc; /* How many arguments. */ + char **argv; /* Array of arguments for command pipe. */ + int flags; /* Or'ed combination of TCL_STDIN, TCL_STDOUT, + * TCL_STDERR, and TCL_ENFORCE_MODE. */ +{ + Tcl_File *inPipePtr, *outPipePtr, *errFilePtr; + Tcl_File inPipe, outPipe, errFile; + int numPids, *pidPtr; + Tcl_Channel channel; + + inPipe = outPipe = errFile = NULL; + + inPipePtr = (flags & TCL_STDIN) ? &inPipe : NULL; + outPipePtr = (flags & TCL_STDOUT) ? &outPipe : NULL; + errFilePtr = (flags & TCL_STDERR) ? &errFile : NULL; + + numPids = TclCreatePipeline(interp, argc, argv, &pidPtr, inPipePtr, + outPipePtr, errFilePtr); + + if (numPids < 0) { + goto error; + } + + /* + * Verify that the pipes that were created satisfy the + * readable/writable constraints. + */ + + if (flags & TCL_ENFORCE_MODE) { + if ((flags & TCL_STDOUT) && (outPipe == NULL)) { + Tcl_AppendResult(interp, "can't read output from command:", + " standard output was redirected", (char *) NULL); + goto error; + } + if ((flags & TCL_STDIN) && (inPipe == NULL)) { + Tcl_AppendResult(interp, "can't write input to command:", + " standard input was redirected", (char *) NULL); + goto error; + } + } + + channel = TclCreateCommandChannel(outPipe, inPipe, errFile, + numPids, pidPtr); + + if (channel == (Tcl_Channel) NULL) { + Tcl_AppendResult(interp, "pipe for command could not be created", + (char *) NULL); + goto error; + } + return channel; + +error: + if (numPids > 0) { + Tcl_DetachPids(numPids, pidPtr); + ckfree((char *) pidPtr); + } + if (inPipe != NULL) { + TclClosePipeFile(inPipe); + } + if (outPipe != NULL) { + TclClosePipeFile(outPipe); + } + if (errFile != NULL) { + TclClosePipeFile(errFile); + } + return NULL; +} diff --git a/tcl7.3/tclInt.h b/tcl7.6/generic/tclInt.h similarity index 60% rename from tcl7.3/tclInt.h rename to tcl7.6/generic/tclInt.h index f8a3566..e194116 100644 --- a/tcl7.3/tclInt.h +++ b/tcl7.6/generic/tclInt.h @@ -4,26 +4,12 @@ * Declarations of things used internally by the Tcl interpreter. * * Copyright (c) 1987-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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) + * SCCS: @(#) tclInt.h 1.218 96/09/30 12:26:59 */ #ifndef _TCLINT @@ -50,31 +36,25 @@ #include #ifdef NO_LIMITS_H -# include "compat/limits.h" +# include "../compat/limits.h" #else # include #endif #ifdef NO_STDLIB_H -# include "compat/stdlib.h" +# include "../compat/stdlib.h" #else # include #endif #ifdef NO_STRING_H -#include "compat/string.h" +#include "../compat/string.h" #else #include #endif -#include - -/* - * 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(); +#if defined(__STDC__) || defined(HAS_STDARG) +# include +#else +# include +#endif /* *---------------------------------------------------------------- @@ -282,17 +262,16 @@ typedef struct Trace { } Trace; /* - * The stucture below defines a deletion callback, which is - * a procedure to invoke just before an interpreter is deleted. + * The structure below defines an entry in the assocData hash table which + * is associated with an interpreter. The entry contains a pointer to a + * function to call when the interpreter is deleted, and a pointer to + * a user-defined piece of data. */ -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; +typedef struct AssocData { + Tcl_InterpDeleteProc *proc; /* Proc to call when deleting. */ + ClientData clientData; /* Value to pass to proc. */ +} AssocData; /* * The structure below defines a frame, which is a procedure invocation. @@ -356,45 +335,11 @@ typedef struct HistoryRev { * current history event. */ int newSize; /* Number of bytes in newBytes. */ char *newBytes; /* Replacement for the range given by - * firstIndex and lastIndex. */ + * firstIndex and lastIndex (malloced). */ 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 @@ -419,15 +364,21 @@ typedef struct 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. + * One of the following structures exists for each command in + * an interpreter. The Tcl_Command opaque type actually refers + * to these structures. *---------------------------------------------------------------- */ typedef struct Command { + Tcl_HashEntry *hPtr; /* Pointer to the hash table entry in + * interp->commandTable that refers to + * this command. Used to get a command's + * name from its Tcl_Command handle. NULL + * means that the hash table entry has + * been removed already (this can happen + * if deleteProc causes the command to be + * deleted or recreated). */ Tcl_CmdProc *proc; /* Procedure to process command. */ ClientData clientData; /* Arbitrary value to pass to proc. */ Tcl_CmdDeleteProc *deleteProc; @@ -435,9 +386,21 @@ typedef struct Command { * command. */ ClientData deleteData; /* Arbitrary value to pass to deleteProc * (usually the same as clientData). */ + int deleted; /* Means that the command is in the process + * of being deleted (its deleteProc is + * currently executing). Any other attempts + * to delete the command should be ignored. */ } Command; -#define CMD_SIZE(nameLength) ((unsigned) sizeof(Command) + nameLength - 3) +/* + *---------------------------------------------------------------- + * 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 Interp { @@ -450,7 +413,9 @@ typedef struct Interp { 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 + * TCL_DYNAMIC means result was allocated with + * ckalloc and should be freed with ckfree. + * Other values give address of procedure * to invoke to free the result. Must be * freed by Tcl_Eval before executing next * command. */ @@ -538,7 +503,7 @@ typedef struct Interp { * stored at partialResult. */ /* - * A cache of compiled regular expressions. See TclCompileRegexp + * A cache of compiled regular expressions. See Tcl_RegExpCompile * in tclUtil.c for details. */ @@ -554,6 +519,19 @@ typedef struct Interp { /* Compiled forms of above strings. Also * malloc-ed, or NULL if not in use yet. */ + /* + * Information about packages. Used only in tclPkg.c. + */ + + Tcl_HashTable packageTable; /* Describes all of the packages loaded + * in or available to this interpreter. + * Keys are package names, values are + * (Package *) pointers. */ + char *packageUnknown; /* Command to invoke during "package + * require" commands for packages that + * aren't described in packageTable. + * Malloc'ed, may be NULL. */ + /* * Information used by Tcl_PrintDouble: */ @@ -575,8 +553,8 @@ typedef struct Interp { * 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. */ + * calling Tcl_Eval. See below for valid + * values. */ char *termPtr; /* Character just after the last one in * a command. Set by Tcl_Eval before * returning. */ @@ -587,13 +565,31 @@ typedef struct Interp { * 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. */ + Tcl_HashTable *assocData; /* Hash table for associating data with + * this interpreter. Cleaned up when + * this interpreter is deleted. */ char resultSpace[TCL_RESULT_SIZE+1]; /* Static space for storing small results. */ } Interp; +/* + * EvalFlag bits for Interp structures: + * + * TCL_BRACKET_TERM 1 means that the current script is terminated by + * a close bracket rather than the end of the string. + * 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). + * TCL_ALLOW_EXCEPTIONS 1 means it's OK for the script to terminate with + * a code other than TCL_OK or TCL_ERROR; 0 means + * codes other than these should be turned into errors. + */ + +#define TCL_BRACKET_TERM 1 +#define TCL_RECORD_BOUNDS 2 +#define TCL_ALLOW_EXCEPTIONS 4 + /* * Flag bits for Interp structures: * @@ -695,18 +691,6 @@ extern char tclTypeTable[]; #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). @@ -731,13 +715,51 @@ extern char tclTypeTable[]; #define TCL_ALIGN(x) ((x + 7) & ~7) /* - * Variables shared among Tcl modules but not used by the outside - * world: + * For each event source (created with Tcl_CreateEventSource) there + * is a structure of the following type: */ -extern int tclNumFiles; -extern OpenFile ** tclOpenFiles; -extern char * tclRegexpError; +typedef struct TclEventSource { + Tcl_EventSetupProc *setupProc; /* This procedure is called by + * Tcl_DoOneEvent to set up information + * for the wait operation, such as + * files to wait for or maximum + * timeout. */ + Tcl_EventCheckProc *checkProc; /* This procedure is called by + * Tcl_DoOneEvent after its wait + * operation to see what events + * are ready and queue them. */ + ClientData clientData; /* Arbitrary one-word argument to pass + * to setupProc and checkProc. */ + struct TclEventSource *nextPtr; /* Next in list of all event sources + * defined for applicaton. */ +} TclEventSource; + +/* + * The following macros are used to specify the runtime platform + * setting of the tclPlatform variable. + */ + +typedef enum { + TCL_PLATFORM_UNIX, /* Any Unix-like OS. */ + TCL_PLATFORM_MAC, /* MacOS. */ + TCL_PLATFORM_WINDOWS /* Any Microsoft Windows OS. */ +} TclPlatformType; + +/* + *---------------------------------------------------------------- + * Variables shared among Tcl modules but not used by the outside + * world: + *---------------------------------------------------------------- + */ + +extern Tcl_Time tclBlockTime; +extern int tclBlockTimeSet; +extern char * tclExecutableName; +extern TclEventSource * tclFirstEventSourcePtr; +extern Tcl_ChannelType tclFileChannelType; +extern char * tclMemDumpFileName; +extern TclPlatformType tclPlatform; /* *---------------------------------------------------------------- @@ -746,43 +768,170 @@ extern char * tclRegexpError; *---------------------------------------------------------------- */ -extern void panic(); -extern regexp * TclCompileRegexp _ANSI_ARGS_((Tcl_Interp *interp, - char *string)); -extern void TclCopyAndCollapse _ANSI_ARGS_((int count, char *src, +EXTERN void panic _ANSI_ARGS_(TCL_VARARGS(char *,format)); +EXTERN int TclChdir _ANSI_ARGS_((Tcl_Interp *interp, + char *dirName)); +EXTERN int TclCleanupChildren _ANSI_ARGS_((Tcl_Interp *interp, + int numPids, int *pidPtr, Tcl_Channel errorChan)); +EXTERN int TclCloseFile _ANSI_ARGS_((Tcl_File file)); +EXTERN char * TclConvertToNative _ANSI_ARGS_((Tcl_Interp *interp, + char *name, Tcl_DString *bufferPtr)); +EXTERN char * TclConvertToNetwork _ANSI_ARGS_((Tcl_Interp *interp, + char *name, Tcl_DString *bufferPtr)); +EXTERN void TclCopyAndCollapse _ANSI_ARGS_((int count, char *src, char *dst)); -extern void TclDeleteVars _ANSI_ARGS_((Interp *iPtr, +EXTERN void TclClosePipeFile _ANSI_ARGS_((Tcl_File file)); +EXTERN Tcl_Channel TclCreateCommandChannel _ANSI_ARGS_(( + Tcl_File readFile, Tcl_File writeFile, + Tcl_File errorFile, int numPids, int *pidPtr)); +EXTERN int TclCreatePipe _ANSI_ARGS_((Tcl_File *readPipe, + Tcl_File *writePipe)); +EXTERN int TclCreatePipeline _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv, int **pidArrayPtr, + Tcl_File *inPipePtr, + Tcl_File *outPipePtr, + Tcl_File *errFilePtr)); +EXTERN Tcl_File TclCreateTempFile _ANSI_ARGS_((char *contents, + Tcl_DString *namePtr)); +EXTERN void TclDeleteVars _ANSI_ARGS_((Interp *iPtr, Tcl_HashTable *tablePtr)); -extern void TclExpandParseValue _ANSI_ARGS_((ParseValue *pvPtr, +EXTERN int TclDoGlob _ANSI_ARGS_((Tcl_Interp *interp, + char *separators, Tcl_DString *headPtr, + char *tail)); +EXTERN void TclExpandParseValue _ANSI_ARGS_((ParseValue *pvPtr, int needed)); -extern int TclFindElement _ANSI_ARGS_((Tcl_Interp *interp, +EXTERN void TclExprFloatError _ANSI_ARGS_((Tcl_Interp *interp, + double value)); +EXTERN int TclFileCopyCmd _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv)) ; +EXTERN int TclFileDeleteCmd _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char ** argv)); +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, +EXTERN Tcl_Channel TclFindFileChannel _ANSI_ARGS_((Tcl_File inFile, + Tcl_File outFile, int *fileUsedPtr)); +EXTERN Proc * TclFindProc _ANSI_ARGS_((Interp *iPtr, char *procName)); -extern int TclGetFrame _ANSI_ARGS_((Tcl_Interp *interp, +EXTERN void TclFreePackageInfo _ANSI_ARGS_((Interp *iPtr)); +EXTERN char * TclGetCwd _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN char * TclGetExtension _ANSI_ARGS_((char *name)); +EXTERN void TclGetAndDetachPids _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Channel chan)); +EXTERN int TclGetDate _ANSI_ARGS_((char *p, + unsigned long now, long zone, + unsigned long *timePtr)); +EXTERN Tcl_Channel TclGetDefaultStdChannel _ANSI_ARGS_((int type)); +EXTERN char * TclGetEnv _ANSI_ARGS_((char *name)); +EXTERN int TclGetFrame _ANSI_ARGS_((Tcl_Interp *interp, char *string, CallFrame **framePtrPtr)); -extern int TclGetListIndex _ANSI_ARGS_((Tcl_Interp *interp, +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, +EXTERN int TclGetLoadedPackages _ANSI_ARGS_((Tcl_Interp *interp, + char *targetName)); +EXTERN int TclGetOpenMode _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int *seekFlagPtr)); +EXTERN char * TclGetUserHome _ANSI_ARGS_((char *name, + Tcl_DString *bufferPtr)); +EXTERN int TclGuessPackageName _ANSI_ARGS_((char *fileName, + Tcl_DString *bufPtr)); +EXTERN int TclHasPipes _ANSI_ARGS_((void)); +EXTERN int TclHasSockets _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int TclIdlePending _ANSI_ARGS_((void)); +EXTERN int TclInterpInit _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN Proc * TclIsProc _ANSI_ARGS_((Command *cmdPtr)); +EXTERN int TclLoadFile _ANSI_ARGS_((Tcl_Interp *interp, + char *fileName, char *sym1, char *sym2, + Tcl_PackageInitProc **proc1Ptr, + Tcl_PackageInitProc **proc2Ptr)); +EXTERN int TclMakeFileTable _ANSI_ARGS_((Tcl_Interp *interp, + int noStdio)); +EXTERN int TclMatchFiles _ANSI_ARGS_((Tcl_Interp *interp, + char *separators, Tcl_DString *dirPtr, + char *pattern, char *tail)); +EXTERN int TclFileMakeDirsCmd _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv)) ; +EXTERN int TclFileRenameCmd _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv)) ; +EXTERN int TclNeedSpace _ANSI_ARGS_((char *start, char *end)); +EXTERN Tcl_File TclOpenFile _ANSI_ARGS_((char *fname, int mode)); + +EXTERN char * TclpAlloc _ANSI_ARGS_((unsigned int size)); +EXTERN int TclpCopyFile _ANSI_ARGS_((char *source, char *dest)); +EXTERN int TclpCopyDirectory _ANSI_ARGS_((char *source, + char *dest, Tcl_DString *errorPtr)); +EXTERN int TclpCreateDirectory _ANSI_ARGS_((char *path)); +EXTERN int TclpCreateProcess _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv, Tcl_File inputFile, + Tcl_File outputFile, Tcl_File errorFile, + char *inputFileName, char *outputFileName, + char *errorFileName, int *pidPtr)); +EXTERN int TclpDeleteFile _ANSI_ARGS_((char *path)); +EXTERN void TclpFree _ANSI_ARGS_((char *ptr)); +EXTERN unsigned long TclpGetClicks _ANSI_ARGS_((void)); +EXTERN unsigned long TclpGetSeconds _ANSI_ARGS_((void)); +EXTERN void TclpGetTime _ANSI_ARGS_((Tcl_Time *time)); +EXTERN int TclpGetTimeZone _ANSI_ARGS_((unsigned long time)); +EXTERN char * TclpGetTZName _ANSI_ARGS_((void)); +EXTERN char * TclpRealloc _ANSI_ARGS_((char *ptr, + unsigned int size)); +EXTERN int TclpRemoveDirectory _ANSI_ARGS_((char *path, + int recursive, Tcl_DString *errorPtr)); +EXTERN int TclpRenameFile _ANSI_ARGS_((char *source, char *dest)); + +EXTERN int TclParseBraces _ANSI_ARGS_((Tcl_Interp *interp, char *string, char **termPtr, ParseValue *pvPtr)); -extern int TclParseNestedCmd _ANSI_ARGS_((Tcl_Interp *interp, +EXTERN int TclParseNestedCmd _ANSI_ARGS_((Tcl_Interp *interp, char *string, int flags, char **termPtr, ParseValue *pvPtr)); -extern int TclParseQuotes _ANSI_ARGS_((Tcl_Interp *interp, +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, +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, +EXTERN int TclpCreateProcess _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv, Tcl_File inputFile, + Tcl_File outputFile, Tcl_File errorFile, + char *inputFileName, char *outputFileName, + char *errorFileName, int *pidPtr)); +EXTERN void TclPlatformExit _ANSI_ARGS_((int status)); +EXTERN void TclPlatformInit _ANSI_ARGS_((Tcl_Interp *interp)); +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, +EXTERN int TclPreventAliasLoop _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Interp *cmdInterp, char *cmdName, + Tcl_CmdProc *proc, ClientData clientData)); +EXTERN int TclReadFile _ANSI_ARGS_((Tcl_File file, + int shouldBlock, char *buf, int toRead)); +EXTERN int TclSeekFile _ANSI_ARGS_((Tcl_File file, + int offset, int whence)); +EXTERN int TclServiceIdle _ANSI_ARGS_((void)); +EXTERN void TclSetupEnv _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int TclSockGetPort _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char *proto, int *portPtr)); +EXTERN int TclSockMinimumBuffers _ANSI_ARGS_((int sock, + int size)); +EXTERN int TclSpawnPipeline _ANSI_ARGS_((Tcl_Interp *interp, + int *pidPtr, int *numPids, int argc, char **argv, + Tcl_File inputFile, + Tcl_File outputFile, + Tcl_File errorFile, + char *intIn, char *finalOut)); +EXTERN int TclTestChannelCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int TclTestChannelEventCmd _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp, + int argc, char **argv)); +EXTERN int TclUpdateReturnInfo _ANSI_ARGS_((Interp *iPtr)); +EXTERN int TclWaitForFile _ANSI_ARGS_((Tcl_File file, + int mask, int timeout)); +EXTERN char * TclWordEnd _ANSI_ARGS_((char *start, int nested, int *semiPtr)); +EXTERN int TclWriteFile _ANSI_ARGS_((Tcl_File file, + int shouldBlock, char *buf, int toWrite)); /* *---------------------------------------------------------------- @@ -790,138 +939,182 @@ extern char * TclWordEnd _ANSI_ARGS_((char *start, int nested, *---------------------------------------------------------------- */ -extern int Tcl_AppendCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_AfterCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_ArrayCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_AppendCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_BreakCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_ArrayCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_CaseCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_BreakCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_CatchCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_CaseCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_ConcatCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_CatchCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_ContinueCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_CdCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_ErrorCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_ClockCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_EvalCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_CloseCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_ExprCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_ConcatCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_ForCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_ContinueCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_ForeachCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_EofCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_FormatCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_ErrorCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_GlobalCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_EvalCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_HistoryCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_ExecCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_IfCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_ExitCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_IncrCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_ExprCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_InfoCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_FblockedCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_JoinCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_FconfigureCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_LappendCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_FileCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_LindexCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_FileEventCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_LinsertCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_FlushCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_LlengthCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_ForCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_ListCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_ForeachCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_LrangeCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_FormatCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_LreplaceCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_GetsCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_LsearchCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_GlobalCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_LsortCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_GlobCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_ProcCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_HistoryCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_RegexpCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_IfCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_RegsubCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_IncrCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_RenameCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_InfoCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_ReturnCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_InterpCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_ScanCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_JoinCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_SetCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_LappendCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_SplitCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_LindexCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_StringCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_LinsertCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_SwitchCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_LlengthCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_TraceCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_ListCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_UnsetCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_LoadCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_UplevelCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_LrangeCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_UpvarCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_LreplaceCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_WhileCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_LsearchCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_Cmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_LsortCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_Cmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_OpenCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_PackageCmd _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_ProcCmd _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_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_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_SeekCmd _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_SocketCmd _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_StringCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_SubstCmd _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_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)); +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_UpdateCmd _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_VwaitCmd _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 TclUnsupported0Cmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); /* *---------------------------------------------------------------- - * Command procedures in the UNIX core: + * Command procedures found only in the Mac version of the core: *---------------------------------------------------------------- */ -extern int Tcl_CdCmd _ANSI_ARGS_((ClientData clientData, +#ifdef MAC_TCL +EXTERN int Tcl_CpCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_CloseCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_EchoCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_EofCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_LsCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_ExecCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_MacBeepCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_ExitCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_MacSourceCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_FileCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_MkdirCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_FlushCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_MvCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_GetsCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_ResourceCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -extern int Tcl_GlobCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_RmCmd _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, +EXTERN int Tcl_RmdirCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); +#endif #endif /* _TCLINT */ diff --git a/tcl7.6/generic/tclInterp.c b/tcl7.6/generic/tclInterp.c new file mode 100644 index 0000000..3ba3647 --- /dev/null +++ b/tcl7.6/generic/tclInterp.c @@ -0,0 +1,2435 @@ +/* + * tclInterp.c -- + * + * This file implements the "interp" command which allows creation + * and manipulation of Tcl interpreters from within Tcl scripts. + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclInterp.c 1.79 96/09/20 17:20:16 + */ + +#include +#include "tclInt.h" +#include "tclPort.h" + +/* + * Counter for how many aliases were created (global) + */ + +static int aliasCounter = 0; + +/* + * + * struct Slave: + * + * Used by the "interp" command to record and find information about slave + * interpreters. Maps from a command name in the master to information about + * a slave interpreter, e.g. what aliases are defined in it. + */ + +typedef struct { + Tcl_Interp *masterInterp; /* Master interpreter for this slave. */ + Tcl_HashEntry *slaveEntry; /* Hash entry in masters slave table for + * this slave interpreter. Used to find + * this record, and used when deleting the + * slave interpreter to delete it from the + * masters table. */ + Tcl_Interp *slaveInterp; /* The slave interpreter. */ + Tcl_Command interpCmd; /* Interpreter object command. */ + Tcl_HashTable aliasTable; /* Table which maps from names of commands + * in slave interpreter to struct Alias + * defined below. */ +} Slave; + +/* + * struct Alias: + * + * Stores information about an alias. Is stored in the slave interpreter + * and used by the source command to find the target command in the master + * when the source command is invoked. + */ + +typedef struct { + char *aliasName; /* Name of alias command. */ + char *targetName; /* Name of target command in master interp. */ + Tcl_Interp *targetInterp; /* Master interpreter. */ + int argc; /* Count of additional args to pass. */ + char **argv; /* Actual additional args to pass. */ + Tcl_HashEntry *aliasEntry; /* Entry for the alias hash table in slave. + * This is used by alias deletion to remove + * the alias from the slave interpreter + * alias table. */ + Tcl_HashEntry *targetEntry; /* Entry for target command in master. + * This is used in the master interpreter to + * map back from the target command to aliases + * redirecting to it. Random access to this + * hash table is never required - we are using + * a hash table only for convenience. */ + Tcl_Command slaveCmd; /* Source command in slave interpreter. */ +} Alias; + +/* + * struct Target: + * + * Maps from master interpreter commands back to the source commands in slave + * interpreters. This is needed because aliases can be created between sibling + * interpreters and must be deleted when the target interpreter is deleted. In + * case they would not be deleted the source interpreter would be left with a + * "dangling pointer". One such record is stored in the Master record of the + * master interpreter (in the targetTable hashtable, see below) with the + * master for each alias which directs to a command in the master. These + * records are used to remove the source command for an from a slave if/when + * the master is deleted. + */ + +typedef struct { + Tcl_Command slaveCmd; /* Command for alias in slave interp. */ + Tcl_Interp *slaveInterp; /* Slave Interpreter. */ +} Target; + +/* + * struct Master: + * + * This record is used for three purposes: First, slaveTable (a hashtable) + * maps from names of commands to slave interpreters. This hashtable is + * used to store information about slave interpreters of this interpreter, + * to map over all slaves, etc. The second purpose is to store information + * about all aliases in slaves (or siblings) which direct to target commands + * in this interpreter (using the targetTable hashtable). The third field in + * the record, isSafe, denotes whether the interpreter is safe or not. Safe + * interpreters have restricted functionality, can only create safe slave + * interpreters and can only load safe extensions. + */ + +typedef struct { + Tcl_HashTable slaveTable; /* Hash table for slave interpreters. + * Maps from command names to Slave records. */ + int isSafe; /* Am I a "safe" interpreter? */ + Tcl_HashTable targetTable; /* Hash table for Target Records. Contains + * all Target records which denote aliases + * from slaves or sibling interpreters that + * direct to commands in this interpreter. This + * table is used to remove dangling pointers + * from the slave (or sibling) interpreters + * when this interpreter is deleted. */ +} Master; + +/* + * Prototypes for local static procedures: + */ + +static int AliasCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *currentInterp, int argc, char **argv)); +static void AliasCmdDeleteProc _ANSI_ARGS_(( + ClientData clientData)); +static int AliasHelper _ANSI_ARGS_((Tcl_Interp *curInterp, + Tcl_Interp *slaveInterp, Tcl_Interp *masterInterp, + Master *masterPtr, char *aliasName, + char *targetName, int argc, char **argv)); +static int CreateInterpObject _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv)); +static Tcl_Interp *CreateSlave _ANSI_ARGS_((Tcl_Interp *interp, + char *slavePath, int safe)); +static int DeleteAlias _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Interp *slaveInterp, char *aliasName)); +static int DescribeAlias _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Interp *slaveInterp, char *aliasName)); +static int DeleteInterpObject _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv)); +static int DeleteOneInterpObject _ANSI_ARGS_((Tcl_Interp *interp, + char *path)); +static Tcl_Interp *GetInterp _ANSI_ARGS_((Tcl_Interp *interp, + Master *masterPtr, char *path, + Master **masterPtrPtr)); +static int GetTarget _ANSI_ARGS_((Tcl_Interp *interp, char *path, + char *aliasName)); +static void MasterRecordDeleteProc _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp)); +static int MakeSafe _ANSI_ARGS_((Tcl_Interp *interp)); +static int SlaveAliasHelper _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv)); +static int SlaveObjectCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static void SlaveObjectDeleteProc _ANSI_ARGS_(( + ClientData clientData)); +static void SlaveRecordDeleteProc _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp)); + +/* + * These are all the Tcl core commands which are available in a safe + * interpeter: + */ + +static char *TclCommandsToKeep[] = { + "after", "append", "array", + "break", + "case", "catch", "clock", "close", "concat", "continue", + "eof", "error", "eval", "expr", + "fblocked", "fileevent", "flush", "for", "foreach", "format", + "gets", "global", + "history", + "if", "incr", "info", "interp", + "join", + "lappend", "lindex", "linsert", "list", "llength", + "lower", "lrange", "lreplace", "lsearch", "lsort", + "package", "pid", "proc", "puts", + "read", "regexp", "regsub", "rename", "return", + "scan", "seek", "set", "split", "string", "subst", "switch", + "tell", "time", "trace", + "unset", "unsupported0", "update", "uplevel", "upvar", + "vwait", + "while", + NULL}; +static int TclCommandsToKeepCt = + (sizeof (TclCommandsToKeep) / sizeof (char *)) -1 ; + +/* + *---------------------------------------------------------------------- + * + * TclPreventAliasLoop -- + * + * When defining an alias or renaming a command, prevent an alias + * loop from being formed. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * If TCL_ERROR is returned, the function also sets interp->result + * to an error message. + * + * NOTE: + * This function is public internal (instead of being static to + * this file) because it is also used from Tcl_RenameCmd. + * + *---------------------------------------------------------------------- + */ + +int +TclPreventAliasLoop(interp, cmdInterp, cmdName, proc, clientData) + Tcl_Interp *interp; /* Interp in which to report errors. */ + Tcl_Interp *cmdInterp; /* Interp in which the command is + * being defined. */ + char *cmdName; /* Name of Tcl command we are + * attempting to define. */ + Tcl_CmdProc *proc; /* The command procedure for the + * command being created. */ + ClientData clientData; /* The client data associated with the + * command to be created. */ +{ + Alias *aliasPtr, *nextAliasPtr; + Tcl_CmdInfo cmdInfo; + + /* + * If we are not creating or renaming an alias, then it is + * always OK to create or rename the command. + */ + + if (proc != AliasCmd) { + return TCL_OK; + } + + /* + * OK, we are dealing with an alias, so traverse the chain of aliases. + * If we encounter the alias we are defining (or renaming to) any in + * the chain then we have a loop. + */ + + aliasPtr = (Alias *) clientData; + nextAliasPtr = aliasPtr; + while (1) { + + /* + * If the target of the next alias in the chain is the same as the + * source alias, we have a loop. + */ + + if ((strcmp(nextAliasPtr->targetName, cmdName) == 0) && + (nextAliasPtr->targetInterp == cmdInterp)) { + Tcl_AppendResult(interp, "cannot define or rename alias \"", + aliasPtr->aliasName, "\": would create a loop", + (char *) NULL); + return TCL_ERROR; + } + + /* + * Otherwise, follow the chain one step further. If the target + * command is undefined then there is no loop. + */ + + if (Tcl_GetCommandInfo(nextAliasPtr->targetInterp, + nextAliasPtr->targetName, &cmdInfo) == 0) { + return TCL_OK; + } + + /* + * See if the target command is an alias - if so, follow the + * loop to its target command. Otherwise we do not have a loop. + */ + + if (cmdInfo.proc != AliasCmd) { + return TCL_OK; + } + nextAliasPtr = (Alias *) cmdInfo.clientData; + } + + /* NOTREACHED */ +} + +/* + *---------------------------------------------------------------------- + * + * MakeSafe -- + * + * Makes its argument interpreter contain only functionality that is + * defined to be part of Safe Tcl. + * + * Results: + * None. + * + * Side effects: + * Removes commands from its argument interpreter. + * + *---------------------------------------------------------------------- + */ + +static int +MakeSafe(interp) + Tcl_Interp *interp; /* Interpreter to be made safe. */ +{ + char **argv; /* Args for Tcl_Eval. */ + int argc, keep, i, j; /* Loop indices. */ + char *cmdGetGlobalCmds = "info commands"; /* What command to run. */ + char *cmdNoEnv = "unset env"; /* How to get rid of env. */ + Master *masterPtr; /* Master record of interp + * to be made safe. */ + Tcl_Channel chan; /* Channel to remove from + * safe interpreter. */ + + /* + * Below, Tcl_Eval sets interp->result, so we do not. + */ + + Tcl_ResetResult(interp); + if ((Tcl_Eval(interp, cmdGetGlobalCmds) == TCL_ERROR) || + (Tcl_SplitList(interp, interp->result, &argc, &argv) != TCL_OK)) { + return TCL_ERROR; + } + for (i = 0; i < argc; i++) { + for (keep = 0, j = 0; j < TclCommandsToKeepCt; j++) { + if (strcmp(TclCommandsToKeep[j], argv[i]) == 0) { + keep = 1; + break; + } + } + if (keep == 0) { + (void) Tcl_DeleteCommand(interp, argv[i]); + } + } + ckfree((char *) argv); + masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", + NULL); + if (masterPtr == (Master *) NULL) { + panic("MakeSafe: could not find master record"); + } + masterPtr->isSafe = 1; + if (Tcl_Eval(interp, cmdNoEnv) == TCL_ERROR) { + return TCL_ERROR; + } + + /* + * Remove the standard channels from the interpreter; safe interpreters + * do not ordinarily have access to stdin, stdout and stderr. + * + * NOTE: These channels are not added to the interpreter by the + * Tcl_CreateInterp call, but may be added later, by another I/O + * operation. We want to ensure that the interpreter does not have + * these channels even if it is being made safe after being used for + * some time.. + */ + + chan = Tcl_GetStdChannel(TCL_STDIN); + if (chan != (Tcl_Channel) NULL) { + Tcl_UnregisterChannel(interp, chan); + } + chan = Tcl_GetStdChannel(TCL_STDOUT); + if (chan != (Tcl_Channel) NULL) { + Tcl_UnregisterChannel(interp, chan); + } + chan = Tcl_GetStdChannel(TCL_STDERR); + if (chan != (Tcl_Channel) NULL) { + Tcl_UnregisterChannel(interp, chan); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * GetInterp -- + * + * Helper function to find a slave interpreter given a pathname. + * + * Results: + * Returns the slave interpreter known by that name in the calling + * interpreter, or NULL if no interpreter known by that name exists. + * + * Side effects: + * Assigns to the pointer variable passed in, if not NULL. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Interp * +GetInterp(interp, masterPtr, path, masterPtrPtr) + Tcl_Interp *interp; /* Interp. to start search from. */ + Master *masterPtr; /* Its master record. */ + char *path; /* The path (name) of interp. to be found. */ + Master **masterPtrPtr; /* (Return) its master record. */ +{ + Tcl_HashEntry *hPtr; /* Search element. */ + Slave *slavePtr; /* Interim slave record. */ + char **argv; /* Split-up path (name) for interp to find. */ + int argc, i; /* Loop indices. */ + Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */ + + if (masterPtrPtr != (Master **) NULL) *masterPtrPtr = masterPtr; + + if (Tcl_SplitList(interp, path, &argc, &argv) != TCL_OK) { + return (Tcl_Interp *) NULL; + } + + for (searchInterp = interp, i = 0; i < argc; i++) { + + hPtr = Tcl_FindHashEntry(&(masterPtr->slaveTable), argv[i]); + if (hPtr == (Tcl_HashEntry *) NULL) { + ckfree((char *) argv); + return (Tcl_Interp *) NULL; + } + slavePtr = (Slave *) Tcl_GetHashValue(hPtr); + searchInterp = slavePtr->slaveInterp; + if (searchInterp == (Tcl_Interp *) NULL) { + ckfree((char *) argv); + return (Tcl_Interp *) NULL; + } + masterPtr = (Master *) Tcl_GetAssocData(searchInterp, + "tclMasterRecord", NULL); + if (masterPtrPtr != (Master **) NULL) *masterPtrPtr = masterPtr; + if (masterPtr == (Master *) NULL) { + ckfree((char *) argv); + return (Tcl_Interp *) NULL; + } + } + ckfree((char *) argv); + return searchInterp; +} + +/* + *---------------------------------------------------------------------- + * + * CreateSlave -- + * + * Helper function to do the actual work of creating a slave interp + * and new object command. Also optionally makes the new slave + * interpreter "safe". + * + * Results: + * Returns the new Tcl_Interp * if successful or NULL if not. If failed, + * the result of the invoking interpreter contains an error message. + * + * Side effects: + * Creates a new slave interpreter and a new object command. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Interp * +CreateSlave(interp, slavePath, safe) + Tcl_Interp *interp; /* Interp. to start search from. */ + char *slavePath; /* Path (name) of slave to create. */ + int safe; /* Should we make it "safe"? */ +{ + Master *masterPtr; /* Master record. */ + Tcl_Interp *slaveInterp; /* Ptr to slave interpreter. */ + Tcl_Interp *masterInterp; /* Ptr to master interp for slave. */ + Slave *slavePtr; /* Slave record. */ + Tcl_HashEntry *hPtr; /* Entry into interp hashtable. */ + int new; /* Indicates whether new entry. */ + int argc; /* Count of elements in slavePath. */ + char **argv; /* Elements in slavePath. */ + char *masterPath; /* Path to its master. */ + + masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", + NULL); + if (masterPtr == (Master *) NULL) { + panic("CreatSlave: could not find master record"); + } + + if (Tcl_SplitList(interp, slavePath, &argc, &argv) != TCL_OK) { + return (Tcl_Interp *) NULL; + } + + if (argc < 2) { + masterInterp = interp; + if (argc == 1) { + slavePath = argv[0]; + } + } else { + masterPath = Tcl_Merge(argc-1, argv); + masterInterp = GetInterp(interp, masterPtr, masterPath, &masterPtr); + if (masterInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter named \"", masterPath, + "\" not found", (char *) NULL); + ckfree((char *) argv); + ckfree((char *) masterPath); + return (Tcl_Interp *) NULL; + } + ckfree((char *) masterPath); + slavePath = argv[argc-1]; + if (!safe) { + safe = masterPtr->isSafe; + } + } + hPtr = Tcl_CreateHashEntry(&(masterPtr->slaveTable), slavePath, &new); + if (new == 0) { + Tcl_AppendResult(interp, "interpreter named \"", slavePath, + "\" already exists, cannot create", (char *) NULL); + ckfree((char *) argv); + return (Tcl_Interp *) NULL; + } + slaveInterp = Tcl_CreateInterp(); + if (slaveInterp == (Tcl_Interp *) NULL) { + panic("CreateSlave: out of memory while creating a new interpreter"); + } + slavePtr = (Slave *) ckalloc((unsigned) sizeof(Slave)); + slavePtr->masterInterp = masterInterp; + slavePtr->slaveEntry = hPtr; + slavePtr->slaveInterp = slaveInterp; + slavePtr->interpCmd = Tcl_CreateCommand(masterInterp, slavePath, + SlaveObjectCmd, (ClientData) slaveInterp, SlaveObjectDeleteProc); + Tcl_InitHashTable(&(slavePtr->aliasTable), TCL_STRING_KEYS); + (void) Tcl_SetAssocData(slaveInterp, "tclSlaveRecord", + SlaveRecordDeleteProc, (ClientData) slavePtr); + Tcl_SetHashValue(hPtr, (ClientData) slavePtr); + Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); + + if (((safe) && (MakeSafe(slaveInterp) == TCL_ERROR)) || + ((!safe) && (Tcl_Init(slaveInterp) == TCL_ERROR))) { + Tcl_ResetResult(interp); + Tcl_AddErrorInfo(interp, Tcl_GetVar2(slaveInterp, "errorInfo", (char *) + NULL, TCL_GLOBAL_ONLY)); + Tcl_SetVar2(interp, "errorCode", (char *) NULL, + Tcl_GetVar2(slaveInterp, "errorCode", (char *) NULL, + TCL_GLOBAL_ONLY), + TCL_GLOBAL_ONLY); + if (slaveInterp->freeProc != NULL) { + interp->result = slaveInterp->result; + interp->freeProc = slaveInterp->freeProc; + slaveInterp->freeProc = 0; + } else { + Tcl_SetResult(interp, slaveInterp->result, TCL_VOLATILE); + } + Tcl_ResetResult(slaveInterp); + (void) Tcl_DeleteCommand(masterInterp, slavePath); + slaveInterp = (Tcl_Interp *) NULL; + } + ckfree((char *) argv); + return slaveInterp; +} + +/* + *---------------------------------------------------------------------- + * + * CreateInterpObject - + * + * Helper function to do the actual work of creating a new interpreter + * and an object command. + * + * Results: + * A Tcl result. + * + * Side effects: + * See user documentation for details. + * + *---------------------------------------------------------------------- + */ + +static int +CreateInterpObject(interp, argc, argv) + Tcl_Interp *interp; /* Invoking interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int safe; /* Create a safe interpreter? */ + Master *masterPtr; /* Master record. */ + int moreFlags; /* Expecting more flag args? */ + char *slavePath; /* Name of slave. */ + char localSlaveName[200]; /* Local area for creating names. */ + int i; /* Loop counter. */ + size_t len; /* Length of option argument. */ + static int interpCounter = 0; /* Unique id for created names. */ + + masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("CreateInterpObject: could not find master record"); + } + moreFlags = 1; + slavePath = NULL; + safe = masterPtr->isSafe; + + if (argc < 2 || argc > 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " create ?-safe? ?--? ?path?\"", (char *) NULL); + return TCL_ERROR; + } + for (i = 2; i < argc; i++) { + len = strlen(argv[i]); + if ((argv[i][0] == '-') && (moreFlags != 0)) { + if ((argv[i][1] == 's') && (strncmp(argv[i], "-safe", len) == 0) + && (len > 1)){ + safe = 1; + } else if ((strncmp(argv[i], "--", len) == 0) && (len > 1)) { + moreFlags = 0; + } else { + Tcl_AppendResult(interp, "bad option \"", argv[i], + "\": should be -safe", (char *) NULL); + return TCL_ERROR; + } + } else { + slavePath = argv[i]; + } + } + if (slavePath == (char *) NULL) { + sprintf(localSlaveName, "interp%d", interpCounter); + interpCounter++; + slavePath = localSlaveName; + } + if (CreateSlave(interp, slavePath, safe) != NULL) { + Tcl_AppendResult(interp, slavePath, (char *) NULL); + return TCL_OK; + } else { + /* + * CreateSlave already set interp->result if there was an error, + * so we do not do it here. + */ + return TCL_ERROR; + } +} + +/* + *---------------------------------------------------------------------- + * + * DeleteOneInterpObject -- + * + * Helper function for DeleteInterpObject. It deals with deleting one + * interpreter at a time. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Deletes an interpreter and its interpreter object command. + * + *---------------------------------------------------------------------- + */ + +static int +DeleteOneInterpObject(interp, path) + Tcl_Interp *interp; /* Interpreter for reporting errors. */ + char *path; /* Path of interpreter to delete. */ +{ + Master *masterPtr; /* Interim storage for master record.*/ + Slave *slavePtr; /* Interim storage for slave record. */ + Tcl_Interp *masterInterp; /* Master of interp. to delete. */ + Tcl_HashEntry *hPtr; /* Search element. */ + int localArgc; /* Local copy of count of elements in + * path (name) of interp. to delete. */ + char **localArgv; /* Local copy of path. */ + char *slaveName; /* Last component in path. */ + char *masterPath; /* One-before-last component in path.*/ + + masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("DeleteInterpObject: could not find master record"); + } + if (Tcl_SplitList(interp, path, &localArgc, &localArgv) != TCL_OK) { + Tcl_AppendResult(interp, "bad interpreter path \"", path, + "\"", (char *) NULL); + return TCL_ERROR; + } + if (localArgc < 2) { + masterInterp = interp; + if (localArgc == 0) { + slaveName = ""; + } else { + slaveName = localArgv[0]; + } + } else { + masterPath = Tcl_Merge(localArgc-1, localArgv); + masterInterp = GetInterp(interp, masterPtr, masterPath, &masterPtr); + if (masterInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter named \"", masterPath, + "\" not found", (char *) NULL); + ckfree((char *) localArgv); + ckfree((char *) masterPath); + return TCL_ERROR; + } + ckfree((char *) masterPath); + slaveName = localArgv[localArgc-1]; + } + hPtr = Tcl_FindHashEntry(&(masterPtr->slaveTable), slaveName); + if (hPtr == (Tcl_HashEntry *) NULL) { + ckfree((char *) localArgv); + Tcl_AppendResult(interp, "interpreter named \"", path, + "\" not found", (char *) NULL); + return TCL_ERROR; + } + slavePtr = (Slave *) Tcl_GetHashValue(hPtr); + slaveName = Tcl_GetCommandName(masterInterp, slavePtr->interpCmd); + if (Tcl_DeleteCommand(masterInterp, slaveName) != 0) { + ckfree((char *) localArgv); + Tcl_AppendResult(interp, "interpreter named \"", path, + "\" not found", (char *) NULL); + return TCL_ERROR; + } + ckfree((char *) localArgv); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteInterpObject -- + * + * Helper function to do the work of deleting zero or more + * interpreters and their interpreter object commands. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Deletes interpreters and their interpreter object command. + * + *---------------------------------------------------------------------- + */ + +static int +DeleteInterpObject(interp, argc, argv) + Tcl_Interp *interp; /* Interpreter start search from. */ + int argc; /* Number of arguments in vector. */ + char **argv; /* Contains path to interps to + * delete. */ +{ + int i; + + for (i = 2; i < argc; i++) { + if (DeleteOneInterpObject(interp, argv[i]) != TCL_OK) { + return TCL_ERROR; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * AliasHelper -- + * + * Helper function to do the work to actually create an alias or + * delete an alias. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * An alias command is created and entered into the alias table + * for the slave interpreter. + * + *---------------------------------------------------------------------- + */ + +static int +AliasHelper(curInterp, slaveInterp, masterInterp, masterPtr, + aliasName, targetName, argc, argv) + Tcl_Interp *curInterp; /* Interp that invoked this proc. */ + Tcl_Interp *slaveInterp; /* Interp where alias cmd will live + * or from which alias will be + * deleted. */ + Tcl_Interp *masterInterp; /* Interp where target cmd will be. */ + Master *masterPtr; /* Master record for target interp. */ + char *aliasName; /* Name of alias cmd. */ + char *targetName; /* Name of target cmd. */ + int argc; /* Additional arguments to store */ + char **argv; /* with alias. */ +{ + Alias *aliasPtr; /* Storage for alias data. */ + Alias *tmpAliasPtr; /* Temp storage for alias to delete. */ + char *tmpAliasName; /* Temp storage for name of alias + * to delete. */ + Tcl_HashEntry *hPtr; /* Entry into interp hashtable. */ + int i; /* Loop index. */ + int new; /* Is it a new hash entry? */ + Target *targetPtr; /* Maps from target command in master + * to source command in slave. */ + Slave *slavePtr; /* Maps from source command in slave + * to target command in master. */ + + slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", NULL); + + /* + * Fix it up if there is no slave record. This can happen if someone + * uses "" as the source for an alias. + */ + + if (slavePtr == (Slave *) NULL) { + slavePtr = (Slave *) ckalloc((unsigned) sizeof(Slave)); + slavePtr->masterInterp = (Tcl_Interp *) NULL; + slavePtr->slaveEntry = (Tcl_HashEntry *) NULL; + slavePtr->slaveInterp = slaveInterp; + slavePtr->interpCmd = (Tcl_Command) NULL; + Tcl_InitHashTable(&(slavePtr->aliasTable), TCL_STRING_KEYS); + (void) Tcl_SetAssocData(slaveInterp, "tclSlaveRecord", + SlaveRecordDeleteProc, (ClientData) slavePtr); + } + + if ((targetName == (char *) NULL) || (targetName[0] == '\0')) { + if (argc != 0) { + Tcl_AppendResult(curInterp, "malformed command: should be", + " \"alias ", aliasName, " {}\"", (char *) NULL); + return TCL_ERROR; + } + + return DeleteAlias(curInterp, slaveInterp, aliasName); + } + + aliasPtr = (Alias *) ckalloc((unsigned) sizeof(Alias)); + aliasPtr->aliasName = (char *) ckalloc((unsigned) strlen(aliasName)+1); + aliasPtr->targetName = (char *) ckalloc((unsigned) strlen(targetName)+1); + strcpy(aliasPtr->aliasName, aliasName); + strcpy(aliasPtr->targetName, targetName); + aliasPtr->targetInterp = masterInterp; + + aliasPtr->argv = (char **) NULL; + aliasPtr->argc = argc; + if (aliasPtr->argc > 0) { + aliasPtr->argv = (char **) ckalloc((unsigned) sizeof(char *) * + aliasPtr->argc); + for (i = 0; i < argc; i++) { + aliasPtr->argv[i] = (char *) ckalloc((unsigned) strlen(argv[i])+1); + strcpy(aliasPtr->argv[i], argv[i]); + } + } + + if (TclPreventAliasLoop(curInterp, slaveInterp, aliasName, AliasCmd, + (ClientData) aliasPtr) != TCL_OK) { + for (i = 0; i < argc; i++) { + ckfree(aliasPtr->argv[i]); + } + if (aliasPtr->argv != (char **) NULL) { + ckfree((char *) aliasPtr->argv); + } + ckfree(aliasPtr->aliasName); + ckfree(aliasPtr->targetName); + ckfree((char *) aliasPtr); + + return TCL_ERROR; + } + + aliasPtr->slaveCmd = Tcl_CreateCommand(slaveInterp, aliasName, AliasCmd, + (ClientData) aliasPtr, AliasCmdDeleteProc); + + /* + * Make an entry in the alias table. If it already exists delete + * the alias command. Then retry. + */ + + do { + hPtr = Tcl_CreateHashEntry(&(slavePtr->aliasTable), aliasName, &new); + if (new == 0) { + tmpAliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + tmpAliasName = Tcl_GetCommandName(slaveInterp, + tmpAliasPtr->slaveCmd); + (void) Tcl_DeleteCommand(slaveInterp, tmpAliasName); + + /* + * The hash entry should be deleted by the Tcl_DeleteCommand + * above, in its command deletion callback (most likely this + * will be AliasCmdDeleteProc, which does the deletion). + */ + } + } while (new == 0); + aliasPtr->aliasEntry = hPtr; + Tcl_SetHashValue(hPtr, (ClientData) aliasPtr); + + /* + * Create the new command. We must do it after deleting any old command, + * because the alias may be pointing at a renamed alias, as in: + * + * interp alias {} foo {} bar # Create an alias "foo" + * rename foo zop # Now rename the alias + * interp alias {} foo {} zop # Now recreate "foo"... + */ + + targetPtr = (Target *) ckalloc((unsigned) sizeof(Target)); + targetPtr->slaveCmd = aliasPtr->slaveCmd; + targetPtr->slaveInterp = slaveInterp; + + do { + hPtr = Tcl_CreateHashEntry(&(masterPtr->targetTable), + (char *) aliasCounter, &new); + aliasCounter++; + } while (new == 0); + + Tcl_SetHashValue(hPtr, (ClientData) targetPtr); + + aliasPtr->targetEntry = hPtr; + + curInterp->result = aliasPtr->aliasName; + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * SlaveAliasHelper - + * + * Handles the different forms of the "interp alias" command: + * - interp alias slavePath aliasName + * Describes an alias. + * - interp alias slavePath aliasName {} + * Deletes an alias. + * - interp alias slavePath srcCmd masterPath targetCmd args... + * Creates an alias. + * + * Results: + * A Tcl result. + * + * Side effects: + * See user documentation for details. + * + *---------------------------------------------------------------------- + */ + +static int +SlaveAliasHelper(interp, argc, argv) + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Master *masterPtr; /* Master record for current interp. */ + Tcl_Interp *slaveInterp, /* Interpreters used when */ + *masterInterp; /* creating an alias btn siblings. */ + Master *masterMasterPtr; /* Master record for master interp. */ + + masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("SlaveAliasHelper: could not find master record"); + } + if (argc < 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " alias slavePath slaveCmd masterPath masterCmd ?args ..?\"", + (char *) NULL); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, masterPtr, argv[2], NULL); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "could not find interpreter \"", + argv[2], "\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 4) { + return DescribeAlias(interp, slaveInterp, argv[3]); + } + if (argc == 5 && strcmp(argv[4], "") == 0) { + return DeleteAlias(interp, slaveInterp, argv[3]); + } + if (argc < 6) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " alias slavePath slaveCmd masterPath masterCmd ?args ..?\"", + (char *) NULL); + return TCL_ERROR; + } + masterInterp = GetInterp(interp, masterPtr, argv[4], &masterMasterPtr); + if (masterInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "could not find interpreter \"", + argv[4], "\"", (char *) NULL); + return TCL_ERROR; + } + return AliasHelper(interp, slaveInterp, masterInterp, masterMasterPtr, + argv[3], argv[5], argc-6, argv+6); +} + +/* + *---------------------------------------------------------------------- + * + * DescribeAlias -- + * + * Sets interp->result to a Tcl list describing the given alias in the + * given interpreter: its target command and the additional arguments + * to prepend to any invocation of the alias. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +DescribeAlias(interp, slaveInterp, aliasName) + Tcl_Interp *interp; /* Interpreter for result and errors. */ + Tcl_Interp *slaveInterp; /* Interpreter defining alias. */ + char *aliasName; /* Name of alias to describe. */ +{ + Slave *slavePtr; /* Slave record for slave interpreter. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + Alias *aliasPtr; /* Structure describing alias. */ + int i; /* Loop variable. */ + + slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", + NULL); + if (slavePtr == (Slave *) NULL) { + + /* + * It's possible that the interpreter still does not have a slave + * record. If so, create such a record now. This is only possible + * for interpreters that were created with Tcl_CreateInterp, not + * those created with Tcl_CreateSlave, so this interpreter does + * not have a master. + */ + + slavePtr = (Slave *) ckalloc((unsigned) sizeof(Slave)); + slavePtr->masterInterp = (Tcl_Interp *) NULL; + slavePtr->slaveEntry = (Tcl_HashEntry *) NULL; + slavePtr->slaveInterp = slaveInterp; + slavePtr->interpCmd = (Tcl_Command) NULL; + Tcl_InitHashTable(&(slavePtr->aliasTable), TCL_STRING_KEYS); + (void) Tcl_SetAssocData(slaveInterp, "tclSlaveRecord", + SlaveRecordDeleteProc, (ClientData) slavePtr); + } + hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName); + if (hPtr == (Tcl_HashEntry *) NULL) { + return TCL_OK; + } + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + Tcl_AppendResult(interp, aliasPtr->targetName, (char *) NULL); + for (i = 0; i < aliasPtr->argc; i++) { + Tcl_AppendElement(interp, aliasPtr->argv[i]); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteAlias -- + * + * Deletes the given alias from the slave interpreter given. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Deletes the alias from the slave interpreter. + * + *---------------------------------------------------------------------- + */ + +static int +DeleteAlias(interp, slaveInterp, aliasName) + Tcl_Interp *interp; /* Interpreter for result and errors. */ + Tcl_Interp *slaveInterp; /* Interpreter defining alias. */ + char *aliasName; /* Name of alias to delete. */ +{ + Slave *slavePtr; /* Slave record for slave interpreter. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + Alias *aliasPtr; /* Structure describing alias to delete. */ + + slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", + NULL); + if (slavePtr == (Slave *) NULL) { + Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", + (char *) NULL); + return TCL_ERROR; + } + + /* + * Get the alias from the alias table, determine the current + * true name of the alias (it may have been renamed!) and then + * delete the true command name. The deleteProc on the alias + * command will take care of removing the entry from the alias + * table. + */ + + hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName); + if (hPtr == (Tcl_HashEntry *) NULL) { + Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", + (char *) NULL); + return TCL_ERROR; + } + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + aliasName = Tcl_GetCommandName(slaveInterp, aliasPtr->slaveCmd); + + /* + * NOTE: The deleteProc for this command will delete the + * alias from the hash table. The deleteProc will also + * delete the target information from the master interpreter + * target table. + */ + + if (Tcl_DeleteCommand(slaveInterp, aliasName) != 0) { + panic("DeleteAlias: did not find alias to be deleted"); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetInterpPath -- + * + * Sets the result of the asking interpreter to a proper Tcl list + * containing the names of interpreters between the asking and + * target interpreters. The target interpreter must be either the + * same as the asking interpreter or one of its slaves (including + * recursively). + * + * Results: + * TCL_OK if the target interpreter is the same as, or a descendant + * of, the asking interpreter; TCL_ERROR else. This way one can + * distinguish between the case where the asking and target interps + * are the same (an empty list is the result, and TCL_OK is returned) + * and when the target is not a descendant of the asking interpreter + * (in which case the Tcl result is an error message and the function + * returns TCL_ERROR). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetInterpPath(askingInterp, targetInterp) + Tcl_Interp *askingInterp; /* Interpreter to start search from. */ + Tcl_Interp *targetInterp; /* Interpreter to find. */ +{ + Master *masterPtr; /* Interim storage for Master record. */ + Slave *slavePtr; /* Interim storage for Slave record. */ + + if (targetInterp == askingInterp) { + return TCL_OK; + } + if (targetInterp == (Tcl_Interp *) NULL) { + return TCL_ERROR; + } + slavePtr = (Slave *) Tcl_GetAssocData(targetInterp, "tclSlaveRecord", + NULL); + if (slavePtr == (Slave *) NULL) { + return TCL_ERROR; + } + if (Tcl_GetInterpPath(askingInterp, slavePtr->masterInterp) == TCL_ERROR) { + /* + * AskingInterp->result was set by recursive call. + */ + return TCL_ERROR; + } + masterPtr = (Master *) Tcl_GetAssocData(slavePtr->masterInterp, + "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("Tcl_GetInterpPath: could not find master record"); + } + Tcl_AppendElement(askingInterp, Tcl_GetHashKey(&(masterPtr->slaveTable), + slavePtr->slaveEntry)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * GetTarget -- + * + * Sets the result of the invoking interpreter to a path name for + * the target interpreter of an alias in one of the slaves. + * + * Results: + * TCL_OK if the target interpreter of the alias is a slave of the + * invoking interpreter, TCL_ERROR else. + * + * Side effects: + * Sets the result of the invoking interpreter. + * + *---------------------------------------------------------------------- + */ + +static int +GetTarget(askingInterp, path, aliasName) + Tcl_Interp *askingInterp; /* Interpreter to start search from. */ + char *path; /* The path of the interp to find. */ + char *aliasName; /* The target of this allias. */ +{ + Tcl_Interp *slaveInterp; /* Interim storage for slave. */ + Slave *slaveSlavePtr; /* Its Slave record. */ + Master *masterPtr; /* Interim storage for Master record. */ + Tcl_HashEntry *hPtr; /* Search element. */ + Alias *aliasPtr; /* Data describing the alias. */ + + Tcl_ResetResult(askingInterp); + + masterPtr = (Master *) Tcl_GetAssocData(askingInterp, "tclMasterRecord", + NULL); + if (masterPtr == (Master *) NULL) { + panic("GetTarget: could not find master record"); + } + slaveInterp = GetInterp(askingInterp, masterPtr, path, NULL); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(askingInterp, "could not find interpreter \"", + path, "\"", (char *) NULL); + return TCL_ERROR; + } + slaveSlavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", + NULL); + if (slaveSlavePtr == (Slave *) NULL) { + panic("GetTarget: could not find slave record"); + } + hPtr = Tcl_FindHashEntry(&(slaveSlavePtr->aliasTable), aliasName); + if (hPtr == (Tcl_HashEntry *) NULL) { + Tcl_AppendResult(askingInterp, "alias \"", aliasName, "\" in path \"", + path, "\" not found", (char *) NULL); + return TCL_ERROR; + } + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + if (aliasPtr == (Alias *) NULL) { + panic("GetTarget: could not find alias record"); + } + if (Tcl_GetInterpPath(askingInterp, aliasPtr->targetInterp) == TCL_ERROR) { + Tcl_ResetResult(askingInterp); + Tcl_AppendResult(askingInterp, "target interpreter for alias \"", + aliasName, "\" in path \"", path, "\" is not my descendant", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_InterpCmd -- + * + * This procedure is invoked to process the "interp" 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_InterpCmd(clientData, interp, argc, argv) + ClientData clientData; /* Unused. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Interp *slaveInterp; /* A slave. */ + Tcl_Interp *masterInterp; /* A master. */ + Master *masterPtr; /* Master record for current interp. */ + Slave *slavePtr; /* Record for slave interp. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + Tcl_HashSearch hSearch; /* Iteration variable. */ + size_t len; /* Length of command name. */ + int result; /* Result of eval. */ + char *cmdName; /* Name of sub command to do. */ + char *cmd; /* Command to eval. */ + Tcl_Channel chan; /* Channel to share or transfer. */ + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " cmd ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + cmdName = argv[1]; + + masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("Tcl_InterpCmd: could not find master record"); + } + + len = strlen(cmdName); + + if (cmdName[0] == 'a') { + if ((strncmp(cmdName, "alias", len) == 0) && (len <= 5)) { + return SlaveAliasHelper(interp, argc, argv); + } + + if (strcmp(cmdName, "aliases") == 0) { + if (argc != 2 && argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " aliases ?path?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 3) { + slaveInterp = GetInterp(interp, masterPtr, argv[2], NULL); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter \"", + argv[2], "\" not found", (char *) NULL); + return TCL_ERROR; + } + } else { + slaveInterp = interp; + } + slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, + "tclSlaveRecord", NULL); + if (slavePtr == (Slave *) NULL) { + return TCL_OK; + } + for (hPtr = Tcl_FirstHashEntry(&(slavePtr->aliasTable), &hSearch); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + Tcl_AppendElement(interp, + Tcl_GetHashKey(&(slavePtr->aliasTable), hPtr)); + } + return TCL_OK; + } + } + + if ((cmdName[0] == 'c') && (strncmp(cmdName, "create", len) == 0)) { + return CreateInterpObject(interp, argc, argv); + } + + if ((cmdName[0] == 'd') && (strncmp(cmdName, "delete", len) == 0)) { + return DeleteInterpObject(interp, argc, argv); + } + + if (cmdName[0] == 'e') { + if ((strncmp(cmdName, "eval", len) == 0) && (len > 1)) { + if (argc < 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " eval path arg ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, masterPtr, argv[2], NULL); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter named \"", argv[2], + "\" not found", (char *) NULL); + return TCL_ERROR; + } + cmd = Tcl_Concat(argc-3, argv+3); + Tcl_Preserve((ClientData) slaveInterp); + result = Tcl_Eval(slaveInterp, cmd); + ckfree((char *) cmd); + + /* + * Now make the result and any error information accessible. We + * have to be careful because the slave interpreter and the current + * interpreter can be the same - do not destroy the result.. This + * can happen if an interpreter contains an alias which is directed + * at a target command in the same interpreter. + */ + + if (interp != slaveInterp) { + if (result == TCL_ERROR) { + + /* + * An error occurred, so transfer error information from + * the target interpreter back to our interpreter. Must + * clear interp's result before calling Tcl_AddErrorInfo, + * since Tcl_AddErrorInfo will store the interp's result in + * errorInfo before appending slaveInterp's $errorInfo; + * we've already got everything we need in the slave + * interpreter's $errorInfo. + */ + + Tcl_ResetResult(interp); + Tcl_AddErrorInfo(interp, Tcl_GetVar2(slaveInterp, + "errorInfo", (char *) NULL, TCL_GLOBAL_ONLY)); + Tcl_SetVar2(interp, "errorCode", (char *) NULL, + Tcl_GetVar2(slaveInterp, "errorCode", (char *) + NULL, TCL_GLOBAL_ONLY), + TCL_GLOBAL_ONLY); + } + if (slaveInterp->freeProc != NULL) { + interp->result = slaveInterp->result; + interp->freeProc = slaveInterp->freeProc; + slaveInterp->freeProc = 0; + } else { + Tcl_SetResult(interp, slaveInterp->result, TCL_VOLATILE); + } + Tcl_ResetResult(slaveInterp); + } + Tcl_Release((ClientData) slaveInterp); + return result; + } + if ((strncmp(cmdName, "exists", len) == 0) && (len > 2)) { + if (argc > 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " exists ?path?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 3) { + if (GetInterp(interp, masterPtr, argv[2], NULL) == + (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "0", (char *) NULL); + } else { + Tcl_AppendResult(interp, "1", (char *) NULL); + } + } else { + Tcl_AppendResult(interp, "1", (char *) NULL); + } + return TCL_OK; + } + } + + if (cmdName[0] == 'i') { + if ((len > 1) && (strncmp(cmdName, "issafe", len) == 0)) { + if (argc > 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " issafe ?path?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 3) { + slaveInterp = GetInterp(interp, masterPtr, argv[2], + &masterPtr); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter \"", argv[2], + "\" not found", (char *) NULL); + return TCL_ERROR; + } + } + if (masterPtr->isSafe == 0) { + Tcl_AppendResult(interp, "0", (char *) NULL); + } else { + Tcl_AppendResult(interp, "1", (char *) NULL); + } + return TCL_OK; + } + } + + if (cmdName[0] == 's') { + if ((strncmp(cmdName, "slaves", len) == 0) && (len > 1)) { + if (argc != 2 && argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " slaves ?path?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 3) { + if (GetInterp(interp, masterPtr, argv[2], &masterPtr) == + (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter \"", argv[2], + "\" not found", (char *) NULL); + return TCL_ERROR; + } + } + for (hPtr = Tcl_FirstHashEntry(&(masterPtr->slaveTable), &hSearch); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + Tcl_AppendElement(interp, + Tcl_GetHashKey(&(masterPtr->slaveTable), hPtr)); + } + return TCL_OK; + } + if ((strncmp(cmdName, "share", len) == 0) && (len > 1)) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " share srcPath channelId destPath\"", (char *) NULL); + return TCL_ERROR; + } + masterInterp = GetInterp(interp, masterPtr, argv[2], NULL); + if (masterInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter \"", argv[2], + "\" not found", (char *) NULL); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, masterPtr, argv[4], NULL); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter \"", argv[4], + "\" not found", (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(masterInterp, argv[3], NULL); + if (chan == (Tcl_Channel) NULL) { + if (interp != masterInterp) { + Tcl_AppendResult(interp, masterInterp->result, + (char *) NULL); + Tcl_ResetResult(masterInterp); + } + return TCL_ERROR; + } + Tcl_RegisterChannel(slaveInterp, chan); + return TCL_OK; + } + } + + if ((cmdName[0] == 't') && (strncmp(cmdName, "target", len) == 0)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " target path alias\"", (char *) NULL); + return TCL_ERROR; + } + return GetTarget(interp, argv[2], argv[3]); + } + + if ((cmdName[0] == 't') && (strncmp(cmdName, "transfer", len) == 0)) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " transfer srcPath channelId destPath\"", (char *) NULL); + return TCL_ERROR; + } + masterInterp = GetInterp(interp, masterPtr, argv[2], NULL); + if (masterInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter \"", argv[2], + "\" not found", (char *) NULL); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, masterPtr, argv[4], NULL); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter \"", argv[4], + "\" not found", (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(masterInterp, argv[3], NULL); + if (chan == (Tcl_Channel) NULL) { + if (interp != masterInterp) { + Tcl_AppendResult(interp, masterInterp->result, (char *) NULL); + Tcl_ResetResult(masterInterp); + } + return TCL_ERROR; + } + Tcl_RegisterChannel(slaveInterp, chan); + if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) { + if (interp != masterInterp) { + Tcl_AppendResult(interp, masterInterp->result, (char *) NULL); + Tcl_ResetResult(masterInterp); + } + return TCL_ERROR; + } + + return TCL_OK; + } + + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be alias, aliases, create, delete, exists, eval, ", + "issafe, share, slaves, target or transfer", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * SlaveObjectCmd -- + * + * Command to manipulate an interpreter, e.g. to send commands to it + * to be evaluated. One such command exists for each slave interpreter. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See user documentation for details. + * + *---------------------------------------------------------------------- + */ + +static int +SlaveObjectCmd(clientData, interp, argc, argv) + ClientData clientData; /* Slave interpreter. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Master *masterPtr; /* Master record for slave interp. */ + Slave *slavePtr; /* Slave record. */ + Tcl_Interp *slaveInterp; /* Slave interpreter. */ + char *cmdName; /* Name of command to do. */ + char *cmd; /* Command to evaluate in slave + * interpreter. */ + Alias *aliasPtr; /* Alias information. */ + Tcl_HashEntry *hPtr; /* For local searches. */ + Tcl_HashSearch hSearch; /* For local searches. */ + int result; /* Loop counter, status return. */ + size_t len; /* Length of command name. */ + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " cmd ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + + slaveInterp = (Tcl_Interp *) clientData; + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter ", argv[0], " has been deleted", + (char *) NULL); + return TCL_ERROR; + } + + slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, + "tclSlaveRecord", NULL); + if (slavePtr == (Slave *) NULL) { + panic("SlaveObjectCmd: could not find slave record"); + } + + cmdName = argv[1]; + len = strlen(cmdName); + + if (cmdName[0] == 'a') { + if (strncmp(cmdName, "alias", len) == 0) { + switch (argc-2) { + case 0: + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " alias aliasName ?targetName? ?args..?", + (char *) NULL); + return TCL_ERROR; + + case 1: + + /* + * Return the name of the command in the current + * interpreter for which the argument is an alias in the + * slave interpreter, and the list of saved arguments + */ + + return DescribeAlias(interp, slaveInterp, argv[2]); + + default: + masterPtr = (Master *) Tcl_GetAssocData(interp, + "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("SlaveObjectCmd: could not find master record"); + } + return AliasHelper(interp, slaveInterp, interp, masterPtr, + argv[2], argv[3], argc-4, argv+4); + } + } + + if (strncmp(cmdName, "aliases", len) == 0) { + + /* + * Return the names of all the aliases created in the + * slave interpreter. + */ + + for (hPtr = Tcl_FirstHashEntry(&(slavePtr->aliasTable), + &hSearch); + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + Tcl_AppendElement(interp, aliasPtr->aliasName); + } + return TCL_OK; + } + } + + if (cmdName[0] == 'e') { + if ((len > 1) && (strncmp(cmdName, "eval", len) == 0)) { + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " eval arg ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + + cmd = Tcl_Concat(argc-2, argv+2); + Tcl_Preserve((ClientData) slaveInterp); + result = Tcl_Eval(slaveInterp, cmd); + ckfree((char *) cmd); + + /* + * Make the result and any error information accessible. We have + * to be careful because the slave interpreter and the current + * interpreter can be the same - do not destroy the result.. This + * can happen if an interpreter contains an alias which is directed + * at a target command in the same interpreter. + */ + + if (interp != slaveInterp) { + if (result == TCL_ERROR) { + + /* + * An error occurred, so transfer error information from the + * destination interpreter back to our interpreter. Clear + * interp's result before calling Tcl_AddErrorInfo, since + * Tcl_AddErrorInfo stores the interp's result in errorInfo + * before appending slaveInterp's $errorInfo; + * we've already got everything we need in the slave + * interpreter's $errorInfo. + */ + + Tcl_ResetResult(interp); + Tcl_AddErrorInfo(interp, Tcl_GetVar2(slaveInterp, + "errorInfo", (char *) NULL, TCL_GLOBAL_ONLY)); + Tcl_SetVar2(interp, "errorCode", (char *) NULL, + Tcl_GetVar2(slaveInterp, "errorCode", + (char *) NULL, TCL_GLOBAL_ONLY), + TCL_GLOBAL_ONLY); + } + if (slaveInterp->freeProc != NULL) { + interp->result = slaveInterp->result; + interp->freeProc = slaveInterp->freeProc; + slaveInterp->freeProc = 0; + } else { + Tcl_SetResult(interp, slaveInterp->result, TCL_VOLATILE); + } + Tcl_ResetResult(slaveInterp); + } + Tcl_Release((ClientData) slaveInterp); + return result; + } + } + + if (cmdName[0] == 'i') { + if ((len > 1) && (strncmp(cmdName, "issafe", len) == 0)) { + if (argc > 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " issafe\"", (char *) NULL); + return TCL_ERROR; + } + masterPtr = (Master *) Tcl_GetAssocData(slaveInterp, + "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("SlaveObjectCmd: could not find master record"); + } + if (masterPtr->isSafe == 1) { + Tcl_AppendResult(interp, "1", (char *) NULL); + } else { + Tcl_AppendResult(interp, "0", (char *) NULL); + } + return TCL_OK; + } + } + + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be alias, aliases, eval, or issafe", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * SlaveObjectDeleteProc -- + * + * Invoked when an object command for a slave interpreter is deleted; + * cleans up all state associated with the slave interpreter and destroys + * the slave interpreter. + * + * Results: + * None. + * + * Side effects: + * Cleans up all state associated with the slave interpreter and + * destroys the slave interpreter. + * + *---------------------------------------------------------------------- + */ + +static void +SlaveObjectDeleteProc(clientData) + ClientData clientData; /* The SlaveRecord for the command. */ +{ + Slave *slavePtr; /* Interim storage for Slave record. */ + Tcl_Interp *slaveInterp; /* And for a slave interp. */ + + slaveInterp = (Tcl_Interp *) clientData; + slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord",NULL); + if (slavePtr == (Slave *) NULL) { + panic("SlaveObjectDeleteProc: could not find slave record"); + } + + /* + * Delete the entry in the slave table in the master interpreter now. + * This is to avoid an infinite loop in the Master hash table cleanup in + * the master interpreter. This can happen if this slave is being deleted + * because the master is being deleted and the slave deletion is deferred + * because it is still active. + */ + + Tcl_DeleteHashEntry(slavePtr->slaveEntry); + + /* + * Set to NULL so that when the slave record is cleaned up in the slave + * it does not try to delete the command causing all sorts of grief. + * See SlaveRecordDeleteProc(). + */ + + slavePtr->interpCmd = NULL; + + /* + * Destroy the interpreter - this will cause all the deleteProcs for + * all commands (including aliases) to run. + * + * NOTE: WE ASSUME THAT THE INTERPRETER HAS NOT BEEN DELETED YET!! + */ + + Tcl_DeleteInterp(slavePtr->slaveInterp); +} + +/* + *---------------------------------------------------------------------- + * + * AliasCmd -- + * + * This is the procedure that services invocations of aliases in a + * slave interpreter. One such command exists for each alias. When + * invoked, this procedure redirects the invocation to the target + * command in the master interpreter as designated by the Alias + * record associated with this command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Causes forwarding of the invocation; all possible side effects + * may occur as a result of invoking the command to which the + * invocation is forwarded. + * + *---------------------------------------------------------------------- + */ + +static int +AliasCmd(clientData, interp, argc, argv) + ClientData clientData; /* Alias record. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Alias *aliasPtr; /* Describes the alias. */ + Tcl_CmdInfo cmdInfo; /* Info about target command. */ + int result; /* Result of execution. */ + int i, j, addArgc; /* Loop counters. */ + int localArgc; /* Local argument count. */ + char **localArgv; /* Local argument vector. */ + Interp *iPtr; /* The target interpreter. */ + + aliasPtr = (Alias *) clientData; + + result = Tcl_GetCommandInfo(aliasPtr->targetInterp, aliasPtr->targetName, + &cmdInfo); + if (result == 0) { + Tcl_AppendResult(interp, "aliased target \"", aliasPtr->targetName, + "\" for \"", argv[0], "\" not found", (char *) NULL); + return TCL_ERROR; + } + if (aliasPtr->argc <= 0) { + localArgv = argv; + localArgc = argc; + } else { + addArgc = aliasPtr->argc; + localArgc = argc + addArgc; + localArgv = (char **) ckalloc((unsigned) sizeof(char *) * localArgc); + localArgv[0] = argv[0]; + for (i = 0, j = 1; i < addArgc; i++, j++) { + localArgv[j] = aliasPtr->argv[i]; + } + for (i = 1; i < argc; i++, j++) { + localArgv[j] = argv[i]; + } + } + + /* + * Invoke the redirected command in the target interpreter. Note + * that we are not calling eval because of possible security holes with + * $ substitution and bracketed command evaluation. + * + * We duplicate some code here from Tcl_Eval to implement recursion + * level counting and correct deletion of the target interpreter if + * that was requested but delayed because of in-progress evaluations. + */ + + iPtr = (Interp *) aliasPtr->targetInterp; + iPtr->numLevels++; + Tcl_Preserve((ClientData) iPtr); + Tcl_ResetResult((Tcl_Interp *) iPtr); + result = (cmdInfo.proc)(cmdInfo.clientData, (Tcl_Interp *) iPtr, + localArgc, localArgv); + iPtr->numLevels--; + if (iPtr->numLevels == 0) { + if (result == TCL_RETURN) { + result = TclUpdateReturnInfo(iPtr); + } + if ((result != TCL_OK) && (result != TCL_ERROR)) { + Tcl_ResetResult((Tcl_Interp *) iPtr); + 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; + } + } + + /* + * Clean up any locally allocated argument vector structure. + */ + + if (localArgv != argv) { + ckfree((char *) localArgv); + } + + /* + * + * NOTE: Need to be careful if the target interpreter and the current + * interpreter are the same - must not destroy result. This may happen + * if an alias is created which redirects to a command in the same + * interpreter as the one in which the source command will be defined. + * Also: We cannot use aliasPtr any more because the alias may have + * been deleted. + */ + + if (interp != (Tcl_Interp *) iPtr) { + if (result == TCL_ERROR) { + /* + * An error occurred, so transfer error information from the + * destination interpreter back to our interpreter. Some tricky + * points: + * 1. Must call Tcl_AddErrorInfo in destination interpreter to + * make sure that the errorInfo variable has been initialized + * (it's initialized lazily and might not have been initialized + * yet). + * 2. Must clear interp's result before calling Tcl_AddErrorInfo, + * since Tcl_AddErrorInfo will store the interp's result in + * errorInfo before appending aliasPtr->interp's $errorInfo; + * we've already got everything we need in the redirected + * interpreter's $errorInfo. + */ + + if (!(iPtr->flags & ERR_ALREADY_LOGGED)) { + Tcl_AddErrorInfo((Tcl_Interp *) iPtr, ""); + } + iPtr->flags &= ~ERR_ALREADY_LOGGED; + Tcl_ResetResult(interp); + Tcl_AddErrorInfo(interp, Tcl_GetVar2((Tcl_Interp *) iPtr, + "errorInfo", (char *) NULL, TCL_GLOBAL_ONLY)); + Tcl_SetVar2(interp, "errorCode", (char *) NULL, + Tcl_GetVar2((Tcl_Interp *) iPtr, "errorCode", + (char *) NULL, TCL_GLOBAL_ONLY), TCL_GLOBAL_ONLY); + } + if (iPtr->freeProc != NULL) { + interp->result = iPtr->result; + interp->freeProc = iPtr->freeProc; + iPtr->freeProc = 0; + } else { + Tcl_SetResult(interp, iPtr->result, TCL_VOLATILE); + } + Tcl_ResetResult((Tcl_Interp *) iPtr); + } + Tcl_Release((ClientData) iPtr); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * AliasCmdDeleteProc -- + * + * Is invoked when an alias command is deleted in a slave. Cleans up + * all storage associated with this alias. + * + * Results: + * None. + * + * Side effects: + * Deletes the alias record and its entry in the alias table for + * the interpreter. + * + *---------------------------------------------------------------------- + */ + +static void +AliasCmdDeleteProc(clientData) + ClientData clientData; /* The alias record for this alias. */ +{ + Alias *aliasPtr; /* Alias record for alias to delete. */ + Target *targetPtr; /* Record for target of this alias. */ + int i; /* Loop counter. */ + + aliasPtr = (Alias *) clientData; + + targetPtr = (Target *) Tcl_GetHashValue(aliasPtr->targetEntry); + ckfree((char *) targetPtr); + Tcl_DeleteHashEntry(aliasPtr->targetEntry); + + ckfree((char *) aliasPtr->targetName); + ckfree((char *) aliasPtr->aliasName); + for (i = 0; i < aliasPtr->argc; i++) { + ckfree((char *) aliasPtr->argv[i]); + } + if (aliasPtr->argv != (char **) NULL) { + ckfree((char *) aliasPtr->argv); + } + + Tcl_DeleteHashEntry(aliasPtr->aliasEntry); + + ckfree((char *) aliasPtr); +} + +/* + *---------------------------------------------------------------------- + * + * MasterRecordDeleteProc - + * + * Is invoked when an interpreter (which is using the "interp" facility) + * is deleted, and it cleans up the storage associated with the + * "tclMasterRecord" assoc-data entry. + * + * Results: + * None. + * + * Side effects: + * Cleans up storage. + * + *---------------------------------------------------------------------- + */ + +static void +MasterRecordDeleteProc(clientData, interp) + ClientData clientData; /* Master record for deleted interp. */ + Tcl_Interp *interp; /* Interpreter being deleted. */ +{ + Target *targetPtr; /* Loop variable. */ + Tcl_HashEntry *hPtr; /* Search element. */ + Tcl_HashSearch hSearch; /* Search record (internal). */ + Slave *slavePtr; /* Loop variable. */ + char *cmdName; /* Name of command to delete. */ + Master *masterPtr; /* Interim storage. */ + + masterPtr = (Master *) clientData; + for (hPtr = Tcl_FirstHashEntry(&(masterPtr->slaveTable), &hSearch); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + slavePtr = (Slave *) Tcl_GetHashValue(hPtr); + cmdName = Tcl_GetCommandName(interp, slavePtr->interpCmd); + (void) Tcl_DeleteCommand(interp, cmdName); + } + Tcl_DeleteHashTable(&(masterPtr->slaveTable)); + + for (hPtr = Tcl_FirstHashEntry(&(masterPtr->targetTable), &hSearch); + hPtr != NULL; + hPtr = Tcl_FirstHashEntry(&(masterPtr->targetTable), &hSearch)) { + targetPtr = (Target *) Tcl_GetHashValue(hPtr); + cmdName = Tcl_GetCommandName(targetPtr->slaveInterp, + targetPtr->slaveCmd); + (void) Tcl_DeleteCommand(targetPtr->slaveInterp, cmdName); + } + Tcl_DeleteHashTable(&(masterPtr->targetTable)); + + ckfree((char *) masterPtr); +} + +/* + *---------------------------------------------------------------------- + * + * SlaveRecordDeleteProc -- + * + * Is invoked when an interpreter (which is using the interp facility) + * is deleted, and it cleans up the storage associated with the + * tclSlaveRecord assoc-data entry. + * + * Results: + * None + * + * Side effects: + * Cleans up storage. + * + *---------------------------------------------------------------------- + */ + +static void +SlaveRecordDeleteProc(clientData, interp) + ClientData clientData; /* Slave record for deleted interp. */ + Tcl_Interp *interp; /* Interpreter being deleted. */ +{ + Slave *slavePtr; /* Interim storage. */ + Alias *aliasPtr; + Tcl_HashTable *hTblPtr; + Tcl_HashEntry *hPtr; + Tcl_HashSearch hSearch; + + slavePtr = (Slave *) clientData; + + /* + * In every case that we call SetAssocData on "tclSlaveRecord", + * slavePtr is not NULL. Otherwise we panic. + */ + + if (slavePtr == NULL) { + panic("SlaveRecordDeleteProc: NULL slavePtr"); + } + + if (slavePtr->interpCmd != (Tcl_Command) NULL) { + Command *cmdPtr = (Command *) slavePtr->interpCmd; + + /* + * The interpCmd has not been deleted in the master yet, since + * it's callback sets interpCmd to NULL. + * + * Probably Tcl_DeleteInterp() was called on this interpreter directly, + * rather than via "interp delete", or equivalent (deletion of the + * command in the master). + * + * Perform the cleanup done by SlaveObjectDeleteProc() directly, + * and turn off the callback now (since we are about to free slavePtr + * and this interpreter is going away, while the deletion of commands + * in the master may be deferred). + */ + + Tcl_DeleteHashEntry(slavePtr->slaveEntry); + cmdPtr->clientData = NULL; + cmdPtr->deleteProc = NULL; + cmdPtr->deleteData = NULL; + + /* + * Get the command name from the master interpreter instead of + * relying on the stored name; the command may have been renamed. + */ + + Tcl_DeleteCommand(slavePtr->masterInterp, + Tcl_GetCommandName(slavePtr->masterInterp, + slavePtr->interpCmd)); + } + + /* + * If there are any aliases, delete those now. This removes any + * dependency on the order of deletion between commands and the + * slave record. + */ + + hTblPtr = (Tcl_HashTable *) &(slavePtr->aliasTable); + for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch)) { + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + + /* + * The call to Tcl_DeleteCommand will release the storage + * occuppied by the hash entry and the alias record. + * NOTE that we cannot use the alias name directly because its + * storage will be deleted in the command deletion callback. Hence + * we must use the name for the command as stored in the hash table. + */ + + Tcl_DeleteCommand(interp, + Tcl_GetCommandName(interp, aliasPtr->slaveCmd)); + } + + /* + * Finally dispose of the hash table and the slave record. + */ + + Tcl_DeleteHashTable(hTblPtr); + ckfree((char *) slavePtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclInterpInit -- + * + * Initializes the invoking interpreter for using the "interp" + * facility. This is called from inside Tcl_Init. + * + * Results: + * None. + * + * Side effects: + * Adds the "interp" command to an interpreter and initializes several + * records in the associated data of the invoking interpreter. + * + *---------------------------------------------------------------------- + */ + +int +TclInterpInit(interp) + Tcl_Interp *interp; /* Interpreter to initialize. */ +{ + Master *masterPtr; /* Its Master record. */ + + masterPtr = (Master *) ckalloc((unsigned) sizeof(Master)); + masterPtr->isSafe = 0; + Tcl_InitHashTable(&(masterPtr->slaveTable), TCL_STRING_KEYS); + Tcl_InitHashTable(&(masterPtr->targetTable), TCL_ONE_WORD_KEYS); + + (void) Tcl_SetAssocData(interp, "tclMasterRecord", MasterRecordDeleteProc, + (ClientData) masterPtr); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_IsSafe -- + * + * Determines whether an interpreter is safe + * + * Results: + * 1 if it is safe, 0 if it is not. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_IsSafe(interp) + Tcl_Interp *interp; /* Is this interpreter "safe" ? */ +{ + Master *masterPtr; /* Its master record. */ + + if (interp == (Tcl_Interp *) NULL) { + return 0; + } + masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("Tcl_IsSafe: could not find master record"); + } + return masterPtr->isSafe; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_MakeSafe -- + * + * Makes an interpreter safe. + * + * Results: + * TCL_OK if it succeeds, TCL_ERROR else. + * + * Side effects: + * Removes functionality from an interpreter. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_MakeSafe(interp) + Tcl_Interp *interp; /* Make this interpreter "safe". */ +{ + if (interp == (Tcl_Interp *) NULL) { + return TCL_ERROR; + } + return MakeSafe(interp); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateSlave -- + * + * Creates a slave interpreter. The slavePath argument denotes the + * name of the new slave relative to the current interpreter; the + * slave is a direct descendant of the one-before-last component of + * the path, e.g. it is a descendant of the current interpreter if + * the slavePath argument contains only one component. Optionally makes + * the slave interpreter safe. + * + * Results: + * Returns the interpreter structure created, or NULL if an error + * occurred. + * + * Side effects: + * Creates a new interpreter and a new interpreter object command in + * the interpreter indicated by the slavePath argument. + * + *---------------------------------------------------------------------- + */ + +Tcl_Interp * +Tcl_CreateSlave(interp, slavePath, isSafe) + Tcl_Interp *interp; /* Interpreter to start search at. */ + char *slavePath; /* Name of slave to create. */ + int isSafe; /* Should new slave be "safe" ? */ +{ + if ((interp == (Tcl_Interp *) NULL) || (slavePath == (char *) NULL)) { + return NULL; + } + return CreateSlave(interp, slavePath, isSafe); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetSlave -- + * + * Finds a slave interpreter by its path name. + * + * Results: + * Returns a Tcl_Interp * for the named interpreter or NULL if not + * found. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Interp * +Tcl_GetSlave(interp, slavePath) + Tcl_Interp *interp; /* Interpreter to start search from. */ + char *slavePath; /* Path of slave to find. */ +{ + Master *masterPtr; /* Interim storage for Master record. */ + + if ((interp == (Tcl_Interp *) NULL) || (slavePath == (char *) NULL)) { + return NULL; + } + masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("Tcl_GetSlave: could not find master record"); + } + return GetInterp(interp, masterPtr, slavePath, NULL); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetMaster -- + * + * Finds the master interpreter of a slave interpreter. + * + * Results: + * Returns a Tcl_Interp * for the master interpreter or NULL if none. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Interp * +Tcl_GetMaster(interp) + Tcl_Interp *interp; /* Get the master of this interpreter. */ +{ + Slave *slavePtr; /* Slave record of this interpreter. */ + + if (interp == (Tcl_Interp *) NULL) { + return NULL; + } + slavePtr = (Slave *) Tcl_GetAssocData(interp, "tclSlaveRecord", NULL); + if (slavePtr == (Slave *) NULL) { + return NULL; + } + return slavePtr->masterInterp; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateAlias -- + * + * Creates an alias between two interpreters. + * + * Results: + * TCL_OK if successful, TCL_ERROR if failed. If TCL_ERROR is returned + * the result of slaveInterp will contain an error message. + * + * Side effects: + * Creates a new alias, manipulates the result field of slaveInterp. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_CreateAlias(slaveInterp, slaveCmd, targetInterp, targetCmd, argc, argv) + Tcl_Interp *slaveInterp; /* Interpreter for source command. */ + char *slaveCmd; /* Command to install in slave. */ + Tcl_Interp *targetInterp; /* Interpreter for target command. */ + char *targetCmd; /* Name of target command. */ + int argc; /* How many additional arguments? */ + char **argv; /* These are the additional args. */ +{ + Master *masterPtr; /* Master record for target interp. */ + + if ((slaveInterp == (Tcl_Interp *) NULL) || + (targetInterp == (Tcl_Interp *) NULL) || + (slaveCmd == (char *) NULL) || + (targetCmd == (char *) NULL)) { + return TCL_ERROR; + } + masterPtr = (Master *) Tcl_GetAssocData(targetInterp, "tclMasterRecord", + NULL); + if (masterPtr == (Master *) NULL) { + panic("Tcl_CreateAlias: could not find master record"); + } + return AliasHelper(slaveInterp, slaveInterp, targetInterp, masterPtr, + slaveCmd, targetCmd, argc, argv); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetAlias -- + * + * Gets information about an alias. + * + * Results: + * TCL_OK if successful, TCL_ERROR else. If TCL_ERROR is returned, the + * result field of the interpreter given as argument will contain an + * error message. + * + * Side effects: + * Manipulates the result field of the interpreter given as argument. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr, + argvPtr) + Tcl_Interp *interp; /* Interp to start search from. */ + char *aliasName; /* Name of alias to find. */ + Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */ + char **targetNamePtr; /* (Return) name of target command. */ + int *argcPtr; /* (Return) count of addnl args. */ + char ***argvPtr; /* (Return) additional arguments. */ +{ + Slave *slavePtr; /* Slave record for slave interp. */ + Tcl_HashEntry *hPtr; /* Search element. */ + Alias *aliasPtr; /* Storage for alias found. */ + + if ((interp == (Tcl_Interp *) NULL) || (aliasName == (char *) NULL)) { + return TCL_ERROR; + } + slavePtr = (Slave *) Tcl_GetAssocData(interp, "tclSlaveRecord", NULL); + if (slavePtr == (Slave *) NULL) { + panic("Tcl_GetAlias: could not find slave record"); + } + hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName); + if (hPtr == (Tcl_HashEntry *) NULL) { + Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", + (char *) NULL); + return TCL_ERROR; + } + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + if (targetInterpPtr != (Tcl_Interp **) NULL) { + *targetInterpPtr = aliasPtr->targetInterp; + } + if (targetNamePtr != (char **) NULL) { + *targetNamePtr = aliasPtr->targetName; + } + if (argcPtr != (int *) NULL) { + *argcPtr = aliasPtr->argc; + } + if (argvPtr != (char ***) NULL) { + *argvPtr = aliasPtr->argv; + } + return TCL_OK; +} diff --git a/tcl7.3/tclLink.c b/tcl7.6/generic/tclLink.c similarity index 71% rename from tcl7.3/tclLink.c rename to tcl7.6/generic/tclLink.c index 887d976..de69a0e 100644 --- a/tcl7.3/tclLink.c +++ b/tcl7.6/generic/tclLink.c @@ -3,35 +3,19 @@ * * 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 + * first suggested by Andreas Stolcke 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. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tclLink.c 1.13 96/08/09 16:23:34 */ -#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" /* @@ -42,16 +26,34 @@ static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclLink.c,v 1.4 93/07/29 1 typedef struct Link { Tcl_Interp *interp; /* Interpreter containing Tcl variable. */ + char *varName; /* Name of variable (must be global). This + * is needed during trace callbacks, since + * the actual variable may be aliased at + * that time via upvar. */ 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. */ + int flags; /* Miscellaneous one-bit values; see below + * for definitions. */ } Link; +/* + * Definitions for flag bits: + * LINK_READ_ONLY - 1 means errors should be generated if Tcl + * script attempts to write variable. + * LINK_BEING_UPDATED - 1 means that a call to Tcl_UpdateLinkedVar + * is in progress for this variable, so + * trace callbacks on the variable should + * be ignored. + */ + +#define LINK_READ_ONLY 1 +#define LINK_BEING_UPDATED 2 + /* * Forward references to procedures defined later in this file: */ @@ -98,11 +100,18 @@ Tcl_LinkVar(interp, varName, addr, type) linkPtr = (Link *) ckalloc(sizeof(Link)); linkPtr->interp = interp; + linkPtr->varName = (char *) ckalloc((unsigned) (strlen(varName) + 1)); + strcpy(linkPtr->varName, varName); linkPtr->addr = addr; linkPtr->type = type & ~TCL_LINK_READ_ONLY; - linkPtr->writable = (type & TCL_LINK_READ_ONLY) == 0; + if (type & TCL_LINK_READ_ONLY) { + linkPtr->flags = LINK_READ_ONLY; + } else { + linkPtr->flags = 0; + } if (Tcl_SetVar(interp, varName, StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { + ckfree(linkPtr->varName); ckfree((char *) linkPtr); return TCL_ERROR; } @@ -110,6 +119,7 @@ Tcl_LinkVar(interp, varName, addr, type) |TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, (ClientData) linkPtr); if (code != TCL_OK) { + ckfree(linkPtr->varName); ckfree((char *) linkPtr); } return code; @@ -146,11 +156,52 @@ Tcl_UnlinkVar(interp, varName) return; } Tcl_UntraceVar(interp, varName, - TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, (ClientData) linkPtr); + ckfree(linkPtr->varName); ckfree((char *) linkPtr); } +/* + *---------------------------------------------------------------------- + * + * Tcl_UpdateLinkedVar -- + * + * This procedure is invoked after a linked variable has been + * changed by C code. It updates the Tcl variable so that + * traces on the variable will trigger. + * + * Results: + * None. + * + * Side effects: + * The Tcl variable "varName" is updated from its C value, + * causing traces on the variable to trigger. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_UpdateLinkedVar(interp, varName) + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *varName; /* Name of global variable that is linked. */ +{ + Link *linkPtr; + char buffer[TCL_DOUBLE_SPACE]; + int savedFlag; + + linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY, + LinkTraceProc, (ClientData) NULL); + if (linkPtr == NULL) { + return; + } + savedFlag = linkPtr->flags & LINK_BEING_UPDATED; + linkPtr->flags |= LINK_BEING_UPDATED; + Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), + TCL_GLOBAL_ONLY); + linkPtr->flags = (linkPtr->flags & ~LINK_BEING_UPDATED) | savedFlag; +} + /* *---------------------------------------------------------------------- * @@ -193,18 +244,29 @@ LinkTraceProc(clientData, interp, name1, name2, flags) if (flags & TCL_TRACE_UNSETS) { if (flags & TCL_INTERP_DESTROYED) { + ckfree(linkPtr->varName); 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 + } else if (flags & TCL_TRACE_DESTROYED) { + Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), + TCL_GLOBAL_ONLY); + Tcl_TraceVar(interp, linkPtr->varName, TCL_GLOBAL_ONLY |TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, (ClientData) linkPtr); } return NULL; } + /* + * If we were invoked because of a call to Tcl_UpdateLinkedVar, then + * don't do anything at all. In particular, we don't want to get + * upset that the variable is being modified, even if it is + * supposed to be read-only. + */ + + if (linkPtr->flags & LINK_BEING_UPDATED) { + return NULL; + } + /* * For read accesses, update the Tcl variable if the C variable * has changed since the last time we updated the Tcl variable. @@ -226,7 +288,7 @@ LinkTraceProc(clientData, interp, name1, name2, flags) return "internal error: bad linked variable type"; } if (changed) { - Tcl_SetVar2(interp, name1, name2, StringValue(linkPtr, buffer), + Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY); } return NULL; @@ -241,12 +303,12 @@ LinkTraceProc(clientData, interp, name1, name2, flags) * could occur when the result has been partially set. */ - if (!linkPtr->writable) { - Tcl_SetVar2(interp, name1, name2, StringValue(linkPtr, buffer), - TCL_GLOBAL_ONLY); + if (linkPtr->flags & LINK_READ_ONLY) { + Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), + TCL_GLOBAL_ONLY); return "linked variable is read-only"; } - value = Tcl_GetVar2(interp, name1, name2, TCL_GLOBAL_ONLY); + value = Tcl_GetVar(interp, linkPtr->varName, TCL_GLOBAL_ONLY); if (value == NULL) { /* * This shouldn't ever happen. @@ -260,8 +322,8 @@ LinkTraceProc(clientData, interp, name1, name2, flags) 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); + Tcl_SetVar(interp, linkPtr->varName, + StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY); return "variable must have integer value"; } *(int *)(linkPtr->addr) = linkPtr->lastValue.i; @@ -270,8 +332,8 @@ LinkTraceProc(clientData, interp, name1, name2, flags) 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); + Tcl_SetVar(interp, linkPtr->varName, + StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY); return "variable must have real value"; } *(double *)(linkPtr->addr) = linkPtr->lastValue.d; @@ -280,8 +342,8 @@ LinkTraceProc(clientData, interp, name1, name2, flags) 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); + Tcl_SetVar(interp, linkPtr->varName, + StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY); return "variable must have boolean value"; } *(int *)(linkPtr->addr) = linkPtr->lastValue.i; @@ -291,7 +353,7 @@ LinkTraceProc(clientData, interp, name1, name2, flags) if (*pp != NULL) { ckfree(*pp); } - *pp = ckalloc((unsigned) (strlen(value) + 1)); + *pp = (char *) ckalloc((unsigned) (strlen(value) + 1)); strcpy(*pp, value); break; default: diff --git a/tcl7.6/generic/tclLoad.c b/tcl7.6/generic/tclLoad.c new file mode 100644 index 0000000..7570dba --- /dev/null +++ b/tcl7.6/generic/tclLoad.c @@ -0,0 +1,630 @@ +/* + * tclLoad.c -- + * + * This file provides the generic portion (those that are the same + * on all platforms) of Tcl's dynamic loading facilities. + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclLoad.c 1.15 96/10/12 17:05:58 + */ + +#include "tclInt.h" + +/* + * The following structure describes a package that has been loaded + * either dynamically (with the "load" command) or statically (as + * indicated by a call to Tcl_PackageLoaded). All such packages + * are linked together into a single list for the process. Packages + * are never unloaded, so these structures are never freed. + */ + +typedef struct LoadedPackage { + char *fileName; /* Name of the file from which the + * package was loaded. An empty string + * means the package is loaded statically. + * Malloc-ed. */ + char *packageName; /* Name of package prefix for the package, + * properly capitalized (first letter UC, + * others LC), no "_", as in "Net". + * Malloc-ed. */ + Tcl_PackageInitProc *initProc; + /* Initialization procedure to call to + * incorporate this package into a trusted + * interpreter. */ + Tcl_PackageInitProc *safeInitProc; + /* Initialization procedure to call to + * incorporate this package into a safe + * interpreter (one that will execute + * untrusted scripts). NULL means the + * package can't be used in unsafe + * interpreters. */ + struct LoadedPackage *nextPtr; + /* Next in list of all packages loaded into + * this application process. NULL means + * end of list. */ +} LoadedPackage; + +static LoadedPackage *firstPackagePtr = NULL; + /* First in list of all packages loaded into + * this process. */ + +/* + * The following structure represents a particular package that has + * been incorporated into a particular interpreter (by calling its + * initialization procedure). There is a list of these structures for + * each interpreter, with an AssocData value (key "load") for the + * interpreter that points to the first package (if any). + */ + +typedef struct InterpPackage { + LoadedPackage *pkgPtr; /* Points to detailed information about + * package. */ + struct InterpPackage *nextPtr; + /* Next package in this interpreter, or + * NULL for end of list. */ +} InterpPackage; + +/* + * Prototypes for procedures that are private to this file: + */ + +static void LoadCleanupProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp)); +static void LoadExitProc _ANSI_ARGS_((ClientData clientData)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_LoadCmd -- + * + * This procedure is invoked to process the "load" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_LoadCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Interp *target; + LoadedPackage *pkgPtr, *defaultPtr; + Tcl_DString pkgName, initName, safeInitName, fileName; + Tcl_PackageInitProc *initProc, *safeInitProc; + InterpPackage *ipFirstPtr, *ipPtr; + int code, c, gotPkgName, namesMatch, filesMatch; + char *p, *fullFileName, *p1, *p2; + + if ((argc < 2) || (argc > 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " fileName ?packageName? ?interp?\"", (char *) NULL); + return TCL_ERROR; + } + fullFileName = Tcl_TranslateFileName(interp, argv[1], &fileName); + if (fullFileName == NULL) { + return TCL_ERROR; + } + Tcl_DStringInit(&pkgName); + Tcl_DStringInit(&initName); + Tcl_DStringInit(&safeInitName); + if ((argc >= 3) && (argv[2][0] != 0)) { + gotPkgName = 1; + } else { + gotPkgName = 0; + } + if ((fullFileName[0] == 0) && !gotPkgName) { + interp->result = "must specify either file name or package name"; + code = TCL_ERROR; + goto done; + } + + /* + * Figure out which interpreter we're going to load the package into. + */ + + target = interp; + if (argc == 4) { + target = Tcl_GetSlave(interp, argv[3]); + if (target == NULL) { + Tcl_AppendResult(interp, "couldn't find slave interpreter named \"", + argv[3], "\"", (char *) NULL); + return TCL_ERROR; + } + } + + /* + * Scan through the packages that are currently loaded to see if the + * package we want is already loaded. We'll use a loaded package if + * it meets any of the following conditions: + * - Its name and file match the once we're looking for. + * - Its file matches, and we weren't given a name. + * - Its name matches, the file name was specified as empty, and there + * is only no statically loaded package with the same name. + */ + + defaultPtr = NULL; + for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { + if (!gotPkgName) { + namesMatch = 0; + } else { + namesMatch = 1; + for (p1 = argv[2], p2 = pkgPtr->packageName; ; p1++, p2++) { + if ((isupper(UCHAR(*p1)) ? tolower(UCHAR(*p1)) : *p1) + != (isupper(UCHAR(*p2)) ? tolower(UCHAR(*p2)) : *p2)) { + namesMatch = 0; + break; + } + if (*p1 == 0) { + break; + } + } + } + filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0); + if (filesMatch && (namesMatch || !gotPkgName)) { + break; + } + if (namesMatch && (fullFileName[0] == 0)) { + defaultPtr = pkgPtr; + } + if (filesMatch && !namesMatch && (fullFileName[0] != 0)) { + /* + * Can't have two different packages loaded from the same + * file. + */ + + Tcl_AppendResult(interp, "file \"", fullFileName, + "\" is already loaded for package \"", + pkgPtr->packageName, "\"", (char *) NULL); + code = TCL_ERROR; + goto done; + } + } + if (pkgPtr == NULL) { + pkgPtr = defaultPtr; + } + + /* + * Scan through the list of packages already loaded in the target + * interpreter. If the package we want is already loaded there, + * then there's nothing for us to to. + */ + + if (pkgPtr != NULL) { + ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad", + (Tcl_InterpDeleteProc **) NULL); + for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { + if (ipPtr->pkgPtr == pkgPtr) { + code = TCL_OK; + goto done; + } + } + } + + if (pkgPtr == NULL) { + /* + * The desired file isn't currently loaded, so load it. It's an + * error if the desired package is a static one. + */ + + if (fullFileName[0] == 0) { + Tcl_AppendResult(interp, "package \"", argv[2], + "\" isn't loaded statically", (char *) NULL); + code = TCL_ERROR; + goto done; + } + + /* + * Figure out the module name if it wasn't provided explicitly. + */ + + if (gotPkgName) { + Tcl_DStringAppend(&pkgName, argv[2], -1); + } else { + if (!TclGuessPackageName(fullFileName, &pkgName)) { + int pargc; + char **pargv, *pkgGuess; + + /* + * The platform-specific code couldn't figure out the + * module name. Make a guess by taking the last element + * of the file name, stripping off any leading "lib", + * and then using all of the alphabetic and underline + * characters that follow that. + */ + + Tcl_SplitPath(fullFileName, &pargc, &pargv); + pkgGuess = pargv[pargc-1]; + if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i') + && (pkgGuess[2] == 'b')) { + pkgGuess += 3; + } + for (p = pkgGuess; isalpha(UCHAR(*p)) || (*p == '_'); p++) { + /* Empty loop body. */ + } + if (p == pkgGuess) { + ckfree((char *)pargv); + Tcl_AppendResult(interp, + "couldn't figure out package name for ", + fullFileName, (char *) NULL); + code = TCL_ERROR; + goto done; + } + Tcl_DStringAppend(&pkgName, pkgGuess, (p - pkgGuess)); + ckfree((char *)pargv); + } + } + + /* + * Fix the capitalization in the package name so that the first + * character is in caps but the others are all lower-case. + */ + + p = Tcl_DStringValue(&pkgName); + c = UCHAR(*p); + if (c != 0) { + if (islower(c)) { + *p = (char) toupper(c); + } + p++; + while (1) { + c = UCHAR(*p); + if (c == 0) { + break; + } + if (isupper(c)) { + *p = (char) tolower(c); + } + p++; + } + } + + /* + * Compute the names of the two initialization procedures, + * based on the package name. + */ + + Tcl_DStringAppend(&initName, Tcl_DStringValue(&pkgName), -1); + Tcl_DStringAppend(&initName, "_Init", 5); + Tcl_DStringAppend(&safeInitName, Tcl_DStringValue(&pkgName), -1); + Tcl_DStringAppend(&safeInitName, "_SafeInit", 9); + + /* + * Call platform-specific code to load the package and find the + * two initialization procedures. + */ + + code = TclLoadFile(interp, fullFileName, Tcl_DStringValue(&initName), + Tcl_DStringValue(&safeInitName), &initProc, &safeInitProc); + if (code != TCL_OK) { + goto done; + } + if (initProc == NULL) { + Tcl_AppendResult(interp, "couldn't find procedure ", + Tcl_DStringValue(&initName), (char *) NULL); + code = TCL_ERROR; + goto done; + } + + /* + * Create a new record to describe this package. + */ + + if (firstPackagePtr == NULL) { + Tcl_CreateExitHandler(LoadExitProc, (ClientData) NULL); + } + pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage)); + pkgPtr->fileName = (char *) ckalloc((unsigned) + (strlen(fullFileName) + 1)); + strcpy(pkgPtr->fileName, fullFileName); + pkgPtr->packageName = (char *) ckalloc((unsigned) + (Tcl_DStringLength(&pkgName) + 1)); + strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName)); + pkgPtr->initProc = initProc; + pkgPtr->safeInitProc = safeInitProc; + pkgPtr->nextPtr = firstPackagePtr; + firstPackagePtr = pkgPtr; + } + + /* + * Invoke the package's initialization procedure (either the + * normal one or the safe one, depending on whether or not the + * interpreter is safe). + */ + + if (Tcl_IsSafe(target)) { + if (pkgPtr->safeInitProc != NULL) { + code = (*pkgPtr->safeInitProc)(target); + } else { + Tcl_AppendResult(interp, + "can't use package in a safe interpreter: ", + "no ", pkgPtr->packageName, "_SafeInit procedure", + (char *) NULL); + code = TCL_ERROR; + goto done; + } + } else { + code = (*pkgPtr->initProc)(target); + } + if ((code == TCL_ERROR) && (target != interp)) { + /* + * An error occurred, so transfer error information from the + * destination interpreter back to our interpreter. Must clear + * interp's result before calling Tcl_AddErrorInfo, since + * Tcl_AddErrorInfo will store the interp's result in errorInfo + * before appending target's $errorInfo; we've already got + * everything we need in target's $errorInfo. + */ + + Tcl_ResetResult(interp); + Tcl_AddErrorInfo(interp, Tcl_GetVar2(target, + "errorInfo", (char *) NULL, TCL_GLOBAL_ONLY)); + Tcl_SetVar2(interp, "errorCode", (char *) NULL, + Tcl_GetVar2(target, "errorCode", (char *) NULL, + TCL_GLOBAL_ONLY), TCL_GLOBAL_ONLY); + Tcl_SetResult(interp, target->result, TCL_VOLATILE); + } + + /* + * Record the fact that the package has been loaded in the + * target interpreter. + */ + + if (code == TCL_OK) { + /* + * Refetch ipFirstPtr: loading the package may have introduced + * additional static packages at the head of the linked list! + */ + + ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad", + (Tcl_InterpDeleteProc **) NULL); + ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage)); + ipPtr->pkgPtr = pkgPtr; + ipPtr->nextPtr = ipFirstPtr; + Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, + (ClientData) ipPtr); + } + + done: + Tcl_DStringFree(&pkgName); + Tcl_DStringFree(&initName); + Tcl_DStringFree(&safeInitName); + Tcl_DStringFree(&fileName); + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_StaticPackage -- + * + * This procedure is invoked to indicate that a particular + * package has been linked statically with an application. + * + * Results: + * None. + * + * Side effects: + * Once this procedure completes, the package becomes loadable + * via the "load" command with an empty file name. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) + Tcl_Interp *interp; /* If not NULL, it means that the + * package has already been loaded + * into the given interpreter by + * calling the appropriate init proc. */ + char *pkgName; /* Name of package (must be properly + * capitalized: first letter upper + * case, others lower case). */ + Tcl_PackageInitProc *initProc; /* Procedure to call to incorporate + * this package into a trusted + * interpreter. */ + Tcl_PackageInitProc *safeInitProc; /* Procedure to call to incorporate + * this package into a safe interpreter + * (one that will execute untrusted + * scripts). NULL means the package + * can't be used in safe + * interpreters. */ +{ + LoadedPackage *pkgPtr; + InterpPackage *ipPtr, *ipFirstPtr; + + /* + * Check to see if someone else has already reported this package as + * statically loaded. If this call is redundant then just return. + */ + + for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { + if ((pkgPtr->initProc == initProc) + && (pkgPtr->safeInitProc == safeInitProc) + && (strcmp(pkgPtr->packageName, pkgName) == 0)) { + return; + } + } + + if (firstPackagePtr == NULL) { + Tcl_CreateExitHandler(LoadExitProc, (ClientData) NULL); + } + pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage)); + pkgPtr->fileName = (char *) ckalloc((unsigned) 1); + pkgPtr->fileName[0] = 0; + pkgPtr->packageName = (char *) ckalloc((unsigned) + (strlen(pkgName) + 1)); + strcpy(pkgPtr->packageName, pkgName); + pkgPtr->initProc = initProc; + pkgPtr->safeInitProc = safeInitProc; + pkgPtr->nextPtr = firstPackagePtr; + firstPackagePtr = pkgPtr; + + if (interp != NULL) { + ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(interp, "tclLoad", + (Tcl_InterpDeleteProc **) NULL); + ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage)); + ipPtr->pkgPtr = pkgPtr; + ipPtr->nextPtr = ipFirstPtr; + Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc, + (ClientData) ipPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclGetLoadedPackages -- + * + * This procedure returns information about all of the files + * that are loaded (either in a particular intepreter, or + * for all interpreters). + * + * Results: + * The return value is a standard Tcl completion code. If + * successful, a list of lists is placed in interp->result. + * Each sublist corresponds to one loaded file; its first + * element is the name of the file (or an empty string for + * something that's statically loaded) and the second element + * is the name of the package in that file. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclGetLoadedPackages(interp, targetName) + Tcl_Interp *interp; /* Interpreter in which to return + * information or error message. */ + char *targetName; /* Name of target interpreter or NULL. + * If NULL, return info about all interps; + * otherwise, just return info about this + * interpreter. */ +{ + Tcl_Interp *target; + LoadedPackage *pkgPtr; + InterpPackage *ipPtr; + char *prefix; + + if (targetName == NULL) { + /* + * Return information about all of the available packages. + */ + + prefix = "{"; + for (pkgPtr = firstPackagePtr; pkgPtr != NULL; + pkgPtr = pkgPtr->nextPtr) { + Tcl_AppendResult(interp, prefix, (char *) NULL); + Tcl_AppendElement(interp, pkgPtr->fileName); + Tcl_AppendElement(interp, pkgPtr->packageName); + Tcl_AppendResult(interp, "}", (char *) NULL); + prefix = " {"; + } + return TCL_OK; + } + + /* + * Return information about only the packages that are loaded in + * a given interpreter. + */ + + target = Tcl_GetSlave(interp, targetName); + if (target == NULL) { + Tcl_AppendResult(interp, "couldn't find slave interpreter named \"", + targetName, "\"", (char *) NULL); + return TCL_ERROR; + } + ipPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad", + (Tcl_InterpDeleteProc **) NULL); + prefix = "{"; + for ( ; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { + pkgPtr = ipPtr->pkgPtr; + Tcl_AppendResult(interp, prefix, (char *) NULL); + Tcl_AppendElement(interp, pkgPtr->fileName); + Tcl_AppendElement(interp, pkgPtr->packageName); + Tcl_AppendResult(interp, "}", (char *) NULL); + prefix = " {"; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * LoadCleanupProc -- + * + * This procedure is called to delete all of the InterpPackage + * structures for an interpreter when the interpreter is deleted. + * It gets invoked via the Tcl AssocData mechanism. + * + * Results: + * None. + * + * Side effects: + * Storage for all of the InterpPackage procedures for interp + * get deleted. + * + *---------------------------------------------------------------------- + */ + +static void +LoadCleanupProc(clientData, interp) + ClientData clientData; /* Pointer to first InterpPackage structure + * for interp. */ + Tcl_Interp *interp; /* Interpreter that is being deleted. */ +{ + InterpPackage *ipPtr, *nextPtr; + + ipPtr = (InterpPackage *) clientData; + while (ipPtr != NULL) { + nextPtr = ipPtr->nextPtr; + ckfree((char *) ipPtr); + ipPtr = nextPtr; + } +} + +/* + *---------------------------------------------------------------------- + * + * LoadExitProc -- + * + * This procedure is invoked just before the application exits. + * It frees all of the LoadedPackage structures. + * + * Results: + * None. + * + * Side effects: + * Memory is freed. + * + *---------------------------------------------------------------------- + */ + +static void +LoadExitProc(clientData) + ClientData clientData; /* Not used. */ +{ + LoadedPackage *pkgPtr; + + while (firstPackagePtr != NULL) { + pkgPtr = firstPackagePtr; + firstPackagePtr = pkgPtr->nextPtr; + ckfree(pkgPtr->fileName); + ckfree(pkgPtr->packageName); + ckfree((char *) pkgPtr); + } +} diff --git a/tcl7.6/generic/tclLoadNone.c b/tcl7.6/generic/tclLoadNone.c new file mode 100644 index 0000000..87b56e0 --- /dev/null +++ b/tcl7.6/generic/tclLoadNone.c @@ -0,0 +1,81 @@ +/* + * tclLoadNone.c -- + * + * This procedure provides a version of the TclLoadFile for use + * in systems that don't support dynamic loading; it just returns + * an error. + * + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclLoadNone.c 1.5 96/02/15 11:43:01 + */ + +#include "tclInt.h" + +/* + *---------------------------------------------------------------------- + * + * TclLoadFile -- + * + * This procedure is called to carry out dynamic loading of binary + * code; it is intended for use only on systems that don't support + * dynamic loading (it returns an error). + * + * Results: + * The result is TCL_ERROR, and an error message is left in + * interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *fileName; /* Name of the file containing the desired + * code. */ + char *sym1, *sym2; /* Names of two procedures to look up in + * the file's symbol table. */ + Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; + /* Where to return the addresses corresponding + * to sym1 and sym2. */ +{ + interp->result = + "dynamic loading is not currently available on this system"; + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * TclGuessPackageName -- + * + * If the "load" command is invoked without providing a package + * name, this procedure is invoked to try to figure it out. + * + * Results: + * Always returns 0 to indicate that we couldn't figure out a + * package name; generic code will then try to guess the package + * from the file name. A return value of 1 would have meant that + * we figured out the package name and put it in bufPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclGuessPackageName(fileName, bufPtr) + char *fileName; /* Name of file containing package (already + * translated to local form if needed). */ + Tcl_DString *bufPtr; /* Initialized empty dstring. Append + * package name to this if possible. */ +{ + return 0; +} diff --git a/tcl7.3/tclMain.c b/tcl7.6/generic/tclMain.c similarity index 56% rename from tcl7.3/tclMain.c rename to tcl7.6/generic/tclMain.c index f080dcd..b3f2702 100644 --- a/tcl7.3/tclMain.c +++ b/tcl7.6/generic/tclMain.c @@ -1,56 +1,45 @@ /* - * main.c -- + * tclMain.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. + * Copyright (c) 1988-1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tclMain.c 1.51 96/09/05 17:57:01 */ -#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 "tcl.h" +#include "tclInt.h" -#include -#include -#include +/* + * The following code ensures that tclLink.c is linked whenever + * Tcl is linked. Without this code there's no reference to the + * code in that file from anywhere in Tcl, so it may not be + * linked into the application. + */ + +EXTERN int Tcl_LinkVar(); +int (*tclDummyLinkVarPtr)() = Tcl_LinkVar; /* * Declarations for various library procedures and variables (don't want - * to include tclUnix.h here, because people might copy this file out of + * to include tclPort.h here, because people might copy this file out of * the Tcl source directory to make their own modified versions). + * Note: "exit" should really be declared here, but there's no way to + * declare it without causing conflicts with other definitions elsewher + * on some systems, so it's better just to leave it out. */ -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. */ @@ -63,35 +52,45 @@ static int quitFlag = 0; /* 1 means the "checkmem" command was * Forward references for procedures defined later in this file: */ +#ifdef TCL_MEM_DEBUG static int CheckmemCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char *argv[])); +#endif /* *---------------------------------------------------------------------- * - * main -- + * Tcl_Main -- * - * This is the main program for a Tcl-based shell that reads - * Tcl commands from standard input. + * Main program for tclsh and most other Tcl-based applications. * * Results: - * None. + * None. This procedure never returns (it exits the process when + * it's done. * * Side effects: - * Can be almost arbitrary, depending on what the Tcl commands do. + * This procedure initializes the Tk world and then starts + * interpreting commands; almost anything could happen, depending + * on the script being interpreted. * *---------------------------------------------------------------------- */ -int -main(argc, argv) +void +Tcl_Main(argc, argv, appInitProc) int argc; /* Number of arguments. */ char **argv; /* Array of argument strings. */ + Tcl_AppInitProc *appInitProc; /* Application-specific initialization + * procedure to call after most + * initialization but before starting + * to execute commands. */ { char buffer[1000], *cmd, *args, *fileName; - int code, gotPartial, tty; + int code, gotPartial, tty, length; int exitCode = 0; + Tcl_Channel inChannel, outChannel, errChannel; + Tcl_FindExecutable(argv[0]); interp = Tcl_CreateInterp(); #ifdef TCL_MEM_DEBUG Tcl_InitMemory(interp); @@ -126,13 +125,19 @@ main(argc, argv) 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 ((*appInitProc)(interp) != TCL_OK) { + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel) { + Tcl_Write(errChannel, + "application-specific initialization failed: ", -1); + Tcl_Write(errChannel, interp->result, -1); + Tcl_Write(errChannel, "\n", 1); + } } /* @@ -143,7 +148,18 @@ main(argc, argv) if (fileName != NULL) { code = Tcl_EvalFile(interp, fileName); if (code != TCL_OK) { - fprintf(stderr, "%s\n", interp->result); + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel) { + /* + * The following statement guarantees that the errorInfo + * variable is set properly. + */ + + Tcl_AddErrorInfo(interp, ""); + Tcl_Write(errChannel, + Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY), -1); + Tcl_Write(errChannel, "\n", 1); + } exitCode = 1; } goto done; @@ -151,95 +167,95 @@ main(argc, argv) /* * We're running interactively. Source a user-specific startup - * file if Tcl_AppInit specified one and if the file exists. + * file if the application 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); - } + Tcl_SourceRCFile(interp); /* - * Process commands from stdin until there's an end-of-file. + * Process commands from stdin until there's an end-of-file. Note + * that we need to fetch the standard channels again after every + * eval, since they may have been changed. */ gotPartial = 0; Tcl_DStringInit(&command); + inChannel = Tcl_GetStdChannel(TCL_STDIN); + outChannel = Tcl_GetStdChannel(TCL_STDOUT); 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); +defaultPrompt: + if (!gotPartial && outChannel) { + Tcl_Write(outChannel, "% ", 2); } } else { code = Tcl_Eval(interp, promptCmd); + inChannel = Tcl_GetStdChannel(TCL_STDIN); + outChannel = Tcl_GetStdChannel(TCL_STDOUT); + errChannel = Tcl_GetStdChannel(TCL_STDERR); if (code != TCL_OK) { - fprintf(stderr, "%s\n", interp->result); + if (errChannel) { + Tcl_Write(errChannel, interp->result, -1); + Tcl_Write(errChannel, "\n", 1); + } 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; - } + if (outChannel) { + Tcl_Flush(outChannel); } - buffer[0] = 0; } - cmd = Tcl_DStringAppend(&command, buffer, -1); - if ((buffer[0] != 0) && !Tcl_CommandComplete(cmd)) { + if (!inChannel) { + goto done; + } + length = Tcl_Gets(inChannel, &command); + if (length < 0) { + goto done; + } + if ((length == 0) && Tcl_Eof(inChannel) && (!gotPartial)) { + goto done; + } + + /* + * Add the newline removed by Tcl_Gets back to the string. + */ + + (void) Tcl_DStringAppend(&command, "\n", -1); + + cmd = Tcl_DStringValue(&command); + if (!Tcl_CommandComplete(cmd)) { gotPartial = 1; continue; } gotPartial = 0; code = Tcl_RecordAndEval(interp, cmd, 0); + inChannel = Tcl_GetStdChannel(TCL_STDIN); + outChannel = Tcl_GetStdChannel(TCL_STDOUT); + errChannel = Tcl_GetStdChannel(TCL_STDERR); Tcl_DStringFree(&command); if (code != TCL_OK) { - fprintf(stderr, "%s\n", interp->result); + if (errChannel) { + Tcl_Write(errChannel, interp->result, -1); + Tcl_Write(errChannel, "\n", 1); + } } else if (tty && (*interp->result != 0)) { - printf("%s\n", interp->result); + if (outChannel) { + Tcl_Write(outChannel, interp->result, -1); + Tcl_Write(outChannel, "\n", 1); + } } #ifdef TCL_MEM_DEBUG if (quitFlag) { Tcl_DeleteInterp(interp); - Tcl_DumpActiveMemory(dumpFile); - exit(0); + Tcl_Exit(0); } #endif } @@ -250,10 +266,9 @@ main(argc, argv) * cleanup on exit. The Tcl_Eval call should never return. */ - done: +done: sprintf(buffer, "exit %d", exitCode); Tcl_Eval(interp, buffer); - return 1; } /* @@ -284,12 +299,14 @@ CheckmemCmd(clientData, interp, argc, argv) int argc; /* Number of arguments. */ char *argv[]; /* String values of arguments. */ { + extern char *tclMemDumpFileName; if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " fileName\"", (char *) NULL); return TCL_ERROR; } strcpy(dumpFile, argv[1]); + tclMemDumpFileName = dumpFile; quitFlag = 1; return TCL_OK; } diff --git a/tcl7.6/generic/tclNotify.c b/tcl7.6/generic/tclNotify.c new file mode 100644 index 0000000..8094764 --- /dev/null +++ b/tcl7.6/generic/tclNotify.c @@ -0,0 +1,581 @@ +/* + * tclNotify.c -- + * + * This file provides the parts of the Tcl event notifier that are + * the same on all platforms, plus a few other parts that are used + * on more than one platform but not all. + * + * The notifier is the lowest-level part of the event system. It + * manages an event queue that holds Tcl_Event structures and a list + * of event sources that can add events to the queue. It also + * contains the procedure Tcl_DoOneEvent that invokes the event + * sources and blocks to wait for new events, but Tcl_DoOneEvent + * is in the platform-specific part of the notifier (in files like + * tclUnixNotify.c). + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclNotify.c 1.7 96/09/19 16:40:16 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * The following variable records the address of the first event + * source in the list of all event sources for the application. + * This variable is accessed by the notifier to traverse the list + * and invoke each event source. + */ + +TclEventSource *tclFirstEventSourcePtr = NULL; + +/* + * The following variables indicate how long to block in the event + * notifier the next time it blocks (default: block forever). + */ + +static int blockTimeSet = 0; /* 0 means there is no maximum block + * time: block forever. */ +static Tcl_Time blockTime; /* If blockTimeSet is 1, gives the + * maximum elapsed time for the next block. */ + +/* + * The following variables keep track of the event queue. In addition + * to the first (next to be serviced) and last events in the queue, + * we keep track of a "marker" event. This provides a simple priority + * mechanism whereby events can be inserted at the front of the queue + * but behind all other high-priority events already in the queue (this + * is used for things like a sequence of Enter and Leave events generated + * during a grab in Tk). + */ + +static Tcl_Event *firstEventPtr = NULL; + /* First pending event, or NULL if none. */ +static Tcl_Event *lastEventPtr = NULL; + /* Last pending event, or NULL if none. */ +static Tcl_Event *markerEventPtr = NULL; + /* Last high-priority event in queue, or + * NULL if none. */ + +/* + * Prototypes for procedures used only in this file: + */ + +static int ServiceEvent _ANSI_ARGS_((int flags)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateEventSource -- + * + * This procedure is invoked to create a new source of events. + * The source is identified by a procedure that gets invoked + * during Tcl_DoOneEvent to check for events on that source + * and queue them. + * + * + * Results: + * None. + * + * Side effects: + * SetupProc and checkProc will be invoked each time that Tcl_DoOneEvent + * runs out of things to do. SetupProc will be invoked before + * Tcl_DoOneEvent calls select or whatever else it uses to wait + * for events. SetupProc typically calls functions like Tcl_WatchFile + * or Tcl_SetMaxBlockTime to indicate what to wait for. + * + * CheckProc is called after select or whatever operation was actually + * used to wait. It figures out whether anything interesting actually + * happened (e.g. by calling Tcl_FileReady), and then calls + * Tcl_QueueEvent to queue any events that are ready. + * + * Each of these procedures is passed two arguments, e.g. + * (*checkProc)(ClientData clientData, int flags)); + * ClientData is the same as the clientData argument here, and flags + * is a combination of things like TCL_FILE_EVENTS that indicates + * what events are of interest: setupProc and checkProc use flags + * to figure out whether their events are relevant or not. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_CreateEventSource(setupProc, checkProc, clientData) + Tcl_EventSetupProc *setupProc; /* Procedure to invoke to figure out + * what to wait for. */ + Tcl_EventCheckProc *checkProc; /* Procedure to call after waiting + * to see what happened. */ + ClientData clientData; /* One-word argument to pass to + * setupProc and checkProc. */ +{ + TclEventSource *sourcePtr; + + sourcePtr = (TclEventSource *) ckalloc(sizeof(TclEventSource)); + sourcePtr->setupProc = setupProc; + sourcePtr->checkProc = checkProc; + sourcePtr->clientData = clientData; + sourcePtr->nextPtr = tclFirstEventSourcePtr; + tclFirstEventSourcePtr = sourcePtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteEventSource -- + * + * This procedure is invoked to delete the source of events + * given by proc and clientData. + * + * Results: + * None. + * + * Side effects: + * The given event source is cancelled, so its procedure will + * never again be called. If no such source exists, nothing + * happens. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteEventSource(setupProc, checkProc, clientData) + Tcl_EventSetupProc *setupProc; /* Procedure to invoke to figure out + * what to wait for. */ + Tcl_EventCheckProc *checkProc; /* Procedure to call after waiting + * to see what happened. */ + ClientData clientData; /* One-word argument to pass to + * setupProc and checkProc. */ +{ + TclEventSource *sourcePtr, *prevPtr; + + for (sourcePtr = tclFirstEventSourcePtr, prevPtr = NULL; + sourcePtr != NULL; + prevPtr = sourcePtr, sourcePtr = sourcePtr->nextPtr) { + if ((sourcePtr->setupProc != setupProc) + || (sourcePtr->checkProc != checkProc) + || (sourcePtr->clientData != clientData)) { + continue; + } + if (prevPtr == NULL) { + tclFirstEventSourcePtr = sourcePtr->nextPtr; + } else { + prevPtr->nextPtr = sourcePtr->nextPtr; + } + ckfree((char *) sourcePtr); + return; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_QueueEvent -- + * + * Insert an event into the Tk event queue at one of three + * positions: the head, the tail, or before a floating marker. + * Events inserted before the marker will be processed in + * first-in-first-out order, but before any events inserted at + * the tail of the queue. Events inserted at the head of the + * queue will be processed in last-in-first-out order. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_QueueEvent(evPtr, position) + Tcl_Event* evPtr; /* Event to add to queue. The storage + * space must have been allocated the caller + * with malloc (ckalloc), and it becomes + * the property of the event queue. It + * will be freed after the event has been + * handled. */ + Tcl_QueuePosition position; /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, + * TCL_QUEUE_MARK. */ +{ + if (position == TCL_QUEUE_TAIL) { + /* + * Append the event on the end of the queue. + */ + + evPtr->nextPtr = NULL; + if (firstEventPtr == NULL) { + firstEventPtr = evPtr; + } else { + lastEventPtr->nextPtr = evPtr; + } + lastEventPtr = evPtr; + } else if (position == TCL_QUEUE_HEAD) { + /* + * Push the event on the head of the queue. + */ + + evPtr->nextPtr = firstEventPtr; + if (firstEventPtr == NULL) { + lastEventPtr = evPtr; + } + firstEventPtr = evPtr; + } else if (position == TCL_QUEUE_MARK) { + /* + * Insert the event after the current marker event and advance + * the marker to the new event. + */ + + if (markerEventPtr == NULL) { + evPtr->nextPtr = firstEventPtr; + firstEventPtr = evPtr; + } else { + evPtr->nextPtr = markerEventPtr->nextPtr; + markerEventPtr->nextPtr = evPtr; + } + markerEventPtr = evPtr; + if (evPtr->nextPtr == NULL) { + lastEventPtr = evPtr; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteEvents -- + * + * Calls a procedure for each event in the queue and deletes those + * for which the procedure returns 1. Events for which the + * procedure returns 0 are left in the queue. + * + * Results: + * None. + * + * Side effects: + * Potentially removes one or more events from the event queue. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteEvents(proc, clientData) + Tcl_EventDeleteProc *proc; /* The procedure to call. */ + ClientData clientData; /* type-specific data. */ +{ + Tcl_Event *evPtr, *prevPtr, *hold; + + for (prevPtr = (Tcl_Event *) NULL, evPtr = firstEventPtr; + evPtr != (Tcl_Event *) NULL; + ) { + if ((*proc) (evPtr, clientData) == 1) { + if (firstEventPtr == evPtr) { + firstEventPtr = evPtr->nextPtr; + if (evPtr->nextPtr == (Tcl_Event *) NULL) { + lastEventPtr = (Tcl_Event *) NULL; + } + } else { + prevPtr->nextPtr = evPtr->nextPtr; + } + hold = evPtr; + evPtr = evPtr->nextPtr; + ckfree((char *) hold); + } else { + prevPtr = evPtr; + evPtr = evPtr->nextPtr; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * ServiceEvent -- + * + * Process one event from the event queue. This routine is called + * by the notifier whenever it wants Tk to process an event. + * + * Results: + * The return value is 1 if the procedure actually found an event + * to process. If no processing occurred, then 0 is returned. + * + * Side effects: + * Invokes all of the event handlers for the highest priority + * event in the event queue. May collapse some events into a + * single event or discard stale events. + * + *---------------------------------------------------------------------- + */ + +static int +ServiceEvent(flags) + int flags; /* Indicates what events should be processed. + * May be any combination of TCL_WINDOW_EVENTS + * TCL_FILE_EVENTS, TCL_TIMER_EVENTS, or other + * flags defined elsewhere. Events not + * matching this will be skipped for processing + * later. */ +{ + Tcl_Event *evPtr, *prevPtr; + Tcl_EventProc *proc; + + /* + * No event flags is equivalent to TCL_ALL_EVENTS. + */ + + if ((flags & TCL_ALL_EVENTS) == 0) { + flags |= TCL_ALL_EVENTS; + } + + /* + * Loop through all the events in the queue until we find one + * that can actually be handled. + */ + + for (evPtr = firstEventPtr; evPtr != NULL; evPtr = evPtr->nextPtr) { + /* + * Call the handler for the event. If it actually handles the + * event then free the storage for the event. There are two + * tricky things here, but stemming from the fact that the event + * code may be re-entered while servicing the event: + * + * 1. Set the "proc" field to NULL. This is a signal to ourselves + * that we shouldn't reexecute the handler if the event loop + * is re-entered. + * 2. When freeing the event, must search the queue again from the + * front to find it. This is because the event queue could + * change almost arbitrarily while handling the event, so we + * can't depend on pointers found now still being valid when + * the handler returns. + */ + + proc = evPtr->proc; + evPtr->proc = NULL; + if ((proc != NULL) && (*proc)(evPtr, flags)) { + if (firstEventPtr == evPtr) { + firstEventPtr = evPtr->nextPtr; + if (evPtr->nextPtr == NULL) { + lastEventPtr = NULL; + } + if (markerEventPtr == evPtr) { + markerEventPtr = NULL; + } + } else { + for (prevPtr = firstEventPtr; prevPtr->nextPtr != evPtr; + prevPtr = prevPtr->nextPtr) { + /* Empty loop body. */ + } + prevPtr->nextPtr = evPtr->nextPtr; + if (evPtr->nextPtr == NULL) { + lastEventPtr = prevPtr; + } + if (markerEventPtr == evPtr) { + markerEventPtr = prevPtr; + } + } + ckfree((char *) evPtr); + return 1; + } else { + /* + * The event wasn't actually handled, so we have to restore + * the proc field to allow the event to be attempted again. + */ + + evPtr->proc = proc; + } + + /* + * The handler for this event asked to defer it. Just go on to + * the next event. + */ + + continue; + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetMaxBlockTime -- + * + * This procedure is invoked by event sources to tell the notifier + * how long it may block the next time it blocks. The timePtr + * argument gives a maximum time; the actual time may be less if + * some other event source requested a smaller time. + * + * Results: + * None. + * + * Side effects: + * May reduce the length of the next sleep in the notifier. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetMaxBlockTime(timePtr) + Tcl_Time *timePtr; /* Specifies a maximum elapsed time for + * the next blocking operation in the + * event notifier. */ +{ + if (!blockTimeSet || (timePtr->sec < blockTime.sec) + || ((timePtr->sec == blockTime.sec) + && (timePtr->usec < blockTime.usec))) { + blockTime = *timePtr; + blockTimeSet = 1; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DoOneEvent -- + * + * Process a single event of some sort. If there's no work to + * do, wait for an event to occur, then process it. + * + * Results: + * The return value is 1 if the procedure actually found an event + * to process. If no processing occurred, then 0 is returned (this + * can happen if the TCL_DONT_WAIT flag is set or if there are no + * event handlers to wait for in the set specified by flags). + * + * Side effects: + * May delay execution of process while waiting for an event, + * unless TCL_DONT_WAIT is set in the flags argument. Event + * sources are invoked to check for and queue events. Event + * handlers may produce arbitrary side effects. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_DoOneEvent(flags) + int flags; /* Miscellaneous flag values: may be any + * combination of TCL_DONT_WAIT, + * TCL_WINDOW_EVENTS, TCL_FILE_EVENTS, + * TCL_TIMER_EVENTS, TCL_IDLE_EVENTS, or + * others defined by event sources. */ +{ + TclEventSource *sourcePtr; + Tcl_Time *timePtr; + + /* + * No event flags is equivalent to TCL_ALL_EVENTS. + */ + + if ((flags & TCL_ALL_EVENTS) == 0) { + flags |= TCL_ALL_EVENTS; + } + + /* + * The core of this procedure is an infinite loop, even though + * we only service one event. The reason for this is that we + * might think we have an event ready (e.g. the connection to + * the server becomes readable), but then we might discover that + * there's nothing interesting on that connection, so no event + * was serviced. Or, the select operation could return prematurely + * due to a signal. The easiest thing in both these cases is + * just to loop back and try again. + */ + + while (1) { + + /* + * The first thing we do is to service any asynchronous event + * handlers. + */ + + if (Tcl_AsyncReady()) { + (void) Tcl_AsyncInvoke((Tcl_Interp *) NULL, 0); + return 1; + } + + /* + * If idle events are the only things to service, skip the + * main part of the loop and go directly to handle idle + * events (i.e. don't wait even if TCL_DONT_WAIT isn't set. + */ + + if (flags == TCL_IDLE_EVENTS) { + flags = TCL_IDLE_EVENTS|TCL_DONT_WAIT; + goto idleEvents; + } + + /* + * Ask Tk to service a queued event, if there are any. + */ + + if (ServiceEvent(flags)) { + return 1; + } + + /* + * There are no events already queued. Invoke all of the + * event sources to give them a chance to setup for the wait. + */ + + blockTimeSet = 0; + for (sourcePtr = tclFirstEventSourcePtr; sourcePtr != NULL; + sourcePtr = sourcePtr->nextPtr) { + (*sourcePtr->setupProc)(sourcePtr->clientData, flags); + } + if ((flags & TCL_DONT_WAIT) || + ((flags & TCL_IDLE_EVENTS) && TclIdlePending())) { + /* + * Don't block: there are idle events waiting, or we don't + * care about idle events anyway, or the caller asked us not + * to block. + */ + + blockTime.sec = 0; + blockTime.usec = 0; + timePtr = &blockTime; + } else if (blockTimeSet) { + timePtr = &blockTime; + } else { + timePtr = NULL; + } + + /* + * Wait until an event occurs or the timer expires. + */ + + if (Tcl_WaitForEvent(timePtr) == TCL_ERROR) { + return 0; + } + + /* + * Give each of the event sources a chance to queue events, + * then call ServiceEvent and give it another chance to + * service events. + */ + + for (sourcePtr = tclFirstEventSourcePtr; sourcePtr != NULL; + sourcePtr = sourcePtr->nextPtr) { + (*sourcePtr->checkProc)(sourcePtr->clientData, flags); + } + if (ServiceEvent(flags)) { + return 1; + } + + /* + * We've tried everything at this point, but nobody had anything + * to do. Check for idle events. If none, either quit or go back + * to the top and try again. + */ + + idleEvents: + if ((flags & TCL_IDLE_EVENTS) && TclServiceIdle()) { + return 1; + } + if (flags & TCL_DONT_WAIT) { + return 0; + } + } +} diff --git a/tcl7.3/tclParse.c b/tcl7.6/generic/tclParse.c similarity index 83% rename from tcl7.3/tclParse.c rename to tcl7.6/generic/tclParse.c index 510cbc0..84dedcd 100644 --- a/tcl7.3/tclParse.c +++ b/tcl7.6/generic/tclParse.c @@ -6,40 +6,33 @@ * strings or nested sub-commands). * * Copyright (c) 1987-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tclParse.c 1.51 96/09/06 09:47:29 */ -#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" +#include "tclPort.h" /* * 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. + * meaningful to Tcl parsing are represented here. The table is + * designed to be referenced with either signed or unsigned characters, + * so it has 384 entries. The first 128 entries correspond to negative + * character values, the next 256 correspond to positive character + * values. The last 128 entries are identical to the first 128. The + * table is always indexed with a 128-byte offset (the 128th entry + * corresponds to a 0 character value). */ char tclTypeTable[] = { + /* + * Negative character values, from -128 to -1: + */ + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, @@ -72,6 +65,11 @@ 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, + + /* + * Positive character values, from 0-127: + */ + 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, @@ -104,6 +102,43 @@ char tclTypeTable[] = { 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, + + /* + * Large unsigned character values, from 128-255: + */ + + 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, }; /* @@ -111,6 +146,7 @@ char tclTypeTable[] = { */ static char * QuoteEnd _ANSI_ARGS_((char *string, int term)); +static char * ScriptEnd _ANSI_ARGS_((char *p, int nested)); static char * VarNameEnd _ANSI_ARGS_((char *string)); /* @@ -146,32 +182,40 @@ Tcl_Backslash(src, readPtr) count = 2; switch (*p) { + /* + * Note: in the conversions below, use absolute values (e.g., + * 0xa) rather than symbolic values (e.g. \n) that get converted + * by the compiler. It's possible that compilers on some + * platforms will do the symbolic conversions differently, which + * could result in non-portable Tcl scripts. + */ + case 'a': - result = 0x7; /* Don't say '\a' here, since some compilers */ - break; /* don't support it. */ + result = 0x7; + break; case 'b': - result = '\b'; + result = 0x8; break; case 'f': - result = '\f'; + result = 0xc; break; case 'n': - result = '\n'; + result = 0xa; break; case 'r': - result = '\r'; + result = 0xd; break; case 't': - result = '\t'; + result = 0x9; break; case 'v': - result = '\v'; + result = 0xb; break; case 'x': if (isxdigit(UCHAR(p[1]))) { char *end; - result = strtoul(p+1, &end, 16); + result = (char) strtoul(p+1, &end, 16); count = end - src; } else { count = 2; @@ -181,7 +225,7 @@ Tcl_Backslash(src, readPtr) case '\n': do { p++; - } while (isspace(UCHAR(*p))); + } while ((*p == ' ') || (*p == '\t')); result = ' '; count = p - src; break; @@ -191,19 +235,19 @@ Tcl_Backslash(src, readPtr) break; default: if (isdigit(UCHAR(*p))) { - result = *p - '0'; + result = (char)(*p - '0'); p++; if (!isdigit(UCHAR(*p))) { break; } count = 3; - result = (result << 3) + (*p - '0'); + result = (char)((result << 3) + (*p - '0')); p++; if (!isdigit(UCHAR(*p))) { break; } count = 4; - result = (result << 3) + (*p - '0'); + result = (char)((result << 3) + (*p - '0')); break; } result = *p; @@ -739,28 +783,33 @@ TclParseWords(interp, string, flags, maxWords, termPtr, argcPtr, argv, pvPtr) /* * 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). + * character was the end of the word. */ 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); + /* + * Line is continued on next line; the backslash-newline + * sequence turns into space, which is OK. No need to do + * anything here. + */ + } else { + 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; } - return TCL_ERROR; } src = *termPtr; dst = pvPtr->next; - } /* @@ -841,7 +890,8 @@ TclExpandParseValue(pvPtr, needed) * mark new buffer as malloc-ed. */ - memcpy((VOID *) new, (VOID *) pvPtr->buffer, pvPtr->next - pvPtr->buffer); + memcpy((VOID *) new, (VOID *) pvPtr->buffer, + (size_t) (pvPtr->next - pvPtr->buffer)); pvPtr->next = new + (pvPtr->next - pvPtr->buffer); if (pvPtr->clientData != 0) { ckfree(pvPtr->buffer); @@ -876,7 +926,7 @@ 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). */ + * bracket is a word terminator). */ int *semiPtr; /* Set to 1 if word ends with a command- * terminating semi-colon, zero otherwise. * If NULL then ignored. */ @@ -946,19 +996,23 @@ TclWordEnd(start, nested, semiPtr) while (1) { if (*p == '[') { - for (p++; *p != ']'; p++) { - p = TclWordEnd(p, 1, (int *) NULL); - if (*p == 0) { - return p; - } + p = ScriptEnd(p+1, 1); + if (*p == 0) { + return p; } p++; } else if (*p == '\\') { + if (p[1] == '\n') { + /* + * Backslash-newline: it maps to a space character + * that is a word separator, so the word ends just before + * the backslash. + */ + + return p-1; + } (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) { @@ -1093,6 +1147,81 @@ VarNameEnd(string) } return p-1; } + + +/* + *---------------------------------------------------------------------- + * + * ScriptEnd -- + * + * Given a pointer to the beginning of a Tcl script, find the end of + * the script. + * + * Results: + * The return value is a pointer to the last character that's part + * of the script pointed to by "p". If the command 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. + * + *---------------------------------------------------------------------- + */ + +static char * +ScriptEnd(p, nested) + char *p; /* Script to check. */ + int nested; /* Zero means this is a top-level command. + * One means this is a nested command (the + * last character of the script must be + * an unquoted ]). */ +{ + int commentOK = 1; + int length; + + while (1) { + while (isspace(UCHAR(*p))) { + if (*p == '\n') { + commentOK = 1; + } + p++; + } + if ((*p == '#') && commentOK) { + do { + if (*p == '\\') { + /* + * If the script ends with backslash-newline, then + * this command isn't complete. + */ + + if ((p[1] == '\n') && (p[2] == 0)) { + return p+2; + } + Tcl_Backslash(p, &length); + p += length; + } else { + p++; + } + } while ((*p != 0) && (*p != '\n')); + continue; + } + p = TclWordEnd(p, nested, &commentOK); + if (*p == 0) { + return p; + } + p++; + if (nested) { + if (*p == ']') { + return p; + } + } else { + if (*p == 0) { + return p-1; + } + } + } +} /* *---------------------------------------------------------------------- @@ -1192,9 +1321,15 @@ Tcl_ParseVar(interp, string, termPtr) pv.clientData = (ClientData) NULL; if (TclParseQuotes(interp, string+1, ')', 0, &end, &pv) != TCL_OK) { - char msg[100]; + char msg[200]; + int length; + + length = string-name1; + if (length > 100) { + length = 100; + } sprintf(msg, "\n (parsing index for array \"%.*s\")", - string-name1, name1); + length, name1); Tcl_AddErrorInfo(interp, msg); result = NULL; name2 = pv.buffer; @@ -1249,29 +1384,11 @@ int Tcl_CommandComplete(cmd) char *cmd; /* Command to check. */ { - register char *p = cmd; - int commentOK = 1; + char *p; - 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++; + if (*cmd == 0) { + return 1; } + p = ScriptEnd(cmd, 0); + return (*p != 0); } diff --git a/tcl7.6/generic/tclPatch.h b/tcl7.6/generic/tclPatch.h new file mode 100644 index 0000000..ec26abc --- /dev/null +++ b/tcl7.6/generic/tclPatch.h @@ -0,0 +1,23 @@ +/* + * tclPatch.h -- + * + * This file does nothing except define a "patch level" for Tcl. + * The patch level has the form "X.YpZ" where X.Y is the base + * release, and Z is a serial number that is used to sequence + * patches for a given release. Thus 7.4p1 is the first patch + * to release 7.4, 7.4p2 is the patch that follows 7.4p1, and + * so on. The "pZ" is omitted in an original new release, and + * it is replaced with "bZ" for beta releases or "aZ for alpha + * releases. The patch level ensures that patches are applied + * in the correct order and only to appropriate sources. + * + * Copyright (c) 1993-1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclPatch.h 1.23 96/10/02 14:36:15 + */ + +#define TCL_PATCH_LEVEL "7.6" diff --git a/tcl7.6/generic/tclPkg.c b/tcl7.6/generic/tclPkg.c new file mode 100644 index 0000000..004282e --- /dev/null +++ b/tcl7.6/generic/tclPkg.c @@ -0,0 +1,732 @@ +/* + * tclPkg.c -- + * + * This file implements package and version control for Tcl via + * the "package" command and a few C APIs. + * + * Copyright (c) 1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclPkg.c 1.7 96/10/12 17:06:01 + */ + +#include "tclInt.h" + +/* + * Each invocation of the "package ifneeded" command creates a structure + * of the following type, which is used to load the package into the + * interpreter if it is requested with a "package require" command. + */ + +typedef struct PkgAvail { + char *version; /* Version string; malloc'ed. */ + char *script; /* Script to invoke to provide this version + * of the package. Malloc'ed and protected + * by Tcl_Preserve and Tcl_Release. */ + struct PkgAvail *nextPtr; /* Next in list of available versions of + * the same package. */ +} PkgAvail; + +/* + * For each package that is known in any way to an interpreter, there + * is one record of the following type. These records are stored in + * the "packageTable" hash table in the interpreter, keyed by + * package name such as "Tk" (no version number). + */ + +typedef struct Package { + char *version; /* Version that has been supplied in this + * interpreter via "package provide" + * (malloc'ed). NULL means the package doesn't + * exist in this interpreter yet. */ + PkgAvail *availPtr; /* First in list of all available versions + * of this package. */ +} Package; + +/* + * Prototypes for procedures defined in this file: + */ + +static int CheckVersion _ANSI_ARGS_((Tcl_Interp *interp, + char *string)); +static int ComparePkgVersions _ANSI_ARGS_((char *v1, char *v2, + int *satPtr)); +static Package * FindPackage _ANSI_ARGS_((Tcl_Interp *interp, + char *name)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_PkgProvide -- + * + * This procedure is invoked to declare that a particular version + * of a particular package is now present in an interpreter. There + * must not be any other version of this package already + * provided in the interpreter. + * + * Results: + * Normally returns TCL_OK; if there is already another version + * of the package loaded then TCL_ERROR is returned and an error + * message is left in interp->result. + * + * Side effects: + * The interpreter remembers that this package is available, + * so that no other version of the package may be provided for + * the interpreter. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_PkgProvide(interp, name, version) + Tcl_Interp *interp; /* Interpreter in which package is now + * available. */ + char *name; /* Name of package. */ + char *version; /* Version string for package. */ +{ + Package *pkgPtr; + + pkgPtr = FindPackage(interp, name); + if (pkgPtr->version == NULL) { + pkgPtr->version = ckalloc((unsigned) (strlen(version) + 1)); + strcpy(pkgPtr->version, version); + return TCL_OK; + } + if (ComparePkgVersions(pkgPtr->version, version, (int *) NULL) == 0) { + return TCL_OK; + } + Tcl_AppendResult(interp, "conflicting versions provided for package \"", + name, "\": ", pkgPtr->version, ", then ", version, (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PkgRequire -- + * + * This procedure is called by code that depends on a particular + * version of a particular package. If the package is not already + * provided in the interpreter, this procedure invokes a Tcl script + * to provide it. If the package is already provided, this + * procedure makes sure that the caller's needs don't conflict with + * the version that is present. + * + * Results: + * If successful, returns the version string for the currently + * provided version of the package, which may be different from + * the "version" argument. If the caller's requirements + * cannot be met (e.g. the version requested conflicts with + * a currently provided version, or the required version cannot + * be found, or the script to provide the required version + * generates an error), NULL is returned and an error + * message is left in interp->result. + * + * Side effects: + * The script from some previous "package ifneeded" command may + * be invoked to provide the package. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_PkgRequire(interp, name, version, exact) + Tcl_Interp *interp; /* Interpreter in which package is now + * available. */ + char *name; /* Name of desired package. */ + char *version; /* Version string for desired version; + * NULL means use the latest version + * available. */ + int exact; /* Non-zero means that only the particular + * version given is acceptable. Zero means + * use the latest compatible version. */ +{ + Package *pkgPtr; + PkgAvail *availPtr, *bestPtr; + char *script; + int code, satisfies, result, pass; + Tcl_DString command; + + /* + * It can take up to three passes to find the package: one pass to + * run the "package unknown" script, one to run the "package ifneeded" + * script for a specific version, and a final pass to lookup the + * package loaded by the "package ifneeded" script. + */ + + for (pass = 1; ; pass++) { + pkgPtr = FindPackage(interp, name); + if (pkgPtr->version != NULL) { + break; + } + + /* + * The package isn't yet present. Search the list of available + * versions and invoke the script for the best available version. + */ + + bestPtr = NULL; + for (availPtr = pkgPtr->availPtr; availPtr != NULL; + availPtr = availPtr->nextPtr) { + if ((bestPtr != NULL) && (ComparePkgVersions(availPtr->version, + bestPtr->version, (int *) NULL) <= 0)) { + continue; + } + if (version != NULL) { + result = ComparePkgVersions(availPtr->version, version, + &satisfies); + if ((result != 0) && exact) { + continue; + } + if (!satisfies) { + continue; + } + } + bestPtr = availPtr; + } + if (bestPtr != NULL) { + /* + * We found an ifneeded script for the package. Be careful while + * executing it: this could cause reentrancy, so (a) protect the + * script itself from deletion and (b) don't assume that bestPtr + * will still exist when the script completes. + */ + + script = bestPtr->script; + Tcl_Preserve((ClientData) script); + code = Tcl_GlobalEval(interp, script); + Tcl_Release((ClientData) script); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + Tcl_AddErrorInfo(interp, + "\n (\"package ifneeded\" script)"); + } + return NULL; + } + Tcl_ResetResult(interp); + pkgPtr = FindPackage(interp, name); + break; + } + + /* + * Package not in the database. If there is a "package unknown" + * command, invoke it (but only on the first pass; after that, + * we should not get here in the first place). + */ + + if (pass > 1) { + break; + } + script = ((Interp *) interp)->packageUnknown; + if (script != NULL) { + Tcl_DStringInit(&command); + Tcl_DStringAppend(&command, script, -1); + Tcl_DStringAppendElement(&command, name); + Tcl_DStringAppend(&command, " ", 1); + Tcl_DStringAppend(&command, (version != NULL) ? version : "{}", + -1); + if (exact) { + Tcl_DStringAppend(&command, " -exact", 7); + } + code = Tcl_GlobalEval(interp, Tcl_DStringValue(&command)); + Tcl_DStringFree(&command); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + Tcl_AddErrorInfo(interp, + "\n (\"package unknown\" script)"); + } + return NULL; + } + Tcl_ResetResult(interp); + } + } + + if (pkgPtr->version == NULL) { + Tcl_AppendResult(interp, "can't find package ", name, + (char *) NULL); + if (version != NULL) { + Tcl_AppendResult(interp, " ", version, (char *) NULL); + } + return NULL; + } + + /* + * At this point we now that the package is present. Make sure that the + * provided version meets the current requirement. + */ + + if (version == NULL) { + return pkgPtr->version; + } + result = ComparePkgVersions(pkgPtr->version, version, &satisfies); + if ((satisfies && !exact) || (result == 0)) { + return pkgPtr->version; + } + Tcl_AppendResult(interp, "version conflict for package \"", + name, "\": have ", pkgPtr->version, ", need ", version, + (char *) NULL); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PackageCmd -- + * + * This procedure is invoked to process the "package" 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_PackageCmd(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; + size_t length; + int c, exact, i, satisfies; + PkgAvail *availPtr, *prevPtr; + Package *pkgPtr; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Tcl_HashTable *tablePtr; + char *version; + + 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 == 'f') && (strncmp(argv[1], "forget", length) == 0)) { + for (i = 2; i < argc; i++) { + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[i]); + if (hPtr == NULL) { + return TCL_OK; + } + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + Tcl_DeleteHashEntry(hPtr); + if (pkgPtr->version != NULL) { + ckfree(pkgPtr->version); + } + while (pkgPtr->availPtr != NULL) { + availPtr = pkgPtr->availPtr; + pkgPtr->availPtr = availPtr->nextPtr; + ckfree(availPtr->version); + Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); + ckfree((char *) availPtr); + } + ckfree((char *) pkgPtr); + } + } else if ((c == 'i') && (strncmp(argv[1], "ifneeded", length) == 0)) { + if ((argc != 4) && (argc != 5)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ifneeded package version ?script?\"", (char *) NULL); + return TCL_ERROR; + } + if (CheckVersion(interp, argv[3]) != TCL_OK) { + return TCL_ERROR; + } + if (argc == 4) { + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[2]); + if (hPtr == NULL) { + return TCL_OK; + } + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + } else { + pkgPtr = FindPackage(interp, argv[2]); + } + for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL; + prevPtr = availPtr, availPtr = availPtr->nextPtr) { + if (ComparePkgVersions(availPtr->version, argv[3], (int *) NULL) + == 0) { + if (argc == 4) { + interp->result = availPtr->script; + return TCL_OK; + } + Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); + break; + } + } + if (argc == 4) { + return TCL_OK; + } + if (availPtr == NULL) { + availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail)); + availPtr->version = ckalloc((unsigned) (strlen(argv[3]) + 1)); + strcpy(availPtr->version, argv[3]); + if (prevPtr == NULL) { + availPtr->nextPtr = pkgPtr->availPtr; + pkgPtr->availPtr = availPtr; + } else { + availPtr->nextPtr = prevPtr->nextPtr; + prevPtr->nextPtr = availPtr; + } + } + availPtr->script = ckalloc((unsigned) (strlen(argv[4]) + 1)); + strcpy(availPtr->script, argv[4]); + } else if ((c == 'n') && (strncmp(argv[1], "names", length) == 0)) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " names\"", (char *) NULL); + return TCL_ERROR; + } + tablePtr = &iPtr->packageTable; + for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) { + Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr)); + } + } + } else if ((c == 'p') && (strncmp(argv[1], "provide", length) == 0)) { + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " provide package ?version?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 3) { + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[2]); + if (hPtr != NULL) { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + if (pkgPtr->version != NULL) { + interp->result = pkgPtr->version; + } + } + return TCL_OK; + } + if (CheckVersion(interp, argv[3]) != TCL_OK) { + return TCL_ERROR; + } + return Tcl_PkgProvide(interp, argv[2], argv[3]); + } else if ((c == 'r') && (strncmp(argv[1], "require", length) == 0)) { + if (argc < 3) { + requireSyntax: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " require ?-exact? package ?version?\"", (char *) NULL); + return TCL_ERROR; + } + if ((argv[2][0] == '-') && (strcmp(argv[2], "-exact") == 0)) { + exact = 1; + } else { + exact = 0; + } + version = NULL; + if (argc == (4+exact)) { + version = argv[3+exact]; + if (CheckVersion(interp, version) != TCL_OK) { + return TCL_ERROR; + } + } else if ((argc != 3) || exact) { + goto requireSyntax; + } + version = Tcl_PkgRequire(interp, argv[2+exact], version, exact); + if (version == NULL) { + return TCL_ERROR; + } + interp->result = version; + } else if ((c == 'u') && (strncmp(argv[1], "unknown", length) == 0)) { + if (argc == 2) { + if (iPtr->packageUnknown != NULL) { + iPtr->result = iPtr->packageUnknown; + } + } else if (argc == 3) { + if (iPtr->packageUnknown != NULL) { + ckfree(iPtr->packageUnknown); + } + if (argv[2][0] == 0) { + iPtr->packageUnknown = NULL; + } else { + iPtr->packageUnknown = (char *) ckalloc((unsigned) + (strlen(argv[2]) + 1)); + strcpy(iPtr->packageUnknown, argv[2]); + } + } else { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " unknown ?command?\"", (char *) NULL); + return TCL_ERROR; + } + } else if ((c == 'v') && (strncmp(argv[1], "vcompare", length) == 0) + && (length >= 2)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " vcompare version1 version2\"", (char *) NULL); + return TCL_ERROR; + } + if ((CheckVersion(interp, argv[2]) != TCL_OK) + || (CheckVersion(interp, argv[3]) != TCL_OK)) { + return TCL_ERROR; + } + sprintf(interp->result, "%d", ComparePkgVersions(argv[2], argv[3], + (int *) NULL)); + } else if ((c == 'v') && (strncmp(argv[1], "versions", length) == 0) + && (length >= 2)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " versions package\"", (char *) NULL); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[2]); + if (hPtr != NULL) { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + for (availPtr = pkgPtr->availPtr; availPtr != NULL; + availPtr = availPtr->nextPtr) { + Tcl_AppendElement(interp, availPtr->version); + } + } + } else if ((c == 'v') && (strncmp(argv[1], "vsatisfies", length) == 0) + && (length >= 2)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " vsatisfies version1 version2\"", (char *) NULL); + return TCL_ERROR; + } + if ((CheckVersion(interp, argv[2]) != TCL_OK) + || (CheckVersion(interp, argv[3]) != TCL_OK)) { + return TCL_ERROR; + } + ComparePkgVersions(argv[2], argv[3], &satisfies); + sprintf(interp->result, "%d", satisfies); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be forget, ifneeded, names, ", + "provide, require, unknown, vcompare, ", + "versions, or vsatisfies", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FindPackage -- + * + * This procedure finds the Package record for a particular package + * in a particular interpreter, creating a record if one doesn't + * already exist. + * + * Results: + * The return value is a pointer to the Package record for the + * package. + * + * Side effects: + * A new Package record may be created. + * + *---------------------------------------------------------------------- + */ + +static Package * +FindPackage(interp, name) + Tcl_Interp *interp; /* Interpreter to use for package lookup. */ + char *name; /* Name of package to fine. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr; + int new; + Package *pkgPtr; + + hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &new); + if (new) { + pkgPtr = (Package *) ckalloc(sizeof(Package)); + pkgPtr->version = NULL; + pkgPtr->availPtr = NULL; + Tcl_SetHashValue(hPtr, pkgPtr); + } else { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + } + return pkgPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclFreePackageInfo -- + * + * This procedure is called during interpreter deletion to + * free all of the package-related information for the + * interpreter. + * + * Results: + * None. + * + * Side effects: + * Memory is freed. + * + *---------------------------------------------------------------------- + */ + +void +TclFreePackageInfo(iPtr) + Interp *iPtr; /* Interpereter that is being deleted. */ +{ + Package *pkgPtr; + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + PkgAvail *availPtr; + + for (hPtr = Tcl_FirstHashEntry(&iPtr->packageTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + if (pkgPtr->version != NULL) { + ckfree(pkgPtr->version); + } + while (pkgPtr->availPtr != NULL) { + availPtr = pkgPtr->availPtr; + pkgPtr->availPtr = availPtr->nextPtr; + ckfree(availPtr->version); + Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); + ckfree((char *) availPtr); + } + ckfree((char *) pkgPtr); + } + Tcl_DeleteHashTable(&iPtr->packageTable); + if (iPtr->packageUnknown != NULL) { + ckfree(iPtr->packageUnknown); + } +} + +/* + *---------------------------------------------------------------------- + * + * CheckVersion -- + * + * This procedure checks to see whether a version number has + * valid syntax. + * + * Results: + * If string is a properly formed version number the TCL_OK + * is returned. Otherwise TCL_ERROR is returned and an error + * message is left in interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +CheckVersion(interp, string) + Tcl_Interp *interp; /* Used for error reporting. */ + char *string; /* Supposedly a version number, which is + * groups of decimal digits separated + * by dots. */ +{ + char *p = string; + + if (!isdigit(UCHAR(*p))) { + goto error; + } + for (p++; *p != 0; p++) { + if (!isdigit(UCHAR(*p)) && (*p != '.')) { + goto error; + } + } + if (p[-1] != '.') { + return TCL_OK; + } + + error: + Tcl_AppendResult(interp, "expected version number but got \"", + string, "\"", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * ComparePkgVersions -- + * + * This procedure compares two version numbers. + * + * Results: + * The return value is -1 if v1 is less than v2, 0 if the two + * version numbers are the same, and 1 if v1 is greater than v2. + * If *satPtr is non-NULL, the word it points to is filled in + * with 1 if v2 >= v1 and both numbers have the same major number + * or 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ComparePkgVersions(v1, v2, satPtr) + char *v1, *v2; /* Versions strings, of form 2.1.3 (any + * number of version numbers). */ + int *satPtr; /* If non-null, the word pointed to is + * filled in with a 0/1 value. 1 means + * v1 "satisfies" v2: v1 is greater than + * or equal to v2 and both version numbers + * have the same major number. */ +{ + int thisIsMajor, n1, n2; + + /* + * Each iteration of the following loop processes one number from + * each string, terminated by a ".". If those numbers don't match + * then the comparison is over; otherwise, we loop back for the + * next number. + */ + + thisIsMajor = 1; + while (1) { + /* + * Parse one decimal number from the front of each string. + */ + + n1 = n2 = 0; + while ((*v1 != 0) && (*v1 != '.')) { + n1 = 10*n1 + (*v1 - '0'); + v1++; + } + while ((*v2 != 0) && (*v2 != '.')) { + n2 = 10*n2 + (*v2 - '0'); + v2++; + } + + /* + * Compare and go on to the next version number if the + * current numbers match. + */ + + if (n1 != n2) { + break; + } + if (*v1 != 0) { + v1++; + } else if (*v2 == 0) { + break; + } + if (*v2 != 0) { + v2++; + } + thisIsMajor = 0; + } + if (satPtr != NULL) { + *satPtr = (n1 == n2) || ((n1 > n2) && !thisIsMajor); + } + if (n1 > n2) { + return 1; + } else if (n1 == n2) { + return 0; + } else { + return -1; + } +} diff --git a/tcl7.6/generic/tclPort.h b/tcl7.6/generic/tclPort.h new file mode 100644 index 0000000..2aa27f5 --- /dev/null +++ b/tcl7.6/generic/tclPort.h @@ -0,0 +1,29 @@ +/* + * tclPort.h -- + * + * This header file handles porting issues that occur because + * of differences between systems. It reads in platform specific + * portability files. + * + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclPort.h 1.15 96/02/07 17:24:21 + */ + +#ifndef _TCLPORT +#define _TCLPORT + +#if defined(__WIN32__) || defined(_WIN32) +# include "../win/tclWinPort.h" +#else +# if defined(MAC_TCL) +# include "tclMacPort.h" +# else +# include "../unix/tclUnixPort.h" +# endif +#endif + +#endif /* _TCLPORT */ diff --git a/tcl7.3/tclUnixStr.c b/tcl7.6/generic/tclPosixStr.c similarity index 53% rename from tcl7.3/tclUnixStr.c rename to tcl7.6/generic/tclPosixStr.c index 454f30a..162021f 100644 --- a/tcl7.3/tclUnixStr.c +++ b/tcl7.6/generic/tclPosixStr.c @@ -1,37 +1,21 @@ /* - * tclUnixStr.c -- + * tclPosixStr.c -- * * This file contains procedures that generate strings - * corresponding to various UNIX-related codes, such + * corresponding to various POSIX-related codes, such * as errno and signals. * - * Copyright (c) 1991-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tclPosixStr.c 1.32 96/10/10 10:09:42 */ -#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" +#include "tclPort.h" /* *---------------------------------------------------------------------- @@ -79,7 +63,7 @@ Tcl_ErrnoId() #ifdef EALIGN case EALIGN: return "EALIGN"; #endif -#ifdef EALREADY +#if defined(EALREADY) && (!defined(EBUSY) || (EALREADY != EBUSY )) case EALREADY: return "EALREADY"; #endif #ifdef EBADE @@ -133,7 +117,7 @@ Tcl_ErrnoId() #if defined(EDEADLK) && (!defined(EWOULDBLOCK) || (EDEADLK != EWOULDBLOCK)) case EDEADLK: return "EDEADLK"; #endif -#ifdef EDEADLOCK +#if defined(EDEADLOCK) && (!defined(EDEADLK) || (EDEADLOCK != EDEADLK)) case EDEADLOCK: return "EDEADLOCK"; #endif #ifdef EDESTADDRREQ @@ -169,7 +153,7 @@ Tcl_ErrnoId() #ifdef EHOSTUNREACH case EHOSTUNREACH: return "EHOSTUNREACH"; #endif -#ifdef EIDRM +#if defined(EIDRM) && (!defined(EINPROGRESS) || (EIDRM != EINPROGRESS)) case EIDRM: return "EIDRM"; #endif #ifdef EINIT @@ -229,7 +213,7 @@ Tcl_ErrnoId() #ifdef ELNRNG case ELNRNG: return "ELNRNG"; #endif -#ifdef ELOOP +#if defined(ELOOP) && (!defined(ENOENT) || (ELOOP != ENOENT)) case ELOOP: return "ELOOP"; #endif #ifdef EMFILE @@ -274,7 +258,7 @@ Tcl_ErrnoId() #ifdef ENOCSI case ENOCSI: return "ENOCSI"; #endif -#ifdef ENODATA +#if defined(ENODATA) && (!defined(ECONNREFUSED) || (ENODATA != ECONNREFUSED)) case ENODATA: return "ENODATA"; #endif #ifdef ENODEV @@ -310,7 +294,7 @@ Tcl_ErrnoId() #ifdef ENOSPC case ENOSPC: return "ENOSPC"; #endif -#ifdef ENOSR +#if defined(ENOSR) && (!defined(ENAMETOOLONG) || (ENAMETOOLONG != ENOSR)) case ENOSR: return "ENOSR"; #endif #if defined(ENOSTR) && (!defined(ENOTTY) || (ENOTTY != ENOSTR)) @@ -340,6 +324,9 @@ Tcl_ErrnoId() #ifdef ENOTSOCK case ENOTSOCK: return "ENOTSOCK"; #endif +#ifdef ENOTSUP + case ENOTSUP: return "ENOTSUP"; +#endif #ifdef ENOTTY case ENOTTY: return "ENOTTY"; #endif @@ -355,7 +342,7 @@ Tcl_ErrnoId() #ifdef EPERM case EPERM: return "EPERM"; #endif -#ifdef EPFNOSUPPORT +#if defined(EPFNOSUPPORT) && (!defined(ENOLCK) || (ENOLCK != EPFNOSUPPORT)) case EPFNOSUPPORT: return "EPFNOSUPPORT"; #endif #ifdef EPIPE @@ -433,10 +420,10 @@ Tcl_ErrnoId() #ifdef ESUCCESS case ESUCCESS: return "ESUCCESS"; #endif -#ifdef ETIME +#if defined(ETIME) && (!defined(ELOOP) || (ETIME != ELOOP)) case ETIME: return "ETIME"; #endif -#ifdef ETIMEDOUT +#if defined(ETIMEDOUT) && (!defined(ENOSTR) || (ETIMEDOUT != ENOSTR)) case ETIMEDOUT: return "ETIMEDOUT"; #endif #ifdef ETOOMANYREFS @@ -470,6 +457,458 @@ Tcl_ErrnoId() return "unknown error"; } +/* + *---------------------------------------------------------------------- + * + * Tcl_ErrnoMsg -- + * + * Return a human-readable message corresponding to a given + * errno value. + * + * Results: + * The return value is the standard POSIX error message for + * errno. This procedure is used instead of strerror because + * strerror returns slightly different values on different + * machines (e.g. different capitalizations), which cause + * problems for things such as regression tests. This procedure + * provides messages for most standard errors, then it calls + * strerror for things it doesn't understand. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_ErrnoMsg(err) + int err; /* Error number (such as in errno variable). */ +{ + switch (err) { +#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 "resource temporarily unavailable"; +#endif +#ifdef EALIGN + case EALIGN: return "EALIGN"; +#endif +#if defined(EALREADY) && (!defined(EBUSY) || (EALREADY != EBUSY )) + 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 "file 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 +#if defined(EDEADLOCK) && (!defined(EDEADLK) || (EDEADLOCK != EDEADLK)) + 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 +#if defined(EIDRM) && (!defined(EINPROGRESS) || (EIDRM != EINPROGRESS)) + 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 +#if defined(ELOOP) && (!defined(ENOENT) || (ELOOP != ENOENT)) + 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 +#if defined(ENODATA) && (!defined(ECONNREFUSED) || (ENODATA != ECONNREFUSED)) + 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 +#if defined(ENOSR) && (!defined(ENAMETOOLONG) || (ENAMETOOLONG != ENOSR)) + case ENOSR: return "out of stream resources"; +#endif +#if defined(ENOSTR) && (!defined(ENOTTY) || (ENOTTY != 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 +#if defined(ENOTEMPTY) && (!defined(EEXIST) || (ENOTEMPTY != EEXIST)) + 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 ENOTSUP + case ENOTSUP: return "operation not supported"; +#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 +#if defined(EPFNOSUPPORT) && (!defined(ENOLCK) || (ENOLCK != 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 +#if defined(ETIME) && (!defined(ELOOP) || (ETIME != ELOOP)) + case ETIME: return "timer expired"; +#endif +#if defined(ETIMEDOUT) && (!defined(ENOSTR) || (ETIMEDOUT != ENOSTR)) + 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 + default: +#ifdef NO_STRERROR + return "unknown POSIX error"; +#else + return strerror(errno); +#endif + } +} + /* *---------------------------------------------------------------------- * @@ -535,7 +974,7 @@ Tcl_SignalId(sig) #ifdef SIGKILL case SIGKILL: return "SIGKILL"; #endif -#if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) +#if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) && (!defined(SIGPROF) || (SIGLOST != SIGPROF)) case SIGLOST: return "SIGLOST"; #endif #ifdef SIGPIPE diff --git a/tk3.6/tkPreserve.c b/tcl7.6/generic/tclPreserve.c similarity index 55% rename from tk3.6/tkPreserve.c rename to tcl7.6/generic/tclPreserve.c index d915159..24b41ee 100644 --- a/tk3.6/tkPreserve.c +++ b/tcl7.6/generic/tclPreserve.c @@ -1,54 +1,37 @@ /* - * tkPreserve.c -- + * tclPreserve.c -- * * This file contains a collection of procedures that are used * to make sure that widget records and other data structures * aren't reallocated when there are nested procedures that * depend on their existence. * - * Copyright (c) 1991-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tclPreserve.c 1.18 96/08/05 13:15:08 */ -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkPreserve.c,v 1.8 93/07/22 17:08:09 ouster Exp $ SPRITE (Berkeley)"; -#endif /* not lint */ - -#include "tkConfig.h" -#include "tk.h" +#include "tclInt.h" /* * The following data structure is used to keep track of all the - * Tk_Preserve calls that are still in effect. It grows as needed + * Tcl_Preserve calls that are still in effect. It grows as needed * to accommodate any number of calls in effect. */ typedef struct { ClientData clientData; /* Address of preserved block. */ - int refCount; /* Number of Tk_Preserve calls in effect + int refCount; /* Number of Tcl_Preserve calls in effect * for block. */ - int mustFree; /* Non-zero means Tk_EventuallyFree was - * called while a Tk_Preserve call was in + int mustFree; /* Non-zero means Tcl_EventuallyFree was + * called while a Tcl_Preserve call was in * effect, so the structure must be freed * when refCount becomes zero. */ - Tk_FreeProc *freeProc; /* Procedure to call to free. */ + Tcl_FreeProc *freeProc; /* Procedure to call to free. */ } Reference; static Reference *refArray; /* First in array of references. */ @@ -57,31 +40,67 @@ static int spaceAvl = 0; /* Total number of structures available static int inUse = 0; /* Count of structures currently in use * in refArray. */ #define INITIAL_SIZE 2 + +/* + * Static routines in this file: + */ + +static void PreserveExitProc _ANSI_ARGS_((ClientData clientData)); + /* *---------------------------------------------------------------------- * - * Tk_Preserve -- + * PreserveExitProc -- + * + * Called during exit processing to clean up the reference array. + * + * Results: + * None. + * + * Side effects: + * Frees the storage of the reference array. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +PreserveExitProc(clientData) + ClientData clientData; /* NULL -Unused. */ +{ + if (spaceAvl != 0) { + ckfree((char *) refArray); + refArray = (Reference *) NULL; + inUse = 0; + spaceAvl = 0; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Preserve -- * * This procedure is used by a procedure to declare its interest * in a particular block of memory, so that the block will not be - * reallocated until a matching call to Tk_Release has been made. + * reallocated until a matching call to Tcl_Release has been made. * * Results: * None. * * Side effects: * Information is retained so that the block of memory will - * not be freed until at least the matching call to Tk_Release. + * not be freed until at least the matching call to Tcl_Release. * *---------------------------------------------------------------------- */ void -Tk_Preserve(clientData) +Tcl_Preserve(clientData) ClientData clientData; /* Pointer to malloc'ed block of memory. */ { - register Reference *refPtr; + Reference *refPtr; int i; /* @@ -103,6 +122,8 @@ Tk_Preserve(clientData) if (inUse == spaceAvl) { if (spaceAvl == 0) { + Tcl_CreateExitHandler((Tcl_ExitProc *) PreserveExitProc, + (ClientData) NULL); refArray = (Reference *) ckalloc((unsigned) (INITIAL_SIZE*sizeof(Reference))); spaceAvl = INITIAL_SIZE; @@ -111,7 +132,8 @@ Tk_Preserve(clientData) new = (Reference *) ckalloc((unsigned) (2*spaceAvl*sizeof(Reference))); - memcpy((VOID *) new, (VOID *) refArray, spaceAvl*sizeof(Reference)); + memcpy((VOID *) new, (VOID *) refArray, + spaceAvl*sizeof(Reference)); ckfree((char *) refArray); refArray = new; spaceAvl *= 2; @@ -126,34 +148,37 @@ Tk_Preserve(clientData) refPtr->clientData = clientData; refPtr->refCount = 1; refPtr->mustFree = 0; + refPtr->freeProc = TCL_STATIC; inUse += 1; } /* *---------------------------------------------------------------------- * - * Tk_Release -- + * Tcl_Release -- * * This procedure is called to cancel a previous call to - * Tk_Preserve, thereby allowing a block of memory to be + * Tcl_Preserve, thereby allowing a block of memory to be * freed (if no one else cares about it). * * Results: * None. * * Side effects: - * If Tk_EventuallyFree has been called for clientData, and if - * no other call to Tk_Preserve is still in effect, the block of + * If Tcl_EventuallyFree has been called for clientData, and if + * no other call to Tcl_Preserve is still in effect, the block of * memory is freed. * *---------------------------------------------------------------------- */ void -Tk_Release(clientData) +Tcl_Release(clientData) ClientData clientData; /* Pointer to malloc'ed block of memory. */ { - register Reference *refPtr; + Reference *refPtr; + int mustFree; + Tcl_FreeProc *freeProc; int i; for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) { @@ -162,23 +187,28 @@ Tk_Release(clientData) } refPtr->refCount--; if (refPtr->refCount == 0) { - if (refPtr->mustFree) { - if (refPtr->freeProc == (Tk_FreeProc *) free) { - ckfree((char *) refPtr->clientData); - } else { - (*refPtr->freeProc)(refPtr->clientData); - } - } - /* - * Copy down the last reference in the array to fill the - * hole left by the unused reference. - */ + /* + * Must remove information from the slot before calling freeProc + * to avoid reentrancy problems if the freeProc calls Tcl_Preserve + * on the same clientData. Copy down the last reference in the + * array to overwrite the current slot. + */ + freeProc = refPtr->freeProc; + mustFree = refPtr->mustFree; inUse--; if (i < inUse) { refArray[i] = refArray[inUse]; } + if (mustFree) { + if ((freeProc == TCL_DYNAMIC) || + (freeProc == (Tcl_FreeProc *) free)) { + ckfree((char *) clientData); + } else { + (*freeProc)((char *) clientData); + } + } } return; } @@ -187,18 +217,18 @@ Tk_Release(clientData) * Reference not found. This is a bug in the caller. */ - panic("Tk_Release couldn't find reference for 0x%x", clientData); + panic("Tcl_Release couldn't find reference for 0x%x", clientData); } /* *---------------------------------------------------------------------- * - * Tk_EventuallyFree -- + * Tcl_EventuallyFree -- * - * Free up a block of memory, unless a call to Tk_Preserve is in + * Free up a block of memory, unless a call to Tcl_Preserve is in * effect for that block. In this case, defer the free until all - * calls to Tk_Preserve have been undone by matching calls to - * Tk_Release. + * calls to Tcl_Preserve have been undone by matching calls to + * Tcl_Release. * * Results: * None. @@ -210,11 +240,11 @@ Tk_Release(clientData) */ void -Tk_EventuallyFree(clientData, freeProc) +Tcl_EventuallyFree(clientData, freeProc) ClientData clientData; /* Pointer to malloc'ed block of memory. */ - Tk_FreeProc *freeProc; /* Procedure to actually do free. */ + Tcl_FreeProc *freeProc; /* Procedure to actually do free. */ { - register Reference *refPtr; + Reference *refPtr; int i; /* @@ -227,7 +257,7 @@ Tk_EventuallyFree(clientData, freeProc) continue; } if (refPtr->mustFree) { - panic("Tk_EventuallyFree called twice for 0x%x\n", clientData); + panic("Tcl_EventuallyFree called twice for 0x%x\n", clientData); } refPtr->mustFree = 1; refPtr->freeProc = freeProc; @@ -238,9 +268,10 @@ Tk_EventuallyFree(clientData, freeProc) * No reference for this block. Free it now. */ - if (freeProc == (Tk_FreeProc *) free) { + if ((freeProc == TCL_DYNAMIC) + || (freeProc == (Tcl_FreeProc *) free)) { ckfree((char *) clientData); } else { - (*freeProc)(clientData); + (*freeProc)((char *)clientData); } } diff --git a/tcl7.3/tclProc.c b/tcl7.6/generic/tclProc.c similarity index 86% rename from tcl7.3/tclProc.c rename to tcl7.6/generic/tclProc.c index 6d290c5..0b34e23 100644 --- a/tcl7.3/tclProc.c +++ b/tcl7.6/generic/tclProc.c @@ -5,30 +5,14 @@ * including the "proc" and "uplevel" commands. * * Copyright (c) 1987-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tclProc.c 1.72 96/02/15 11:42:48 */ -#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" /* @@ -513,19 +497,7 @@ InterpProc(clientData, interp, argc, argv) 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; - } - } + result = TclUpdateReturnInfo(iPtr); } else if (result == TCL_ERROR) { char msg[100]; @@ -554,7 +526,25 @@ InterpProc(clientData, interp, argc, argv) procDone: iPtr->framePtr = frame.callerPtr; iPtr->varFramePtr = frame.callerVarPtr; - TclDeleteVars(iPtr, &frame.varTable); + + /* + * The check below is a hack. The problem is that there could be + * unset traces on the variables, which cause scripts to be evaluated. + * This will clear the ERR_IN_PROGRESS flag, losing stack trace + * information if the procedure was exiting with an error. The + * code below preserves the flag. Unfortunately, that isn't + * really enough: we really should preserve the errorInfo variable + * too (otherwise a nested error in the trace script will trash + * errorInfo). What's really needed is a general-purpose + * mechanism for saving and restoring interpreter state. + */ + + if (iPtr->flags & ERR_IN_PROGRESS) { + TclDeleteVars(iPtr, &frame.varTable); + iPtr->flags |= ERR_IN_PROGRESS; + } else { + TclDeleteVars(iPtr, &frame.varTable); + } return result; } @@ -623,3 +613,46 @@ CleanupProc(procPtr) } ckfree((char *) procPtr); } + +/* + *---------------------------------------------------------------------- + * + * TclUpdateReturnInfo -- + * + * This procedure is called when procedures return, and at other + * points where the TCL_RETURN code is used. It examines fields + * such as iPtr->returnCode and iPtr->errorCode and modifies + * the real return status accordingly. + * + * Results: + * The return value is the true completion code to use for + * the procedure, instead of TCL_RETURN. + * + * Side effects: + * The errorInfo and errorCode variables may get modified. + * + *---------------------------------------------------------------------- + */ + +int +TclUpdateReturnInfo(iPtr) + Interp *iPtr; /* Interpreter for which TCL_RETURN + * exception is being processed. */ +{ + int code; + + code = iPtr->returnCode; + iPtr->returnCode = TCL_OK; + if (code == TCL_ERROR) { + Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode", (char *) NULL, + (iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE", + TCL_GLOBAL_ONLY); + iPtr->flags |= ERROR_CODE_SET; + if (iPtr->errorInfo != NULL) { + Tcl_SetVar2((Tcl_Interp *) iPtr, "errorInfo", (char *) NULL, + iPtr->errorInfo, TCL_GLOBAL_ONLY); + iPtr->flags |= ERR_IN_PROGRESS; + } + } + return code; +} diff --git a/tcl7.3/tclRegexp.h b/tcl7.6/generic/tclRegexp.h similarity index 55% rename from tcl7.3/tclRegexp.h rename to tcl7.6/generic/tclRegexp.h index c346000..986316b 100644 --- a/tcl7.3/tclRegexp.h +++ b/tcl7.6/generic/tclRegexp.h @@ -3,15 +3,24 @@ * * Caveat: this is V8 regexp(3) [actually, a reimplementation thereof], * not the System V one. + * + * SCCS: @(#) tclRegexp.h 1.6 96/04/02 18:43:57 */ +#ifndef _REGEXP +#define _REGEXP 1 + #ifndef _TCL #include "tcl.h" #endif -#ifndef _REGEXP -#define _REGEXP 1 -#define NSUBEXP 10 +/* + * NSUBEXP must be at least 10, and no greater than 117 or the parser + * will not work properly. + */ + +#define NSUBEXP 20 + typedef struct regexp { char *startp[NSUBEXP]; char *endp[NSUBEXP]; @@ -22,9 +31,10 @@ typedef struct regexp { 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)); +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)); +EXTERN char *TclGetRegError _ANSI_ARGS_((void)); #endif /* REGEXP */ diff --git a/tcl7.6/generic/tclTest.c b/tcl7.6/generic/tclTest.c new file mode 100644 index 0000000..48ede8e --- /dev/null +++ b/tcl7.6/generic/tclTest.c @@ -0,0 +1,2068 @@ +/* + * 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-1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclTest.c 1.83 96/10/03 14:56:36 + */ + +#define TCL_TEST + +#include "tclInt.h" +#include "tclPort.h" + +/* + * Declare external functions used in Windows tests. + */ + +#if defined(__WIN32__) +extern TclPlatformType * TclWinGetPlatform _ANSI_ARGS_((void)); +#endif + +/* + * 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 dynamic string below is used by the "testdstring" command + * to test the dynamic string facilities. + */ + +static Tcl_DString dstring; + +/* + * One of the following structures exists for each command created + * by TestdelCmd: + */ + +typedef struct DelCmd { + Tcl_Interp *interp; /* Interpreter in which command exists. */ + char *deleteCmd; /* Script to execute when command is + * deleted. Malloc'ed. */ +} DelCmd; + +/* + * The following structure is used to keep track of modal timeout + * handlers created by the "testmodal" command. + */ + +typedef struct Modal { + Tcl_Interp *interp; /* Interpreter in which to set variable + * "x" when timer fires. */ + char *key; /* Null-terminated string to store in + * global variable "x" in interp when + * timer fires. Malloc-ed. */ +} Modal; + +/* + * Forward declarations for procedures defined later in this file: + */ + +int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +static int AsyncHandlerProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int code)); +static void CleanupTestSetassocdataTests _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp)); +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 DelCmdProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static void DelDeleteProc _ANSI_ARGS_((ClientData clientData)); +static void ExitProcEven _ANSI_ARGS_((ClientData clientData)); +static void ExitProcOdd _ANSI_ARGS_((ClientData clientData)); +static void ModalTimeoutProc _ANSI_ARGS_((ClientData clientData)); +static void SpecialFree _ANSI_ARGS_((char *blockPtr)); +static int StaticInitProc _ANSI_ARGS_((Tcl_Interp *interp)); +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 TestcmdtokenCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestchmodCmd _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 TestdelCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestdelassocdataCmd _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 TestexithandlerCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestfileCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestfilewaitCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestfeventCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestfhandleCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestgetassocdataCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestgetplatformCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestinterpdeleteCmd _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)); +static int TestmodalCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestPanicCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestsetassocdataCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestsetplatformCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TeststaticpkgCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TesttranslatefilenameCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestupvarCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestwordendCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); + +/* + * External (platform specific) initialization routine: + */ + +EXTERN int TclplatformtestInit _ANSI_ARGS_(( + Tcl_Interp *interp)); + +/* + *---------------------------------------------------------------------- + * + * Tcltest_Init -- + * + * This procedure performs application-specific initialization. + * Most applications, especially those that incorporate additional + * packages, will have their own version of this procedure. + * + * Results: + * Returns a standard Tcl completion code, and leaves an error + * message in interp->result if an error occurs. + * + * Side effects: + * Depends on the startup script. + * + *---------------------------------------------------------------------- + */ + +int +Tcltest_Init(interp) + Tcl_Interp *interp; /* Interpreter for application. */ +{ + if (Tcl_PkgProvide(interp, "Tcltest", TCL_VERSION) == 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, "testchannel", TclTestChannelCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testchannelevent", TclTestChannelEventCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testchmod", TestchmodCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testcmdtoken", TestcmdtokenCmd, (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_CreateCommand(interp, "testdel", TestdelCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testdelassocdata", TestdelassocdataCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_DStringInit(&dstring); + Tcl_CreateCommand(interp, "testdstring", TestdstringCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testexithandler", TestexithandlerCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testfhandle", TestfhandleCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testfile", TestfileCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testfilewait", TestfilewaitCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testlink", TestlinkCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testmodal", TestmodalCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testtranslatefilename", + TesttranslatefilenameCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testwordend", TestwordendCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testfevent", TestfeventCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testpanic", TestPanicCmd, (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); + + /* + * And finally add any platform specific test commands. + */ + + return TclplatformtestInit(interp); +} + +/* + *---------------------------------------------------------------------- + * + * 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 = (char *) 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], "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; +} + +/* + *---------------------------------------------------------------------- + * + * TestcmdinfoCmd -- + * + * This procedure implements the "testcmdinfo" command. It is used + * to test Tcl_GetCommandInfo, Tcl_SetCommandInfo, 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); +} + +/* + *---------------------------------------------------------------------- + * + * TestcmdtokenCmd -- + * + * This procedure implements the "testcmdtoken" command. It is used + * to test Tcl_Command tokens and Tcl_GetCommandName. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates and deletes various commands and modifies their data. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestcmdtokenCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Command token; + long int l; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option arg\"", (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[1], "create") == 0) { + token = Tcl_CreateCommand(interp, argv[2], CmdProc1, + (ClientData) "original", (Tcl_CmdDeleteProc *) NULL); + sprintf(interp->result, "%lx", (long int) token); + } else if (strcmp(argv[1], "name") == 0) { + if (sscanf(argv[2], "%lx", &l) != 1) { + Tcl_AppendResult(interp, "bad command token \"", argv[2], + "\"", (char *) NULL); + return TCL_ERROR; + } + interp->result = Tcl_GetCommandName(interp, (Tcl_Command) l); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be create or name", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * 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!"); + } +} + +/* + *---------------------------------------------------------------------- + * + * TestdelCmd -- + * + * 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 +TestdelCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + DelCmd *dPtr; + Tcl_Interp *slave; + + if (argc != 4) { + interp->result = "wrong # args"; + return TCL_ERROR; + } + + slave = Tcl_GetSlave(interp, argv[1]); + if (slave == NULL) { + return TCL_ERROR; + } + + dPtr = (DelCmd *) ckalloc(sizeof(DelCmd)); + dPtr->interp = interp; + dPtr->deleteCmd = (char *) ckalloc((unsigned) (strlen(argv[3]) + 1)); + strcpy(dPtr->deleteCmd, argv[3]); + + Tcl_CreateCommand(slave, argv[2], DelCmdProc, (ClientData) dPtr, + DelDeleteProc); + return TCL_OK; +} + +static int +DelCmdProc(clientData, interp, argc, argv) + ClientData clientData; /* String result to return. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + DelCmd *dPtr = (DelCmd *) clientData; + + Tcl_AppendResult(interp, dPtr->deleteCmd, (char *) NULL); + ckfree(dPtr->deleteCmd); + ckfree((char *) dPtr); + return TCL_OK; +} + +static void +DelDeleteProc(clientData) + ClientData clientData; /* String command to evaluate. */ +{ + DelCmd *dPtr = (DelCmd *) clientData; + + Tcl_Eval(dPtr->interp, dPtr->deleteCmd); + Tcl_ResetResult(dPtr->interp); + ckfree(dPtr->deleteCmd); + ckfree((char *) dPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TestdelassocdataCmd -- + * + * This procedure implements the "testdelassocdata" command. It is used + * to test Tcl_DeleteAssocData. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Deletes an association between a key and associated data from an + * interpreter. + * + *---------------------------------------------------------------------- + */ + +static int +TestdelassocdataCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " data_key\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_DeleteAssocData(interp, argv[1]); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * 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], "gresult") == 0) { + if (argc != 3) { + goto wrongNumArgs; + } + if (strcmp(argv[2], "staticsmall") == 0) { + interp->result = "short"; + } else if (strcmp(argv[2], "staticlarge") == 0) { + interp->result = "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n"; + } else if (strcmp(argv[2], "free") == 0) { + interp->result = (char *) ckalloc(100); + interp->freeProc = TCL_DYNAMIC; + strcpy(interp->result, "This is a malloc-ed string"); + } else if (strcmp(argv[2], "special") == 0) { + interp->result = (char *) ckalloc(100); + interp->result += 4; + interp->freeProc = SpecialFree; + strcpy(interp->result, "This is a specially-allocated string"); + } else { + Tcl_AppendResult(interp, "bad gresult option \"", argv[2], + "\": must be staticsmall, staticlarge, free, or special", + (char *) NULL); + return TCL_ERROR; + } + Tcl_DStringGetResult(interp, &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; +} + +/* + * The procedure below is used as a special freeProc to test how well + * Tcl_DStringGetResult handles freeProc's other than free. + */ + +static void SpecialFree(blockPtr) + char *blockPtr; /* Block to free. */ +{ + ckfree(blockPtr - 4); +} + +/* + *---------------------------------------------------------------------- + * + * TestexithandlerCmd -- + * + * This procedure implements the "testexithandler" command. It is + * used to test Tcl_CreateExitHandler and Tcl_DeleteExitHandler. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestexithandlerCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int value; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " create|delete value\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[2], &value) != TCL_OK) { + return TCL_ERROR; + } + if (strcmp(argv[1], "create") == 0) { + Tcl_CreateExitHandler((value & 1) ? ExitProcOdd : ExitProcEven, + (ClientData) value); + } else if (strcmp(argv[1], "delete") == 0) { + Tcl_DeleteExitHandler((value & 1) ? ExitProcOdd : ExitProcEven, + (ClientData) value); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be create or delete", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +static void +ExitProcOdd(clientData) + ClientData clientData; /* Integer value to print. */ +{ + char buf[100]; + + sprintf(buf, "odd %d\n", (int) clientData); + write(1, buf, strlen(buf)); +} + +static void +ExitProcEven(clientData) + ClientData clientData; /* Integer value to print. */ +{ + char buf[100]; + + sprintf(buf, "even %d\n", (int) clientData); + write(1, buf, strlen(buf)); +} + +/* + *---------------------------------------------------------------------- + * + * TestfhandleCmd -- + * + * This procedure implements the "testfhandle" command. It is + * used to test Tcl_GetFile, Tcl_FreeFile, and + * Tcl_GetFileInfo. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestfhandleCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ +#define MAX_FHANDLES 10 + static Tcl_File testHandles[MAX_FHANDLES]; + static initialized = 0; + + int i, index, type; + ClientData data; + + if (!initialized) { + for (i = 0; i < MAX_FHANDLES; i++) { + testHandles[i] = NULL; + } + initialized = 1; + } + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " option ... \"", (char *) NULL); + return TCL_ERROR; + } + index = -1; + if (argc >= 3) { + if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) { + return TCL_ERROR; + } + if (index >= MAX_FHANDLES) { + Tcl_AppendResult(interp, "bad index ", argv[2], (char *) NULL); + return TCL_ERROR; + } + } + if (strcmp(argv[1], "compare") == 0) { + int index2; + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " index index\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[3], (int *) &index2) != TCL_OK) { + return TCL_ERROR; + } + if (testHandles[index] == testHandles[index2]) { + sprintf(interp->result, "equal"); + } else { + sprintf(interp->result, "notequal"); + } + } else if (strcmp(argv[1], "get") == 0) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " index data type\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[3], (int *) &data) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[4], &type) != TCL_OK) { + return TCL_ERROR; + } + testHandles[index] = Tcl_GetFile(data, type); + } else if (strcmp(argv[1], "free") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " index\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_FreeFile(testHandles[index]); + } else if (strcmp(argv[1], "info1") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " index\"", (char *) NULL); + return TCL_ERROR; + } + data = Tcl_GetFileInfo(testHandles[index], NULL); + sprintf(interp->result, "%d", (int)data); + } else if (strcmp(argv[1], "info2") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " index\"", (char *) NULL); + return TCL_ERROR; + } + data = Tcl_GetFileInfo(testHandles[index], &type); + sprintf(interp->result, "%d %d", (int)data, type); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be compare, get, free, info1, or info2", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestfilewaitCmd -- + * + * This procedure implements the "testfilewait" command. It is + * used to test TclWaitForFile. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestfilewaitCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int mask, result, timeout; + Tcl_Channel channel; + Tcl_File file; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " file readable|writable|both timeout\"", (char *) NULL); + return TCL_ERROR; + } + channel = Tcl_GetChannel(interp, argv[1], NULL); + if (channel == NULL) { + return TCL_ERROR; + } + if (strcmp(argv[2], "readable") == 0) { + mask = TCL_READABLE; + } else if (strcmp(argv[2], "writable") == 0){ + mask = TCL_WRITABLE; + } else if (strcmp(argv[2], "both") == 0){ + mask = TCL_WRITABLE|TCL_READABLE; + } else { + Tcl_AppendResult(interp, "bad argument \"", argv[2], + "\": must be readable, writable, or both", (char *) NULL); + return TCL_ERROR; + } + file = Tcl_GetChannelFile(channel, + (mask & TCL_READABLE) ? TCL_READABLE : TCL_WRITABLE); + if (file == NULL) { + interp->result = "couldn't get channel file"; + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[3], &timeout) != TCL_OK) { + return TCL_ERROR; + } + result = TclWaitForFile(file, mask, timeout); + if (result & TCL_READABLE) { + Tcl_AppendElement(interp, "readable"); + } + if (result & TCL_WRITABLE) { + Tcl_AppendElement(interp, "writable"); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestgetassocdataCmd -- + * + * This procedure implements the "testgetassocdata" command. It is + * used to test Tcl_GetAssocData. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestgetassocdataCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char *res; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " data_key\"", (char *) NULL); + return TCL_ERROR; + } + res = (char *) Tcl_GetAssocData(interp, argv[1], NULL); + if (res != NULL) { + Tcl_AppendResult(interp, res, NULL); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestgetplatformCmd -- + * + * This procedure implements the "testgetplatform" command. It is + * used to retrievel the value of the tclPlatform global variable. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestgetplatformCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + static char *platformStrings[] = { "unix", "mac", "windows" }; + TclPlatformType *platform; + +#ifdef __WIN32__ + platform = TclWinGetPlatform(); +#else + platform = &tclPlatform; +#endif + + if (argc != 1) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + (char *) NULL); + return TCL_ERROR; + } + + Tcl_AppendResult(interp, platformStrings[*platform], NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestinterpdeleteCmd -- + * + * This procedure tests the code in tclInterp.c that deals with + * interpreter deletion. It deletes a user-specified interpreter + * from the hierarchy, and subsequent code checks integrity. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Deletes one or more interpreters. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestinterpdeleteCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Interp *slaveToDelete; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " path\"", (char *) NULL); + return TCL_ERROR; + } + if (argv[1][0] == '\0') { + Tcl_AppendResult(interp, "cannot delete current interpreter", + (char *) NULL); + return TCL_ERROR; + } + slaveToDelete = Tcl_GetSlave(interp, argv[1]); + if (slaveToDelete == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "could not find interpreter \"", + argv[1], "\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_DeleteInterp(slaveToDelete); + 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; + static int created = 0; + 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 (created) { + Tcl_UnlinkVar(interp, "int"); + Tcl_UnlinkVar(interp, "real"); + Tcl_UnlinkVar(interp, "bool"); + Tcl_UnlinkVar(interp, "string"); + } + created = 1; + 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"); + created = 0; + } 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 = (char *) ckalloc((unsigned) (strlen(argv[5]) + 1)); + strcpy(stringVar, argv[5]); + } + } + } else if (strcmp(argv[1], "update") == 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; + } + Tcl_UpdateLinkedVar(interp, "int"); + } + if (argv[3][0] != 0) { + if (Tcl_GetDouble(interp, argv[3], &realVar) != TCL_OK) { + return TCL_ERROR; + } + Tcl_UpdateLinkedVar(interp, "real"); + } + if (argv[4][0] != 0) { + if (Tcl_GetInt(interp, argv[4], &boolVar) != TCL_OK) { + return TCL_ERROR; + } + Tcl_UpdateLinkedVar(interp, "bool"); + } + if (argv[5][0] != 0) { + if (stringVar != NULL) { + ckfree(stringVar); + } + if (strcmp(argv[5], "-") == 0) { + stringVar = NULL; + } else { + stringVar = (char *) ckalloc((unsigned) (strlen(argv[5]) + 1)); + strcpy(stringVar, argv[5]); + } + Tcl_UpdateLinkedVar(interp, "string"); + } + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be create, delete, get, set, or update", + (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; +} + +/* + *---------------------------------------------------------------------- + * + * CleanupTestSetassocdataTests -- + * + * This function is called when an interpreter is deleted to clean + * up any data left over from running the testsetassocdata command. + * + * Results: + * None. + * + * Side effects: + * Releases storage. + * + *---------------------------------------------------------------------- + */ + /* ARGSUSED */ +static void +CleanupTestSetassocdataTests(clientData, interp) + ClientData clientData; /* Data to be released. */ + Tcl_Interp *interp; /* Interpreter being deleted. */ +{ + ckfree((char *) clientData); +} + +/* + *---------------------------------------------------------------------- + * + * TestmodalCmd -- + * + * This procedure implements the "testmodal" command. It is used + * to test modal timeouts created by Tcl_CreateModalTimeout. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Modifies or creates an association between a key and associated + * data for this interpreter. + * + *---------------------------------------------------------------------- + */ + +static int +TestmodalCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ +#define NUM_MODALS 10 + static Modal modals[NUM_MODALS]; + static int numModals = 0; + int ms; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " option ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + + if (strcmp(argv[1], "create") == 0) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " create ms key\"", (char *) NULL); + return TCL_ERROR; + } + if (numModals >= NUM_MODALS) { + interp->result = "too many modal timeouts"; + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[2], &ms) != TCL_OK) { + return TCL_ERROR; + } + modals[numModals].interp = interp; + modals[numModals].key = (char *) ckalloc((unsigned) + (strlen(argv[3]) + 1)); + strcpy(modals[numModals].key, argv[3]); + Tcl_CreateModalTimeout(ms, ModalTimeoutProc, + (ClientData) &modals[numModals]); + numModals += 1; + } else if (strcmp(argv[1], "delete") == 0) { + if (numModals == 0) { + interp->result = "no more modal timeouts"; + return TCL_ERROR; + } + numModals -= 1; + ckfree(modals[numModals].key); + Tcl_DeleteModalTimeout(ModalTimeoutProc, + (ClientData) &modals[numModals]); + } else if (strcmp(argv[1], "event") == 0) { + Tcl_DoOneEvent(TCL_TIMER_EVENTS|TCL_DONT_WAIT); + } else if (strcmp(argv[1], "eventnotimers") == 0) { + Tcl_DoOneEvent(0x100000|TCL_DONT_WAIT); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be create, delete, event, or eventnotimers", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +static void +ModalTimeoutProc(clientData) + ClientData clientData; /* Pointer to Modal structure. */ +{ + Modal *modalPtr = (Modal *) clientData; + Tcl_SetVar(modalPtr->interp, "x", modalPtr->key, + TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT); +} + +/* + *---------------------------------------------------------------------- + * + * TestsetassocdataCmd -- + * + * This procedure implements the "testsetassocdata" command. It is used + * to test Tcl_SetAssocData. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Modifies or creates an association between a key and associated + * data for this interpreter. + * + *---------------------------------------------------------------------- + */ + +static int +TestsetassocdataCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char *buf; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " data_key data_item\"", (char *) NULL); + return TCL_ERROR; + } + + buf = ckalloc((unsigned) strlen(argv[2]) + 1); + strcpy(buf, argv[2]); + + Tcl_SetAssocData(interp, argv[1], CleanupTestSetassocdataTests, + (ClientData) buf); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestsetplatformCmd -- + * + * This procedure implements the "testsetplatform" command. It is + * used to change the tclPlatform global variable so all file + * name conversions can be tested on a single platform. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Sets the tclPlatform global variable. + * + *---------------------------------------------------------------------- + */ + +static int +TestsetplatformCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + size_t length; + TclPlatformType *platform; + +#ifdef __WIN32__ + platform = TclWinGetPlatform(); +#else + platform = &tclPlatform; +#endif + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " platform\"", (char *) NULL); + return TCL_ERROR; + } + + length = strlen(argv[1]); + if (strncmp(argv[1], "unix", length) == 0) { + *platform = TCL_PLATFORM_UNIX; + } else if (strncmp(argv[1], "mac", length) == 0) { + *platform = TCL_PLATFORM_MAC; + } else if (strncmp(argv[1], "windows", length) == 0) { + *platform = TCL_PLATFORM_WINDOWS; + } else { + Tcl_AppendResult(interp, "unsupported platform: should be one of ", + "unix, mac, or windows", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TeststaticpkgCmd -- + * + * This procedure implements the "teststaticpkg" command. + * It is used to test the procedure Tcl_StaticPackage. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * When the packge given by argv[1] is loaded into an interpeter, + * variable "x" in that interpreter is set to "loaded". + * + *---------------------------------------------------------------------- + */ + +static int +TeststaticpkgCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int safe, loaded; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " pkgName safe loaded\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[2], &safe) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[3], &loaded) != TCL_OK) { + return TCL_ERROR; + } + Tcl_StaticPackage((loaded) ? interp : NULL, argv[1], StaticInitProc, + (safe) ? StaticInitProc : NULL); + return TCL_OK; +} + +static int +StaticInitProc(interp) + Tcl_Interp *interp; /* Interpreter in which package + * is supposedly being loaded. */ +{ + Tcl_SetVar(interp, "x", "loaded", TCL_GLOBAL_ONLY); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TesttranslatefilenameCmd -- + * + * This procedure implements the "testtranslatefilename" command. + * It is used to test the Tcl_TranslateFileName command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TesttranslatefilenameCmd(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; + char *result; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " path\"", (char *) NULL); + return TCL_ERROR; + } + result = Tcl_TranslateFileName(interp, argv[1], &buffer); + if (result == NULL) { + return TCL_ERROR; + } + Tcl_AppendResult(interp, result, NULL); + Tcl_DStringFree(&buffer); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestupvarCmd -- + * + * This procedure implements the "testupvar2" command. It is used + * to test Tcl_UpVar and Tcl_UpVar2. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates or modifies an "upvar" reference. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestupvarCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if ((argc != 5) && (argc != 6)) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " level name ?name2? dest global\"", (char *) NULL); + return TCL_ERROR; + } + + if (argc == 5) { + return Tcl_UpVar(interp, argv[1], argv[2], argv[3], + (strcmp(argv[4], "global") == 0) ? TCL_GLOBAL_ONLY : 0); + } else { + return Tcl_UpVar2(interp, argv[1], argv[2], + (argv[3][0] == 0) ? (char *) NULL : argv[3], argv[4], + (strcmp(argv[5], "global") == 0) ? TCL_GLOBAL_ONLY : 0); + } +} + +/* + *---------------------------------------------------------------------- + * + * TestwordendCmd -- + * + * This procedure implements the "testwordend" command. It is used + * to test TclWordEnd. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestwordendCmd(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 # arguments: should be \"", + argv[0], " string\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_SetResult(interp, TclWordEnd(argv[1], 0, (int *) NULL), TCL_VOLATILE); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestfeventCmd -- + * + * This procedure implements the "testfevent" command. It is + * used for testing the "fileevent" command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates and deletes interpreters. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestfeventCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + static Tcl_Interp *interp2 = NULL; + int code; + Tcl_Channel chan; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option ?arg arg ...?", (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[1], "cmd") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " cmd script", (char *) NULL); + return TCL_ERROR; + } + if (interp2 != (Tcl_Interp *) NULL) { + code = Tcl_GlobalEval(interp2, argv[2]); + interp->result = interp2->result; + return code; + } else { + Tcl_AppendResult(interp, + "called \"testfevent code\" before \"testfevent create\"", + (char *) NULL); + return TCL_ERROR; + } + } else if (strcmp(argv[1], "create") == 0) { + if (interp2 != NULL) { + Tcl_DeleteInterp(interp2); + } + interp2 = Tcl_CreateInterp(); + return TCL_OK; + } else if (strcmp(argv[1], "delete") == 0) { + if (interp2 != NULL) { + Tcl_DeleteInterp(interp2); + } + interp2 = NULL; + } else if (strcmp(argv[1], "share") == 0) { + if (interp2 != NULL) { + chan = Tcl_GetChannel(interp, argv[2], NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + Tcl_RegisterChannel(interp2, chan); + } + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestPanicCmd -- + * + * Calls the panic routine. + * + * Results: + * Always returns TCL_OK. + * + * Side effects: + * May exit application. + * + *---------------------------------------------------------------------- + */ + +static int +TestPanicCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char *argString; + + /* + * Put the arguments into a var args structure + * Append all of the arguments together separated by spaces + */ + + argString = Tcl_Merge(argc-1, argv+1); + panic(argString); + ckfree(argString); + + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * TestchmodCmd -- + * + * Implements the "testchmod" cmd. Used when testing "file" + * command. The only attribute used by the Mac and Windows platforms + * is the user write flag; if this is not set, the file is + * made read-only. Otehrwise, the file is made read-write. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Changes permissions of specified files. + * + *--------------------------------------------------------------------------- + */ + +static int +TestchmodCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int i, mode; + char *rest; + + if (argc < 2) { + usage: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " mode file ?file ...?", (char *) NULL); + return TCL_ERROR; + } + + mode = (int) strtol(argv[1], &rest, 8); + if (*rest != '\0') { + goto usage; + } + + for (i = 2; i < argc; i++) { + Tcl_DString buffer; + + argv[i] = Tcl_TranslateFileName(interp, argv[i], &buffer); + if (argv[i] == NULL) { + return TCL_ERROR; + } + if (chmod(argv[i], (unsigned) mode) != 0) { + Tcl_AppendResult(interp, argv[i], ": ", Tcl_PosixError(interp), + (char *) NULL); + return TCL_ERROR; + } + Tcl_DStringFree(&buffer); + } + return TCL_OK; +} + +static int +TestfileCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int force, i, j, result; + Tcl_DString error, name[2]; + + if (argc < 3) { + return TCL_ERROR; + } + + force = 0; + i = 2; + if (strcmp(argv[2], "-force") == 0) { + force = 1; + i = 3; + } + + Tcl_DStringInit(&name[0]); + Tcl_DStringInit(&name[1]); + Tcl_DStringInit(&error); + + if (argc - i > 2) { + return TCL_ERROR; + } + + for (j = i; j < argc; j++) { + argv[j] = Tcl_TranslateFileName(interp, argv[j], &name[j - i]); + if (argv[j] == NULL) { + return TCL_ERROR; + } + } + + if (strcmp(argv[1], "mv") == 0) { + result = TclpRenameFile(argv[i], argv[i + 1]); + } else if (strcmp(argv[1], "cp") == 0) { + result = TclpCopyFile(argv[i], argv[i + 1]); + } else if (strcmp(argv[1], "rm") == 0) { + result = TclpDeleteFile(argv[i]); + } else if (strcmp(argv[1], "mkdir") == 0) { + result = TclpCreateDirectory(argv[i]); + } else if (strcmp(argv[1], "cpdir") == 0) { + result = TclpCopyDirectory(argv[i], argv[i + 1], &error); + } else if (strcmp(argv[1], "rmdir") == 0) { + result = TclpRemoveDirectory(argv[i], force, &error); + } else { + result = TCL_ERROR; + goto end; + } + + if (result != TCL_OK) { + if (Tcl_DStringValue(&error)[0] != '\0') { + Tcl_AppendResult(interp, Tcl_DStringValue(&error), " ", NULL); + } + Tcl_AppendResult(interp, Tcl_ErrnoId(), (char *) NULL); + } + + end: + Tcl_DStringFree(&error); + Tcl_DStringFree(&name[0]); + Tcl_DStringFree(&name[1]); + + return result; +} diff --git a/tcl7.3/tclUtil.c b/tcl7.6/generic/tclUtil.c similarity index 83% rename from tcl7.3/tclUtil.c rename to tcl7.6/generic/tclUtil.c index c739adc..5c15536 100644 --- a/tcl7.3/tclUtil.c +++ b/tcl7.6/generic/tclUtil.c @@ -5,31 +5,16 @@ * commands. * * Copyright (c) 1987-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tclUtil.c 1.114 96/06/06 13:48:58 */ -#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" +#include "tclPort.h" /* * The following values are used in the flags returned by Tcl_ScanElement @@ -52,16 +37,6 @@ static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclUtil.c,v 1.84 93/10/11 #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: */ @@ -105,7 +80,9 @@ static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr, int TclFindElement(interp, list, elementPtr, nextPtr, sizePtr, bracePtr) - Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + Tcl_Interp *interp; /* Interpreter to use for error reporting. + * If NULL, then no error message is left + * after errors. */ register char *list; /* String containing Tcl list with zero * or more elements (possibly in braces). */ char **elementPtr; /* Fill in with location of first significant @@ -185,10 +162,12 @@ TclFindElement(interp, list, elementPtr, nextPtr, sizePtr, bracePtr) && (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); + if (interp != NULL) { + Tcl_ResetResult(interp); + sprintf(interp->result, + "list element in braces followed by \"%.*s\" instead of space", + (int) (p2-p), p); + } return TCL_ERROR; } else if (openBraces != 0) { openBraces--; @@ -242,10 +221,12 @@ TclFindElement(interp, list, elementPtr, nextPtr, sizePtr, bracePtr) && (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"); + if (interp != NULL) { + Tcl_ResetResult(interp); + sprintf(interp->result, + "list element in quotes followed by \"%.*s\" %s", (int) (p2-p), p, + "instead of space"); + } return TCL_ERROR; } break; @@ -256,12 +237,16 @@ TclFindElement(interp, list, elementPtr, nextPtr, sizePtr, bracePtr) case 0: if (openBraces != 0) { - Tcl_SetResult(interp, "unmatched open brace in list", - TCL_STATIC); + if (interp != NULL) { + 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); + if (interp != NULL) { + Tcl_SetResult(interp, "unmatched open quote in list", + TCL_STATIC); + } return TCL_ERROR; } size = p - list; @@ -359,7 +344,8 @@ TclCopyAndCollapse(count, src, dst) int Tcl_SplitList(interp, list, argcPtr, argvPtr) - Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + Tcl_Interp *interp; /* Interpreter to use for error reporting. + * If NULL, then no error message is left. */ char *list; /* Pointer to string with list structure. */ int *argcPtr; /* Pointer to location to fill in with * the number of elements in the list. */ @@ -398,13 +384,15 @@ Tcl_SplitList(interp, list, argcPtr, argvPtr) } if (i >= size) { ckfree((char *) argv); - Tcl_SetResult(interp, "internal error in Tcl_SplitList", - TCL_STATIC); + if (interp != NULL) { + Tcl_SetResult(interp, "internal error in Tcl_SplitList", + TCL_STATIC); + } return TCL_ERROR; } argv[i] = p; if (brace) { - strncpy(p, element, elSize); + strncpy(p, element, (size_t) elSize); p += elSize; *p = 0; p++; @@ -578,8 +566,11 @@ Tcl_ConvertElement(src, dst, flags) * code for details of how this works. */ - if (src == NULL) { - src = ""; + if ((src == NULL) || (*src == 0)) { + p[0] = '{'; + p[1] = '}'; + p[2] = 0; + return 2; } if ((flags & USE_BRACES) && !(flags & TCL_DONT_USE_BRACES)) { *p = '{'; @@ -589,15 +580,6 @@ Tcl_ConvertElement(src, dst, flags) } *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 == '{') { /* @@ -809,7 +791,7 @@ Tcl_Concat(argc, argv) if (length == 0) { continue; } - (void) strncpy(p, element, length); + (void) strncpy(p, element, (size_t) length); p += length; *p = ' '; p++; @@ -925,7 +907,11 @@ Tcl_StringMatch(string, pattern) } pattern += 1; } - while ((*pattern != ']') && (*pattern != 0)) { + while (*pattern != ']') { + if (*pattern == 0) { + pattern--; + break; + } pattern += 1; } goto thisCharOK; @@ -987,7 +973,6 @@ Tcl_SetResult(interp, string, freeProc) Tcl_FreeProc *oldFreeProc = iPtr->freeProc; char *oldResult = iPtr->result; - iPtr->freeProc = freeProc; if (string == NULL) { iPtr->resultSpace[0] = 0; iPtr->result = iPtr->resultSpace; @@ -996,7 +981,7 @@ Tcl_SetResult(interp, string, freeProc) length = strlen(string); if (length > TCL_RESULT_SIZE) { iPtr->result = (char *) ckalloc((unsigned) length+1); - iPtr->freeProc = (Tcl_FreeProc *) free; + iPtr->freeProc = TCL_DYNAMIC; } else { iPtr->result = iPtr->resultSpace; iPtr->freeProc = 0; @@ -1004,6 +989,7 @@ Tcl_SetResult(interp, string, freeProc) strcpy(iPtr->result, string); } else { iPtr->result = string; + iPtr->freeProc = freeProc; } /* @@ -1013,7 +999,8 @@ Tcl_SetResult(interp, string, freeProc) */ if (oldFreeProc != 0) { - if (oldFreeProc == (Tcl_FreeProc *) free) { + if ((oldFreeProc == TCL_DYNAMIC) + || (oldFreeProc == (Tcl_FreeProc *) free)) { ckfree(oldResult); } else { (*oldFreeProc)(oldResult); @@ -1041,19 +1028,8 @@ Tcl_SetResult(interp, string, freeProc) */ /* VARARGS2 */ -#ifndef lint void -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 +Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1) { va_list argList; register Interp *iPtr; @@ -1065,8 +1041,7 @@ Tcl_AppendResult(interp, p, va_alist) * needed. */ - va_start(argList); - iPtr = va_arg(argList, Interp *); + iPtr = (Interp *) TCL_VARARGS_START(Tcl_Interp *,arg1,argList); newSpace = 0; while (1) { string = va_arg(argList, char *); @@ -1093,8 +1068,7 @@ Tcl_AppendResult(interp, p, va_alist) * them into the buffer. */ - va_start(argList); - (void) va_arg(argList, Tcl_Interp *); + TCL_VARARGS_START(Tcl_Interp *,arg1,argList); while (1) { string = va_arg(argList, char *); if (string == NULL) { @@ -1152,12 +1126,11 @@ Tcl_AppendElement(interp, string) /* * Convert the string into a list element and copy it to the - * buffer that's forming. + * buffer that's forming, with a space separator if needed. */ dst = iPtr->appendResult + iPtr->appendUsed; - if ((iPtr->appendUsed > 0) && ((dst[-1] != '{') - || ((iPtr->appendUsed > 1) && (dst[-2] == '\\')))) { + if (TclNeedSpace(iPtr->appendResult, dst)) { iPtr->appendUsed++; *dst = ' '; dst++; @@ -1295,19 +1268,8 @@ Tcl_ResetResult(interp) *---------------------------------------------------------------------- */ /* VARARGS2 */ -#ifndef lint void -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 +Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1) { va_list argList; char *string; @@ -1319,8 +1281,7 @@ Tcl_SetErrorCode(interp, p, va_alist) * $errorCode as list elements. */ - va_start(argList); - iPtr = va_arg(argList, Interp *); + iPtr = (Interp *) TCL_VARARGS_START(Tcl_Interp *,arg1,argList); flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT; while (1) { string = va_arg(argList, char *); @@ -1372,7 +1333,7 @@ TclGetListIndex(interp, string, indexPtr) *indexPtr = 0; } } else if (strncmp(string, "end", strlen(string)) == 0) { - *indexPtr = 1<<30; + *indexPtr = INT_MAX; } else { Tcl_AppendResult(interp, "bad index \"", string, "\": must be integer or \"end\"", (char *) NULL); @@ -1384,7 +1345,7 @@ TclGetListIndex(interp, string, indexPtr) /* *---------------------------------------------------------------------- * - * TclCompileRegexp -- + * Tcl_RegExpCompile -- * * Compile a regular expression into a form suitable for fast * matching. This procedure retains a small cache of pre-compiled @@ -1393,8 +1354,10 @@ TclGetListIndex(interp, string, indexPtr) * * 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 + * suitable for passing to Tcl_RegExpExec. This compiled form + * is only valid up until the next call to this procedure, so + * don't keep these around for a long time! If an error occurred + * while compiling the pattern, then NULL is returned and an error * message is left in interp->result. * * Side effects: @@ -1405,8 +1368,8 @@ TclGetListIndex(interp, string, indexPtr) *---------------------------------------------------------------------- */ -regexp * -TclCompileRegexp(interp, string) +Tcl_RegExp +Tcl_RegExpCompile(interp, string) Tcl_Interp *interp; /* For use in error reporting. */ char *string; /* String for which to produce * compiled regular expression. */ @@ -1439,7 +1402,7 @@ TclCompileRegexp(interp, string) iPtr->patLengths[0] = length; iPtr->regexps[0] = result; } - return iPtr->regexps[0]; + return (Tcl_RegExp) iPtr->regexps[0]; } } @@ -1448,12 +1411,12 @@ TclCompileRegexp(interp, string) * cache. */ - tclRegexpError = NULL; + TclRegError((char *) NULL); result = TclRegComp(string); - if (tclRegexpError != NULL) { + if (TclGetRegError() != NULL) { Tcl_AppendResult(interp, "couldn't compile regular expression pattern: ", - tclRegexpError, (char *) NULL); + TclGetRegError(), (char *) NULL); return NULL; } if (iPtr->patterns[NUM_REGEXPS-1] != NULL) { @@ -1469,32 +1432,95 @@ TclCompileRegexp(interp, string) strcpy(iPtr->patterns[0], string); iPtr->patLengths[0] = length; iPtr->regexps[0] = result; - return result; + return (Tcl_RegExp) result; } /* *---------------------------------------------------------------------- * - * TclRegError -- + * Tcl_RegExpExec -- * - * 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. + * Execute the regular expression matcher using a compiled form + * of a regular expression and save information about any match + * that is found. * * Results: - * None. + * 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 a matching range is + * found and 0 if there is no matching range. * * Side effects: - * The value of "string" is saved in "tclRegexpError". + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_RegExpExec(interp, re, string, start) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + Tcl_RegExp re; /* Compiled regular expression; must have + * been returned by previous call to + * Tcl_RegExpCompile. */ + char *string; /* String against which to match re. */ + char *start; /* If string is part of a larger string, + * this identifies beginning of larger + * string, so that "^" won't match. */ +{ + int match; + + regexp *regexpPtr = (regexp *) re; + TclRegError((char *) NULL); + match = TclRegExec(regexpPtr, string, start); + if (TclGetRegError() != NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "error while matching regular expression: ", + TclGetRegError(), (char *) NULL); + return -1; + } + return match; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RegExpRange -- + * + * Returns pointers describing the range of a regular expression match, + * or one of the subranges within the match. + * + * Results: + * The variables at *startPtr and *endPtr are modified to hold the + * addresses of the endpoints of the range given by index. If the + * specified range doesn't exist then NULLs are returned. + * + * Side effects: + * None. * *---------------------------------------------------------------------- */ void -TclRegError(string) - char *string; /* Error message. */ +Tcl_RegExpRange(re, index, startPtr, endPtr) + Tcl_RegExp re; /* Compiled regular expression that has + * been passed to Tcl_RegExpExec. */ + int index; /* 0 means give the range of the entire + * match, > 0 means give the range of + * a matching subrange. Must be no greater + * than NSUBEXP. */ + char **startPtr; /* Store address of first character in + * (sub-) range here. */ + char **endPtr; /* Store address of character just after last + * in (sub-) range here. */ { - tclRegexpError = string; + regexp *regexpPtr = (regexp *) re; + + if (index >= NSUBEXP) { + *startPtr = *endPtr = NULL; + } else { + *startPtr = regexpPtr->startp[index]; + *endPtr = regexpPtr->endp[index]; + } } /* @@ -1523,22 +1549,13 @@ Tcl_RegExpMatch(interp, string, pattern) char *pattern; /* Regular expression to match against * string. */ { - regexp *regexpPtr; - int match; + Tcl_RegExp re; - regexpPtr = TclCompileRegexp(interp, pattern); - if (regexpPtr == NULL) { + re = Tcl_RegExpCompile(interp, pattern); + if (re == 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; + return Tcl_RegExpExec(interp, re, string, string); } /* @@ -1600,7 +1617,7 @@ Tcl_DStringAppend(dsPtr, string, length) * of string, up to null at end. */ { int newSize; - char *newString; + char *newString, *dst, *end; if (length < 0) { length = strlen(string); @@ -1616,7 +1633,8 @@ Tcl_DStringAppend(dsPtr, string, length) if (newSize >= dsPtr->spaceAvl) { dsPtr->spaceAvl = newSize*2; newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); - strcpy(newString, dsPtr->string); + memcpy((VOID *)newString, (VOID *) dsPtr->string, + (size_t) dsPtr->length); if (dsPtr->string != dsPtr->staticSpace) { ckfree(dsPtr->string); } @@ -1628,9 +1646,12 @@ Tcl_DStringAppend(dsPtr, string, length) * one. */ - strncpy(dsPtr->string + dsPtr->length, string, length); + for (dst = dsPtr->string + dsPtr->length, end = string+length; + string < end; string++, dst++) { + *dst = *string; + } + *dst = 0; dsPtr->length += length; - dsPtr->string[dsPtr->length] = 0; return dsPtr->string; } @@ -1668,12 +1689,16 @@ Tcl_DStringAppendElement(dsPtr, string) * 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. + * SPECIAL NOTE: must use memcpy, not strcpy, to copy the string + * to a larger buffer, since there may be embedded NULLs in the + * string in some cases. */ if (newSize >= dsPtr->spaceAvl) { dsPtr->spaceAvl = newSize*2; newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); - strcpy(newString, dsPtr->string); + memcpy((VOID *) newString, (VOID *) dsPtr->string, + (size_t) dsPtr->length); if (dsPtr->string != dsPtr->staticSpace) { ckfree(dsPtr->string); } @@ -1682,13 +1707,11 @@ Tcl_DStringAppendElement(dsPtr, string) /* * 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 "{". + * buffer at the end, with a space, if needed. */ dst = dsPtr->string + dsPtr->length; - if ((dsPtr->length > 0) && ((dst[-1] != '{') - || ((dsPtr->length > 1) && (dst[-2] == '\\')))) { + if (TclNeedSpace(dsPtr->string, dst)) { *dst = ' '; dst++; dsPtr->length++; @@ -1700,23 +1723,25 @@ Tcl_DStringAppendElement(dsPtr, string) /* *---------------------------------------------------------------------- * - * Tcl_DStringTrunc -- + * Tcl_DStringSetLength -- * - * Truncate a dynamic string to a given length without freeing - * up its storage. + * Change the length of a dynamic string. This can cause the + * string to either grow or shrink, depending on the value of + * length. * * Results: * None. * * Side effects: - * The length of dsPtr is reduced to length unless it was already - * shorter than that. + * The length of dsPtr is changed to length and a null byte is + * stored at that position in the string. If length is larger + * than the space allocated for dsPtr, then a panic occurs. * *---------------------------------------------------------------------- */ void -Tcl_DStringTrunc(dsPtr, length) +Tcl_DStringSetLength(dsPtr, length) register Tcl_DString *dsPtr; /* Structure describing dynamic * string. */ int length; /* New length for dynamic string. */ @@ -1724,10 +1749,27 @@ Tcl_DStringTrunc(dsPtr, length) if (length < 0) { length = 0; } - if (length < dsPtr->length) { - dsPtr->length = length; - dsPtr->string[length] = 0; + if (length >= dsPtr->spaceAvl) { + char *newString; + + dsPtr->spaceAvl = length+1; + newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); + + /* + * SPECIAL NOTE: must use memcpy, not strcpy, to copy the string + * to a larger buffer, since there may be embedded NULLs in the + * string in some cases. + */ + + memcpy((VOID *) newString, (VOID *) dsPtr->string, + (size_t) dsPtr->length); + if (dsPtr->string != dsPtr->staticSpace) { + ckfree(dsPtr->string); + } + dsPtr->string = newString; } + dsPtr->length = length; + dsPtr->string[length] = 0; } /* @@ -1789,11 +1831,12 @@ Tcl_DStringResult(interp, dsPtr) Tcl_DString *dsPtr; /* Dynamic string that is to become * the result of interp. */ { - Tcl_FreeResult(interp); + Tcl_ResetResult(interp); if (dsPtr->string != dsPtr->staticSpace) { interp->result = dsPtr->string; - interp->freeProc = (Tcl_FreeProc *) free; + interp->freeProc = TCL_DYNAMIC; } else if (dsPtr->length < TCL_RESULT_SIZE) { + interp->result = ((Interp *) interp)->resultSpace; strcpy(interp->result, dsPtr->string); } else { Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE); @@ -1804,6 +1847,62 @@ Tcl_DStringResult(interp, dsPtr) dsPtr->staticSpace[0] = 0; } +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringGetResult -- + * + * This procedure moves the result of an interpreter into a + * dynamic string. + * + * Results: + * None. + * + * Side effects: + * The interpreter's result is cleared, and the previous contents + * of dsPtr are freed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DStringGetResult(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. */ +{ + Interp *iPtr = (Interp *) interp; + if (dsPtr->string != dsPtr->staticSpace) { + ckfree(dsPtr->string); + } + dsPtr->length = strlen(iPtr->result); + if (iPtr->freeProc != NULL) { + if ((iPtr->freeProc == TCL_DYNAMIC) + || (iPtr->freeProc == (Tcl_FreeProc *) free)) { + dsPtr->string = iPtr->result; + dsPtr->spaceAvl = dsPtr->length+1; + } else { + dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length+1)); + strcpy(dsPtr->string, iPtr->result); + (*iPtr->freeProc)(iPtr->result); + } + dsPtr->spaceAvl = dsPtr->length+1; + iPtr->freeProc = NULL; + } else { + if (dsPtr->length < TCL_DSTRING_STATIC_SIZE) { + dsPtr->string = dsPtr->staticSpace; + dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; + } else { + dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length + 1)); + dsPtr->spaceAvl = dsPtr->length + 1; + } + strcpy(dsPtr->string, iPtr->result); + } + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = 0; +} + /* *---------------------------------------------------------------------- * @@ -1826,13 +1925,10 @@ 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 { + if (TclNeedSpace(dsPtr->string, dsPtr->string + dsPtr->length)) { Tcl_DStringAppend(dsPtr, " {", -1); + } else { + Tcl_DStringAppend(dsPtr, "{", -1); } } @@ -1976,3 +2072,59 @@ TclPrecTraceProc(clientData, interp, name1, name2, flags) iPtr->pdPrec = prec; return (char *) NULL; } + +/* + *---------------------------------------------------------------------- + * + * TclNeedSpace -- + * + * This procedure checks to see whether it is appropriate to + * add a space before appending a new list element to an + * existing string. + * + * Results: + * The return value is 1 if a space is appropriate, 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclNeedSpace(start, end) + char *start; /* First character in string. */ + char *end; /* End of string (place where space will + * be added, if appropriate). */ +{ + /* + * A space is needed unless either + * (a) we're at the start of the string, or + * (b) the trailing characters of the string consist of one or more + * open curly braces preceded by a space or extending back to + * the beginning of the string. + * (c) the trailing characters of the string consist of a space + * preceded by a character other than backslash. + */ + + if (end == start) { + return 0; + } + end--; + if (*end != '{') { + if (isspace(UCHAR(*end)) && ((end == start) || (end[-1] != '\\'))) { + return 0; + } + return 1; + } + do { + if (end == start) { + return 0; + } + end--; + } while (*end == '{'); + if (isspace(UCHAR(*end))) { + return 0; + } + return 1; +} diff --git a/tcl7.3/tclVar.c b/tcl7.6/generic/tclVar.c similarity index 80% rename from tcl7.3/tclVar.c rename to tcl7.6/generic/tclVar.c index 8981cef..d7c60fc 100644 --- a/tcl7.3/tclVar.c +++ b/tcl7.6/generic/tclVar.c @@ -7,32 +7,17 @@ * 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. + * Copyright (c) 1987-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tclVar.c 1.74 96/10/08 08:26:09 */ -#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" +#include "tclPort.h" /* * The strings below are used to indicate what went wrong when a @@ -59,6 +44,15 @@ static char *danglingUpvar = "upvar refers to element in deleted array"; #define CRT_PART1 1 #define CRT_PART2 2 +/* + * The following additional flag is used internally and passed through + * to LookupVar to indicate that a procedure like Tcl_GetVar was called + * instead of Tcl_GetVar2 and the single name value hasn't yet been + * parsed into an array name and index (if any). + */ + +#define PART1_NOT_PARSED 0x10000 + /* * Forward references to procedures defined later in this file: */ @@ -75,7 +69,7 @@ static Var * LookupVar _ANSI_ARGS_((Tcl_Interp *interp, char *part1, Var **arrayPtrPtr)); static int MakeUpvar _ANSI_ARGS_((Interp *iPtr, CallFrame *framePtr, char *otherP1, - char *otherP2, char *myName)); + char *otherP2, char *myName, int flags)); static Var * NewVar _ANSI_ARGS_((void)); static ArraySearch * ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp, Var *varPtr, char *varName, char *string)); @@ -110,25 +104,74 @@ static void VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp, 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 *part1; /* If part2 isn't NULL, this is the name + * of an array. Otherwise, if the + * PART1_NOT_PARSED flag bit is set this + * is a full variable name that could + * include a parenthesized array elemnt. + * If PART1_NOT_PARSED isn't present, then + * this is the name of a scalar variable. */ char *part2; /* Name of an element within array, or NULL. */ - int flags; /* Only the TCL_GLOBAL_ONLY and - * TCL_LEAVE_ERR_MSG bits matter. */ + int flags; /* Only the TCL_GLOBAL_ONLY, TCL_LEAVE_ERR_MSG, + * and PART1_NOT_PARSED 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. */ + Var **arrayPtrPtr; /* If the name refers to an element of an + * array, *arrayPtrPtr gets filled in with + * address of array variable. Otherwise + * this is set to NULL. */ { Interp *iPtr = (Interp *) interp; Tcl_HashTable *tablePtr; Tcl_HashEntry *hPtr; Var *varPtr; int new; + char *openParen, *closeParen; /* If this procedure parses a name + * into array and index, these point + * to the parens around the index. + * Otherwise they are NULL. These + * are needed to restore the parens + * after parsing the name. */ + char *elName; /* Name of array element or NULL; + * may be same as part2, or may be + * openParen+1. */ + char *p; + + /* + * If the name hasn't been parsed into array name and index yet, + * do it now. + */ + + openParen = closeParen = NULL; + elName = part2; + if (flags & PART1_NOT_PARSED) { + for (p = part1; ; p++) { + if (*p == 0) { + elName = NULL; + break; + } + if (*p == '(') { + openParen = p; + do { + p++; + } while (*p != '\0'); + p--; + if (*p == ')') { + closeParen = p; + *openParen = 0; + elName = openParen+1; + } else { + openParen = NULL; + elName = NULL; + } + break; + } + } + } /* * Lookup part1. @@ -142,6 +185,9 @@ LookupVar(interp, part1, part2, flags, msg, create, arrayPtrPtr) } if (create & CRT_PART1) { hPtr = Tcl_CreateHashEntry(tablePtr, part1, &new); + if (openParen != NULL) { + *openParen = '('; + } if (new) { varPtr = NewVar(); Tcl_SetHashValue(hPtr, varPtr); @@ -149,6 +195,9 @@ LookupVar(interp, part1, part2, flags, msg, create, arrayPtrPtr) } } else { hPtr = Tcl_FindHashEntry(tablePtr, part1); + if (openParen != NULL) { + *openParen = '('; + } if (hPtr == NULL) { if (flags & TCL_LEAVE_ERR_MSG) { VarErrMsg(interp, part1, part2, msg, noSuchVar); @@ -161,7 +210,7 @@ LookupVar(interp, part1, part2, flags, msg, create, arrayPtrPtr) varPtr = varPtr->value.upvarPtr; } - if (part2 == NULL) { + if (elName == NULL) { return varPtr; } @@ -188,8 +237,14 @@ LookupVar(interp, part1, part2, flags, msg, create, arrayPtrPtr) return NULL; } *arrayPtrPtr = varPtr; + if (closeParen != NULL) { + *closeParen = 0; + } if (create & CRT_PART2) { - hPtr = Tcl_CreateHashEntry(varPtr->value.tablePtr, part2, &new); + hPtr = Tcl_CreateHashEntry(varPtr->value.tablePtr, elName, &new); + if (closeParen != NULL) { + *closeParen = ')'; + } if (new) { if (varPtr->searchPtr != NULL) { DeleteSearches(varPtr); @@ -199,7 +254,10 @@ LookupVar(interp, part1, part2, flags, msg, create, arrayPtrPtr) varPtr->hPtr = hPtr; } } else { - hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, part2); + hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, elName); + if (closeParen != NULL) { + *closeParen = ')'; + } if (hPtr == NULL) { if (flags & TCL_LEAVE_ERR_MSG) { VarErrMsg(interp, part1, part2, msg, noSuchElement); @@ -241,36 +299,8 @@ Tcl_GetVar(interp, varName, flags) 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); + return Tcl_GetVar2(interp, varName, (char *) NULL, + flags | PART1_NOT_PARSED); } /* @@ -305,8 +335,9 @@ Tcl_GetVar2(interp, part1, part2, flags) * 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. */ + int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, + * TCL_LEAVE_ERR_MSG, and PART1_NOT_PARSED + * bits. */ { Var *varPtr, *arrayPtr; Interp *iPtr = (Interp *) interp; @@ -326,7 +357,7 @@ Tcl_GetVar2(interp, part1, part2, flags) char *msg; msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2, - (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_READS); + (flags & (TCL_GLOBAL_ONLY|PART1_NOT_PARSED)) | TCL_TRACE_READS); if (msg != NULL) { VarErrMsg(interp, part1, part2, "read", msg); goto cleanup; @@ -341,6 +372,8 @@ Tcl_GetVar2(interp, part1, part2, flags) if ((varPtr->flags & VAR_UNDEFINED) && (arrayPtr != NULL) && !(arrayPtr->flags & VAR_UNDEFINED)) { msg = noSuchElement; + } else if (varPtr->flags & VAR_ARRAY) { + msg = isArray; } else { msg = noSuchVar; } @@ -391,36 +424,8 @@ Tcl_SetVar(interp, varName, newValue, flags) * 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); + return Tcl_SetVar2(interp, varName, (char *) NULL, newValue, + flags | PART1_NOT_PARSED); } /* @@ -458,7 +463,8 @@ Tcl_SetVar2(interp, part1, part2, newValue, flags) 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 . */ + * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG, or + * PART1_NOT_PARSED. */ { register Var *varPtr; register Interp *iPtr = (Interp *) interp; @@ -502,6 +508,30 @@ Tcl_SetVar2(interp, part1, part2, newValue, flags) varPtr->valueLength = 0; } + /* + * Call read trace if variable is being appended to. + */ + + if ((flags & TCL_APPEND_VALUE) && ((varPtr->tracePtr != NULL) + || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL)))) { + char *msg; + msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2, + (flags & (TCL_GLOBAL_ONLY|PART1_NOT_PARSED))|TCL_TRACE_READS); + if (msg != NULL) { + VarErrMsg(interp, part1, part2, "read", msg); + result = NULL; + goto cleanup; + } + } + + /* + * Ensure that the new value is not NULL; if it is, replace it with "". + */ + + if (newValue == (char *) NULL) { + newValue = ""; + } + /* * Compute how many total bytes will be needed for the variable's * new value (leave space for a separating space between list @@ -530,7 +560,7 @@ Tcl_SetVar2(interp, part1, part2, newValue, flags) newSize = 24; } - newValue = ckalloc((unsigned) newSize); + newValue = (char *) ckalloc((unsigned) newSize); if (varPtr->valueSpace > 0) { strcpy(newValue, varPtr->value.string); ckfree(varPtr->value.string); @@ -547,8 +577,7 @@ Tcl_SetVar2(interp, part1, part2, newValue, flags) if (flags & TCL_LIST_ELEMENT) { char *dst = varPtr->value.string + varPtr->valueLength; - if ((varPtr->valueLength > 0) && ((dst[-1] != '{') - || ((varPtr->valueLength > 1) && (dst[-2] == '\\')))) { + if (TclNeedSpace(varPtr->value.string, dst)) { *dst = ' '; dst++; varPtr->valueLength++; @@ -569,7 +598,8 @@ Tcl_SetVar2(interp, part1, part2, newValue, flags) char *msg; msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2, - (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_WRITES); + (flags & (TCL_GLOBAL_ONLY|PART1_NOT_PARSED)) + | TCL_TRACE_WRITES); if (msg != NULL) { VarErrMsg(interp, part1, part2, "set", msg); result = NULL; @@ -631,36 +661,8 @@ Tcl_UnsetVar(interp, varName, flags) 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); + return Tcl_UnsetVar2(interp, varName, (char *) NULL, + flags | PART1_NOT_PARSED); } /* @@ -691,7 +693,8 @@ Tcl_UnsetVar2(interp, part1, part2, flags) 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. */ + * TCL_GLOBAL_ONLY, TCL_LEAVE_ERR_MSG, + * or PART1_NOT_PARSED. */ { Var *varPtr, dummyVar; Interp *iPtr = (Interp *) interp; @@ -705,7 +708,7 @@ Tcl_UnsetVar2(interp, part1, part2, flags) } result = (varPtr->flags & VAR_UNDEFINED) ? TCL_ERROR : TCL_OK; - if ((part2 != NULL) && (arrayPtr->searchPtr != NULL)) { + if ((arrayPtr != NULL) && (arrayPtr->searchPtr != NULL)) { DeleteSearches(arrayPtr); } @@ -726,6 +729,7 @@ Tcl_UnsetVar2(interp, part1, part2, flags) varPtr->valueSpace = 0; varPtr->flags = VAR_UNDEFINED; varPtr->tracePtr = NULL; + varPtr->searchPtr = NULL; /* * Call trace procedures for the variable being deleted and delete @@ -742,7 +746,8 @@ Tcl_UnsetVar2(interp, part1, part2, flags) varPtr->refCount++; dummyVar.flags &= ~VAR_TRACE_ACTIVE; (void) CallTraces(iPtr, arrayPtr, &dummyVar, part1, part2, - (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_UNSETS); + (flags & (TCL_GLOBAL_ONLY|PART1_NOT_PARSED)) + | TCL_TRACE_UNSETS); while (dummyVar.tracePtr != NULL) { VarTrace *tracePtr = dummyVar.tracePtr; dummyVar.tracePtr = tracePtr->nextPtr; @@ -773,7 +778,7 @@ Tcl_UnsetVar2(interp, part1, part2, flags) if (result == TCL_ERROR) { if (flags & TCL_LEAVE_ERR_MSG) { VarErrMsg(interp, part1, part2, "unset", - (part2 == NULL) ? noSuchVar : noSuchElement); + (arrayPtr == NULL) ? noSuchVar : noSuchElement); } } @@ -820,38 +825,8 @@ Tcl_TraceVar(interp, varName, flags, proc, clientData) * 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); + return Tcl_TraceVar2(interp, varName, (char *) NULL, + flags | PART1_NOT_PARSED, proc, clientData); } /* @@ -885,7 +860,8 @@ Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData) * 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_TRACE_UNSETS, TCL_GLOBAL_ONLY, and + * PART1_NOT_PARSED. */ Tcl_VarTraceProc *proc; /* Procedure to call when specified ops are * invoked upon varName. */ ClientData clientData; /* Arbitrary argument to pass to proc. */ @@ -943,35 +919,8 @@ Tcl_UntraceVar(interp, varName, flags, proc, clientData) 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(interp, varName, (char *) NULL, flags | PART1_NOT_PARSED, + proc, clientData); } /* @@ -1002,7 +951,8 @@ Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) 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_TRACE_UNSETS, TCL_GLOBAL_ONLY, and + * PART1_NOT_PARSED. */ Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */ ClientData clientData; /* Arbitrary argument to pass to proc. */ { @@ -1012,8 +962,9 @@ Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) Interp *iPtr = (Interp *) interp; ActiveVarTrace *activePtr; - varPtr = LookupVar(interp, part1, part2, flags & TCL_GLOBAL_ONLY, - (char *) NULL, 0, &arrayPtr); + varPtr = LookupVar(interp, part1, part2, + flags & (TCL_GLOBAL_ONLY|PART1_NOT_PARSED), (char *) NULL, 0, + &arrayPtr); if (varPtr == NULL) { return; } @@ -1098,38 +1049,8 @@ Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData) * 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); + return Tcl_VarTraceInfo2(interp, varName, (char *) NULL, + flags | PART1_NOT_PARSED, proc, prevClientData); } /* @@ -1156,7 +1077,8 @@ Tcl_VarTraceInfo2(interp, part1, part2, flags, proc, prevClientData) 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. */ + int flags; /* OR-ed combination of TCL_GLOBAL_ONLY and + * PART1_NOT_PARSED. */ Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */ ClientData prevClientData; /* If non-NULL, gives last value returned * by this procedure, so this call will @@ -1167,8 +1089,9 @@ Tcl_VarTraceInfo2(interp, part1, part2, flags, proc, prevClientData) register VarTrace *tracePtr; Var *varPtr, *arrayPtr; - varPtr = LookupVar(interp, part1, part2, flags & TCL_GLOBAL_ONLY, - (char *) NULL, 0, &arrayPtr); + varPtr = LookupVar(interp, part1, part2, + flags & (TCL_GLOBAL_ONLY|PART1_NOT_PARSED), (char *) NULL, 0, + &arrayPtr); if (varPtr == NULL) { return NULL; } @@ -1223,7 +1146,8 @@ Tcl_SetCmd(dummy, interp, argc, argv) if (argc == 2) { char *value; - value = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG); + value = Tcl_GetVar2(interp, argv[1], (char *) NULL, + TCL_LEAVE_ERR_MSG|PART1_NOT_PARSED); if (value == NULL) { return TCL_ERROR; } @@ -1232,7 +1156,8 @@ Tcl_SetCmd(dummy, interp, argc, argv) } else if (argc == 3) { char *result; - result = Tcl_SetVar(interp, argv[1], argv[2], TCL_LEAVE_ERR_MSG); + result = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[2], + TCL_LEAVE_ERR_MSG|PART1_NOT_PARSED); if (result == NULL) { return TCL_ERROR; } @@ -1278,7 +1203,8 @@ Tcl_UnsetCmd(dummy, interp, argc, argv) return TCL_ERROR; } for (i = 1; i < argc; i++) { - if (Tcl_UnsetVar(interp, argv[i], TCL_LEAVE_ERR_MSG) != TCL_OK) { + if (Tcl_UnsetVar2(interp, argv[i], (char *) NULL, + TCL_LEAVE_ERR_MSG|PART1_NOT_PARSED) != TCL_OK) { return TCL_ERROR; } } @@ -1314,15 +1240,24 @@ Tcl_AppendCmd(dummy, interp, argc, argv) char *result = NULL; /* (Initialization only needed to keep * the compiler from complaining) */ - if (argc < 3) { + if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " varName value ?value ...?\"", (char *) NULL); + argv[0], " varName ?value value ...?\"", (char *) NULL); return TCL_ERROR; } + if (argc == 2) { + result = Tcl_GetVar2(interp, argv[1], (char *) NULL, + TCL_LEAVE_ERR_MSG|PART1_NOT_PARSED); + if (result == NULL) { + return TCL_ERROR; + } + interp->result = result; + return TCL_OK; + } for (i = 2; i < argc; i++) { - result = Tcl_SetVar(interp, argv[1], argv[i], - TCL_APPEND_VALUE|TCL_LEAVE_ERR_MSG); + result = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[i], + TCL_APPEND_VALUE|TCL_LEAVE_ERR_MSG|PART1_NOT_PARSED); if (result == NULL) { return TCL_ERROR; } @@ -1360,15 +1295,25 @@ Tcl_LappendCmd(dummy, interp, argc, argv) char *result = NULL; /* (Initialization only needed to keep * the compiler from complaining) */ - if (argc < 3) { + if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " varName value ?value ...?\"", (char *) NULL); + argv[0], " varName ?value value ...?\"", (char *) NULL); return TCL_ERROR; } + if (argc == 2) { + result = Tcl_GetVar2(interp, argv[1], (char *) NULL, + TCL_LEAVE_ERR_MSG|PART1_NOT_PARSED); + if (result == NULL) { + return TCL_ERROR; + } + interp->result = result; + return TCL_OK; + } for (i = 2; i < argc; i++) { - result = Tcl_SetVar(interp, argv[1], argv[i], - TCL_APPEND_VALUE|TCL_LIST_ELEMENT|TCL_LEAVE_ERR_MSG); + result = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[i], + TCL_APPEND_VALUE|TCL_LIST_ELEMENT|TCL_LEAVE_ERR_MSG + |PART1_NOT_PARSED); if (result == NULL) { return TCL_ERROR; } @@ -1402,9 +1347,10 @@ Tcl_ArrayCmd(dummy, interp, argc, argv) int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { - int length; - char c; - Var *varPtr; + int c, notArray; + size_t length; + Var *varPtr = NULL; /* Initialization needed only to prevent + * compiler warning. */ Tcl_HashEntry *hPtr; Interp *iPtr = (Interp *) interp; @@ -1423,18 +1369,17 @@ Tcl_ArrayCmd(dummy, interp, argc, argv) } else { hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]); } + notArray = 0; 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; + notArray = 1; + } else { + varPtr = (Var *) Tcl_GetHashValue(hPtr); + if (varPtr->flags & VAR_UPVAR) { + varPtr = varPtr->value.upvarPtr; + } + if (!(varPtr->flags & VAR_ARRAY)) { + notArray = 1; + } } /* @@ -1451,6 +1396,9 @@ Tcl_ArrayCmd(dummy, interp, argc, argv) argv[0], " anymore arrayName searchId\"", (char *) NULL); return TCL_ERROR; } + if (notArray) { + goto error; + } searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]); if (searchPtr == NULL) { return TCL_ERROR; @@ -1480,6 +1428,9 @@ Tcl_ArrayCmd(dummy, interp, argc, argv) argv[0], " donesearch arrayName searchId\"", (char *) NULL); return TCL_ERROR; } + if (notArray) { + goto error; + } searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]); if (searchPtr == NULL) { return TCL_ERROR; @@ -1495,24 +1446,64 @@ Tcl_ArrayCmd(dummy, interp, argc, argv) } } ckfree((char *) searchPtr); - } else if ((c == 'n') && (strncmp(argv[1], "names", length) == 0) - && (length >= 2)) { - Tcl_HashSearch search; - Var *varPtr2; - + } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " names arrayName\"", (char *) NULL); + argv[0], " exists arrayName\"", (char *) NULL); return TCL_ERROR; } + interp->result = (notArray) ? "0" : "1"; + } else if ((c == 'g') && (strncmp(argv[1], "get", length) == 0)) { + Tcl_HashSearch search; + Var *varPtr2; + char *name; + + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " get arrayName ?pattern?\"", (char *) NULL); + return TCL_ERROR; + } + if (notArray) { + return TCL_OK; + } 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)); + name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); + if ((argc == 4) && !Tcl_StringMatch(name, argv[3])) { + continue; + } + Tcl_AppendElement(interp, name); + Tcl_AppendElement(interp, varPtr2->value.string); + } + } else if ((c == 'n') && (strncmp(argv[1], "names", length) == 0) + && (length >= 2)) { + Tcl_HashSearch search; + Var *varPtr2; + char *name; + + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " names arrayName ?pattern?\"", (char *) NULL); + return TCL_ERROR; + } + if (notArray) { + return TCL_OK; + } + 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; + } + name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); + if ((argc == 4) && !Tcl_StringMatch(name, argv[3])) { + continue; + } + Tcl_AppendElement(interp, name); } } else if ((c == 'n') && (strncmp(argv[1], "nextelement", length) == 0) && (length >= 2)) { @@ -1525,6 +1516,9 @@ Tcl_ArrayCmd(dummy, interp, argc, argv) (char *) NULL); return TCL_ERROR; } + if (notArray) { + goto error; + } searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]); if (searchPtr == NULL) { return TCL_ERROR; @@ -1547,6 +1541,35 @@ Tcl_ArrayCmd(dummy, interp, argc, argv) } } interp->result = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); + } else if ((c == 's') && (strncmp(argv[1], "set", length) == 0) + && (length >= 2)) { + char **valueArgv; + int valueArgc, i, result; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " set arrayName list\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_SplitList(interp, argv[3], &valueArgc, &valueArgv) != TCL_OK) { + return TCL_ERROR; + } + result = TCL_OK; + if (valueArgc & 1) { + interp->result = "list must have an even number of elements"; + result = TCL_ERROR; + goto setDone; + } + for (i = 0; i < valueArgc; i += 2) { + if (Tcl_SetVar2(interp, argv[2], valueArgv[i], valueArgv[i+1], + TCL_LEAVE_ERR_MSG) == NULL) { + result = TCL_ERROR; + break; + } + } + setDone: + ckfree((char *) valueArgv); + return result; } else if ((c == 's') && (strncmp(argv[1], "size", length) == 0) && (length >= 2)) { Tcl_HashSearch search; @@ -1559,13 +1582,15 @@ Tcl_ArrayCmd(dummy, interp, argc, argv) 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; + if (!notArray) { + 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++; } - size++; } sprintf(interp->result, "%d", size); } else if ((c == 's') && (strncmp(argv[1], "startsearch", length) == 0) @@ -1577,6 +1602,9 @@ Tcl_ArrayCmd(dummy, interp, argc, argv) argv[0], " startsearch arrayName\"", (char *) NULL); return TCL_ERROR; } + if (notArray) { + goto error; + } searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch)); if (varPtr->searchPtr == NULL) { searchPtr->id = 1; @@ -1596,11 +1624,17 @@ Tcl_ArrayCmd(dummy, interp, argc, argv) varPtr->searchPtr = searchPtr; } else { Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": should be anymore, donesearch, names, nextelement, ", - "size, or startsearch", (char *) NULL); + "\": should be anymore, donesearch, exists, ", + "get, names, nextelement, ", + "set, size, or startsearch", (char *) NULL); return TCL_ERROR; } return TCL_OK; + + error: + Tcl_AppendResult(interp, "\"", argv[2], "\" isn't an array", + (char *) NULL); + return TCL_ERROR; } /* @@ -1619,13 +1653,13 @@ Tcl_ArrayCmd(dummy, interp, argc, argv) * 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. + * link. * *---------------------------------------------------------------------- */ static int -MakeUpvar(iPtr, framePtr, otherP1, otherP2, myName) +MakeUpvar(iPtr, framePtr, otherP1, otherP2, myName, flags) Interp *iPtr; /* Interpreter containing variables. Used * for error messages, too. */ CallFrame *framePtr; /* Call frame containing "other" variable. @@ -1634,6 +1668,8 @@ MakeUpvar(iPtr, framePtr, otherP1, otherP2, myName) char *myName; /* Name of variable in local table, which * will refer to otherP1/P2. Must be a * scalar. */ + int flags; /* 0 or TCL_GLOBAL_ONLY: indicates scope of + * myName. */ { Tcl_HashEntry *hPtr; Var *otherPtr, *varPtr, *arrayPtr; @@ -1653,10 +1689,10 @@ MakeUpvar(iPtr, framePtr, otherP1, otherP2, myName) if (otherPtr == NULL) { return TCL_ERROR; } - if (iPtr->varFramePtr != NULL) { - hPtr = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable, myName, &new); - } else { + if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) { hPtr = Tcl_CreateHashEntry(&iPtr->globalTable, myName, &new); + } else { + hPtr = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable, myName, &new); } if (new) { varPtr = NewVar(); @@ -1664,12 +1700,17 @@ MakeUpvar(iPtr, framePtr, otherP1, otherP2, myName) 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. + * The variable already exists. Make sure that this variable + * isn't also "otherVar" (avoid circular links). Also, 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 == otherPtr) { + iPtr->result = "can't upvar from variable to itself"; + return TCL_ERROR; + } if (varPtr->flags & VAR_UPVAR) { Var *upvarPtr; @@ -1685,6 +1726,10 @@ MakeUpvar(iPtr, framePtr, otherP1, otherP2, myName) Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName, "\" already exists", (char *) NULL); return TCL_ERROR; + } else if (varPtr->tracePtr != NULL) { + Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName, + "\" has traces: can't use for upvar", (char *) NULL); + return TCL_ERROR; } } varPtr->flags = (varPtr->flags & ~VAR_UNDEFINED) | VAR_UPVAR; @@ -1693,6 +1738,122 @@ MakeUpvar(iPtr, framePtr, otherP1, otherP2, myName) return TCL_OK; } +/* + *---------------------------------------------------------------------- + * + * Tcl_UpVar -- + * + * This procedure links one variable to another, just like + * the "upvar" command. + * + * Results: + * A standard Tcl completion code. If an error occurs then + * an error message is left in interp->result. + * + * Side effects: + * The variable in frameName whose name is given by varName becomes + * accessible under the name localName, so that references to + * localName are redirected to the other variable like a symbolic + * link. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_UpVar(interp, frameName, varName, localName, flags) + Tcl_Interp *interp; /* Command interpreter in which varName is + * to be looked up. */ + char *frameName; /* Name of the frame containing the source + * variable, such as "1" or "#0". */ + char *varName; /* Name of a variable in interp. May be + * either a scalar name or an element + * in an array. */ + char *localName; /* Destination variable name. */ + int flags; /* Either 0 or TCL_GLOBAL_ONLY; indicates + * whether localName is local or global. */ +{ + int result; + CallFrame *framePtr; + register char *p; + + result = TclGetFrame(interp, frameName, &framePtr); + if (result == -1) { + return TCL_ERROR; + } + + /* + * Figure out whether this is an array reference, then call + * MakeUpvar to do all the real work. + */ + + for (p = varName; *p != '\0'; p++) { + if (*p == '(') { + char *openParen = p; + + do { + p++; + } while (*p != '\0'); + p--; + if (*p != ')') { + goto scalar; + } + *openParen = '\0'; + *p = '\0'; + result = MakeUpvar((Interp *) interp, framePtr, varName, + openParen+1, localName, flags); + *openParen = '('; + *p = ')'; + return result; + } + } + + scalar: + return MakeUpvar((Interp *) interp, framePtr, varName, (char *) NULL, + localName, flags); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UpVar2 -- + * + * This procedure links one variable to another, just like + * the "upvar" command. + * + * Results: + * A standard Tcl completion code. If an error occurs then + * an error message is left in interp->result. + * + * Side effects: + * The variable in frameName whose name is given by part1 and + * part2 becomes accessible under the name localName, so that + * references to localName are redirected to the other variable + * like a symbolic link. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_UpVar2(interp, frameName, part1, part2, localName, flags) + Tcl_Interp *interp; /* Interpreter containing variables. Used + * for error messages too. */ + char *frameName; /* Name of the frame containing the source + * variable, such as "1" or "#0". */ + char *part1, *part2; /* Two parts of source variable name. */ + char *localName; /* Destination variable name. */ + int flags; /* TCL_GLOBAL_ONLY or 0. */ +{ + int result; + CallFrame *framePtr; + + result = TclGetFrame(interp, frameName, &framePtr); + if (result == -1) { + return TCL_ERROR; + } + return MakeUpvar((Interp *) interp, framePtr, part1, part2, + localName, flags); +} + /* *---------------------------------------------------------------------- * @@ -1730,7 +1891,7 @@ Tcl_GlobalCmd(dummy, interp, argc, argv) } for (argc--, argv++; argc > 0; argc--, argv++) { - if (MakeUpvar(iPtr, (CallFrame *) NULL, *argv, (char *) NULL, *argv) + if (MakeUpvar(iPtr, (CallFrame *) NULL, *argv, (char *) NULL, *argv, 0) != TCL_OK) { return TCL_ERROR; } @@ -1800,7 +1961,7 @@ Tcl_UpvarCmd(dummy, interp, argc, argv) for ( ; argc > 0; argc -= 2, argv += 2) { for (p = argv[0]; *p != 0; p++) { if (*p == '(') { - char *open = p; + char *openParen = p; do { p++; @@ -1809,16 +1970,17 @@ Tcl_UpvarCmd(dummy, interp, argc, argv) if (*p != ')') { goto scalar; } - *open = '\0'; + *openParen = '\0'; *p = '\0'; - result = MakeUpvar(iPtr, framePtr, argv[0], open+1, argv[1]); - *open = '('; + result = MakeUpvar(iPtr, framePtr, argv[0], openParen+1, + argv[1], 0); + *openParen = '('; *p = ')'; goto checkResult; } } scalar: - result = MakeUpvar(iPtr, framePtr, argv[0], (char *) NULL, argv[1]); + result = MakeUpvar(iPtr, framePtr, argv[0], (char *) NULL, argv[1], 0); checkResult: if (result != TCL_OK) { @@ -1867,11 +2029,16 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) * indicates what's happening to * variable, plus other stuff like * TCL_GLOBAL_ONLY and - * TCL_INTERP_DESTROYED. */ + * TCL_INTERP_DESTROYED. May also + * contain PART1_NOT_PARSEd, which + * should not be passed through + * to callbacks. */ { register VarTrace *tracePtr; ActiveVarTrace active; - char *result; + char *result, *openParen, *p; + Tcl_DString nameCopy; + int copiedName; /* * If there are already similar trace procedures active for the @@ -1884,6 +2051,42 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) varPtr->flags |= VAR_TRACE_ACTIVE; varPtr->refCount++; + /* + * If the variable name hasn't been parsed into array name and + * element, do it here. If there really is an array element, + * make a copy of the original name so that NULLs can be + * inserted into it to separate the names (can't modify the name + * string in place, because the string might get used by the + * callbacks we invoke). + */ + + copiedName = 0; + if (flags & PART1_NOT_PARSED) { + for (p = part1; ; p++) { + if (*p == 0) { + break; + } + if (*p == '(') { + openParen = p; + do { + p++; + } while (*p != '\0'); + p--; + if (*p == ')') { + Tcl_DStringInit(&nameCopy); + Tcl_DStringAppend(&nameCopy, part1, (p-part1)); + part2 = Tcl_DStringValue(&nameCopy) + + (openParen + 1 - part1); + part2[-1] = 0; + part1 = Tcl_DStringValue(&nameCopy); + copiedName = 1; + } + break; + } + } + } + flags &= ~PART1_NOT_PARSED; + /* * Invoke traces on the array containing the variable, if relevant. */ @@ -1946,6 +2149,9 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) if (arrayPtr != NULL) { arrayPtr->refCount--; } + if (copiedName) { + Tcl_DStringFree(&nameCopy); + } varPtr->flags &= ~VAR_TRACE_ACTIVE; varPtr->refCount--; iPtr->activeTracePtr = active.nextPtr; @@ -2133,15 +2339,23 @@ TclDeleteVars(iPtr, tablePtr) /* * 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. + * the reference count on the variable referred to, and free + * the referenced variable if it's no longer needed. Don't delete + * the hash entry for the other variable if it's in the same table + * as us: this will happen automatically later on. */ if (varPtr->flags & VAR_UPVAR) { upvarPtr = varPtr->value.upvarPtr; upvarPtr->refCount--; - if (upvarPtr->flags & VAR_UNDEFINED) { - CleanupVar(upvarPtr, (Var *) NULL); + if ((upvarPtr->refCount == 0) && (upvarPtr->flags & VAR_UNDEFINED) + && (upvarPtr->tracePtr == NULL)) { + if (upvarPtr->hPtr == NULL) { + ckfree((char *) upvarPtr); + } else if (upvarPtr->hPtr->tablePtr != tablePtr) { + Tcl_DeleteHashEntry(upvarPtr->hPtr); + ckfree((char *) upvarPtr); + } } } @@ -2181,7 +2395,7 @@ TclDeleteVars(iPtr, tablePtr) */ if (iPtr->result == varPtr->value.string) { - iPtr->freeProc = (Tcl_FreeProc *) free; + iPtr->freeProc = TCL_DYNAMIC; } else { ckfree(varPtr->value.string); } @@ -2190,6 +2404,13 @@ TclDeleteVars(iPtr, tablePtr) varPtr->hPtr = NULL; varPtr->tracePtr = NULL; varPtr->flags = VAR_UNDEFINED; + + /* + * Recycle the variable's memory space if there aren't any upvar's + * pointing to it. If there are upvars, then the variable will + * get freed when the last upvar goes away. + */ + if (varPtr->refCount == 0) { ckfree((char *) varPtr); } @@ -2248,7 +2469,7 @@ DeleteArray(iPtr, arrayName, varPtr, flags) */ if (iPtr->result == elPtr->value.string) { - iPtr->freeProc = (Tcl_FreeProc *) free; + iPtr->freeProc = TCL_DYNAMIC; } else { ckfree(elPtr->value.string); } diff --git a/tcl7.6/library/init.tcl b/tcl7.6/library/init.tcl new file mode 100644 index 0000000..c2f057a --- /dev/null +++ b/tcl7.6/library/init.tcl @@ -0,0 +1,634 @@ +# init.tcl -- +# +# Default system startup file for Tcl-based applications. Defines +# "unknown" procedure and auto-load facilities. +# +# SCCS: @(#) init.tcl 1.66 96/10/06 14:29:28 +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +if {[info commands package] == ""} { + error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" +} +package require -exact Tcl 7.6 +if [catch {set auto_path $env(TCLLIBPATH)}] { + set auto_path "" +} +if {[lsearch -exact $auto_path [info library]] < 0} { + lappend auto_path [info library] +} +catch { + foreach dir $tcl_pkgPath { + if {[lsearch -exact $auto_path $dir] < 0} { + lappend auto_path $dir + } + } + unset dir +} +package unknown tclPkgUnknown +if {[info commands exec] == ""} { + + # Some machines, such as the Macintosh, do not have exec. Also, on all + # platforms, safe interpreters do not have exec. + + set auto_noexec 1 +} +set errorCode "" +set errorInfo "" + +# unknown -- +# This procedure is called when a Tcl command is invoked that doesn't +# exist in the interpreter. It takes the following steps to make the +# command available: +# +# 1. See if the autoload facility can locate the command in a +# Tcl script file. If so, load it and execute it. +# 2. If the command was invoked interactively at top-level: +# (a) see if the command exists as an executable UNIX program. +# If so, "exec" the command. +# (b) see if the command requests csh-like history substitution +# in one of the common forms !!, !, or ^old^new. If +# so, emulate csh's history substitution. +# (c) see if the command is a unique abbreviation for another +# command. If so, invoke the command. +# +# Arguments: +# args - A list whose elements are the words of the original +# command, including the command name. + +proc unknown args { + global auto_noexec auto_noload env unknown_pending tcl_interactive + global errorCode errorInfo + + # Save the values of errorCode and errorInfo variables, since they + # may get modified if caught errors occur below. The variables will + # be restored just before re-executing the missing command. + + set savedErrorCode $errorCode + set savedErrorInfo $errorInfo + 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)] { + 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 -errorcode $errorCode \ + "error while autoloading \"$name\": $msg" + } + if ![array size unknown_pending] { + unset unknown_pending + } + if $msg { + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + set code [catch {uplevel $args} msg] + if {$code == 1} { + # + # Strip the last five lines off the error stack (they're + # from the "uplevel" command). + # + + set new [split $errorInfo \n] + set new [join [lrange $new 0 [expr [llength $new] - 6]] \n] + return -code error -errorcode $errorCode \ + -errorinfo $new $msg + } else { + return -code $code $msg + } + } + } + if {([info level] == 1) && ([info script] == "") \ + && [info exists tcl_interactive] && $tcl_interactive} { + if ![info exists auto_noexec] { + set new [auto_execok $name] + if {$new != ""} { + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + return [uplevel exec >&@stdout <@stdin $new [lrange $args 1 end]] + } + } + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + 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. +# +# Arguments: +# cmd - Name of the command to find and load. + +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 [expr {[info commands $cmd] != ""}] + } + if ![info exists auto_path] { + return 0 + } + if [info exists auto_oldpath] { + if {$auto_oldpath == $auto_path} { + return 0 + } + } + set auto_oldpath $auto_path + for {set i [expr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} { + set dir [lindex $auto_path $i] + set f "" + if [catch {set f [open [file join $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 [file join $dir [lindex $line 1]]" + } + } else { + error "[file join $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 +} + +if {[string compare $tcl_platform(platform) windows] == 0} { + +# auto_execok -- +# +# Returns string that indicates name of program to execute if +# name corresponds to a shell builtin or an executable in the +# Windows search path, or "" otherwise. Builds an associative +# array auto_execs that caches information about previous checks, +# for speed. +# +# Arguments: +# name - Name of a command. + +# Windows version. +# +# Note that info executable doesn't work under Windows, so we have to +# look for files with .exe, .com, or .bat extensions. Also, the path +# may be in the Path or PATH environment variables, and path +# components are separated with semicolons, not colons as under Unix. +# +proc auto_execok name { + global auto_execs env tcl_platform + + if [info exists auto_execs($name)] { + return $auto_execs($name) + } + set auto_execs($name) "" + + if {[lsearch -exact {cls copy date del erase dir echo mkdir md rename + ren rmdir rd time type ver vol} $name] != -1} { + if {[info exists env(COMSPEC)]} { + set comspec $env(COMSPEC) + } elseif {[info exists env(ComSpec)]} { + set comspec $env(ComSpec) + } elseif {$tcl_platform(os) == "Windows NT"} { + set comspec "cmd.exe" + } else { + set comspec "command.com" + } + return [set auto_execs($name) [list $comspec /c $name]] + } + + if {[llength [file split $name]] != 1} { + foreach ext {{} .com .exe .bat} { + set file ${name}${ext} + if {[file exists $file] && ![file isdirectory $file]} { + return [set auto_execs($name) $file] + } + } + return "" + } + + set path "[file dirname [info nameof]];.;" + if {[info exists env(WINDIR)]} { + set windir $env(WINDIR) + } elseif {[info exists env(windir)]} { + set windir $env(windir) + } + if {[info exists windir]} { + if {$tcl_platform(os) == "Windows NT"} { + append path "$windir/system32;" + } + append path "$windir/system;$windir;" + } + + if {! [info exists env(PATH)]} { + if [info exists env(Path)] { + append path $env(Path) + } else { + return "" + } + } else { + append path $env(PATH) + } + + foreach dir [split $path {;}] { + if {$dir == ""} { + set dir . + } + foreach ext {{} .com .exe .bat} { + set file [file join $dir ${name}${ext}] + if {[file exists $file] && ![file isdirectory $file]} { + return [set auto_execs($name) $file] + } + } + } + return "" +} + +} else { + +# auto_execok -- +# +# Returns string that indicates name of program to execute if +# name corresponds to an executable in the path. Builds an associative +# array auto_execs that caches information about previous checks, +# for speed. +# +# Arguments: +# name - Name of a command. + +# Unix version. +# +proc auto_execok name { + global auto_execs env + + if [info exists auto_execs($name)] { + return $auto_execs($name) + } + set auto_execs($name) "" + if {[llength [file split $name]] != 1} { + if {[file executable $name] && ![file isdirectory $name]} { + set auto_execs($name) $name + } + return $auto_execs($name) + } + foreach dir [split $env(PATH) :] { + if {$dir == ""} { + set dir . + } + set file [file join $dir $name] + if {[file executable $file] && ![file isdirectory $file]} { + set auto_execs($name) $file + return $file + } + } + return "" +} + +} +# 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 defined in this file. +# +# Arguments: +# None. + +proc auto_reset {} { + global auto_execs auto_index auto_oldpath + foreach p [info procs] { + if {[info exists auto_index($p)] && ![string match auto_* $p] + && ([lsearch -exact {unknown pkg_mkIndex tclPkgSetup + tclPkgUnknown} $p] < 0)} { + 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, +# followed by any number of glob patterns to use in that directory to +# locate all of the relevant files. +# +# Arguments: +# dir - Name of the directory in which to create an index. +# args - Any number of additional arguments giving the +# names of files within dir. If no additional +# are given auto_mkindex will look for *.tcl. + +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" + if {$args == ""} { + set args *.tcl + } + 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 " \[list source \[file join \$dir [list $file]\]\]\n" + } + } + close $f + } msg] + if $error { + set code $errorCode + set info $errorInfo + catch {close $f} + cd $oldDir + error $msg $info $code + } + } + set f "" + set error [catch { + set f [open tclIndex w] + puts $f $index nonewline + close $f + cd $oldDir + } msg] + if $error { + set code $errorCode + set info $errorInfo + catch {close $f} + cd $oldDir + error $msg $info $code + } +} + +# pkg_mkIndex -- +# This procedure creates a package index in a given directory. The +# package index consists of a "pkgIndex.tcl" file whose contents are +# a Tcl script that sets up package information with "package require" +# commands. The commands describe all of the packages defined by the +# files given as arguments. +# +# Arguments: +# dir - Name of the directory in which to create the index. +# args - Any number of additional arguments, each giving +# a glob pattern that matches the names of one or +# more shared libraries or Tcl script files in +# dir. + +proc pkg_mkIndex {dir args} { + global errorCode errorInfo + append index "# Tcl package index file, version 1.0\n" + append index "# This file is generated by the \"pkg_mkIndex\" command\n" + append index "# and sourced either when an application starts up or\n" + append index "# by a \"package unknown\" script. It invokes the\n" + append index "# \"package ifneeded\" command to set up package-related\n" + append index "# information so that packages will be loaded automatically\n" + append index "# in response to \"package require\" commands. When this\n" + append index "# script is sourced, the variable \$dir must contain the\n" + append index "# full path name of this file's directory.\n" + set oldDir [pwd] + cd $dir + foreach file [eval glob $args] { + # For each file, figure out what commands and packages it provides. + # To do this, create a child interpreter, load the file into the + # interpreter, and get a list of the new commands and packages + # that are defined. Define an empty "package unknown" script so + # that there are no recursive package inclusions. + + set c [interp create] + + # If Tk is loaded in the parent interpreter, load it into the + # child also, in case the extension depends on it. + + foreach pkg [info loaded] { + if {[lindex $pkg 1] == "Tk"} { + $c eval {set argv {-geometry +0+0}} + load [lindex $pkg 0] Tk $c + break + } + } + $c eval [list set file $file] + if [catch { + $c eval { + proc dummy args {} + package unknown dummy + set origCmds [info commands] + set dir "" ;# in case file is pkgIndex.tcl + set pkgs "" + + # Try to load the file if it has the shared library extension, + # otherwise source it. It's important not to try to load + # files that aren't shared libraries, because on some systems + # (like SunOS) the loader will abort the whole application + # when it gets an error. + + if {[string compare [file extension $file] \ + [info sharedlibextension]] == 0} { + + # The "file join ." command below is necessary. Without + # it, if the file name has no \'s and we're on UNIX, the + # load command will invoke the LD_LIBRARY_PATH search + # mechanism, which could cause the wrong file to be used. + + load [file join . $file] + set type load + } else { + source $file + set type source + } + foreach i [info commands] { + set cmds($i) 1 + } + foreach i $origCmds { + catch {unset cmds($i)} + } + foreach i [package names] { + if {([string compare [package provide $i] ""] != 0) + && ([string compare $i Tcl] != 0) + && ([string compare $i Tk] != 0)} { + lappend pkgs [list $i [package provide $i]] + } + } + } + } msg] { + puts "error while loading or sourcing $file: $msg" + } + foreach pkg [$c eval set pkgs] { + lappend files($pkg) [list $file [$c eval set type] \ + [lsort [$c eval array names cmds]]] + } + interp delete $c + } + foreach pkg [lsort [array names files]] { + append index "\npackage ifneeded $pkg\ + \[list tclPkgSetup \$dir [lrange $pkg 0 0] [lrange $pkg 1 1]\ + [list $files($pkg)]\]" + } + set f [open pkgIndex.tcl w] + puts $f $index + close $f + cd $oldDir +} + +# tclPkgSetup -- +# This is a utility procedure use by pkgIndex.tcl files. It is invoked +# as part of a "package ifneeded" script. It calls "package provide" +# to indicate that a package is available, then sets entries in the +# auto_index array so that the package's files will be auto-loaded when +# the commands are used. +# +# Arguments: +# dir - Directory containing all the files for this package. +# pkg - Name of the package (no version number). +# version - Version number for the package, such as 2.1.3. +# files - List of files that constitute the package. Each +# element is a sub-list with three elements. The first +# is the name of a file relative to $dir, the second is +# "load" or "source", indicating whether the file is a +# loadable binary or a script to source, and the third +# is a list of commands defined by this file. + +proc tclPkgSetup {dir pkg version files} { + global auto_index + + package provide $pkg $version + foreach fileInfo $files { + set f [lindex $fileInfo 0] + set type [lindex $fileInfo 1] + foreach cmd [lindex $fileInfo 2] { + if {$type == "load"} { + set auto_index($cmd) [list load [file join $dir $f] $pkg] + } else { + set auto_index($cmd) [list source [file join $dir $f]] + } + } + } +} + +# tclMacPkgSearch -- +# The procedure is used on the Macintosh to search a given directory for files +# with a TEXT resource named "pkgIndex". If it exists it is sourced in to the +# interpreter to setup the package database. + +proc tclMacPkgSearch {dir} { + foreach x [glob -nocomplain [file join $dir *.shlb]] { + if [file isfile $x] { + set res [resource open $x] + foreach y [resource list TEXT $res] { + if {$y == "pkgIndex"} {source -rsrc pkgIndex} + } + resource close $res + } + } +} + +# tclPkgUnknown -- +# This procedure provides the default for the "package unknown" function. +# It is invoked when a package that's needed can't be found. It scans +# the auto_path directories and their immediate children looking for +# pkgIndex.tcl files and sources any such files that are found to setup +# the package database. (On the Macintosh we also search for pkgIndex +# TEXT resources in all files.) +# +# Arguments: +# name - Name of desired package. Not used. +# version - Version of desired package. Not used. +# exact - Either "-exact" or omitted. Not used. + +proc tclPkgUnknown {name version {exact {}}} { + global auto_path tcl_platform env + + if ![info exists auto_path] { + return + } + for {set i [expr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} { + set dir [lindex $auto_path $i] + set file [file join $dir pkgIndex.tcl] + if [file readable $file] { + source $file + } + foreach file [glob -nocomplain [file join $dir * pkgIndex.tcl]] { + if [file readable $file] { + set dir [file dirname $file] + source $file + } + } + # On the Macintosh we also look in the resource fork + # of shared libraries + if {$tcl_platform(platform) == "macintosh"} { + set dir [lindex $auto_path $i] + tclMacPkgSearch $dir + foreach x [glob -nocomplain [file join $dir *]] { + if [file isdirectory $x] { + set dir $x + tclMacPkgSearch $dir + } + } + } + } +} diff --git a/tcl7.6/library/ldAout.tcl b/tcl7.6/library/ldAout.tcl new file mode 100644 index 0000000..a15999f --- /dev/null +++ b/tcl7.6/library/ldAout.tcl @@ -0,0 +1,228 @@ +# ldAout.tcl -- +# +# This "tclldAout" procedure in this script acts as a replacement +# for the "ld" command when linking an object file that will be +# loaded dynamically into Tcl or Tk using pseudo-static linking. +# +# Parameters: +# The arguments to the script are the command line options for +# an "ld" command. +# +# Results: +# The "ld" command is parsed, and the "-o" option determines the +# module name. ".a" and ".o" options are accumulated. +# The input archives and object files are examined with the "nm" +# command to determine whether the modules initialization +# entry and safe initialization entry are present. A trivial +# C function that locates the entries is composed, compiled, and +# its .o file placed before all others in the command; then +# "ld" is executed to bind the objects together. +# +# SCCS: @(#) ldAout.tcl 1.11 96/09/17 09:02:20 +# +# Copyright (c) 1995, by General Electric Company. All rights reserved. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# This work was supported in part by the ARPA Manufacturing Automation +# and Design Engineering (MADE) Initiative through ARPA contract +# F33615-94-C-4400. + +proc tclLdAout {{cc {}} {shlib_suffix {}} {shlib_cflags none}} { + global env + global argv + + if {$cc==""} { + set cc $env(CC) + } + + # if only two parameters are supplied there is assumed that the + # only shlib_suffix is missing. This parameter is anyway available + # as "info sharedlibextension" too, so there is no need to transfer + # 3 parameters to the function tclLdAout. For compatibility, this + # function now accepts both 2 and 3 parameters. + + if {$shlib_suffix==""} { + set shlib_suffix $env(SHLIB_SUFFIX) + set shlib_cflags $env(SHLIB_CFLAGS) + } else { + if {$shlib_cflags=="none"} { + set shlib_cflags $shlib_suffix + set shlib_suffix [info sharedlibextension] + } + } + + # seenDotO is nonzero if a .o or .a file has been seen + + set seenDotO 0 + + # minusO is nonzero if the last command line argument was "-o". + + set minusO 0 + + # head has command line arguments up to but not including the first + # .o or .a file. tail has the rest of the arguments. + + set head {} + set tail {} + + # nmCommand is the "nm" command that lists global symbols from the + # object files. + + set nmCommand {|nm -g} + + # entryProtos is the table of _Init and _SafeInit prototypes found in the + # module. + + set entryProtos {} + + # entryPoints is the table of _Init and _SafeInit entries found in the + # module. + + set entryPoints {} + + # libraries is the list of -L and -l flags to the linker. + + set libraries {} + set libdirs {} + + # Process command line arguments + + foreach a $argv { + if {!$minusO && [regexp {\.[ao]$} $a]} { + set seenDotO 1 + lappend nmCommand $a + } + if {$minusO} { + set outputFile $a + set minusO 0 + } elseif {![string compare $a -o]} { + set minusO 1 + } + if [regexp {^-[lL]} $a] { + lappend libraries $a + if [regexp {^-L} $a] { + lappend libdirs [string range $a 2 end] + } + } elseif {$seenDotO} { + lappend tail $a + } else { + lappend head $a + } + } + lappend libdirs /lib /usr/lib + + # MIPS -- If there are corresponding G0 libraries, replace the + # ordinary ones with the G0 ones. + + set libs {} + foreach lib $libraries { + if [regexp {^-l} $lib] { + set lname [string range $lib 2 end] + foreach dir $libdirs { + if [file exists [file join $dir lib${lname}_G0.a]] { + set lname ${lname}_G0 + break + } + } + lappend libs -l$lname + } else { + lappend libs $lib + } + } + set libraries $libs + + # Extract the module name from the "-o" option + + if {![info exists outputFile]} { + error "-o option must be supplied to link a Tcl load module" + } + set m [file tail $outputFile] + set l [expr [string length $m] - [string length $shlib_suffix]] + if [string compare [string range $m $l end] $shlib_suffix] { + error "Output file does not appear to have a $shlib_suffix suffix" + } + set modName [string tolower [string range $m 0 [expr $l-1]]] + if [regexp {^lib} $modName] { + set modName [string range $modName 3 end] + } + if [regexp {[0-9\.]*(_g0)?$} $modName match] { + set modName [string range $modName 0 [expr [string length $modName]-[string length $match]-1]] + } + set modName "[string toupper [string index $modName 0]][string range $modName 1 end]" + + # Catalog initialization entry points found in the module + + set f [open $nmCommand r] + while {[gets $f l] >= 0} { + if [regexp {T[ ]*_?([A-Z][a-z0-9_]*_(Safe)?Init(__FP10Tcl_Interp)?)$} $l trash symbol] { + if {![regexp {_?([A-Z][a-z0-9_]*_(Safe)?Init)} $symbol trash s]} { + set s $symbol + } + append entryProtos {extern int } $symbol { (); } \n + append entryPoints { } \{ { "} $s {", } $symbol { } \} , \n + } + } + close $f + + if {$entryPoints==""} { + error "No entry point found in objects" + } + + # Compose a C function that resolves the initialization entry points and + # embeds the required libraries in the object code. + + set C {#include } + append C \n + append C {char TclLoadLibraries_} $modName { [] =} \n + append C { "@LIBS: } $libraries {";} \n + append C $entryProtos + append C {static struct } \{ \n + append C { char * name;} \n + append C { int (*value)();} \n + append C \} {dictionary [] = } \{ \n + append C $entryPoints + append C { 0, 0 } \n \} \; \n + append C {typedef struct Tcl_Interp Tcl_Interp;} \n + append C {typedef int Tcl_PackageInitProc (Tcl_Interp *);} \n + append C {Tcl_PackageInitProc *} \n + append C TclLoadDictionary_ $modName { (symbol)} \n + append C { char * symbol;} \n + append C {{ + int i; + for (i = 0; dictionary [i] . name != 0; ++i) { + if (!strcmp (symbol, dictionary [i] . name)) { + return dictionary [i].value; + } + } + return 0; +}} \n + + # Write the C module and compile it + + set cFile tcl$modName.c + set f [open $cFile w] + puts -nonewline $f $C + close $f + set ccCommand "$cc -c $shlib_cflags $cFile" + puts stderr $ccCommand + eval exec $ccCommand + + # Now compose and execute the ld command that packages the module + + set ldCommand ld + foreach item $head { + lappend ldCommand $item + } + lappend ldCommand tcl$modName.o + foreach item $tail { + lappend ldCommand $item + } + puts stderr $ldCommand + eval exec $ldCommand + + # Clean up working files + + exec /bin/rm $cFile [file rootname $cFile].o +} diff --git a/tcl7.6/library/license.terms b/tcl7.6/library/license.terms new file mode 100644 index 0000000..96ad966 --- /dev/null +++ b/tcl7.6/library/license.terms @@ -0,0 +1,39 @@ +This software is copyrighted by the Regents of the University of +California, Sun Microsystems, Inc., and other parties. The following +terms apply to all files associated with the software unless explicitly +disclaimed in individual files. + +The authors hereby grant permission to use, copy, modify, distribute, +and license this software and its documentation for any purpose, provided +that existing copyright notices are retained in all copies and that this +notice is included verbatim in any distributions. No written agreement, +license, or royalty fee is required for any of the authorized uses. +Modifications to this software may be copyrighted by their authors +and need not follow the licensing terms described here, provided that +the new terms are clearly indicated on the first page of each file where +they apply. + +IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY +FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES +ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY +DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + +THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE +IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE +NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR +MODIFICATIONS. + +GOVERNMENT USE: If you are acquiring this software on behalf of the +U.S. government, the Government shall have only "Restricted Rights" +in the software and related documentation as defined in the Federal +Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you +are acquiring the software on behalf of the Department of Defense, the +software shall be classified as "Commercial Computer Software" and the +Government shall have only "Restricted Rights" as defined in Clause +252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the +authors grant the U.S. Government and others acting in its behalf +permission to use and distribute the software in accordance with the +terms specified in this license. diff --git a/tcl7.6/library/parray.tcl b/tcl7.6/library/parray.tcl new file mode 100644 index 0000000..430e7ff --- /dev/null +++ b/tcl7.6/library/parray.tcl @@ -0,0 +1,29 @@ +# parray: +# Print the contents of a global array on stdout. +# +# SCCS: @(#) parray.tcl 1.9 96/02/16 08:56:44 +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +proc parray {a {pattern *}} { + upvar 1 $a array + if ![array exists array] { + error "\"$a\" isn't an array" + } + set maxl 0 + foreach name [lsort [array names array $pattern]] { + if {[string length $name] > $maxl} { + set maxl [string length $name] + } + } + set maxl [expr {$maxl + [string length $a] + 2}] + foreach name [lsort [array names array $pattern]] { + set nameString [format %s(%s) $a $name] + puts stdout [format "%-*s = %s" $maxl $nameString $array($name)] + } +} diff --git a/tcl7.6/library/tclIndex b/tcl7.6/library/tclIndex new file mode 100644 index 0000000..98ceff1 --- /dev/null +++ b/tcl7.6/library/tclIndex @@ -0,0 +1,19 @@ +# 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) [list source [file join $dir init.tcl]] +set auto_index(auto_load) [list source [file join $dir init.tcl]] +set auto_index(auto_execok) [list source [file join $dir init.tcl]] +set auto_index(auto_execok) [list source [file join $dir init.tcl]] +set auto_index(auto_reset) [list source [file join $dir init.tcl]] +set auto_index(auto_mkindex) [list source [file join $dir init.tcl]] +set auto_index(pkg_mkIndex) [list source [file join $dir init.tcl]] +set auto_index(tclPkgSetup) [list source [file join $dir init.tcl]] +set auto_index(tclPkgUnknown) [list source [file join $dir init.tcl]] +set auto_index(parray) [list source [file join $dir parray.tcl]] +set auto_index(tclLdAout) [list source [file join $dir ldAout.tcl]] diff --git a/tcl7.6/license.terms b/tcl7.6/license.terms new file mode 100644 index 0000000..96ad966 --- /dev/null +++ b/tcl7.6/license.terms @@ -0,0 +1,39 @@ +This software is copyrighted by the Regents of the University of +California, Sun Microsystems, Inc., and other parties. The following +terms apply to all files associated with the software unless explicitly +disclaimed in individual files. + +The authors hereby grant permission to use, copy, modify, distribute, +and license this software and its documentation for any purpose, provided +that existing copyright notices are retained in all copies and that this +notice is included verbatim in any distributions. No written agreement, +license, or royalty fee is required for any of the authorized uses. +Modifications to this software may be copyrighted by their authors +and need not follow the licensing terms described here, provided that +the new terms are clearly indicated on the first page of each file where +they apply. + +IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY +FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES +ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY +DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + +THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE +IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE +NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR +MODIFICATIONS. + +GOVERNMENT USE: If you are acquiring this software on behalf of the +U.S. government, the Government shall have only "Restricted Rights" +in the software and related documentation as defined in the Federal +Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you +are acquiring the software on behalf of the Department of Defense, the +software shall be classified as "Commercial Computer Software" and the +Government shall have only "Restricted Rights" as defined in Clause +252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the +authors grant the U.S. Government and others acting in its behalf +permission to use and distribute the software in accordance with the +terms specified in this license. diff --git a/tcl7.6/mac/MW_TclHeader.pch b/tcl7.6/mac/MW_TclHeader.pch new file mode 100644 index 0000000..0ac32de --- /dev/null +++ b/tcl7.6/mac/MW_TclHeader.pch @@ -0,0 +1,61 @@ +/* + * MW_TclHeader.pch -- + * + * This file is the source for a pre-compilied header that gets used + * for all files in the Tcl projects. This make compilies go a bit + * faster. This file is only intended to be used in the MetroWerks + * CodeWarrior environment. It essentially acts as a place to set + * compiler flags. See MetroWerks documention for more details. + * + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) MW_TclHeader.pch 1.17 96/09/04 16:35:25 + */ + +/* + * Support for automatically naming the precompiled header file ... + */ +#if __POWERPC__ +#pragma precompile_target "MW_TclHeaderPPC" +#elif __CFM68K__ +#pragma precompile_target "MW_TclHeaderCFM68K" +#else +#pragma precompile_target "MW_TclHeader68K" +#endif + +/* + * The define is used most everywhere to tell Tcl (or any Tcl + * extensions) that we are compiling for the Macintosh platform. + */ +#define MAC_TCL + +/* + * The following two defines are used to prepare for the coming + * of Copland. + */ + +#define STRICT_CONTROLS 1 +#define STRICT_WINDOWS 1 + +/* + * Define the following symbol if you want + * comprehensive debugging turned on. + */ + +/* #define TCL_DEBUG */ + +#ifdef TCL_DEBUG +# define TCL_MEM_DEBUG +# define TCL_TEST +#endif + +/* + * Place any includes below that will are needed by the majority of the + * and is OK to be in any file in the system. + */ + +#include "tcl.h" +#include "tclInt.h" diff --git a/tcl7.6/mac/README b/tcl7.6/mac/README new file mode 100644 index 0000000..7bdcdd0 --- /dev/null +++ b/tcl7.6/mac/README @@ -0,0 +1,207 @@ +Tcl 7.6 for Macintosh + +by Ray Johnson +Sun Microsystems Laboratories +rjohnson@eng.sun.com + +SCCS: @(#) README 1.17 96/10/07 14:00:05 + +1. Introduction +--------------- + +This is the README file for the Macintosh version of the Tcl +scripting language. The file consists of information specific +to the Macintosh version of Tcl. For more general information +please read the README file in the main Tcl directory. + +2. What's new? +-------------- + +There are several new features in Tcl 7.6. The most important +are the new file manipulation commands. These are subcommands +to the file command and include "delete", "rename", "copy", and +"mkdir". These should be used over the old "rm", "rmdir", "mkdir", +and "cp" commands. The older commands will eventually be removed +(they currently contain known bugs.) + +In addition, a new memory allocator has been added to the Mac +version of Tcl. This allocator is much faster than the one shipped +by MetroWerks (which is much faster than calling NewPtr directly). +Having our own allocator will also allow us to have a little more +control over memory useage. More work still needs to be done in +this area - but the goal is to work around the fixed application +partition imposed by the MacOS. The result will be less crashes +of your Tcl applications. I hope you notice a difference. + +There is also a new command called "resource". This command should +be considered "alpha" software. It mostly works but will be +enhanced in the future. Backwards compatability will probably not +be maintained. However, I think you will find it very usefull. +Unfortunantly, the command doesn't currently have documentation - +but you should be able to use the error messages to get an idea +of what it does. + +Aside from bugs in the resource command, I know of no outstanding +bugs in the Tcl core for the Macintosh. (I'm not saying there are +none - just that I don't know about them!) Please let me know what +bugs you find. Also, I welcome any feedback on how to improve the +feature set, the integration with the Mac OS, or the distribution. + + +3. The Distribution +------------------- + +Macintosh Tcl is distributed in three different forms. This +should make it easier to only download what you need. The +packages are as follows: + +mactk4.2.sea.hqx + + This distribution is a "binary" only release. It contains an + installer program that will install a 68k, PowerPC, or Fat + version of the "Tcl Shell" and "Wish" applications. In addition, + it installs the Tcl & Tk libraries in the Extensions folder inside + your System Folder. (These are just text files - no inits are + installed.) + +mactcltk-full-4.2.sea.hqx + + This release contains the full release of Tcl and Tk for the + Macintosh plus the More Files packages which Macintosh Tcl and Tk + rely on. + +mactcl-source-7.6.sea.hqx + + This release contains the complete source for Tcl 7.6. In + addition, Metrowerks CodeWarrior libraries and project files + are included. However, you must already have the More Files + package to compile this code. + +4. Documentation +---------------- + +The "html" subdirectory contains reference documentation in +in the HTML format. You may also find these pages at: + + http://www.smli.com/research/tcl/man/ + +Other documentation and sample Tcl scripts can be found at +the Tcl ftp site: + + ftp://ftp.neosoft.com/tcl/ + +The internet news group comp.lang.tcl is also a valuable +source of information about Tcl. A mailing list is also +available (see below). + +5. Compiling Tcl +---------------- + +In order to compile Macintosh Tcl you must have the +following items: + + CodeWarrior Release 8 or higher (newer is better) + Mac Tcl 7.6 (source) + More Files 1.4.3 + +The project files included with the Mac Tcl source should work +fine. The only thing you may need to update are the access paths. +Unfortunantly, it's somewhat common for the project files to become +slightly corrupted. The most common problem is that the "Prefix file" +found in the "C/C++ Preference" panel is incorrect. This should be +set to MW_TclHeaderPPC or MW_TclHeader68K. + +Special notes: + +* Problem with dnr.c. You will also need to modify the file dnr.c + which is supplied by MetroWerks and included by the Mac Tcl project + files. This file uses C++ style comments which will not compile + because the supplied project files have the "Strict ANSI" option + set. The best thing to do is simply change the C++ style comments + into standard ANSI comment blocks. You should also send a bug + report to MetroWerks so they will fix this stupid problem. + +* There is a small bug in More Files 1.4.3. Look in the file named + morefiles.doc for more details. + +* You may not have the libmoto library which will cause a compile + error. Look at the file libmoto.doc for more details. + +* Check out the file bugs.doc for information about known bugs. + +6. Environment Variables +------------------------ + +Environment variables may be added to the system via three different +mechanisms. The first is automatic inclusion of system variables. These +variables include things like the system folder path. These variables are +determined at startup time (for the interpreter) but are not changed if +the system changes. The following environment variables are created via +this method: + + LOGIN - holds the Chooser name of the Macintosh + USER - also holds the Chooser name of the Macintosh + SYS_FOLDER - path to the system directory + APPLE_M_FOLDER - path to the Apple Menu directory + CP_FOLDER - path to the control panels directory + DESK_FOLDER - path to the desk top directory + EXT_FOLDER - path to the system extensions directory + PREF_FOLDER - path to the preferences directory + PRINT_MON_FOLDER - path to the print monitor directory + SHARED_TRASH_FOLDER - path to the network trash directory + TRASH_FOLDER - path to the trash directory + START_UP_FOLDER - path to the start up directory + PWD - path to the application's default directory + +Environment variables may also be placed in a file. A file named +"Tcl Environment Variables" may be placed in the preferences folder. +Each line of this file should be of the form "VAR_NAME=var_data". + +For example, + + PRINTER=Joe's LW + TCLLIBPATH=Lozoya:System Folder:Tcl Lib + +The last alternative is to place environment variables in a 'STR#' +resource named "Tcl Environment Variables" of the application. This is +considered a little more "Mac like" than a Unix style Environment +Variable file. Each entry in the 'STR#' resource has the same format +as above. The source code file "tclMacEnv.c" contains the +implementation of the env mechanisms. This file contains many +#define's that allow customization of the env mechanisms to fit your +applications needs. + +7. Macintosh Tcl Mailing List +----------------------------- + +A Mailing List has been set up to discuss Macintosh related Tcl issues +including (but not limited to) MacTcl. In order to use this Mailing +List you must have access to the internet. If you have access to the +WWW the home page for this mailing list is located at the following +URL: + + http://www.smli.com/research/tcl/lists/mactcl-list.html + +The home page contains information about the list and an HTML archive +of all the past messages on the list. To subscribe send a message to: + + listserv@sunlabs.sun.com + +In the body of the message (the subject will be ignored) put: + + subscribe mactcl Joe Blow + +Replacing Joe Blow with your real name, of course. If you would just +like to receive more information about the list without subscribing +but the line: + + information mactcl + +in the body instead. + + + +If you have comments or Bug reports send them to: +Ray Johnson +rjohnson@eng.sun.com + diff --git a/tcl7.6/mac/bugs.doc b/tcl7.6/mac/bugs.doc new file mode 100644 index 0000000..36ccf99 --- /dev/null +++ b/tcl7.6/mac/bugs.doc @@ -0,0 +1,27 @@ +Known bug list for Tcl 7.6 for Macintosh + +by Ray Johnson +Sun Microsystems Laboratories +rjohnson@eng.sun.com + +SCCS: @(#) bugs.doc 1.3 96/10/07 14:01:45 + +This was a new feature as of Tcl7.6b1 and as such I'll started with +a clean slate. I currently know of no reproducable bugs. I often +get vague reports - but nothing I've been able to confirm. Let +me know what bugs you find! + +The Macintosh version of Tcl passes most all tests in the Tcl +test suite. Slower Macs may fail some tests in event.test whose +timing constraints are too tight. If other tests fail please report +them. + +Ray + +Bugs fixed since the release of Tcl 7.6b1 + +* Bug in ckrealloc - only showed up in Tk when TCL_MEM_DEBUG was + turned off. The mac implementation of realloc has been fixed. + +* The "package require" command didn't really work before. It now + works much better on the Macintosh platform. diff --git a/tcl7.6/mac/libmoto.doc b/tcl7.6/mac/libmoto.doc new file mode 100644 index 0000000..50b98e1 --- /dev/null +++ b/tcl7.6/mac/libmoto.doc @@ -0,0 +1,39 @@ +Notes about the use of libmoto +------------------------------ + +@(#) libmoto.doc 1.1 96/07/17 14:29:48 + +First of all, libmoto is not required! If you don't have it, you +can simply remove the library reference from the project file and +everything should compile just fine. + +The libmoto library replaces certain functions in the MathLib and +ANSI libraries. Motorola has optimized the functions in the library +to run very fast on the PowerPC. As I said above, you don't need +this library, but it does make things faster. + +Obtaining Libmoto: + + For more information about Libmoto and how to doanload + it, visit the following URL: + + http://www.mot.com/SPS/PowerPC/library/fact_sheet/libmoto.html + + You will need to register for the library. However, the + library is free and you can use it in any commercial product + you might have. + +Installing Libmoto: + + Just follow the instructions provided by the Motorola + README file. You need to make sure that the Libmoto + library is before the ANSI and MathLib libraries in + link order. Also, you will get several warnings stateing + that certain functions have already been defined in + Libmoto. (These can safely be ignored.) + +Finally, you can thank Kate Stewart of Motorola for twisting my +arm at the Tcl/Tk Conference to provide some support for Libmoto. + +Ray Johnson + diff --git a/tcl7.6/mac/license.terms b/tcl7.6/mac/license.terms new file mode 100644 index 0000000..96ad966 --- /dev/null +++ b/tcl7.6/mac/license.terms @@ -0,0 +1,39 @@ +This software is copyrighted by the Regents of the University of +California, Sun Microsystems, Inc., and other parties. The following +terms apply to all files associated with the software unless explicitly +disclaimed in individual files. + +The authors hereby grant permission to use, copy, modify, distribute, +and license this software and its documentation for any purpose, provided +that existing copyright notices are retained in all copies and that this +notice is included verbatim in any distributions. No written agreement, +license, or royalty fee is required for any of the authorized uses. +Modifications to this software may be copyrighted by their authors +and need not follow the licensing terms described here, provided that +the new terms are clearly indicated on the first page of each file where +they apply. + +IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY +FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES +ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY +DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + +THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE +IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE +NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR +MODIFICATIONS. + +GOVERNMENT USE: If you are acquiring this software on behalf of the +U.S. government, the Government shall have only "Restricted Rights" +in the software and related documentation as defined in the Federal +Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you +are acquiring the software on behalf of the Department of Defense, the +software shall be classified as "Commercial Computer Software" and the +Government shall have only "Restricted Rights" as defined in Clause +252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the +authors grant the U.S. Government and others acting in its behalf +permission to use and distribute the software in accordance with the +terms specified in this license. diff --git a/tcl7.6/mac/morefiles.doc b/tcl7.6/mac/morefiles.doc new file mode 100644 index 0000000..ee59303 --- /dev/null +++ b/tcl7.6/mac/morefiles.doc @@ -0,0 +1,72 @@ +Notes about MoreFiles, dnr.c & other non-Tcl source files +--------------------------------------------------------- + +@(#) morefiles.doc 1.2 96/08/28 17:27:22 + +The Macintosh distribution uses several source files that don't +actually ship with Tcl. This sometimes causes problems or confusion +to developers. This document should help clear up a few things. + +dnr.c +----- + +The C file dnr.c is provided by Apple Computer and is usually included +by the various compilier vendors. For Metrowerks, the file is located +in the same place as the system include files. This file is required +by MacTcp and can't, by license terms, be shiped with Mac Tcl/Tk. + +Some versions of this file have used the C++ style of comments. (That +is comments that start with //.) You may need to modify you version +of dnr.c to use normal C style comments. Alternativly, you can change +the preferences in your copy of the Mac Tcl/Tk project files to allow +C++ style comments. + +This modification is kind of a pain. Please feel free to notify +Metrowerks Support and Apple's +Developer Support Center to report this bug. +With enough complaints they may fix it... + +More Files +---------- + +Macintosh Tcl/Tk also uses Jim Luther's very useful package called +More Files. More Files fixes many of the broken or underfunctional +parts of the file system. + +More Files can be found on the MetroWerks CD and Developer CD from +Apple. You can also down load the latest version from: + + ftp://members.aol.com/JumpLong/ + +The package can also be found at the home of Tcl/Tk for the mac: + + ftp://ftp.sunlabs.com/pub/tcl/mac/ + +I used to just link the More Files library in the Tcl projects. +However, this caused problems when libraries wern't matched correctly. +I'm now including the files in the Tcl project directly. This +solves the problem of missmatched libraries - but may not always +compile. + +If you get a compiliation error in MoreFiles you need to contact +Jim Luther. His email address: + + JumpLong@aol.com + +The latest version of More Files is 1.4.3. Early version may work. + +Unfortunantly, there is one bug in his library. The bug is in the +function FSpGetFullPath found in the file FullPath.c. After the +call to PBGetCatInfoSync you need to change the line: + +if ( result == noErr ) + +to: + +if ( (result == noErr) || (result == fnfErr) ) + +Note: the version of MoreFile downloaded from the Sun Tcl/Tk site +will have the fix included. (If you want you can send email to +Jim Luther suggesting that he use Tcl for regression testing!) + +Ray Johnson diff --git a/tcl7.6/mac/porting.notes b/tcl7.6/mac/porting.notes new file mode 100644 index 0000000..f1f36e5 --- /dev/null +++ b/tcl7.6/mac/porting.notes @@ -0,0 +1,23 @@ +Porting Notes +------------- + +@(#) porting.notes 1.5 96/07/31 14:59:28 + +Currently, the Macintosh version Tcl only compilies with the +CodeWarrior C compilier from MetroWerks. It should be straight +forward to port the Tcl source to MPW. + +Tcl on the Mac no longer requires the use of GUSI. It should now +be easier to port Tcl/Tk to other compiliers such as Symantic C +and MPW C. + +If you attempt to port Tcl to other Macintosh compiliers please +let me know. I would be glad to help with advice and encouragement. +If your efforts are succesfull I wold also be interested in puting +those changes into the core distribution. Furthermore, please feel +free to send me any notes you might make about your porting +experience so I may include them in this file for others to reference. + +Ray Johnson +ray.johnson@eng.sun.com + diff --git a/tcl7.6/mac/tclMacAlloc.c b/tcl7.6/mac/tclMacAlloc.c new file mode 100644 index 0000000..04a63c4 --- /dev/null +++ b/tcl7.6/mac/tclMacAlloc.c @@ -0,0 +1,658 @@ +/* + * tclMacAlloc.c -- + * + * This is a very fast storage allocator. It allocates blocks of a + * small number of different sizes, and keeps free lists of each size. + * Blocks that don't exactly fit are passed up to the next larger size. + * Blocks over a certain size are directly allocated by calling NewPtr. + * + * Copyright (c) 1983 Regents of the University of California. + * Copyright (c) 1996 Sun Microsystems, Inc. + * + * Portions contributed by Chris Kingsley, Jack Jansen and Ray Johnson + *. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclMacAlloc.c 1.7 96/09/22 15:37:03 + */ + +#ifdef TCL_DEBUG +# define DEBUG +/* #define MSTATS */ +# define RCHECK +#endif + +typedef unsigned long caddr_t; + +#include "tclMacInt.h" +#include +#include +#include + +/* + * Flags that are used by ConfigureMemory to define how the allocator + * should work. They can be or'd together. + */ +#define MEMORY_ALL_SYS 1 /* All memory should come from the system heap. */ + +static int memoryFlags = 0; + +/* + * The overhead on a block is at least 4 bytes. When free, this space + * contains a pointer to the next free block, and the bottom two bits must + * be zero. When in use, the first byte is set to MAGIC, and the second + * byte is the size index. The remaining bytes are for alignment. + * If range checking is enabled then a second word holds the size of the + * requested block, less 1, rounded up to a multiple of sizeof(RMAGIC). + * The order of elements is critical: ov_magic must overlay the low order + * bits of ov_next, and ov_magic can not be a valid ov_next bit pattern. + */ +union overhead { + union overhead *ov_next; /* when free */ + struct { + unsigned char ovu_magic0; /* magic number */ + unsigned char ovu_index; /* bucket # */ + unsigned char ovu_unused; /* unused */ + unsigned char ovu_magic1; /* other magic number */ +#ifdef RCHECK + unsigned short ovu_rmagic; /* range magic number */ + unsigned long ovu_size; /* actual block size */ +#endif + } ovu; +#define ov_magic0 ovu.ovu_magic0 +#define ov_magic1 ovu.ovu_magic1 +#define ov_index ovu.ovu_index +#define ov_rmagic ovu.ovu_rmagic +#define ov_size ovu.ovu_size +}; + +#define MAGIC 0xef /* magic # on accounting info */ +#define RMAGIC 0x5555 /* magic # on range info */ + +#ifdef RCHECK +#define RSLOP sizeof (unsigned short) +#else +#define RSLOP 0 +#endif + +#define OVERHEAD (sizeof(union overhead) + RSLOP) + +/* + * nextf[i] is the pointer to the next free block of size 2^(i+3). The + * smallest allocatable block is 8 bytes. The overhead information + * precedes the data area returned to the user. + */ +/*#define NBUCKETS 11*/ +#define NBUCKETS 13 +#define MAXMALLOC (1<<(NBUCKETS+2)) +static union overhead *nextf[NBUCKETS]; + +#ifdef MSTATS +/* + * nmalloc[i] is the difference between the number of mallocs and frees + * for a given block size. + */ +static unsigned int nmalloc[NBUCKETS+1]; +#include +#endif + +/* + * The following typedef and variable are used to keep track of memory + * blocks that are allocated directly from the System Heap. This chunks + * of memory must always be freed - even if we crash. + */ +typedef struct listEl { + Handle memoryHandle; + struct listEl * next; +} ListEl; + +ListEl * systemMemory = NULL; +ListEl * appMemory = NULL; + +#if defined(DEBUG) || defined(RCHECK) +#define ASSERT(p) if (!(p)) panic(# p) +#define RANGE_ASSERT(p) if (!(p)) panic(# p) +#else +#define ASSERT(p) +#define RANGE_ASSERT(p) +#endif + +/* + * Prototypes for functions used only in this file. + */ +static void MoreCore _ANSI_ARGS_(()); +static void * SysAlloc _ANSI_ARGS_((long size, int high)); +static void SysFree _ANSI_ARGS_((void * ptr)); +static pascal void CleanUpExitProc _ANSI_ARGS_((void)); +void ConfigureMemory _ANSI_ARGS_((int flags)); +void FreeAllMemory _ANSI_ARGS_((void)); + +/* + *---------------------------------------------------------------------- + * + * TclpAlloc -- + * + * Allocate more memory. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +TclpAlloc(nbytes) + size_t nbytes; +{ + register union overhead *op; + register long bucket; + register unsigned amt; + + /* + * First the simple case: we simple allocate big blocks directly + */ + if ( nbytes + OVERHEAD >= MAXMALLOC ) { + op = (union overhead *)SysAlloc(nbytes+OVERHEAD, false); + if ( op == NULL ) + return NULL; + op->ov_magic0 = op->ov_magic1 = MAGIC; + op->ov_index = 0xff; +#ifdef MSTATS + nmalloc[NBUCKETS]++; +#endif +#ifdef RCHECK + /* + * Record allocated size of block and + * bound space with magic numbers. + */ + op->ov_size = (nbytes + RSLOP - 1) & ~(RSLOP - 1); + op->ov_rmagic = RMAGIC; + *(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC; +#endif + return (void *)(op+1); + } + /* + * Convert amount of memory requested into closest block size + * stored in hash buckets which satisfies request. + * Account for space used per block for accounting. + */ +#ifndef RCHECK + amt = 8; /* size of first bucket */ + bucket = 0; +#else + amt = 16; /* size of first bucket */ + bucket = 1; +#endif + while (nbytes + OVERHEAD > amt) { + amt <<= 1; + if (amt == 0) + return (NULL); + bucket++; + } + ASSERT( bucket < NBUCKETS ); + + /* + * If nothing in hash bucket right now, + * request more memory from the system. + */ + if ((op = nextf[bucket]) == NULL) { + MoreCore(bucket); + if ((op = nextf[bucket]) == NULL) + return (NULL); + } + /* + * Remove from linked list + */ + nextf[bucket] = op->ov_next; + op->ov_magic0 = op->ov_magic1 = MAGIC; + op->ov_index = bucket; +#ifdef MSTATS + nmalloc[bucket]++; +#endif +#ifdef RCHECK + /* + * Record allocated size of block and + * bound space with magic numbers. + */ + op->ov_size = (nbytes + RSLOP - 1) & ~(RSLOP - 1); + op->ov_rmagic = RMAGIC; + *(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC; +#endif + return ((char *)(op + 1)); +} + +/* + *---------------------------------------------------------------------- + * + * MoreCore -- + * + * Allocate more memory to the indicated bucket. + * + * Results: + * None. + * + * Side effects: + * Attempts to get more memory from the system. + * + *---------------------------------------------------------------------- + */ + +static void +MoreCore(bucket) + int bucket; +{ + register union overhead *op; + register long sz; /* size of desired block */ + long amt; /* amount to allocate */ + int nblks; /* how many blocks we get */ + + /* + * sbrk_size <= 0 only for big, FLUFFY, requests (about + * 2^30 bytes on a VAX, I think) or for a negative arg. + */ + sz = 1 << (bucket + 3); + ASSERT(sz > 0); + + amt = MAXMALLOC; + nblks = amt / sz; + ASSERT(nblks*sz == amt); + + op = (union overhead *)SysAlloc(amt, true); + /* no more room! */ + if (op == NULL) + return; + /* + * Add new memory allocated to that on + * free list for this hash bucket. + */ + nextf[bucket] = op; + while (--nblks > 0) { + op->ov_next = (union overhead *)((caddr_t)op + sz); + op = (union overhead *)((caddr_t)op + sz); + } + op->ov_next = (union overhead *)NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TclpFree -- + * + * Free memory. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclpFree(cp) + char *cp; +{ + register long size; + register union overhead *op; + + if (cp == NULL) { + return; + } + + op = (union overhead *)((caddr_t)cp - sizeof (union overhead)); + + ASSERT(op->ov_magic0 == MAGIC); /* make sure it was in use */ + ASSERT(op->ov_magic1 == MAGIC); + if (op->ov_magic0 != MAGIC || op->ov_magic1 != MAGIC) { + return; + } + + RANGE_ASSERT(op->ov_rmagic == RMAGIC); + RANGE_ASSERT(*(unsigned short *)((caddr_t)(op + 1) + op->ov_size) == RMAGIC); + size = op->ov_index; + if ( size == 0xff ) { +#ifdef MSTATS + nmalloc[NBUCKETS]--; +#endif + SysFree((Ptr) op); + return; + } + ASSERT(size < NBUCKETS); + op->ov_next = nextf[size]; /* also clobbers ov_magic */ + nextf[size] = op; +#ifdef MSTATS + nmalloc[size]--; +#endif +} + +/* + *---------------------------------------------------------------------- + * + * TclpRealloc -- + * + * Reallocate memory. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +TclpRealloc(cp, nbytes) + char *cp; +size_t nbytes; +{ + int i; + union overhead *op; + int expensive; + unsigned long maxsize; + + if (cp == NULL) { + return (TclpAlloc(nbytes)); + } + + op = (union overhead *)((caddr_t)cp - sizeof (union overhead)); + + ASSERT(op->ov_magic0 == MAGIC); /* make sure it was in use */ + ASSERT(op->ov_magic1 == MAGIC); + if (op->ov_magic0 != MAGIC || op->ov_magic1 != MAGIC) { + return NULL; + } + + RANGE_ASSERT(op->ov_rmagic == RMAGIC); + RANGE_ASSERT(*(unsigned short *)((caddr_t)(op + 1) + op->ov_size) == RMAGIC); + i = op->ov_index; + /* + * First the malloc/copy cases + */ + expensive = 0; + if ( i == 0xff ) { + Handle hand; + + hand = * (Handle *) ((Ptr) op - sizeof(Handle)); + maxsize = GetHandleSize(hand) - sizeof(Handle); + expensive = 1; + } else { + maxsize = 1 << (i+3); + if ( nbytes + OVERHEAD > maxsize ) { + expensive = 1; + } else if ( i > 0 && nbytes + OVERHEAD < (maxsize/2) ) { + expensive = 1; + } + } + + if (expensive) { + void *newp; + + newp = TclpAlloc(nbytes); + if ( newp == NULL ) { + return NULL; + } + maxsize -= OVERHEAD; + if ( maxsize < nbytes ) + nbytes = maxsize; + memcpy(newp, cp, nbytes); + TclpFree(cp); + return newp; + } + + /* + * Ok, we don't have to copy, it fits as-is + */ +#ifdef RCHECK + op->ov_size = (nbytes + RSLOP - 1) & ~(RSLOP - 1); + *(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC; +#endif + return(cp); +} + +/* + *---------------------------------------------------------------------- + * + * mstats -- + * + * Prints two lines of numbers, one showing the length of the + * free list for each size category, the second showing the + * number of mallocs - frees for each size category. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#ifdef MSTATS +void +mstats(s) + char *s; +{ + register int i, j; + register union overhead *p; + int totfree = 0, + totused = 0; + + fprintf(stderr, "Memory allocation statistics %s\nTclpFree:\t", s); + for (i = 0; i < NBUCKETS; i++) { + for (j = 0, p = nextf[i]; p; p = p->ov_next, j++) + fprintf(stderr, " %d", j); + totfree += j * (1 << (i + 3)); + } + fprintf(stderr, "\nused:\t"); + for (i = 0; i < NBUCKETS; i++) { + fprintf(stderr, " %d", nmalloc[i]); + totused += nmalloc[i] * (1 << (i + 3)); + } + fprintf(stderr, "\n\tTotal small in use: %d, total free: %d\n", + totused, totfree); + fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %d\n", + MAXMALLOC, nmalloc[NBUCKETS]); +} +#endif + +/* + *---------------------------------------------------------------------- + * + * SysAlloc -- + * + * Allocate a new block of memory free from the System. + * + * Results: + * Returns a pointer to a new block of memory. + * + * Side effects: + * May obtain memory from app or sys space. Info is added to + * overhead lists etc.. + * + *---------------------------------------------------------------------- + */ + +static void * +SysAlloc( + long size, + int high) +{ + Handle hand = NULL; + ListEl * newMemoryRecord; + + if (!(memoryFlags & MEMORY_ALL_SYS)) { + hand = NewHandle(size + sizeof(Handle)); + } + if (hand != NULL) { + newMemoryRecord = (ListEl *) NewPtr(sizeof(ListEl)); + if (newMemoryRecord == NULL) { + DisposeHandle(hand); + return NULL; + } + newMemoryRecord->memoryHandle = hand; + newMemoryRecord->next = appMemory; + appMemory = newMemoryRecord; + } else { + /* + * Ran out of memory in application space. Lets try to get + * more memory from system. Otherwise, we return NULL to + * denote failure. + */ + high = false; + hand = NewHandleSys(size); + if (hand == NULL) { + return NULL; + } + if (systemMemory == NULL) { + /* + * This is the first time we've attempted to allocate memory + * directly from the system heap. We need to now install the + * exit handle to ensure the memory is cleaned up. + */ + /* TclMacInstallExitToShellPatch(CleanUpExitProc); */ + } + newMemoryRecord = (ListEl *) NewPtrSys(sizeof(ListEl)); + if (newMemoryRecord == NULL) { + DisposeHandle(hand); + return NULL; + } + newMemoryRecord->memoryHandle = hand; + newMemoryRecord->next = systemMemory; + systemMemory = newMemoryRecord; + } + if (high) { + HLockHi(hand); + } else { + HLock(hand); + } + (** (Handle **) hand) = hand; + + return (*hand + sizeof(Handle)); +} + +/* + *---------------------------------------------------------------------- + * + * SysFree -- + * + * Free memory that we aloocated back to the system. + * + * Results: + * None. + * + * Side effects: + * Memory is freed. + * + *---------------------------------------------------------------------- + */ + +static void +SysFree(void * ptr) +{ + Handle hand; + OSErr err; + + hand = * (Handle *) ((Ptr) ptr - sizeof(Handle)); + DisposeHandle(hand); + err = MemError(); +} + +/* + *---------------------------------------------------------------------- + * + * CleanUpExitProc -- + * + * This procedure is invoked as an exit handler when ExitToShell + * is called. It removes any memory that was allocated directly + * from the system heap. This must be called when the application + * quits or the memory will never be freed. + * + * Results: + * None. + * + * Side effects: + * May free memory in the system heap. + * + *---------------------------------------------------------------------- + */ + +static pascal void +CleanUpExitProc() +{ + ListEl * memRecord; + + while (systemMemory != NULL) { + memRecord = systemMemory; + systemMemory = memRecord->next; + DisposeHandle(memRecord->memoryHandle); + DisposePtr((void *) memRecord); + } +} + +/* + *---------------------------------------------------------------------- + * + * FreeAllMemory -- + * + * This procedure frees all memory blocks allocated by the memory + * sub-system. Make sure you don't have any code that references + * any malloced data! + * + * Results: + * None. + * + * Side effects: + * Frees all memory allocated by TclpAlloc. + * + *---------------------------------------------------------------------- + */ + +void +FreeAllMemory() +{ + ListEl * memRecord; + + while (systemMemory != NULL) { + memRecord = systemMemory; + systemMemory = memRecord->next; + DisposeHandle(memRecord->memoryHandle); + DisposePtr((void *) memRecord); + } + while (appMemory != NULL) { + memRecord = appMemory; + appMemory = memRecord->next; + DisposeHandle(memRecord->memoryHandle); + DisposePtr((void *) memRecord); + } +} + +/* + *---------------------------------------------------------------------- + * + * ConfigureMemory -- + * + * This procedure sets certain flags in this file that control + * how memory is allocated and managed. This call must be made + * before any call to TclpAlloc is made. + * + * Results: + * None. + * + * Side effects: + * Certain state will be changed. + * + *---------------------------------------------------------------------- + */ + +void +ConfigureMemory( + int flags) +{ + memoryFlags = flags; +} diff --git a/tcl7.6/mac/tclMacAppInit.c b/tcl7.6/mac/tclMacAppInit.c new file mode 100644 index 0000000..3a147c4 --- /dev/null +++ b/tcl7.6/mac/tclMacAppInit.c @@ -0,0 +1,193 @@ +/* + * tclMacAppInit.c -- + * + * Provides a version of the Tcl_AppInit procedure for the example shell. + * + * Copyright (c) 1993-1994 Lockheed Missle & Space Company, AI Center + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclMacAppInit.c 1.15 96/09/05 18:26:31 + */ + +#include "tcl.h" +#include "tclInt.h" +#include "tclPort.h" +#include "tclMacInt.h" + +#if defined(THINK_C) +# include +#elif defined(__MWERKS__) +# include +short InstallConsole _ANSI_ARGS_((short fd)); +#endif + +#ifdef TCL_TEST +EXTERN int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +#endif /* TCL_TEST */ + +/* + * Forward declarations for procedures defined later in this file: + */ + +static int MacintoshInit _ANSI_ARGS_((void)); + +/* + *---------------------------------------------------------------------- + * + * main -- + * + * Main program for tclsh. This file can be used as a prototype + * for other applications using the Tcl library. + * + * Results: + * None. This procedure never returns (it exits the process when + * it's done. + * + * Side effects: + * This procedure initializes the Macintosh world and then + * calls Tcl_Main. Tcl_Main will never return except to exit. + * + *---------------------------------------------------------------------- + */ + +void +main(argc, argv) + int argc; /* Number of arguments. */ + char **argv; /* Array of argument strings. */ +{ + char *newArgv[2]; + + if (MacintoshInit() != TCL_OK) { + Tcl_Exit(1); + } + + argc = 1; + newArgv[0] = "tclsh"; + newArgv[1] = NULL; + Tcl_Main(argc, newArgv, Tcl_AppInit); +} + +/* + *---------------------------------------------------------------------- + * + * 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. */ +{ + if (Tcl_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + +#ifdef TCL_TEST + if (Tcltest_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } +#endif /* TCL_TEST */ + + /* + * 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. + */ + + /* + * Call Tcl_CreateCommand for application-specific commands, if + * they weren't already created by the init procedures called above. + * Each call would loo like this: + * + * Tcl_CreateCommand(interp, "tclName", CFuncCmd, NULL, NULL); + */ + + /* + * Specify a user-specific startup script to invoke if the application + * is run interactively. On the Mac we can specifiy either a TEXT resource + * which contains the script or the more UNIX like file location + * may also used. (I highly recommend using the resource method.) + */ + + Tcl_SetVar(interp, "tcl_rcRsrcName", "tclshrc", TCL_GLOBAL_ONLY); + /* Tcl_SetVar(interp, "tcl_rcFileName", "~/.tclshrc", TCL_GLOBAL_ONLY); */ + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * MacintoshInit -- + * + * This procedure calls initalization routines to set up a simple + * console on a Macintosh. This is necessary as the Mac doesn't + * have a stdout & stderr by default. + * + * Results: + * Returns TCL_OK if everything went fine. If it didn't the + * application should probably fail. + * + * Side effects: + * Inits the appropiate console package. + * + *---------------------------------------------------------------------- + */ + +static int +MacintoshInit() +{ +#if defined(THINK_C) + + /* Set options for Think C console package */ + /* The console package calls the Mac init calls */ + console_options.pause_atexit = 0; + console_options.title = "\pTcl Interpreter"; + +#elif defined(__MWERKS__) + + /* Set options for CodeWarrior SIOUX package */ + SIOUXSettings.autocloseonquit = true; + SIOUXSettings.showstatusline = true; + SIOUXSettings.asktosaveonclose = false; + InstallConsole(0); + SIOUXSetTitle("\pTcl Interpreter"); + +#elif defined(applec) + + /* Init packages used by MPW SIOW package */ + InitGraf((Ptr)&qd.thePort); + InitFonts(); + InitWindows(); + InitMenus(); + TEInit(); + InitDialogs(nil); + InitCursor(); + +#endif + + TclMacSetEventProc((TclMacConvertEventPtr) SIOUXHandleOneEvent); + + /* No problems with initialization */ + return TCL_OK; +} diff --git a/tcl7.6/mac/tclMacApplication.r b/tcl7.6/mac/tclMacApplication.r new file mode 100644 index 0000000..2800ef5 --- /dev/null +++ b/tcl7.6/mac/tclMacApplication.r @@ -0,0 +1,75 @@ +/* + * tclMacApplication.r -- + * + * This file creates resources for use Tcl Shell application. + * It should be viewed as an example of how to create a new + * Tcl application using the shared Tcl libraries. + * + * Copyright (c) 1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclMacApplication.r 1.1 96/09/11 21:12:54 + */ + +#include +#include + +/* + * The folowing include and defines help construct + * the version string for Tcl. + */ + +#define RESOURCE_INCLUDED +#include "tcl.h" + +#if (TCL_RELEASE_LEVEL == 0) +# define RELEASE_LEVEL alpha +#elif (TCL_RELEASE_LEVEL == 1) +# define RELEASE_LEVEL beta +#elif (TCL_RELEASE_LEVEL == 2) +# define RELEASE_LEVEL final +#endif + +#if (TCL_RELEASE_LEVEL == 2) +# define MINOR_VERSION (TCL_MINOR_VERSION * 16) + TCL_RELEASE_SERIAL +#else +# define MINOR_VERSION TCL_MINOR_VERSION * 16 +#endif + +resource 'vers' (1) { + TCL_MAJOR_VERSION, MINOR_VERSION, + RELEASE_LEVEL, 0x00, verUS, + TCL_PATCH_LEVEL, + TCL_PATCH_LEVEL ", by Ray Johnson © Sun Microsystems" +}; + +resource 'vers' (2) { + TCL_MAJOR_VERSION, MINOR_VERSION, + RELEASE_LEVEL, 0x00, verUS, + TCL_PATCH_LEVEL, + "Tcl Shell " TCL_PATCH_LEVEL " © 1996" +}; + +#define TCL_APP_CREATOR 'Tcl ' + +type TCL_APP_CREATOR as 'STR '; +resource TCL_APP_CREATOR (0, purgeable) { + "Tcl Shell " TCL_PATCH_LEVEL " © 1996" +}; + +/* + * The 'kind' resource works with a 'BNDL' in Macintosh Easy Open + * to affect the text the Finder displays in the "kind" column and + * file info dialog. This information will be applied to all files + * with the listed creator and type. + */ + +resource 'kind' (128, "Tcl kind", purgeable) { + TCL_APP_CREATOR, + 0, /* region = USA */ + { + 'APPL', "Tcl Shell", + } +}; diff --git a/tcl7.6/mac/tclMacChan.c b/tcl7.6/mac/tclMacChan.c new file mode 100644 index 0000000..7d73707 --- /dev/null +++ b/tcl7.6/mac/tclMacChan.c @@ -0,0 +1,512 @@ +/* + * tclMacChan.c + * + * Channel drivers for Macintosh channels for the + * console fds. + * + * Copyright (c) 1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclMacChan.c 1.35 96/05/30 14:20:57 + */ + +#include "tclInt.h" +#include "tclPort.h" +#include +#include +#include +#include +#include +#include + +/* + * Static routines for this file: + */ + +static int StdIOBlockMode _ANSI_ARGS_((ClientData instanceData, + int mode)); +static int StdIOClose _ANSI_ARGS_((ClientData instanceData, + Tcl_Interp *interp)); +static Tcl_File StdGetFile _ANSI_ARGS_((ClientData instanceData, + int direction)); +static int StdIOInput _ANSI_ARGS_((ClientData instanceData, + char *buf, int toRead, int *errorCode)); +static int StdIOOutput _ANSI_ARGS_((ClientData instanceData, + char *buf, int toWrite, int *errorCode)); +static int StdIOSeek _ANSI_ARGS_((ClientData instanceData, + long offset, int mode, int *errorCode)); +static int StdReady _ANSI_ARGS_((ClientData instanceData, + int mask)); +static void StdWatch _ANSI_ARGS_((ClientData instanceData, + int mask)); + +/* + * This structure describes the channel type structure for file based IO: + */ + +static Tcl_ChannelType consoleChannelType = { + "file", /* Type name. */ + StdIOBlockMode, /* Set blocking/nonblocking mode.*/ + StdIOClose, /* Close proc. */ + StdIOInput, /* Input proc. */ + StdIOOutput, /* Output proc. */ + StdIOSeek, /* Seek proc. */ + NULL, /* Set option proc. */ + NULL, /* Get option proc. */ + StdWatch, /* Initialize notifier. */ + StdReady, /* Are there events? */ + StdGetFile /* Get Tcl_Files out of channel. */ +}; + +/* + * Hack to allow Mac Tk to override the TclGetStdChannels function. + */ + +typedef void (*TclGetStdChannelsProc) _ANSI_ARGS_((Tcl_Channel *stdinPtr, + Tcl_Channel *stdoutPtr, Tcl_Channel *stderrPtr)); + +TclGetStdChannelsProc getStdChannelsProc = NULL; + +/* + * Static variables to hold channels for stdin, stdout and stderr. + */ + +static Tcl_Channel stdinChannel = NULL; +static Tcl_Channel stdoutChannel = NULL; +static Tcl_Channel stderrChannel = NULL; + +/* + *---------------------------------------------------------------------- + * + * StdIOBlockMode -- + * + * Set blocking or non-blocking mode on channel. + * + * Results: + * 0 if successful, errno when failed. + * + * Side effects: + * Sets the device into blocking or non-blocking mode. + * + *---------------------------------------------------------------------- + */ + +static int +StdIOBlockMode(instanceData, mode) + ClientData instanceData; /* Unused. */ + int mode; /* The mode to set. */ +{ + /* + * Do not allow putting stdin, stdout or stderr into nonblocking mode. + */ + + if (mode == TCL_MODE_NONBLOCKING) { + return EFAULT; + } + + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * StdIOClose -- + * + * Closes the IO channel. + * + * Results: + * 0 if successful, the value of errno if failed. + * + * Side effects: + * Closes the physical channel + * + *---------------------------------------------------------------------- + */ + +static int +StdIOClose(instanceData, interp) + ClientData instanceData; /* Unused. */ + Tcl_Interp *interp; /* Unused. */ +{ + int fd, errorCode = 0; + + /* + * Invalidate the stdio cache if necessary. Note that we assume that + * the stdio file and channel pointers will become invalid at the same + * time. + */ + + fd = (int) instanceData; + if (fd == 0) { + fd = 0; + stdinChannel = NULL; + } else if (fd == 1) { + stdoutChannel = NULL; + } else if (fd == 2) { + stderrChannel = NULL; + } else { + panic("recieved invalid std file"); + } + + if (close(fd) < 0) { + errorCode = errno; + } + + return errorCode; +} + +/* + *---------------------------------------------------------------------- + * + * StdGetFile -- + * + * Called from Tcl_GetChannelFile to retrieve Tcl_Files from inside + * a file based channel. + * + * Results: + * The appropriate Tcl_File or NULL if not present. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tcl_File +StdGetFile(instanceData, direction) + ClientData instanceData; /* The file state. */ + int direction; /* Which Tcl_File to retrieve? */ +{ + if ((direction == TCL_READABLE) || (direction == TCL_WRITABLE)) { + return (Tcl_File) instanceData; + } + return (Tcl_File) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * StdIOInput -- + * + * Reads input from the IO channel into the buffer given. Returns + * count of how many bytes were actually read, and an error indication. + * + * Results: + * A count of how many bytes were read is returned and an error + * indication is returned in an output argument. + * + * Side effects: + * Reads input from the actual channel. + * + *---------------------------------------------------------------------- + */ + +int +StdIOInput(instanceData, buf, bufSize, errorCode) + ClientData instanceData; /* Unused. */ + char *buf; /* Where to store data read. */ + int bufSize; /* How much space is available + * in the buffer? */ + int *errorCode; /* Where to store error code. */ +{ + int fd; + int bytesRead; /* How many bytes were read? */ + + *errorCode = 0; + errno = 0; + fd = (int) instanceData; + bytesRead = read(fd, buf, (size_t) bufSize); + if (bytesRead > -1) { + return bytesRead; + } + *errorCode = errno; + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * StdIOOutput-- + * + * Writes the given output on the IO channel. Returns count of how + * many characters were actually written, and an error indication. + * + * Results: + * A count of how many characters were written is returned and an + * error indication is returned in an output argument. + * + * Side effects: + * Writes output on the actual channel. + * + *---------------------------------------------------------------------- + */ + +static int +StdIOOutput(instanceData, buf, toWrite, errorCode) + ClientData instanceData; /* Unused. */ + char *buf; /* The data buffer. */ + int toWrite; /* How many bytes to write? */ + int *errorCode; /* Where to store error code. */ +{ + int written; + int fd; + + *errorCode = 0; + errno = 0; + fd = (int) instanceData; + written = write(fd, buf, (size_t) toWrite); + if (written > -1) { + return written; + } + *errorCode = errno; + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * StdReady -- + * + * Called by the notifier to check whether events of interest are + * present on the channel. On the Macintosh all files are always + * considered to be readable and writeable. + * + * Results: + * Returns OR-ed combination of TCL_READABLE, TCL_WRITABLE and + * TCL_EXCEPTION to indicate which events of interest are present. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +StdReady(instanceData, mask) + ClientData instanceData; /* The file state. */ + int mask; /* Events of interest; an OR-ed + * combination of TCL_READABLE, + * TCL_WRITABLE and TCL_EXCEPTION. */ +{ + return (TCL_READABLE | TCL_WRITABLE); +} + +/* + *---------------------------------------------------------------------- + * + * StdIOSeek -- + * + * Seeks on an IO channel. Returns the new position. + * + * Results: + * -1 if failed, the new position if successful. If failed, it + * also sets *errorCodePtr to the error code. + * + * Side effects: + * Moves the location at which the channel will be accessed in + * future operations. + * + *---------------------------------------------------------------------- + */ + +static int +StdIOSeek(instanceData, offset, mode, errorCodePtr) + ClientData instanceData; /* Unused. */ + long offset; /* Offset to seek to. */ + int mode; /* Relative to where + * should we seek? */ + int *errorCodePtr; /* To store error code. */ +{ + int newLoc; + int fd; + + *errorCodePtr = 0; + fd = (int) instanceData; + newLoc = lseek(fd, offset, mode); + if (newLoc > -1) { + return newLoc; + } + *errorCodePtr = errno; + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * StdWatch -- + * + * Initialize the notifier to watch Tcl_Files from this channel. + * This doesn't do anything on the Macintosh. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +StdWatch(instanceData, mask) + ClientData instanceData; /* The file state. */ + int mask; /* Events of interest; an OR-ed + * combination of TCL_READABLE, + * TCL_WRITABLE and TCL_EXCEPTION. */ +{ + Tcl_Time timeout = { 0, 0 }; + + /* + * Currently, files are always ready under the Macintosh, + * so we just set a 0 timeout. Since there s no notification + * scheme - we just set the timeout time to zero. + */ + + Tcl_SetMaxBlockTime(&timeout); +} + +/* + *---------------------------------------------------------------------- + * + * TclGetAndDetachPids -- + * + * Stores a list of the command PIDs for a command channel in + * interp->result and detaches the PIDs. + * + * Results: + * None. + * + * Side effects: + * Modifies interp->result. + * + *---------------------------------------------------------------------- + */ + +void +TclGetAndDetachPids(interp, chan) + Tcl_Interp *interp; + Tcl_Channel chan; +{ + return; +} + +/* + *---------------------------------------------------------------------- + * + * 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. + * + *---------------------------------------------------------------------- + */ + +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. */ +{ + ProcessSerialNumber psn; + Tcl_Channel chan; + + if (argc > 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " ?channelId?\"", (char *) NULL); + return TCL_ERROR; + } + + if (argc == 2) { + chan = Tcl_GetChannel(interp, argv[1], NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + + /* + * We can't create pipelines on the Mac so + * this will always return an empty list. + */ + return TCL_OK; + } + + GetCurrentProcess(&psn); + sprintf(interp->result, "0x%08x%08x", psn.highLongOfPSN, psn.lowLongOfPSN); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetDefaultStdChannel -- + * + * Constructs a channel for the specified standard OS handle. + * + * Results: + * Returns the specified default standard channel, or NULL. + * + * Side effects: + * May cause the creation of a standard channel and the underlying + * file. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +TclGetDefaultStdChannel(type) + int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */ +{ + Tcl_Channel channel = NULL; + int fd = 0; /* Initializations needed to prevent */ + int mode = 0; /* compiler warning (used before set). */ + char *bufMode = NULL; + char channelName[20]; + int channelPermissions; + + /* + * If the channels were not created yet, create them now and + * store them in the static variables. + */ + + switch (type) { + case TCL_STDIN: + fd = 0; + channelPermissions = TCL_READABLE; + bufMode = "line"; + break; + case TCL_STDOUT: + fd = 1; + channelPermissions = TCL_WRITABLE; + bufMode = "line"; + break; + case TCL_STDERR: + fd = 2; + channelPermissions = TCL_WRITABLE; + bufMode = "none"; + break; + default: + panic("TclGetDefaultStdChannel: Unexpected channel type"); + break; + } + + sprintf(channelName, "console%d", (int) fd); + channel = Tcl_CreateChannel(&consoleChannelType, channelName, + (ClientData) fd, channelPermissions); + /* + * Set up the normal channel options for stdio handles. + */ + + Tcl_SetChannelOption(NULL, channel, "-translation", "cr"); + Tcl_SetChannelOption(NULL, channel, "-buffering", bufMode); + + return channel; +} diff --git a/tcl7.6/mac/tclMacEnv.c b/tcl7.6/mac/tclMacEnv.c new file mode 100644 index 0000000..3528dcf --- /dev/null +++ b/tcl7.6/mac/tclMacEnv.c @@ -0,0 +1,524 @@ +/* + * tclMacEnv.c -- + * + * Implements the "environment" on a Macintosh. + * + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclMacEnv.c 1.27 96/09/05 11:18:56 + */ + +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include "tcl.h" +#include "tclInt.h" +#include "tclMacInt.h" +#include "tclPort.h" + +#define kMaxEnvStringSize 255 +#define kMaxEnvVarSize 100 +#define kLoginnameTag "LOGIN=" +#define kUsernameTag "USER=" +#define kDefaultDirTag "HOME=" + +/* + * The following specifies a text file where additional environment variables + * can be set. The file must reside in the preferences folder. If the file + * doesn't exist NO error will occur. Commet out the difinition if you do + * NOT want to use an environment variables file. + */ +#define kPrefsFile "Tcl Environment Variables" + +/* + * The following specifies the Name of a 'STR#' resource in the application + * where additional environment variables may be set. If the resource doesn't + * exist no errors will occur. Commet it out if you don't want it. + */ +#define REZ_ENV "\pTcl Environment Variables" + +/* Globals */ +char **environ = NULL; + +/* + * Declarations for local procedures defined in this file: + */ +static char ** RezRCVariables _ANSI_ARGS_((void)); +static char ** FileRCVariables _ANSI_ARGS_((void)); +static char ** PathVariables _ANSI_ARGS_((void)); +static char ** SystemVariables _ANSI_ARGS_((void)); +static char * MakeFolderEnvVar _ANSI_ARGS_((char * prefixTag, + long whichFolder)); +static char * GetUserName _ANSI_ARGS_((void)); + +/* + *---------------------------------------------------------------------- + * + * RezRCVariables -- + * + * Creates environment variables from the applications resource fork. + * The function looks for the 'STR#' resource with the name defined + * in the #define REZ_ENV. If the define is not defined this code + * will not be included. If the resource doesn't exist or no strings + * reside in the resource nothing will happen. + * + * Results: + * ptr to value on success, NULL if error. + * + * Side effects: + * Memory is allocated and returned to the caller. + * + *---------------------------------------------------------------------- + */ + +#ifdef REZ_ENV +static char ** +RezRCVariables() +{ + Handle envStrs = NULL; + char** rezEnv = NULL; + short int numStrs; + + envStrs = GetNamedResource('STR#', REZ_ENV); + if (envStrs == NULL) return NULL; + numStrs = *((short *) (*envStrs)); + + rezEnv = (char **) ckalloc((numStrs + 1) * sizeof(char *)); + + if (envStrs != NULL) { + ResType theType; + Str255 theName; + short theID, index = 1; + int i = 0; + char* string; + + GetResInfo(envStrs, &theID, &theType, theName); + for(;;) { + GetIndString(theName, theID, index++); + if (theName[0] == '\0') break; + string = (char *) ckalloc(theName[0] + 2); + strncpy(string, (char *) theName + 1, theName[0]); + string[theName[0]] = '\0'; + rezEnv[i++] = string; + } + ReleaseResource(envStrs); + + rezEnv[i] = NULL; + return rezEnv; + } + + return NULL; +} +#endif + +/* + *---------------------------------------------------------------------- + * + * FileRCVariables -- + * + * Creates environment variables from a file in the system preferences + * folder. The function looks for a file in the preferences folder + * a name defined in the #define kPrefsFile. If the define is not + * defined this code will not be included. If the resource doesn't exist or + * no strings reside in the resource nothing will happen. + * + * Results: + * ptr to value on success, NULL if error. + * + * Side effects: + * Memory is allocated and returned to the caller. + * + *---------------------------------------------------------------------- + */ + +#ifdef kPrefsFile +static char ** +FileRCVariables() +{ + char *prefsFolder = NULL; + char *tempPtr = NULL; + char **fileEnv = NULL; + FILE *thePrefsFile = NULL; + int i; + char tempStr[kMaxEnvStringSize]; + FSSpec currentDir, prefDir; + OSErr err; + + /* + * Save default folder and change working dir + * to the preferences folder. + */ + FSpGetDefaultDir(¤tDir); + err = FSpFindFolder(kOnSystemDisk, kPreferencesFolderType, + kDontCreateFolder, &prefDir); + err = FSpSetDefaultDir(&prefDir); + + /* TODO: this code should use new channel IO. */ + if ((thePrefsFile = fopen(kPrefsFile, "r")) == NULL) { + FSpSetDefaultDir(¤tDir); + return NULL; + } + + fileEnv = (char **) ckalloc((kMaxEnvVarSize + 1) * sizeof(char *)); + + i = 0; + while (fgets(tempStr, kMaxEnvStringSize, thePrefsFile) != NULL) { + /* + * First strip off new line char + */ + if (tempStr[strlen(tempStr)-1] == '\n') { + tempStr[strlen(tempStr)-1] = '\0'; + } + if (tempStr[0] == '\0' || tempStr[0] == '#') { + /* + * skip empty lines or commented lines + */ + continue; + } + + tempPtr = (char *) ckalloc(strlen(tempStr) + 1); + strcpy(tempPtr,tempStr); + fileEnv[i++] = tempPtr; + } + + fileEnv[i] = NULL; + fclose(thePrefsFile); + + FSpSetDefaultDir(¤tDir); + return fileEnv; +} +#endif + +/* + *---------------------------------------------------------------------- + * + * MakeFolderEnvVar -- + * + * This function creates "environment" variable by taking a prefix and + * appending a folder path to a directory. The directory is specified + * by a integer value acceptable by the FindFolder function. + * + * Results: + * The function returns an *allocated* string. If the folder doesn't + * exist the return string is still allocated and just contains the + * given prefix. + * + * Side effects: + * Memory is allocated and returned to the caller. + * + *---------------------------------------------------------------------- + */ + +static char * +MakeFolderEnvVar(prefixTag, whichFolder) + char * prefixTag; /* Prefix added before result. */ + long whichFolder; /* Constant for FSpFindFolder. */ +{ + char * thePath = NULL; + char * result = NULL; + OSErr theErr = noErr; + Handle theString = NULL; + FSSpec theFolder; + int size; + Tcl_DString pathStr; + Tcl_DString tagPathStr; + + Tcl_DStringInit(&pathStr); + theErr = FSpFindFolder(kOnSystemDisk, whichFolder, + kDontCreateFolder, &theFolder); + if (theErr == noErr) { + theErr = FSpPathFromLocation(&theFolder, &size, &theString); + + HLock(theString); + tclPlatform = TCL_PLATFORM_MAC; + Tcl_DStringAppend(&pathStr, *theString, -1); + HUnlock(theString); + DisposeHandle(theString); + + Tcl_DStringInit(&tagPathStr); + Tcl_DStringAppend(&tagPathStr, prefixTag, strlen(prefixTag)); + Tcl_DStringAppend(&tagPathStr, pathStr.string, pathStr.length); + Tcl_DStringFree(&pathStr); + + /* + * Make sure the path ends with a ':' + */ + if (tagPathStr.string[tagPathStr.length - 1] != ':') { + Tcl_DStringAppend(&tagPathStr, ":", 1); + } + + /* + * Don't free tagPathStr - rather make sure it's allocated + * and return it as the result. + */ + if (tagPathStr.string == tagPathStr.staticSpace) { + result = (char *) ckalloc(tagPathStr.length + 1); + strcpy(result, tagPathStr.string); + } else { + result = tagPathStr.string; + } + } else { + result = (char *) ckalloc(strlen(prefixTag) + 1); + strcpy(result, prefixTag); + } + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * PathVariables -- + * + * Creates environment variables from the system call FSpFindFolder. + * The function generates environment variables for many of the + * commonly used paths on the Macintosh. + * + * Results: + * ptr to value on success, NULL if error. + * + * Side effects: + * Memory is allocated and returned to the caller. + * + *---------------------------------------------------------------------- + */ + +static char ** +PathVariables() +{ + int i = 0; + char **sysEnv; + char *thePath = NULL; + + sysEnv = (char **) ckalloc((12) * sizeof(char *)); + + sysEnv[i++] = MakeFolderEnvVar("PREF_FOLDER=", kPreferencesFolderType); + sysEnv[i++] = MakeFolderEnvVar("SYS_FOLDER=", kSystemFolderType); + sysEnv[i++] = MakeFolderEnvVar("TEMP=", kTemporaryFolderType); + sysEnv[i++] = MakeFolderEnvVar("APPLE_M_FOLDER=", kAppleMenuFolderType); + sysEnv[i++] = MakeFolderEnvVar("CP_FOLDER=", kControlPanelFolderType); + sysEnv[i++] = MakeFolderEnvVar("DESK_FOLDER=", kDesktopFolderType); + sysEnv[i++] = MakeFolderEnvVar("EXT_FOLDER=", kExtensionFolderType); + sysEnv[i++] = MakeFolderEnvVar("PRINT_MON_FOLDER=", + kPrintMonitorDocsFolderType); + sysEnv[i++] = MakeFolderEnvVar("SHARED_TRASH_FOLDER=", + kWhereToEmptyTrashFolderType); + sysEnv[i++] = MakeFolderEnvVar("TRASH_FOLDER=", kTrashFolderType); + sysEnv[i++] = MakeFolderEnvVar("START_UP_FOLDER=", kStartupFolderType); + sysEnv[i++] = NULL; + + return sysEnv; +} + +/* + *---------------------------------------------------------------------- + * + * SystemVariables -- + * + * Creates environment variables from various Mac system calls. + * + * Results: + * ptr to value on success, NULL if error. + * + * Side effects: + * Memory is allocated and returned to the caller. + * + *---------------------------------------------------------------------- + */ + +static char ** +SystemVariables() +{ + int i = 0; + char ** sysEnv; + char * thePath = NULL; + Handle theString = NULL; + FSSpec currentDir; + int size; + + sysEnv = (char **) ckalloc((4) * sizeof(char *)); + + /* + * Get user name from chooser. It will be assigned to both + * the USER and LOGIN environment variables. + */ + thePath = GetUserName(); + sysEnv[i] = (char *) ckalloc(strlen(kLoginnameTag) + strlen(thePath) + 1); + strcpy(sysEnv[i], kLoginnameTag); + strcpy(sysEnv[i]+strlen(kLoginnameTag), thePath); + i++; + sysEnv[i] = (char *) ckalloc(strlen(kUsernameTag) + strlen(thePath) + 1); + strcpy(sysEnv[i], kUsernameTag); + strcpy(sysEnv[i]+strlen(kUsernameTag), thePath); + i++; + + /* + * Get 'home' directory + */ +#ifdef kDefaultDirTag + FSpGetDefaultDir(¤tDir); + FSpPathFromLocation(¤tDir, &size, &theString); + HLock(theString); + sysEnv[i] = (char *) ckalloc(strlen(kDefaultDirTag) + size + 4); + strcpy(sysEnv[i], kDefaultDirTag); + strncpy(sysEnv[i]+strlen(kDefaultDirTag) , *theString, size); + if (sysEnv[i][strlen(kDefaultDirTag) + size - 1] != ':') { + sysEnv[i][strlen(kDefaultDirTag) + size] = ':'; + sysEnv[i][strlen(kDefaultDirTag) + size + 1] = '\0'; + } else { + sysEnv[i][strlen(kDefaultDirTag) + size] = '\0'; + } + HUnlock(theString); + DisposeHandle(theString); + i++; +#endif + + sysEnv[i++] = NULL; + return sysEnv; +} + +/* + *---------------------------------------------------------------------- + * + * TclMacCreateEnv -- + * + * This function allocates and populates the global "environ" + * variable. Entries are in traditional Unix format but variables + * are, hopefully, a bit more relevant for the Macintosh. + * + * Results: + * The number of elements in the newly created environ array. + * + * Side effects: + * Memory is allocated and pointed too by the environ variable. + * + *---------------------------------------------------------------------- + */ + +int +TclMacCreateEnv() +{ + char ** sysEnv = NULL; + char ** pathEnv = NULL; + char ** fileEnv = NULL; + char ** rezEnv = NULL; + int count = 0; + int i, j; + + sysEnv = SystemVariables(); + if (sysEnv != NULL) { + for (i = 0; sysEnv[i] != NULL; count++, i++) { + /* Empty Loop */ + } + } + + pathEnv = PathVariables(); + if (pathEnv != NULL) { + for (i = 0; pathEnv[i] != NULL; count++, i++) { + /* Empty Loop */ + } + } + +#ifdef kPrefsFile + fileEnv = FileRCVariables(); + if (fileEnv != NULL) { + for (i = 0; fileEnv[i] != NULL; count++, i++) { + /* Empty Loop */ + } + } +#endif + +#ifdef REZ_ENV + rezEnv = RezRCVariables(); + if (rezEnv != NULL) { + for (i = 0; rezEnv[i] != NULL; count++, i++) { + /* Empty Loop */ + } + } +#endif + + /* + * Create environ variable + */ + environ = (char **) ckalloc((count + 1) * sizeof(char *)); + j = 0; + + if (sysEnv != NULL) { + for (i = 0; sysEnv[i] != NULL;) + environ[j++] = sysEnv[i++]; + ckfree((char *) sysEnv); + } + + if (pathEnv != NULL) { + for (i = 0; pathEnv[i] != NULL;) + environ[j++] = pathEnv[i++]; + ckfree((char *) pathEnv); + } + +#ifdef kPrefsFile + if (fileEnv != NULL) { + for (i = 0; fileEnv[i] != NULL;) + environ[j++] = fileEnv[i++]; + ckfree((char *) fileEnv); + } +#endif + +#ifdef REZ_ENV + if (rezEnv != NULL) { + for (i = 0; rezEnv[i] != NULL;) + environ[j++] = rezEnv[i++]; + ckfree((char *) rezEnv); + } +#endif + + environ[j] = NULL; + return j; +} + +/* + *---------------------------------------------------------------------- + * + * GetUserName -- + * + * Get the user login name. + * + * Results: + * ptr to static string, NULL if error. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +GetUserName() +{ + static char buf[33]; + short refnum; + Handle h; + + refnum = CurResFile(); + UseResFile(0); + h = GetResource('STR ', -16096); + UseResFile(refnum); + if (h == NULL) { + return NULL; + } + + HLock(h); + strncpy(buf, (*h)+1, **h); + buf[**h] = '\0'; + HUnlock(h); + return(buf[0] ? buf : NULL); +} diff --git a/tcl7.6/mac/tclMacExit.c b/tcl7.6/mac/tclMacExit.c new file mode 100644 index 0000000..252686d --- /dev/null +++ b/tcl7.6/mac/tclMacExit.c @@ -0,0 +1,316 @@ +/* + * tclMacExit.c -- + * + * This file contains routines that deal with cleaning up various state + * when Tcl/Tk applications quit. Unfortunantly, not all state is cleaned + * up by the process when an application quites or crashes. Also you + * need to do different things depending on wether you are running as + * 68k code, PowerPC, or a code resource. The Exit handler code was + * adapted from code posted on alt.sources.mac by Dave Nebinger. + * + * Copyright (c) 1995 Dave Nebinger. + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclMacExit.c 1.3 96/09/05 10:51:02 + */ + +#include "tclInt.h" +#include "tclMacInt.h" +#include +#include + +/* + * Various typedefs and defines needed to patch ExitToShell. + */ + +enum { + uppExitToShellProcInfo = kPascalStackBased +}; + +#if USESROUTINEDESCRIPTORS +typedef UniversalProcPtr ExitToShellUPP; + +#define CallExitToShellProc(userRoutine) \ + CallUniversalProc((UniversalProcPtr)(userRoutine),uppExitToShellProcInfo) +#define NewExitToShellProc(userRoutine) \ + (ExitToShellUPP)NewRoutineDescriptor((ProcPtr)(userRoutine), \ + uppExitToShellProcInfo, GetCurrentArchitecture()) + +#else +typedef ExitToShellProcPtr ExitToShellUPP; + +#define CallExitToShellProc(userRoutine) \ + (*(userRoutine))() +#define NewExitToShellProc(userRoutine) \ + (ExitToShellUPP)(userRoutine) +#endif + +#define DisposeExitToShellProc(userRoutine) \ + DisposeRoutineDescriptor(userRoutine) + +#if defined(powerc)||defined(__powerc) +#pragma options align=mac68k +#endif +struct ExitToShellUPPList{ + struct ExitToShellUPPList* nextProc; + ExitToShellUPP userProc; +}; +#if defined(powerc)||defined(__powerc) +#pragma options align=reset +#endif + +typedef struct ExitToShellDataStruct ExitToShellDataRec,* ExitToShellDataPtr,** ExitToShellDataHdl; + +typedef struct ExitToShellUPPList ExitToShellUPPList,* ExitToShellUPPListPtr,** ExitToShellUPPHdl; + +#if defined(powerc)||defined(__powerc) +#pragma options align=mac68k +#endif +struct ExitToShellDataStruct{ + unsigned long a5; + ExitToShellUPPList* userProcs; + ExitToShellUPP oldProc; +}; +#if defined(powerc)||defined(__powerc) +#pragma options align=reset +#endif + +/* + * Static globals used within this file. + */ +static ExitToShellDataPtr gExitToShellData = (ExitToShellDataPtr) NULL; + + +/* + *---------------------------------------------------------------------- + * + * TclPlatformExit -- + * + * This procedure implements the Macintosh specific exit routine. + * We explicitly callthe ExitHandler function to do various clean + * up. + * + * Results: + * None. + * + * Side effects: + * We exit the process. + * + *---------------------------------------------------------------------- + */ + +void +TclPlatformExit(status) + int status; +{ + TclMacExitHandler(); + ExitToShell(); +} + +/* + *---------------------------------------------------------------------- + * + * TclMacExitHandler -- + * + * This procedure is invoked after Tcl at the last possible moment + * to clean up any state Tcl has left around that may cause other + * applications to crash. For example, this function can be used + * as the termination routine for CFM applications. + * + * Results: + * None. + * + * Side effects: + * Various cleanup occurs. + * + *---------------------------------------------------------------------- + */ + +void +TclMacExitHandler() +{ + ExitToShellUPPListPtr curProc; + + /* + * Loop through all installed Exit handlers + * and call them. Always make sure we are in + * a clean state in case we are recursivly called. + */ + if ((gExitToShellData) != NULL && (gExitToShellData->userProcs != NULL)){ + + /* + * Call the installed exit to shell routines. + */ + curProc = gExitToShellData->userProcs; + do { + gExitToShellData->userProcs = curProc->nextProc; + CallExitToShellProc(curProc->userProc); + DisposeExitToShellProc(curProc->userProc); + DisposePtr((Ptr) curProc); + curProc = gExitToShellData->userProcs; + } while (curProc != (ExitToShellUPPListPtr) NULL); + } + + return; +} + +/* + *---------------------------------------------------------------------- + * + * TclMacInstallExitToShellPatch -- + * + * This procedure installs a way to clean up state at the latest + * possible moment before we exit. These are things that must + * be cleaned up or the system will crash. The exact way in which + * this is implemented depends on the architecture in which we are + * running. For 68k applications we patch the ExitToShell call. + * For PowerPC applications we just create a list of procs to call. + * The function ExitHandler should be installed in the Code + * Fragments terminiation routine. + * + * Results: + * None. + * + * Side effects: + * Installs the new routine. + * + *---------------------------------------------------------------------- + */ + +OSErr +TclMacInstallExitToShellPatch(newProc) + ExitToShellProcPtr newProc; +{ + ExitToShellUPP exitHandler; + ExitToShellUPPListPtr listPtr; + + if (gExitToShellData == (ExitToShellDataPtr) NULL){ + TclMacInitExitToShell(true); + } + + /* + * Add the passed in function pointer to the list of functions + * to be called when ExitToShell is called. + */ + exitHandler = NewExitToShellProc(newProc); + listPtr = (ExitToShellUPPListPtr) NewPtrClear(sizeof(ExitToShellUPPList)); + listPtr->userProc = exitHandler; + listPtr->nextProc = gExitToShellData->userProcs; + gExitToShellData->userProcs = listPtr; + + return noErr; +} + +/* + *---------------------------------------------------------------------- + * + * ExitToShellPatchRoutine -- + * + * This procedure is invoked when someone calls ExitToShell for + * this application. This function performs some last miniute + * clean up and then calls the real ExitToShell routine. + * + * Results: + * None. + * + * Side effects: + * Various cleanup occurs. + * + *---------------------------------------------------------------------- + */ + +static pascal void +ExitToShellPatchRoutine() +{ + ExitToShellUPP oldETS; + long oldA5; + + /* + * Set up our A5 world. This allows us to have + * access to our global variables in the 68k world. + */ + oldA5 = SetCurrentA5(); + SetA5(gExitToShellData->a5); + + /* + * Call the function that invokes all + * of the handlers. + */ + TclMacExitHandler(); + + /* + * Call the origional ExitToShell routine. + */ + oldETS = gExitToShellData->oldProc; + DisposePtr((Ptr) gExitToShellData); + SetA5(oldA5); + CallExitToShellProc(oldETS); + return; +} + +/* + *---------------------------------------------------------------------- + * + * TclMacInitExitToShell -- + * + * This procedure initializes the ExitToShell clean up machanism. + * Generally, this is handled automatically when users make a call + * to InstallExitToShellPatch. However, it can be called + * explicitly at startup time to turn off the patching mechanism. + * This can be used by code resources which could be removed from + * the application before ExitToShell is called. + * + * Note, if we are running from CFM code we never install the + * patch. Instead, the function ExitHandler should be installed + * as the terminiation routine for the code fragment. + * + * Results: + * None. + * + * Side effects: + * Creates global state. + * + *---------------------------------------------------------------------- + */ + +void +TclMacInitExitToShell(usePatch) + int usePatch; +{ + if (gExitToShellData == (ExitToShellDataPtr) NULL){ +#if GENERATINGCFM + gExitToShellData = (ExitToShellDataPtr) + NewPtr(sizeof(ExitToShellDataRec)); + gExitToShellData->a5 = SetCurrentA5(); + gExitToShellData->userProcs = (ExitToShellUPPList*) NULL; +#else + ExitToShellUPP oldExitToShell, newExitToShellPatch; + short exitToShellTrap; + + /* + * Initialize patch mechanism. + */ + + gExitToShellData = (ExitToShellDataPtr) NewPtr(sizeof(ExitToShellDataRec)); + gExitToShellData->a5 = SetCurrentA5(); + gExitToShellData->userProcs = (ExitToShellUPPList*) NULL; + + /* + * Save state needed to call origional ExitToShell routine. Install + * the new ExitToShell code in it's place. + */ + if (usePatch) { + exitToShellTrap = _ExitToShell & 0x3ff; + newExitToShellPatch = NewExitToShellProc(ExitToShellPatchRoutine); + oldExitToShell = (ExitToShellUPP) + NGetTrapAddress(exitToShellTrap, ToolTrap); + NSetTrapAddress((UniversalProcPtr) newExitToShellPatch, + exitToShellTrap, ToolTrap); + gExitToShellData->oldProc = oldExitToShell; + } +#endif + } +} diff --git a/tcl7.6/mac/tclMacFCmd.c b/tcl7.6/mac/tclMacFCmd.c new file mode 100644 index 0000000..8655abf --- /dev/null +++ b/tcl7.6/mac/tclMacFCmd.c @@ -0,0 +1,1014 @@ +/* + * tclMacFCmd.c -- + * + * Implements the Macintosh specific portions of the file manipulation + * subcommands of the "file" command. + * + * Copyright (c) 1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclMacFCmd.c 1.11 96/10/10 10:13:49 + */ + +#include "tclInt.h" +#include "tclMacInt.h" +#include "tclPort.h" +#include +#include +#include +#include +#include +#include +#include +#include + +/* + * Prototypes for procedure only used in this file + */ + +OSErr FSpGetFLockCompat(const FSSpec *specPtr, + Boolean *lockedPtr); + +static OSErr GenerateUniqueName(short vRefNum, long dirID1, + long dirID2, Str31 uniqueName); +static OSErr GetFileSpecs(char *path, FSSpec *pathSpecPtr, + FSSpec *dirSpecPtr, Boolean *pathExistsPtr, + Boolean *pathIsDirectoryPtr); +static OSErr MoveRename(const FSSpec *srcSpecPtr, + const FSSpec *dstSpecPtr, StringPtr copyName); +static int Pstrequal(ConstStr255Param stringA, + ConstStr255Param stringB); + +static pascal Boolean CopyErrHandler( + OSErr error, /* Error that occured */ + short failedOperation, /* operation that caused the error */ + short srcVRefNum, /* volume ref number of source */ + long srcDirID, /* directory id of source */ + StringPtr srcName, /* name of source */ + short dstVRefNum, /* volume ref number of dst */ + long dstDirID, /* directory id of dst */ + StringPtr dstName /* name of dst directory */ +) ; + + +/* + *--------------------------------------------------------------------------- + * + * TclpRenameFile -- + * + * Changes the name of an existing file or directory, from src to dst. + * If src and dst refer to the same file or directory, does nothing + * and returns success. Otherwise if dst already exists, it will be + * deleted and replaced by src subject to the following conditions: + * If src is a directory, dst may be an empty directory. + * If src is a file, dst may be a file. + * In any other situation where dst already exists, the rename will + * fail. + * + * Results: + * If the directory was successfully created, returns TCL_OK. + * Otherwise the return value is TCL_ERROR and errno is set to + * indicate the error. Some possible values for errno are: + * + * EACCES: src or dst parent directory can't be read and/or written. + * EEXIST: dst is a non-empty directory. + * EINVAL: src is a root directory or dst is a subdirectory of src. + * EISDIR: dst is a directory, but src is not. + * ENOENT: src doesn't exist. src or dst is "". + * ENOTDIR: src is a directory, but dst is not. + * EXDEV: src and dst are on different filesystems. + * + * Side effects: + * The implementation of rename may allow cross-filesystem renames, + * but the caller should be prepared to emulate it with copy and + * delete if errno is EXDEV. + * + *--------------------------------------------------------------------------- + */ + +int +TclpRenameFile( + char *src, /* Pathname of file or dir to be renamed. */ + char *dst) /* New pathname for file or directory. */ +{ + FSSpec srcFileSpec, dstFileSpec, dstDirSpec; + OSErr err; + long srcID, dummy; + Boolean srcIsDirectory, dstIsDirectory, dstExists, dstLocked; + + err = FSpLocationFromPath(strlen(src), src, &srcFileSpec); + if (err == noErr) { + FSpGetDirectoryID(&srcFileSpec, &srcID, &srcIsDirectory); + } + if (err == noErr) { + err = GetFileSpecs(dst, &dstFileSpec, &dstDirSpec, &dstExists, + &dstIsDirectory); + } + if (err == noErr) { + if (dstExists == 0) { + err = MoveRename(&srcFileSpec, &dstDirSpec, dstFileSpec.name); + goto end; + } + err = FSpGetFLockCompat(&dstFileSpec, &dstLocked); + if (dstLocked) { + FSpRstFLockCompat(&dstFileSpec); + } + } + if (err == noErr) { + if (srcIsDirectory) { + if (dstIsDirectory) { + /* + * The following call will remove an empty directory. If it + * fails, it's because it wasn't empty. + */ + + if (TclpRemoveDirectory(dst, 0, NULL) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Now that that empty directory is gone, we can try + * renaming src. If that fails, we'll put this empty + * directory back, for completeness. + */ + + err = MoveRename(&srcFileSpec, &dstDirSpec, dstFileSpec.name); + if (err != noErr) { + FSpDirCreateCompat(&dstFileSpec, smSystemScript, &dummy); + if (dstLocked) { + FSpSetFLockCompat(&dstFileSpec); + } + } + } else { + errno = ENOTDIR; + return TCL_ERROR; + } + } else { + if (dstIsDirectory) { + errno = EISDIR; + return TCL_ERROR; + } else { + /* + * Overwrite existing file by: + * + * 1. Rename existing file to temp name. + * 2. Rename old file to new name. + * 3. If success, delete temp file. If failure, + * put temp file back to old name. + */ + + Str31 tmpName; + FSSpec tmpFileSpec; + + err = GenerateUniqueName(dstFileSpec.vRefNum, + dstFileSpec.parID, dstFileSpec.parID, tmpName); + if (err == noErr) { + err = FSpRenameCompat(&dstFileSpec, tmpName); + } + if (err == noErr) { + err = FSMakeFSSpecCompat(dstFileSpec.vRefNum, + dstFileSpec.parID, tmpName, &tmpFileSpec); + } + if (err == noErr) { + err = MoveRename(&srcFileSpec, &dstDirSpec, + dstFileSpec.name); + } + if (err == noErr) { + FSpDeleteCompat(&tmpFileSpec); + } else { + FSpDeleteCompat(&dstFileSpec); + FSpRenameCompat(&tmpFileSpec, dstFileSpec.name); + if (dstLocked) { + FSpSetFLockCompat(&dstFileSpec); + } + } + } + } + } + + end: + if (err != noErr) { + errno = TclMacOSErrorToPosixError(err); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpCopyFile -- + * + * Copy a single file (not a directory). If dst already exists and + * is not a directory, it is removed. + * + * Results: + * If the file was successfully copied, returns TCL_OK. Otherwise + * the return value is TCL_ERROR and errno is set to indicate the + * error. Some possible values for errno are: + * + * EACCES: src or dst parent directory can't be read and/or written. + * EISDIR: src or dst is a directory. + * ENOENT: src doesn't exist. src or dst is "". + * + * Side effects: + * This procedure will also copy symbolic links, block, and + * character devices, and fifos. For symbolic links, the links + * themselves will be copied and not what they point to. For the + * other special file types, the directory entry will be copied and + * not the contents of the device that it refers to. + * + *--------------------------------------------------------------------------- + */ + +int +TclpCopyFile( + char *src, /* Pathname of file to be copied. */ + char *dst) /* Pathname of file to copy to. */ +{ + OSErr err, dstErr; + Boolean dstExists, dstIsDirectory, dstLocked; + FSSpec srcFileSpec, dstFileSpec, dstDirSpec, tmpFileSpec; + Str31 tmpName; + + err = FSpLocationFromPath(strlen(src), src, &srcFileSpec); + if (err == noErr) { + err = GetFileSpecs(dst, &dstFileSpec, &dstDirSpec, &dstExists, + &dstIsDirectory); + } + if (dstExists) { + if (dstIsDirectory) { + errno = EISDIR; + return TCL_ERROR; + } + err = FSpGetFLockCompat(&dstFileSpec, &dstLocked); + if (dstLocked) { + FSpRstFLockCompat(&dstFileSpec); + } + + /* + * Backup dest file. + */ + + dstErr = GenerateUniqueName(dstFileSpec.vRefNum, dstFileSpec.parID, + dstFileSpec.parID, tmpName); + if (dstErr == noErr) { + dstErr = FSpRenameCompat(&dstFileSpec, tmpName); + } + } + if (err == noErr) { + err = FSpFileCopy(&srcFileSpec, &dstDirSpec, + (StringPtr) dstFileSpec.name, NULL, 0, true); + } + if ((dstExists != false) && (dstErr == noErr)) { + FSMakeFSSpecCompat(dstFileSpec.vRefNum, dstFileSpec.parID, + tmpName, &tmpFileSpec); + if (err == noErr) { + /* + * Delete backup file. + */ + + FSpDeleteCompat(&tmpFileSpec); + } else { + + /* + * Restore backup file. + */ + + FSpDeleteCompat(&dstFileSpec); + FSpRenameCompat(&tmpFileSpec, dstFileSpec.name); + if (dstLocked) { + FSpSetFLockCompat(&dstFileSpec); + } + } + } + + if (err != noErr) { + errno = TclMacOSErrorToPosixError(err); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpDeleteFile -- + * + * Removes a single file (not a directory). + * + * Results: + * If the file was successfully deleted, returns TCL_OK. Otherwise + * the return value is TCL_ERROR and errno is set to indicate the + * error. Some possible values for errno are: + * + * EACCES: a parent directory can't be read and/or written. + * EISDIR: path is a directory. + * ENOENT: path doesn't exist or is "". + * + * Side effects: + * The file is deleted, even if it is read-only. + * + *--------------------------------------------------------------------------- + */ + +int +TclpDeleteFile( + char *path) /* Pathname of file to be removed. */ +{ + OSErr err; + FSSpec fileSpec; + Boolean isDirectory; + long dirID; + + err = FSpLocationFromPath(strlen(path), path, &fileSpec); + if (err == noErr) { + /* + * Since FSpDeleteCompat will delete an empty directory, make sure + * that this isn't a directory first. + */ + + FSpGetDirectoryID(&fileSpec, &dirID, &isDirectory); + if (isDirectory == true) { + errno = EISDIR; + return TCL_ERROR; + } + } + err = FSpDeleteCompat(&fileSpec); + if (err == fLckdErr) { + FSpRstFLockCompat(&fileSpec); + err = FSpDeleteCompat(&fileSpec); + if (err != noErr) { + FSpSetFLockCompat(&fileSpec); + } + } + if (err != noErr) { + errno = TclMacOSErrorToPosixError(err); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpCreateDirectory -- + * + * Creates the specified directory. All parent directories of the + * specified directory must already exist. The directory is + * automatically created with permissions so that user can access + * the new directory and create new files or subdirectories in it. + * + * Results: + * If the directory was successfully created, returns TCL_OK. + * Otherwise the return value is TCL_ERROR and errno is set to + * indicate the error. Some possible values for errno are: + * + * EACCES: a parent directory can't be read and/or written. + * EEXIST: path already exists. + * ENOENT: a parent directory doesn't exist. + * + * Side effects: + * A directory is created with the current umask, except that + * permission for u+rwx will always be added. + * + *--------------------------------------------------------------------------- + */ + +int +TclpCreateDirectory( + char *path) /* Pathname of directory to create. */ +{ + OSErr err; + FSSpec dirSpec; + long outDirID; + + err = FSpLocationFromPath(strlen(path), path, &dirSpec); + if (err == noErr) { + err = dupFNErr; /* EEXIST. */ + } else if (err == fnfErr) { + err = FSpDirCreateCompat(&dirSpec, smSystemScript, &outDirID); + } + + if (err != noErr) { + errno = TclMacOSErrorToPosixError(err); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpCopyDirectory -- + * + * Recursively copies a directory. The target directory dst must + * not already exist. Note that this function does not merge two + * directory hierarchies, even if the target directory is an an + * empty directory. + * + * Results: + * If the directory was successfully copied, returns TCL_OK. + * Otherwise the return value is TCL_ERROR, errno is set to indicate + * the error, and the pathname of the file that caused the error + * is stored in errorPtr. See TclpCreateDirectory and TclpCopyFile + * for a description of possible values for errno. + * + * Side effects: + * An exact copy of the directory hierarchy src will be created + * with the name dst. If an error occurs, the error will + * be returned immediately, and remaining files will not be + * processed. + * + *--------------------------------------------------------------------------- + */ + +int +TclpCopyDirectory( + char *src, /* Pathname of directory to be copied. */ + char *dst, /* Pathname of target directory. */ + Tcl_DString *errorPtr) /* If non-NULL, initialized DString for + * error reporting. */ +{ + OSErr err, saveErr; + long srcID, tmpDirID; + FSSpec srcFileSpec, dstFileSpec, dstDirSpec, tmpDirSpec, tmpFileSpec; + Boolean srcIsDirectory, srcLocked; + Boolean dstIsDirectory, dstExists; + Str31 tmpName; + + err = FSpLocationFromPath(strlen(src), src, &srcFileSpec); + if (err == noErr) { + err = FSpGetDirectoryID(&srcFileSpec, &srcID, &srcIsDirectory); + } + if (err == noErr) { + if (srcIsDirectory == false) { + err = afpObjectTypeErr; /* ENOTDIR. */ + } + } + if (err == noErr) { + err = GetFileSpecs(dst, &dstFileSpec, &dstDirSpec, &dstExists, + &dstIsDirectory); + } + if (dstExists) { + if (dstIsDirectory == false) { + err = afpObjectTypeErr; /* ENOTDIR. */ + } else { + err = dupFNErr; /* EEXIST. */ + } + } + if (err != noErr) { + goto done; + } + if ((srcFileSpec.vRefNum == dstFileSpec.vRefNum) && + (srcFileSpec.parID == dstFileSpec.parID) && + (Pstrequal(srcFileSpec.name, dstFileSpec.name) != 0)) { + /* + * Copying on top of self. No-op. + */ + + goto done; + } + + /* + * This algorthm will work making a copy of the source directory in + * the current directory with a new name, in a new directory with the + * same name, and in a new directory with a new name: + * + * 1. Make dstDir/tmpDir. + * 2. Copy srcDir/src to dstDir/tmpDir/src + * 3. Rename dstDir/tmpDir/src to dstDir/tmpDir/dst (if necessary). + * 4. CatMove dstDir/tmpDir/dst to dstDir/dst. + * 5. Remove dstDir/tmpDir. + */ + + err = FSpGetFLockCompat(&srcFileSpec, &srcLocked); + if (srcLocked) { + FSpRstFLockCompat(&srcFileSpec); + } + if (err == noErr) { + err = GenerateUniqueName(dstFileSpec.vRefNum, dstFileSpec.parID, + dstFileSpec.parID, tmpName); + } + if (err == noErr) { + FSMakeFSSpecCompat(dstFileSpec.vRefNum, dstFileSpec.parID, + tmpName, &tmpDirSpec); + err = FSpDirCreateCompat(&tmpDirSpec, smSystemScript, &tmpDirID); + } + if (err == noErr) { + err = FSpDirectoryCopy(&srcFileSpec, &tmpDirSpec, NULL, 0, true, + CopyErrHandler); + } + + /* + * Even if the Copy failed, Rename/Move whatever did get copied to the + * appropriate final destination, if possible. + */ + + saveErr = err; + err = noErr; + if (Pstrequal(srcFileSpec.name, dstFileSpec.name) == 0) { + err = FSMakeFSSpecCompat(tmpDirSpec.vRefNum, tmpDirID, + srcFileSpec.name, &tmpFileSpec); + if (err == noErr) { + err = FSpRenameCompat(&tmpFileSpec, dstFileSpec.name); + } + } + if (err == noErr) { + err = FSMakeFSSpecCompat(tmpDirSpec.vRefNum, tmpDirID, + dstFileSpec.name, &tmpFileSpec); + } + if (err == noErr) { + err = FSpCatMoveCompat(&tmpFileSpec, &dstDirSpec); + } + if (err == noErr) { + if (srcLocked) { + FSpSetFLockCompat(&dstFileSpec); + } + } + + FSpDeleteCompat(&tmpDirSpec); + + if (saveErr != noErr) { + err = saveErr; + } + + done: + if (err != noErr) { + errno = TclMacOSErrorToPosixError(err); + if (errorPtr != NULL) { + Tcl_DStringAppend(errorPtr, dst, -1); + } + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * CopyErrHandler -- + * + * This procedure is called from the MoreFiles procedure + * FSpDirectoryCopy whenever an error occurs. + * + * Results: + * False if the condition should not be considered an error, true + * otherwise. + * + * Side effects: + * Since FSpDirectoryCopy() is called only after removing any + * existing target directories, there shouldn't be any errors. + * + *---------------------------------------------------------------------- + */ +static pascal Boolean +CopyErrHandler( + OSErr error, /* Error that occured */ + short failedOperation, /* operation that caused the error */ + short srcVRefNum, /* volume ref number of source */ + long srcDirID, /* directory id of source */ + StringPtr srcName, /* name of source */ + short dstVRefNum, /* volume ref number of dst */ + long dstDirID, /* directory id of dst */ + StringPtr dstName /* name of dst directory */ +) { + return true; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpRemoveDirectory -- + * + * Removes directory (and its contents, if the recursive flag is set). + * + * Results: + * If the directory was successfully removed, returns TCL_OK. + * Otherwise the return value is TCL_ERROR, errno is set to indicate + * the error, and the pathname of the file that caused the error + * is stored in errorPtr. Some possible values for errno are: + * + * EACCES: path directory can't be read and/or written. + * EEXIST: path is a non-empty directory. + * EINVAL: path is a root directory. + * ENOENT: path doesn't exist or is "". + * ENOTDIR: path is not a directory. + * + * Side effects: + * Directory removed. If an error occurs, the error will be returned + * immediately, and remaining files will not be deleted. + * + *--------------------------------------------------------------------------- + */ + +int +TclpRemoveDirectory( + char *path, /* Pathname of directory to be removed. */ + int recursive, /* If non-zero, removes directories that + * are nonempty. Otherwise, will only remove + * empty directories. */ + Tcl_DString *errorPtr) /* If non-NULL, initialized DString for + * error reporting. */ +{ + OSErr err; + FSSpec fileSpec; + long dirID; + int locked; + Boolean isDirectory; + CInfoPBRec pb; + Str255 fileName; + + locked = 0; + err = FSpLocationFromPath(strlen(path), path, &fileSpec); + if (err != noErr) { + goto done; + } + + /* + * Since FSpDeleteCompat will delete a file, make sure this isn't + * a file first. + */ + + isDirectory = 1; + FSpGetDirectoryID(&fileSpec, &dirID, &isDirectory); + if (isDirectory == 0) { + errno = ENOTDIR; + return TCL_ERROR; + } + + err = FSpDeleteCompat(&fileSpec); + if (err == fLckdErr) { + locked = 1; + FSpRstFLockCompat(&fileSpec); + err = FSpDeleteCompat(&fileSpec); + } + if (err == noErr) { + return TCL_OK; + } + if (err != fBsyErr) { + goto done; + } + + if (recursive == 0) { + /* + * fBsyErr means one of three things: file busy, directory not empty, + * or working directory control block open. Determine if directory + * is empty. If directory is not empty, return EEXIST. + */ + + pb.hFileInfo.ioVRefNum = fileSpec.vRefNum; + pb.hFileInfo.ioDirID = dirID; + pb.hFileInfo.ioNamePtr = (StringPtr) fileName; + pb.hFileInfo.ioFDirIndex = 1; + if (PBGetCatInfoSync(&pb) == noErr) { + err = dupFNErr; /* EEXIST */ + goto done; + } + } + + /* + * DeleteDirectory removes a directory and all its contents, including + * any locked files. There is no interface to get the name of the + * file that caused the error, if an error occurs deleting this tree, + * unless we rewrite DeleteDirectory ourselves. + */ + + err = DeleteDirectory(fileSpec.vRefNum, dirID, NULL); + + done: + if (err != noErr) { + if (errorPtr != NULL) { + Tcl_DStringAppend(errorPtr, path, -1); + } + if (locked) { + FSpSetFLockCompat(&fileSpec); + } + errno = TclMacOSErrorToPosixError(err); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------------------- + * + * MoveRename -- + * + * Helper function for TclpRenameFile. Renames a file or directory + * into the same directory or another directory. The target name + * must not already exist in the destination directory. + * + * Don't use FSpMoveRenameCompat because it doesn't work with + * directories or with locked files. + * + * Results: + * Returns a mac error indicating the cause of the failure. + * + * Side effects: + * Creates a temp file in the target directory to handle a rename + * between directories. + * + *-------------------------------------------------------------------------- + */ + +static OSErr +MoveRename( + const FSSpec *srcFileSpecPtr, /* Source object. */ + const FSSpec *dstDirSpecPtr, /* Destination directory. */ + StringPtr copyName) /* New name for object in destination + * directory. */ +{ + OSErr err; + long srcID, dstID; + Boolean srcIsDir, dstIsDir; + Str31 tmpName; + FSSpec dstFileSpec, srcDirSpec, tmpSrcFileSpec, tmpDstFileSpec; + Boolean locked; + + if (srcFileSpecPtr->parID == 1) { + /* + * Trying to rename a volume. + */ + + return badMovErr; + } + if (srcFileSpecPtr->vRefNum != dstDirSpecPtr->vRefNum) { + /* + * Renaming across volumes. + */ + + return diffVolErr; + } + err = FSpGetFLockCompat(srcFileSpecPtr, &locked); + if (locked) { + FSpRstFLockCompat(srcFileSpecPtr); + } + if (err == noErr) { + err = FSpGetDirectoryID(dstDirSpecPtr, &dstID, &dstIsDir); + } + if (err == noErr) { + if (srcFileSpecPtr->parID == dstID) { + /* + * Renaming object within directory. + */ + + err = FSpRenameCompat(srcFileSpecPtr, copyName); + goto done; + } + if (Pstrequal(srcFileSpecPtr->name, copyName)) { + /* + * Moving object to another directory (under same name). + */ + + err = FSpCatMoveCompat(srcFileSpecPtr, dstDirSpecPtr); + goto done; + } + err = FSpGetDirectoryID(srcFileSpecPtr, &srcID, &srcIsDir); + } + if (err == noErr) { + /* + * Fullblown: rename source object to temp name, move temp to + * dest directory, and rename temp to target. + */ + + err = GenerateUniqueName(srcFileSpecPtr->vRefNum, + srcFileSpecPtr->parID, dstID, tmpName); + FSMakeFSSpecCompat(srcFileSpecPtr->vRefNum, srcFileSpecPtr->parID, + tmpName, &tmpSrcFileSpec); + FSMakeFSSpecCompat(dstDirSpecPtr->vRefNum, dstID, tmpName, + &tmpDstFileSpec); + } + if (err == noErr) { + err = FSpRenameCompat(srcFileSpecPtr, tmpName); + } + if (err == noErr) { + err = FSpCatMoveCompat(&tmpSrcFileSpec, dstDirSpecPtr); + if (err == noErr) { + err = FSpRenameCompat(&tmpDstFileSpec, copyName); + if (err == noErr) { + goto done; + } + FSMakeFSSpecCompat(srcFileSpecPtr->vRefNum, srcFileSpecPtr->parID, + NULL, &srcDirSpec); + FSpCatMoveCompat(&tmpDstFileSpec, &srcDirSpec); + } + FSpRenameCompat(&tmpSrcFileSpec, srcFileSpecPtr->name); + } + + done: + if (locked != false) { + if (err == noErr) { + FSMakeFSSpecCompat(dstDirSpecPtr->vRefNum, + dstID, copyName, &dstFileSpec); + FSpSetFLockCompat(&dstFileSpec); + } else { + FSpSetFLockCompat(srcFileSpecPtr); + } + } + return err; +} + +/* + *--------------------------------------------------------------------------- + * + * GetFileSpecs -- + * + * Generate a filename that is not in either of the two specified + * directories (on the same volume). + * + * Results: + * Standard macintosh error. On success, uniqueName is filled with + * the name of the temporary file. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static OSErr +GenerateUniqueName( + short vRefNum, /* Volume on which the following directories + * are located. */ + long dirID1, /* ID of first directory. */ + long dirID2, /* ID of second directory. May be the same + * as the first. */ + Str31 uniqueName) /* Filled with filename for a file that is + * not located in either of the above two + * directories. */ +{ + OSErr err; + long i; + CInfoPBRec pb; + static unsigned char hexStr[16] = "0123456789ABCDEF"; + static long startSeed = 248923489; + + pb.hFileInfo.ioVRefNum = vRefNum; + pb.hFileInfo.ioFDirIndex = 0; + pb.hFileInfo.ioNamePtr = uniqueName; + + while (1) { + startSeed++; + pb.hFileInfo.ioNamePtr[0] = 8; + for (i = 1; i <= 8; i++) { + pb.hFileInfo.ioNamePtr[i] = hexStr[((startSeed >> ((8-i)*4)) & 0xf)]; + } + pb.hFileInfo.ioDirID = dirID1; + err = PBGetCatInfoSync(&pb); + if (err == fnfErr) { + if (dirID1 != dirID2) { + pb.hFileInfo.ioDirID = dirID2; + err = PBGetCatInfoSync(&pb); + } + if (err == fnfErr) { + return noErr; + } + } + if (err == noErr) { + continue; + } + return err; + } +} + +/* + *--------------------------------------------------------------------------- + * + * GetFileSpecs -- + * + * Gets FSSpecs for the specified path and its parent directory. + * + * Results: + * The return value is noErr if there was no error getting FSSpecs, + * otherwise it is an error describing the problem. Fills buffers + * with information, as above. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static OSErr +GetFileSpecs( + char *path, /* The path to query. */ + FSSpec *pathSpecPtr, /* Filled with information about path. */ + FSSpec *dirSpecPtr, /* Filled with information about path's + * parent directory. */ + Boolean *pathExistsPtr, /* Set to true if path actually exists, + * false if it doesn't or there was an + * error reading the specified path. */ + Boolean *pathIsDirectoryPtr)/* Set to true if path is itself a directory, + * otherwise false. */ +{ + char *dirName; + OSErr err; + int argc; + char **argv; + long d; + Tcl_DString buffer; + + *pathExistsPtr = false; + *pathIsDirectoryPtr = false; + + Tcl_DStringInit(&buffer); + Tcl_SplitPath(path, &argc, &argv); + if (argc == 1) { + dirName = ":"; + } else { + dirName = Tcl_JoinPath(argc - 1, argv, &buffer); + } + err = FSpLocationFromPath(strlen(dirName), dirName, dirSpecPtr); + Tcl_DStringFree(&buffer); + ckfree((char *) argv); + + if (err == noErr) { + err = FSpLocationFromPath(strlen(path), path, pathSpecPtr); + if (err == noErr) { + *pathExistsPtr = true; + err = FSpGetDirectoryID(pathSpecPtr, &d, pathIsDirectoryPtr); + } else if (err == fnfErr) { + err = noErr; + } + } + return err; +} + +/* + *------------------------------------------------------------------------- + * + * FSpGetFLockCompat -- + * + * Determines if there exists a software lock on the specified + * file. The software lock could prevent the file from being + * renamed or moved. + * + * Results: + * Standard macintosh error code. + * + * Side effects: + * None. + * + * + *------------------------------------------------------------------------- + */ + +OSErr +FSpGetFLockCompat( + const FSSpec *specPtr, /* File to query. */ + Boolean *lockedPtr) /* Set to true if file is locked, false + * if it isn't or there was an error reading + * specified file. */ +{ + CInfoPBRec pb; + OSErr err; + + pb.hFileInfo.ioVRefNum = specPtr->vRefNum; + pb.hFileInfo.ioDirID = specPtr->parID; + pb.hFileInfo.ioNamePtr = (StringPtr) specPtr->name; + pb.hFileInfo.ioFDirIndex = 0; + + err = PBGetCatInfoSync(&pb); + if ((err == noErr) && (pb.hFileInfo.ioFlAttrib & 0x01)) { + *lockedPtr = true; + } else { + *lockedPtr = false; + } + return err; +} + +/* + *---------------------------------------------------------------------- + * + * Pstrequal -- + * + * Pascal string compare. + * + * Results: + * Returns 1 if strings equal, 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +static int +Pstrequal ( + ConstStr255Param stringA, /* Pascal string A */ + ConstStr255Param stringB) /* Pascal string B */ +{ + int i, len; + + len = *stringA; + for (i = 0; i <= len; i++) { + if (*stringA++ != *stringB++) { + return 0; + } + } + return 1; +} + + diff --git a/tcl7.6/mac/tclMacFile.c b/tcl7.6/mac/tclMacFile.c new file mode 100644 index 0000000..d43f3e3 --- /dev/null +++ b/tcl7.6/mac/tclMacFile.c @@ -0,0 +1,1606 @@ +/* + * tclMacFile.c -- + * + * This file implements the channel drivers for Macintosh + * files. It also comtains Macintosh version of other Tcl + * functions that deal with the file system. + * + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclMacFile.c 1.49 96/10/10 10:11:36 + */ + +/* + * Note: This code eventually needs to support async I/O. In doing this + * we will need to keep track of all current async I/O. If exit to shell + * is called - we shouldn't exit until all asyc I/O completes. + */ + +#include "tclInt.h" +#include "tclPort.h" +#include "tclMacInt.h" +#include +#include +#include +#include +#include +#include +#include +#include + +/* + * The following are flags returned by GetOpenMode. They + * are or'd together to determine how opening and handling + * a file should occur. + */ + +#define TCL_RDONLY (1<<0) +#define TCL_WRONLY (1<<1) +#define TCL_RDWR (1<<2) +#define TCL_CREAT (1<<3) +#define TCL_TRUNC (1<<4) +#define TCL_APPEND (1<<5) +#define TCL_ALWAYS_APPEND (1<<6) +#define TCL_EXCL (1<<7) +#define TCL_NOCTTY (1<<8) +#define TCL_NONBLOCK (1<<9) +#define TCL_RW_MODES (TCL_RDONLY|TCL_WRONLY|TCL_RDWR) + +/* + * This structure describes per-instance state of a + * macintosh file based channel. + */ + +typedef struct FileState { + short fileRef; /* Macintosh file reference number. */ + Tcl_Channel fileChan; /* Pointer to the channel for this file. */ + int appendMode; /* Flag to tell if in O_APPEND mode or not. */ + int volumeRef; /* Flag to tell if in O_APPEND mode or not. */ +} FileState; + +/* + * The variable below caches the name of the current working directory + * in order to avoid repeated calls to getcwd. The string is malloc-ed. + * NULL means the cache needs to be refreshed. + */ + +static char *currentDir = NULL; + +/* + * Static routines for this file: + */ + +static int FileBlockMode _ANSI_ARGS_((ClientData instanceData, + int mode)); +static int FileClose _ANSI_ARGS_((ClientData instanceData, + Tcl_Interp *interp)); +static Tcl_File FileGet _ANSI_ARGS_((ClientData instanceData, + int direction)); +static int FileInput _ANSI_ARGS_((ClientData instanceData, + char *buf, int toRead, int *errorCode)); +static int FileOutput _ANSI_ARGS_((ClientData instanceData, + char *buf, int toWrite, int *errorCode)); +static int FileReady _ANSI_ARGS_((ClientData instanceData, + int mask)); +static int FileSeek _ANSI_ARGS_((ClientData instanceData, + long offset, int mode, int *errorCode)); +static void FileWatch _ANSI_ARGS_((ClientData instanceData, + int mask)); +static int GetOpenMode _ANSI_ARGS_((Tcl_Interp *interp, + char *string)); +static Tcl_Channel OpenFileChannel _ANSI_ARGS_((char *fileName, int mode, + int permissions, int *errorCodePtr)); + +/* + * This variable describes the channel type structure for file based IO. + */ + +static Tcl_ChannelType fileChannelType = { + "file", /* Type name. */ + FileBlockMode, /* Set blocking or + * non-blocking mode.*/ + FileClose, /* Close proc. */ + FileInput, /* Input proc. */ + FileOutput, /* Output proc. */ + FileSeek, /* Seek proc. */ + NULL, /* Set option proc. */ + NULL, /* Get option proc. */ + FileWatch, /* Initialize notifier. */ + FileReady, /* Are there events? */ + FileGet /* Get Tcl_Files out of channel. */ +}; + + +/* + *---------------------------------------------------------------------- + * + * TclChdir -- + * + * Change the current working directory. + * + * Results: + * The result is a standard Tcl result. If an error occurs and + * interp isn't NULL, an error message is left in interp->result. + * + * Side effects: + * The working directory for this application is changed. Also + * the cache maintained used by TclGetCwd is deallocated and + * set to NULL. + * + *---------------------------------------------------------------------- + */ + +int +TclChdir(interp, dirName) + Tcl_Interp *interp; /* If non NULL, used for error reporting. */ + char *dirName; /* Path to new working directory. */ +{ + FSSpec spec; + OSErr err; + Boolean isFolder; + long dirID; + + if (currentDir != NULL) { + ckfree(currentDir); + currentDir = NULL; + } + + err = FSpLocationFromPath(strlen(dirName), dirName, &spec); + if (err != noErr) { + errno = ENOENT; + goto chdirError; + } + + err = FSpGetDirectoryID(&spec, &dirID, &isFolder); + if (err != noErr) { + errno = ENOENT; + goto chdirError; + } + + if (isFolder != true) { + errno = ENOTDIR; + goto chdirError; + } + + err = FSpSetDefaultDir(&spec); + if (err != noErr) { + switch (err) { + case afpAccessDenied: + errno = EACCES; + break; + default: + errno = ENOENT; + } + goto chdirError; + } + + return TCL_OK; + chdirError: + if (interp != NULL) { + Tcl_AppendResult(interp, "couldn't change working directory to \"", + dirName, "\": ", Tcl_PosixError(interp), (char *) NULL); + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetCwd -- + * + * Return the path name of the current working directory. + * + * Results: + * The result is the full path name of the current working + * directory, or NULL if an error occurred while figuring it + * out. If an error occurs and interp isn't NULL, an error + * message is left in interp->result. + * + * Side effects: + * The path name is cached to avoid having to recompute it + * on future calls; if it is already cached, the cached + * value is returned. + * + *---------------------------------------------------------------------- + */ + +char * +TclGetCwd(interp) + Tcl_Interp *interp; /* If non NULL, used for error reporting. */ +{ + FSSpec theSpec; + int length; + Handle pathHandle = NULL; + + if (currentDir == NULL) { + if (FSpGetDefaultDir(&theSpec) != noErr) { + if (interp != NULL) { + interp->result = "error getting working directory name"; + } + return NULL; + } + if (FSpPathFromLocation(&theSpec, &length, &pathHandle) != noErr) { + if (interp != NULL) { + interp->result = "error getting working directory name"; + } + return NULL; + } + HLock(pathHandle); + currentDir = (char *) ckalloc((unsigned) (length + 1)); + strcpy(currentDir, *pathHandle); + HUnlock(pathHandle); + DisposeHandle(pathHandle); + } + return currentDir; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_WaitPid -- + * + * Fakes a call to wait pid. + * + * Results: + * Always returns -1. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_WaitPid(pid, statPtr, options) + int pid; + int *statPtr; + int options; +{ + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * TclCreateTempFile -- + * + * This function creates a temporary file initialized with an + * optional string, and returns a file handle with the file pointer + * at the beginning of the file. + * + * Results: + * A handle to a file. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_File +TclCreateTempFile(contents, namePtr) + char *contents; /* String to write into temp file, or NULL. */ + Tcl_DString *namePtr; /* If non-NULL, pointer to initialized + * DString that is filled with the name of + * the temp file that was created. */ +{ + char fileName[L_tmpnam]; + Tcl_File file; + int length = (contents == NULL) ? 0 : strlen(contents); + + tmpnam(fileName); + file = TclOpenFile(fileName, O_RDWR|O_CREAT|O_TRUNC); + unlink(fileName); + + if ((file != NULL) && (length > 0)) { + int fd = (int)Tcl_GetFileInfo(file, NULL); + while (1) { + if (write(fd, contents, length) != -1) { + break; + } else if (errno != EINTR) { + close(fd); + Tcl_FreeFile(file); + return NULL; + } + } + lseek(fd, 0, SEEK_SET); + } + if (namePtr != NULL) { + Tcl_DStringAppend(namePtr, fileName, -1); + } + return file; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FindExecutable -- + * + * This procedure computes the absolute path name of the current + * application, given its argv[0] value. However, this + * implementation doesn't use of need the argv[0] value. NULL + * may be passed in its place. + * + * Results: + * None. + * + * Side effects: + * The variable tclExecutableName gets filled in with the file + * name for the application, if we figured it out. If we couldn't + * figure it out, Tcl_FindExecutable is set to NULL. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_FindExecutable(argv0) + char *argv0; /* The value of the application's argv[0]. */ +{ + ProcessSerialNumber psn; + ProcessInfoRec info; + Str63 appName; + FSSpec fileSpec; + int pathLength; + Handle pathName = NULL; + OSErr err; + + GetCurrentProcess(&psn); + info.processInfoLength = sizeof(ProcessInfoRec); + info.processName = appName; + info.processAppSpec = &fileSpec; + GetProcessInformation(&psn, &info); + + if (tclExecutableName != NULL) { + ckfree(tclExecutableName); + tclExecutableName = NULL; + } + + err = FSpPathFromLocation(&fileSpec, &pathLength, &pathName); + + tclExecutableName = (char *) ckalloc((unsigned) pathLength + 1); + HLock(pathName); + strcpy(tclExecutableName, *pathName); + HUnlock(pathName); + DisposeHandle(pathName); +} + +/* + *---------------------------------------------------------------------- + * + * TclGetUserHome -- + * + * This function takes the passed in user name and finds the + * corresponding home directory specified in the password file. + * + * Results: + * On a Macintosh we always return a NULL. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +TclGetUserHome(name, bufferPtr) + char *name; /* User name to use to find home directory. */ + Tcl_DString *bufferPtr; /* May be used to hold result. Must not hold + * anything at the time of the call, and need + * not even be initialized. */ +{ + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TclMatchFiles -- + * + * This routine is used by the globbing code to search a + * directory for all files which match a given pattern. + * + * Results: + * If the tail argument is NULL, then the matching files are + * added to the interp->result. Otherwise, TclDoGlob is called + * recursively for each matching subdirectory. The return value + * is a standard Tcl result indicating whether an error occurred + * in globbing. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- */ + +int +TclMatchFiles(interp, separators, dirPtr, pattern, tail) + Tcl_Interp *interp; /* Interpreter to receive results. */ + char *separators; /* Directory separators to pass to TclDoGlob. */ + Tcl_DString *dirPtr; /* Contains path to directory to search. */ + char *pattern; /* Pattern to match against. */ + char *tail; /* Pointer to end of pattern. Tail must + * point to a location in pattern. */ +{ + char *dirName, *patternEnd = tail; + char savedChar; + int result = TCL_OK; + int baseLength = Tcl_DStringLength(dirPtr); + CInfoPBRec pb; + OSErr err; + FSSpec dirSpec; + Boolean isDirectory; + long dirID; + short itemIndex; + Str255 fileName; + + + /* + * Make sure that the directory part of the name really is a + * directory. + */ + + dirName = dirPtr->string; + FSpLocationFromPath(strlen(dirName), dirName, &dirSpec); + err = FSpGetDirectoryID(&dirSpec, &dirID, &isDirectory); + if ((err != noErr) || !isDirectory) { + return TCL_OK; + } + + /* + * Now open the directory for reading and iterate over the contents. + */ + + pb.hFileInfo.ioVRefNum = dirSpec.vRefNum; + pb.hFileInfo.ioDirID = dirID; + pb.hFileInfo.ioNamePtr = (StringPtr) fileName; + pb.hFileInfo.ioFDirIndex = itemIndex = 1; + + /* + * Clean up the end of the pattern and the tail pointer. Leave + * the tail pointing to the first character after the path separator + * following the pattern, or NULL. Also, ensure that the pattern + * is null-terminated. + */ + + if (*tail == '\\') { + tail++; + } + if (*tail == '\0') { + tail = NULL; + } else { + tail++; + } + savedChar = *patternEnd; + *patternEnd = '\0'; + + while (1) { + pb.hFileInfo.ioFDirIndex = itemIndex; + pb.hFileInfo.ioDirID = dirID; + err = PBGetCatInfoSync(&pb); + if (err != noErr) { + break; + } + + /* + * Now check to see if the file matches. If there are more + * characters to be processed, then ensure matching files are + * directories before calling TclDoGlob. Otherwise, just add + * the file to the result. + */ + + p2cstr(fileName); + if (Tcl_StringMatch((char *) fileName, pattern)) { + Tcl_DStringSetLength(dirPtr, baseLength); + Tcl_DStringAppend(dirPtr, (char *) fileName, -1); + if (tail == NULL) { + if ((dirPtr->length > 1) && + (strchr(dirPtr->string+1, ':') == NULL)) { + Tcl_AppendElement(interp, dirPtr->string+1); + } else { + Tcl_AppendElement(interp, dirPtr->string); + } + } else if ((pb.hFileInfo.ioFlAttrib & ioDirMask) != 0) { + Tcl_DStringAppend(dirPtr, ":", 1); + result = TclDoGlob(interp, separators, dirPtr, tail); + if (result != TCL_OK) { + break; + } + } + } + + itemIndex++; + } + *patternEnd = savedChar; + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclMacStat -- + * + * This function replaces the library version of stat. The stat + * function provided by most Mac compiliers is rather broken and + * incomplete. + * + * Results: + * See stat documentation. + * + * Side effects: + * See stat documentation. + * + *---------------------------------------------------------------------- + */ + +int +TclMacStat(path, buf) + char *path; + struct stat *buf; +{ + HFileInfo fpb; + HVolumeParam vpb; + OSErr err; + FSSpec fileSpec; + Boolean isDirectory; + long dirID; + + err = FSpLocationFromPath(strlen(path), path, &fileSpec); + if (err != noErr) { + errno = TclMacOSErrorToPosixError(err); + return -1; + } + + /* + * Fill the fpb & vpb struct up with info about file or directory. + */ + + FSpGetDirectoryID(&fileSpec, &dirID, &isDirectory); + vpb.ioVRefNum = fpb.ioVRefNum = fileSpec.vRefNum; + vpb.ioNamePtr = fpb.ioNamePtr = fileSpec.name; + if (isDirectory) { + fpb.ioDirID = fileSpec.parID; + } else { + fpb.ioDirID = dirID; + } + + fpb.ioFDirIndex = 0; + err = PBGetCatInfoSync((CInfoPBPtr)&fpb); + if (err == noErr) { + vpb.ioVolIndex = 0; + err = PBHGetVInfoSync((HParmBlkPtr)&vpb); + if (err == noErr && buf != NULL) { + /* + * Files are always readable by everyone. + */ + + buf->st_mode = S_IRUSR | S_IRGRP | S_IROTH; + + /* + * Use the Volume Info & File Info to fill out stat buf. + */ + if (fpb.ioFlAttrib & 0x10) { + buf->st_mode |= S_IFDIR; + buf->st_nlink = 2; + } else { + buf->st_nlink = 1; + if (fpb.ioFlFndrInfo.fdFlags & 0x8000) { + buf->st_mode |= S_IFLNK; + } else { + buf->st_mode |= S_IFREG; + } + } + if ((fpb.ioFlAttrib & 0x10) || (fpb.ioFlFndrInfo.fdType == 'APPL')) { + /* + * Directories and applications are executable by everyone. + */ + + buf->st_mode |= S_IXUSR | S_IXGRP | S_IXOTH; + } + if ((fpb.ioFlAttrib & 0x01) == 0){ + /* + * If not locked, then everyone has write acces. + */ + + buf->st_mode |= S_IWUSR | S_IWGRP | S_IWOTH; + } + buf->st_ino = fpb.ioDirID; + buf->st_dev = fpb.ioVRefNum; + buf->st_uid = -1; + buf->st_gid = -1; + buf->st_rdev = 0; + buf->st_size = fpb.ioFlLgLen; + buf->st_atime = buf->st_mtime = fpb.ioFlMdDat; + buf->st_ctime = fpb.ioFlCrDat; + buf->st_blksize = vpb.ioVAlBlkSiz; + buf->st_blocks = (buf->st_size + buf->st_blksize - 1) / buf->st_blksize; + } + } + + if (err != noErr) { + errno = TclMacOSErrorToPosixError(err); + } + + return (err == noErr ? 0 : -1); +} + +/* + *---------------------------------------------------------------------- + * + * TclMacReadlink -- + * + * This function replaces the library version of readlink. + * + * Results: + * See readlink documentation. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclMacReadlink(path, buf, size) + char *path; + char *buf; + int size; +{ + HFileInfo fpb; + OSErr err; + FSSpec fileSpec; + Boolean isDirectory; + Boolean wasAlias; + long dirID; + char fileName[256]; + char *end; + Handle theString = NULL; + int pathSize; + + /* + * Remove ending colons if they exist. + */ + while ((strlen(path) != 0) && (path[strlen(path) - 1] == ':')) { + path[strlen(path) - 1] = NULL; + } + + if (strchr(path, ':') == NULL) { + strcpy(fileName, path); + path = NULL; + } else { + end = strrchr(path, ':') + 1; + strcpy(fileName, end); + *end = NULL; + } + c2pstr(fileName); + + /* + * Create the file spec for the directory of the file + * we want to look at. + */ + if (path != NULL) { + err = FSpLocationFromPath(strlen(path), path, &fileSpec); + if (err != noErr) { + errno = EINVAL; + return -1; + } + } else { + FSMakeFSSpecCompat(0, 0, NULL, &fileSpec); + } + + /* + * Fill the fpb struct up with info about file or directory. + */ + FSpGetDirectoryID(&fileSpec, &dirID, &isDirectory); + fpb.ioVRefNum = fileSpec.vRefNum; + fpb.ioDirID = dirID; + fpb.ioNamePtr = (StringPtr) fileName; + + fpb.ioFDirIndex = 0; + err = PBGetCatInfoSync((CInfoPBPtr)&fpb); + if (err != noErr) { + errno = TclMacOSErrorToPosixError(err); + return -1; + } else { + if (fpb.ioFlAttrib & 0x10) { + errno = EINVAL; + return -1; + } else { + if (fpb.ioFlFndrInfo.fdFlags & 0x8000) { + /* + * The file is a link! + */ + } else { + errno = EINVAL; + return -1; + } + } + } + + /* + * If we are here it's really a link - now find out + * where it points to. + */ + err = FSMakeFSSpecCompat(fileSpec.vRefNum, dirID, (StringPtr) fileName, &fileSpec); + if (err == noErr) { + err = ResolveAliasFile(&fileSpec, true, &isDirectory, &wasAlias); + } + if ((err == fnfErr) || wasAlias) { + err = FSpPathFromLocation(&fileSpec, &pathSize, &theString); + if ((err != noErr) || (pathSize > size)) { + DisposeHandle(theString); + errno = ENAMETOOLONG; + return -1; + } + } else { + errno = EINVAL; + return -1; + } + + strncpy(buf, *theString, pathSize); + DisposeHandle(theString); + + return pathSize; +} + +/* + *---------------------------------------------------------------------- + * + * TclMacAccess -- + * + * This function replaces the library version of access. The + * access function provided by most Mac compiliers is rather + * broken or incomplete. + * + * Results: + * See access documentation. + * + * Side effects: + * See access documentation. + * + *---------------------------------------------------------------------- + */ + +int +TclMacAccess(path, mode) + const char *path; + int mode; +{ + HFileInfo fpb; + HVolumeParam vpb; + OSErr err; + FSSpec fileSpec; + Boolean isDirectory; + long dirID; + int full_mode = 0; + + err = FSpLocationFromPath(strlen(path), (char *) path, &fileSpec); + if (err != noErr) { + errno = TclMacOSErrorToPosixError(err); + return -1; + } + + /* + * Fill the fpb & vpb struct up with info about file or directory. + */ + FSpGetDirectoryID(&fileSpec, &dirID, &isDirectory); + vpb.ioVRefNum = fpb.ioVRefNum = fileSpec.vRefNum; + vpb.ioNamePtr = fpb.ioNamePtr = fileSpec.name; + if (isDirectory) { + fpb.ioDirID = fileSpec.parID; + } else { + fpb.ioDirID = dirID; + } + + fpb.ioFDirIndex = 0; + err = PBGetCatInfoSync((CInfoPBPtr)&fpb); + if (err == noErr) { + vpb.ioVolIndex = 0; + err = PBHGetVInfoSync((HParmBlkPtr)&vpb); + if (err == noErr) { + /* + * Use the Volume Info & File Info to determine + * access information. If we have got this far + * we know the directory is searchable or the file + * exists. (We have F_OK) + */ + + /* + * Check to see if the volume is hardware or + * software locked. If so we arn't W_OK. + */ + if (mode & W_OK) { + if ((vpb.ioVAtrb & 0x0080) || (vpb.ioVAtrb & 0x8000)) { + errno = EROFS; + return -1; + } + if (fpb.ioFlAttrib & 0x01) { + errno = EACCES; + return -1; + } + } + + /* + * Directories are always searchable and executable. But only + * files of type 'APPL' are executable. + */ + if (!(fpb.ioFlAttrib & 0x10) && (mode & X_OK) + && (fpb.ioFlFndrInfo.fdType != 'APPL')) { + return -1; + } + } + } + + if (err != noErr) { + errno = TclMacOSErrorToPosixError(err); + return -1; + } + + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclMacFOpenHack -- + * + * This function replaces fopen. It supports paths with alises. + * Note, remember to undefine the fopen macro! + * + * Results: + * See fopen documentation. + * + * Side effects: + * See fopen documentation. + * + *---------------------------------------------------------------------- + */ + +#undef fopen +FILE * +TclMacFOpenHack(path, mode) + const char *path; + const char *mode; +{ + OSErr err; + FSSpec fileSpec; + Handle pathString = NULL; + int size; + FILE * f; + + err = FSpLocationFromPath(strlen(path), (char *) path, &fileSpec); + if ((err != noErr) && (err != fnfErr)) { + return NULL; + } + err = FSpPathFromLocation(&fileSpec, &size, &pathString); + if ((err != noErr) && (err != fnfErr)) { + return NULL; + } + + HLock(pathString); + f = fopen(*pathString, mode); + HUnlock(pathString); + DisposeHandle(pathString); + return f; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_OpenFileChannel -- + * + * Open an File based channel on Unix systems. + * + * Results: + * The new channel or NULL. If NULL, the output argument + * errorCodePtr is set to a POSIX error. + * + * Side effects: + * May open the channel and may cause creation of a file on the + * file system. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_OpenFileChannel(interp, fileName, modeString, permissions) + Tcl_Interp *interp; /* Interpreter for error reporting; + * can be NULL. */ + char *fileName; /* Name of file to open. */ + char *modeString; /* A list of POSIX open modes or + * a string such as "rw". */ + int permissions; /* If the open involves creating a + * file, with what modes to create + * it? */ +{ + Tcl_Channel chan; + int mode; + char *nativeName; + Tcl_DString buffer; + int errorCode; + + mode = GetOpenMode(interp, modeString); + if (mode == -1) { + return NULL; + } + + nativeName = Tcl_TranslateFileName(interp, fileName, &buffer); + if (nativeName == NULL) { + return NULL; + } + + chan = OpenFileChannel(nativeName, mode, permissions, &errorCode); + Tcl_DStringFree(&buffer); + + if (chan == NULL) { + Tcl_SetErrno(errorCode); + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "couldn't open \"", fileName, "\": ", + Tcl_PosixError(interp), (char *) NULL); + } + return NULL; + } + + return chan; +} + +/* + *---------------------------------------------------------------------- + * + * OpenFileChannel-- + * + * Opens a Macintosh file and creates a Tcl channel to control it. + * + * Results: + * A Tcl channel. + * + * Side effects: + * Will open a Macintosh file. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Channel +OpenFileChannel(fileName, mode, permissions, errorCodePtr) + char *fileName; /* Name of file to open. */ + int mode; /* Mode for opening file. */ + int permissions; /* If the open involves creating a + * file, with what modes to create + * it? */ + int *errorCodePtr; /* Where to store error code. */ +{ + int channelPermissions; + Tcl_Channel chan; + char macPermision; + FSSpec fileSpec; + OSErr err; + short fileRef; + FileState *fileState; + char channelName[64]; + + /* + * Note we use fsRdWrShPerm instead of fsRdWrPerm which allows shared + * writes on a file. This isn't common on a mac but is common with + * Windows and UNIX and the feature is used by Tcl. + */ + + switch (mode & (TCL_RDONLY | TCL_WRONLY | TCL_RDWR)) { + case TCL_RDWR: + channelPermissions = (TCL_READABLE | TCL_WRITABLE); + macPermision = fsRdWrShPerm; + break; + case TCL_WRONLY: + /* + * Mac's fsRdPerm permission actually defaults to fsRdWrPerm because + * the Mac OS doesn't realy support write only access. We explicitly + * set the permission fsRdWrShPerm so that we can have shared write + * access. + */ + channelPermissions = TCL_WRITABLE; + macPermision = fsRdWrShPerm; + break; + case TCL_RDONLY: + default: + channelPermissions = TCL_READABLE; + macPermision = fsRdPerm; + break; + } + + err = FSpLocationFromPath(strlen(fileName), fileName, &fileSpec); + if ((err != noErr) && (err != fnfErr)) { + *errorCodePtr = errno = TclMacOSErrorToPosixError(err); + Tcl_SetErrno(errno); + return NULL; + } + + if ((err == fnfErr) && (mode & TCL_CREAT)) { + err = HCreate(fileSpec.vRefNum, fileSpec.parID, fileSpec.name, 'MPW ', 'TEXT'); + if (err != noErr) { + *errorCodePtr = errno = TclMacOSErrorToPosixError(err); + Tcl_SetErrno(errno); + return NULL; + } + } else if ((mode & TCL_CREAT) && (mode & TCL_EXCL)) { + *errorCodePtr = errno = EEXIST; + Tcl_SetErrno(errno); + return NULL; + } + + err = HOpenDF(fileSpec.vRefNum, fileSpec.parID, fileSpec.name, macPermision, &fileRef); + if (err != noErr) { + *errorCodePtr = errno = TclMacOSErrorToPosixError(err); + Tcl_SetErrno(errno); + return NULL; + } + + if (mode & TCL_TRUNC) { + SetEOF(fileRef, 0); + } + + sprintf(channelName, "file%d", (int) fileRef); + fileState = (FileState *) ckalloc((unsigned) sizeof(FileState)); + chan = Tcl_CreateChannel(&fileChannelType, channelName, + (ClientData) fileState, channelPermissions); + if (chan == (Tcl_Channel) NULL) { + *errorCodePtr = errno = EFAULT; + Tcl_SetErrno(errno); + FSClose(fileRef); + ckfree((char *) fileState); + return NULL; + } + + fileState->fileChan = chan; + fileState->volumeRef = fileSpec.vRefNum; + fileState->fileRef = fileRef; + if (mode & TCL_ALWAYS_APPEND) { + fileState->appendMode = true; + } else { + fileState->appendMode = false; + } + + if ((mode & TCL_ALWAYS_APPEND) || (mode & TCL_APPEND)) { + if (Tcl_Seek(chan, 0, SEEK_END) < 0) { + *errorCodePtr = errno = EFAULT; + Tcl_SetErrno(errno); + Tcl_Close(NULL, chan); + FSClose(fileRef); + ckfree((char *) fileState); + return NULL; + } + } + + return chan; +} + +/* + *---------------------------------------------------------------------- + * + * FileBlockMode -- + * + * Set blocking or non-blocking mode on channel. Macintosh files + * can never really be set to blocking or non-blocking modes. + * However, we don't generate an error - we just return success. + * + * Results: + * 0 if successful, errno when failed. + * + * Side effects: + * Sets the device into blocking or non-blocking mode. + * + *---------------------------------------------------------------------- + */ + +static int +FileBlockMode(instanceData, mode) + ClientData instanceData; /* Unused. */ + int mode; /* The mode to set. */ +{ + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * FileClose -- + * + * Closes the IO channel. + * + * Results: + * 0 if successful, the value of errno if failed. + * + * Side effects: + * Closes the physical channel + * + *---------------------------------------------------------------------- + */ + +static int +FileClose(instanceData, interp) + ClientData instanceData; /* Unused. */ + Tcl_Interp *interp; /* Unused. */ +{ + FileState *fileState = (FileState *) instanceData; + int errorCode = 0; + OSErr err; + + err = FSClose(fileState->fileRef); + FlushVol(NULL, fileState->volumeRef); + if (err != noErr) { + errorCode = errno = TclMacOSErrorToPosixError(err); + panic("error during file close"); + } + + ckfree((char *) fileState); + Tcl_SetErrno(errorCode); + return errorCode; +} + +/* + *---------------------------------------------------------------------- + * + * FileGet -- + * + * Called from Tcl_GetChannelFile to retrieve Tcl_Files from inside + * a file based channel. + * + * Results: + * The appropriate Tcl_File or NULL if not present. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tcl_File +FileGet(instanceData, direction) + ClientData instanceData; /* The file state. */ + int direction; /* Which Tcl_File to retrieve? */ +{ + FileState *fileState = (FileState *) instanceData; + + if ((direction == TCL_READABLE) || (direction == TCL_WRITABLE)) { + return (Tcl_File) fileState->fileRef; + } + return (Tcl_File) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * FileInput -- + * + * Reads input from the IO channel into the buffer given. Returns + * count of how many bytes were actually read, and an error indication. + * + * Results: + * A count of how many bytes were read is returned and an error + * indication is returned in an output argument. + * + * Side effects: + * Reads input from the actual channel. + * + *---------------------------------------------------------------------- + */ + +int +FileInput(instanceData, buffer, bufSize, errorCodePtr) + ClientData instanceData; /* Unused. */ + char *buffer; /* Where to store data read. */ + int bufSize; /* How much space is available + * in the buffer? */ + int *errorCodePtr; /* Where to store error code. */ +{ + FileState *fileState = (FileState *) instanceData; + OSErr err; + long length = bufSize; + + *errorCodePtr = 0; + errno = 0; + err = FSRead(fileState->fileRef, &length, buffer); + if ((err == noErr) || (err == eofErr)) { + return length; + } else { + switch (err) { + case ioErr: + *errorCodePtr = errno = EIO; + case afpAccessDenied: + *errorCodePtr = errno = EACCES; + default: + *errorCodePtr = errno = EINVAL; + } + return -1; + } + *errorCodePtr = errno; + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * FileOutput-- + * + * Writes the given output on the IO channel. Returns count of how + * many characters were actually written, and an error indication. + * + * Results: + * A count of how many characters were written is returned and an + * error indication is returned in an output argument. + * + * Side effects: + * Writes output on the actual channel. + * + *---------------------------------------------------------------------- + */ + +static int +FileOutput(instanceData, buffer, toWrite, errorCodePtr) + ClientData instanceData; /* Unused. */ + char *buffer; /* The data buffer. */ + int toWrite; /* How many bytes to write? */ + int *errorCodePtr; /* Where to store error code. */ +{ + FileState *fileState = (FileState *) instanceData; + long length = toWrite; + OSErr err; + + *errorCodePtr = 0; + errno = 0; + + if (fileState->appendMode == true) { + FileSeek(instanceData, 0, SEEK_END, errorCodePtr); + *errorCodePtr = 0; + } + + err = FSWrite(fileState->fileRef, &length, buffer); + if (err == noErr) { + err = FlushFile(fileState->fileRef); + } else { + *errorCodePtr = errno = TclMacOSErrorToPosixError(err); + return -1; + } + return length; +} + +/* + *---------------------------------------------------------------------- + * + * FileReady -- + * + * Called by the notifier to check whether events of interest are + * present on the channel. On the Macintosh all files are always + * considered to be readable and writeable. + * + * Results: + * Returns OR-ed combination of TCL_READABLE, TCL_WRITABLE and + * TCL_EXCEPTION to indicate which events of interest are present. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +FileReady(instanceData, mask) + ClientData instanceData; /* The file state. */ + int mask; /* Events of interest; an OR-ed + * combination of TCL_READABLE, + * TCL_WRITABLE and TCL_EXCEPTION. */ +{ + return (TCL_READABLE | TCL_WRITABLE); +} + +/* + *---------------------------------------------------------------------- + * + * FileSeek -- + * + * Seeks on an IO channel. Returns the new position. + * + * Results: + * -1 if failed, the new position if successful. If failed, it + * also sets *errorCodePtr to the error code. + * + * Side effects: + * Moves the location at which the channel will be accessed in + * future operations. + * + *---------------------------------------------------------------------- + */ + +static int +FileSeek(instanceData, offset, mode, errorCodePtr) + ClientData instanceData; /* Unused. */ + long offset; /* Offset to seek to. */ + int mode; /* Relative to where + * should we seek? */ + int *errorCodePtr; /* To store error code. */ +{ + FileState *fileState = (FileState *) instanceData; + IOParam pb; + OSErr err; + + *errorCodePtr = 0; + pb.ioCompletion = NULL; + pb.ioRefNum = fileState->fileRef; + if (mode == SEEK_SET) { + pb.ioPosMode = fsFromStart; + } else if (mode == SEEK_END) { + pb.ioPosMode = fsFromLEOF; + } else if (mode == SEEK_CUR) { + err = PBGetFPosSync((ParmBlkPtr) &pb); + if (pb.ioResult == noErr) { + if (offset == 0) { + return pb.ioPosOffset; + } + offset += pb.ioPosOffset; + } + pb.ioPosMode = fsFromStart; + } + pb.ioPosOffset = offset; + err = PBSetFPosSync((ParmBlkPtr) &pb); + if (pb.ioResult == noErr){ + return pb.ioPosOffset; + } else if (pb.ioResult == eofErr) { + long currentEOF, newEOF; + long buffer, i, length; + + err = PBGetEOFSync((ParmBlkPtr) &pb); + currentEOF = (long) pb.ioMisc; + if (mode == SEEK_SET) { + newEOF = offset; + } else if (mode == SEEK_END) { + newEOF = offset + currentEOF; + } else if (mode == SEEK_CUR) { + err = PBGetFPosSync((ParmBlkPtr) &pb); + newEOF = offset + pb.ioPosOffset; + } + + /* + * Write 0's to the new EOF. + */ + pb.ioPosOffset = 0; + pb.ioPosMode = fsFromLEOF; + err = PBGetFPosSync((ParmBlkPtr) &pb); + length = 1; + buffer = 0; + for (i = 0; i < (newEOF - currentEOF); i++) { + err = FSWrite(fileState->fileRef, &length, &buffer); + } + err = PBGetFPosSync((ParmBlkPtr) &pb); + if (pb.ioResult == noErr){ + return pb.ioPosOffset; + } + } + *errorCodePtr = errno = TclMacOSErrorToPosixError(err); + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * FileWatch -- + * + * Initialize the notifier to watch Tcl_Files from this channel. + * This doesn't do anything on the Macintosh. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +FileWatch(instanceData, mask) + ClientData instanceData; /* The file state. */ + int mask; /* Events of interest; an OR-ed + * combination of TCL_READABLE, + * TCL_WRITABLE and TCL_EXCEPTION. */ +{ + Tcl_Time timeout = { 0, 0 }; + + /* + * Currently, files are always ready under the Macintosh, + * so we just set a 0 timeout. Since there s no notification + * scheme - we just set the timeout time to zero. + */ + + Tcl_SetMaxBlockTime(&timeout); +} + +/* + *---------------------------------------------------------------------- + * + * TclMacOSErrorToPosixError -- + * + * Given a Macintosh OSErr return the appropiate POSIX error. + * + * Results: + * A Posix error. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclMacOSErrorToPosixError(error) + int error; /* A Macintosh error. */ +{ + switch (error) { + case noErr: + return 0; + case bdNamErr: + return ENAMETOOLONG; + case afpObjectTypeErr: + return ENOTDIR; + case fnfErr: + case dirNFErr: + return ENOENT; + case dupFNErr: + return EEXIST; + case dirFulErr: + case dskFulErr: + return ENOSPC; + case fBsyErr: + return EBUSY; + case tmfoErr: + return ENFILE; + case fLckdErr: + case permErr: + case afpAccessDenied: + return EACCES; + case wPrErr: + case vLckdErr: + return EROFS; + case badMovErr: + return EINVAL; + case diffVolErr: + return EXDEV; + default: + return EINVAL; + } +} + +/* + *---------------------------------------------------------------------- + * + * GetOpenMode -- + * + * Description: + * Computes a POSIX mode mask from a given string and also sets + * a flag to indicate whether the caller should seek to EOF during + * opening of the file. + * + * Results: + * On success, returns mode to pass to "open". If an error occurs, the + * returns -1 and if interp is not NULL, sets interp->result to an + * error message. + * + * Side effects: + * Sets the integer referenced by seekFlagPtr to 1 if the caller + * should seek to EOF during opening the file. + * + * Special note: + * This code is based on a prototype implementation contributed + * by Mark Diekhans. + * + *---------------------------------------------------------------------- + */ + +static int +GetOpenMode(interp, string) + Tcl_Interp *interp; /* Interpreter to use for error + * reporting - may be NULL. */ + char *string; /* Mode string, e.g. "r+" or + * "RDONLY CREAT". */ +{ + int mode, modeArgc, c, i, gotRW; + char **modeArgv, *flag; + + /* + * 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 = TCL_RDONLY; + break; + case 'w': + mode = TCL_WRONLY|TCL_CREAT|TCL_TRUNC; + break; + case 'a': + mode = TCL_WRONLY|TCL_CREAT|TCL_APPEND; + break; + default: + error: + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, + "illegal access mode \"", string, "\"", + (char *) NULL); + } + return -1; + } + if (string[1] == '+') { + mode &= ~(TCL_RDONLY|TCL_WRONLY); + mode |= TCL_RDWR; + if (string[2] != 0) { + goto error; + } + } else if (string[1] != 0) { + goto error; + } + return mode; + } + + /* + * The access modes are specified using a list of POSIX modes + * such as TCL_CREAT. + */ + + if (Tcl_SplitList(interp, string, &modeArgc, &modeArgv) != TCL_OK) { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AddErrorInfo(interp, + "\n while processing open access modes \""); + Tcl_AddErrorInfo(interp, string); + Tcl_AddErrorInfo(interp, "\""); + } + return -1; + } + + gotRW = 0; + for (i = 0; i < modeArgc; i++) { + flag = modeArgv[i]; + c = flag[0]; + if ((c == 'R') && (strcmp(flag, "RDONLY") == 0)) { + mode = (mode & ~TCL_RW_MODES) | TCL_RDONLY; + gotRW = 1; + } else if ((c == 'W') && (strcmp(flag, "WRONLY") == 0)) { + mode = (mode & ~TCL_RW_MODES) | TCL_WRONLY; + gotRW = 1; + } else if ((c == 'R') && (strcmp(flag, "RDWR") == 0)) { + mode = (mode & ~TCL_RW_MODES) | TCL_RDWR; + gotRW = 1; + } else if ((c == 'A') && (strcmp(flag, "APPEND") == 0)) { + mode |= TCL_ALWAYS_APPEND; + } else if ((c == 'C') && (strcmp(flag, "CREAT") == 0)) { + mode |= TCL_CREAT; + } else if ((c == 'E') && (strcmp(flag, "EXCL") == 0)) { + mode |= TCL_EXCL; + } else if ((c == 'N') && (strcmp(flag, "NOCTTY") == 0)) { + mode |= TCL_NOCTTY; + } else if ((c == 'N') && (strcmp(flag, "NONBLOCK") == 0)) { + mode |= TCL_NONBLOCK; + } else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) { + mode |= TCL_TRUNC; + } else { + if (interp != (Tcl_Interp *) NULL) { + 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 -1; + } + } + ckfree((char *) modeArgv); + if (!gotRW) { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "access mode must include either", + " RDONLY, WRONLY, or RDWR", (char *) NULL); + } + return -1; + } + return mode; +} diff --git a/tcl7.6/mac/tclMacInit.c b/tcl7.6/mac/tclMacInit.c new file mode 100644 index 0000000..74c1c84 --- /dev/null +++ b/tcl7.6/mac/tclMacInit.c @@ -0,0 +1,242 @@ +/* + * tclMacInit.c -- + * + * Contains the Mac-specific interpreter initialization functions. + * + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclMacInit.c 1.29 96/10/04 14:47:28 + */ + +#include +#include +#include +#include +#include +#include "tclInt.h" +#include "tclMacInt.h" + +/* + *---------------------------------------------------------------------- + * + * TclPlatformInit -- + * + * Performs Mac-specific interpreter initialization related to the + * tcl_platform and tcl_library variables. + * + * Results: + * None. + * + * Side effects: + * Sets "tcl_library" & "tcl_platfrom" Tcl variable + * + *---------------------------------------------------------------------- + */ + +void +TclPlatformInit(interp) + Tcl_Interp *interp; +{ + char *libDir; + Tcl_DString path, libPath; + long int gestaltResult; + int minor, major; + char versStr[10]; + + /* + * Set runtime C variable that tells cross platform C functions + * what platform they are running on. This can change at + * runtime for testing purposes. + */ + tclPlatform = TCL_PLATFORM_MAC; + + /* + * Define the tcl_platfrom variable. + */ + Tcl_SetVar2(interp, "tcl_platform", "platform", "macintosh", + TCL_GLOBAL_ONLY); + Tcl_SetVar2(interp, "tcl_platform", "os", "MacOS", TCL_GLOBAL_ONLY); + Gestalt(gestaltSystemVersion, &gestaltResult); + major = (gestaltResult & 0x0000FF00) >> 8; + minor = (gestaltResult & 0x000000F0) >> 4; + sprintf(versStr, "%d.%d", major, minor); + Tcl_SetVar2(interp, "tcl_platform", "osVersion", versStr, TCL_GLOBAL_ONLY); +#if GENERATINGPOWERPC + Tcl_SetVar2(interp, "tcl_platform", "machine", "ppc", TCL_GLOBAL_ONLY); +#else + Tcl_SetVar2(interp, "tcl_platform", "machine", "68k", TCL_GLOBAL_ONLY); +#endif + + /* + * The tcl_library path can be found in one of two places. As an element + * in the env array. Or the default which is to a folder in side the + * Extensions folder of your system. + */ + + Tcl_DStringInit(&path); + libDir = Tcl_GetVar2(interp, "env", "TCL_LIBRARY", TCL_GLOBAL_ONLY); + if (libDir != NULL) { + Tcl_SetVar(interp, "tcl_library", libDir, TCL_GLOBAL_ONLY); + } else { + libDir = Tcl_GetVar2(interp, "env", "EXT_FOLDER", TCL_GLOBAL_ONLY); + if (libDir != NULL) { + Tcl_JoinPath(1, &libDir, &path); + + Tcl_DStringInit(&libPath); + Tcl_DStringAppend(&libPath, ":Tool Command Language:tcl", -1); + Tcl_DStringAppend(&libPath, TCL_VERSION, -1); + Tcl_JoinPath(1, &libPath.string, &path); + Tcl_DStringFree(&libPath); + Tcl_SetVar(interp, "tcl_library", path.string, TCL_GLOBAL_ONLY); + } else { + Tcl_SetVar(interp, "tcl_library", "no library", TCL_GLOBAL_ONLY); + } + } + + /* + * Now create the tcl_pkgPath variable. + */ + Tcl_DStringSetLength(&path, 0); + libDir = Tcl_GetVar2(interp, "env", "EXT_FOLDER", TCL_GLOBAL_ONLY); + if (libDir != NULL) { + Tcl_JoinPath(1, &libDir, &path); + libDir = ":Tool Command Language:"; + Tcl_JoinPath(1, &libDir, &path); + Tcl_SetVar(interp, "tcl_pkgPath", path.string, + TCL_GLOBAL_ONLY|TCL_LIST_ELEMENT); + } else { + Tcl_SetVar(interp, "tcl_pkgPath", "no extension folder", + TCL_GLOBAL_ONLY); + } + Tcl_DStringFree(&path); +} + +/* + *---------------------------------------------------------------------- + * + * 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 {[catch {source -rsrc Init}] != 0} {\n\ + if [file exists [info library]:init.tcl] {\n\ + source [info library]:init.tcl\n\ + } else {\n\ + set msg \"can't find Init resource or [info library]:init.tcl;\"\n\ + append msg \" perhaps you need to\\ninstall Tcl or set your \"\n\ + append msg \"TCL_LIBRARY environment variable?\"\n\ + error $msg\n\ + }\n}"; + + /* + * For Macintosh applications the Init function may be contained in + * the application resources. If it exists we use it - otherwise we + * look in the tcl_library directory. + */ + + return Tcl_Eval(interp, initCmd); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SourceRCFile -- + * + * This procedure is typically invoked by Tcl_Main or Tk_Main + * procedure to source an application specific rc file into the + * interpreter at startup time. This will either source a file + * in the "tcl_rcFileName" variable or a TEXT resource in the + * "tcl_rcRsrcName" variable. + * + * Results: + * None. + * + * Side effects: + * Depends on what's in the rc script. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SourceRCFile(interp) + Tcl_Interp *interp; /* Interpreter to source rc file into. */ +{ + Tcl_DString temp; + char *fileName; + Tcl_Channel errChannel; + Handle h; + + fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY); + + if (fileName != NULL) { + Tcl_Channel c; + char *fullName; + + Tcl_DStringInit(&temp); + fullName = Tcl_TranslateFileName(interp, fileName, &temp); + if (fullName == NULL) { + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel) { + Tcl_Write(errChannel, interp->result, -1); + Tcl_Write(errChannel, "\n", 1); + } + } else { + + /* + * Test for the existence of the rc file before trying to read it. + */ + + c = Tcl_OpenFileChannel(NULL, fullName, "r", 0); + if (c != (Tcl_Channel) NULL) { + Tcl_Close(NULL, c); + if (Tcl_EvalFile(interp, fullName) != TCL_OK) { + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel) { + Tcl_Write(errChannel, interp->result, -1); + Tcl_Write(errChannel, "\n", 1); + } + } + } + } + Tcl_DStringFree(&temp); + } + + fileName = Tcl_GetVar(interp, "tcl_rcRsrcName", TCL_GLOBAL_ONLY); + + if (fileName != NULL) { + c2pstr(fileName); + h = GetNamedResource('TEXT', (StringPtr) fileName); + p2cstr((StringPtr) fileName); + if (h != NULL) { + if (TclMacEvalResource(interp, fileName, 0, NULL) != TCL_OK) { + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel) { + Tcl_Write(errChannel, interp->result, -1); + Tcl_Write(errChannel, "\n", 1); + } + } + Tcl_ResetResult(interp); + ReleaseResource(h); + } + } +} diff --git a/tcl7.6/mac/tclMacInt.h b/tcl7.6/mac/tclMacInt.h new file mode 100644 index 0000000..cf3f67c --- /dev/null +++ b/tcl7.6/mac/tclMacInt.h @@ -0,0 +1,68 @@ +/* + * tclMacInt.h -- + * + * Declarations of Macintosh specific shared variables and procedures. + * + * Copyright (c) 1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclMacInt.h 1.14 96/10/02 15:53:06 + */ + +#ifndef _TCLMACINT +#define _TCLMACINT + +#ifndef _TCL +# include "tcl.h" +#endif +#include +#include + +/* + * Typedefs used by Macintosh parts of Tcl. + */ +typedef pascal void (*ExitToShellProcPtr)(void); +typedef int (*TclMacConvertEventPtr) _ANSI_ARGS_((EventRecord *eventPtr)); + +/* + * Prototypes for functions found in the tclMacUtil.c compatability library. + */ + +EXTERN int FSpGetDefaultDir _ANSI_ARGS_((FSSpecPtr theSpec)); +EXTERN int FSpSetDefaultDir _ANSI_ARGS_((FSSpecPtr theSpec)); +EXTERN int FSpLocationFromPath _ANSI_ARGS_((int length, char *path, + FSSpecPtr theSpec)); +EXTERN OSErr FSpFindFolder _ANSI_ARGS_((short vRefNum, OSType folderType, + Boolean createFolder, FSSpec *spec)); +EXTERN OSErr FSpPathFromLocation _ANSI_ARGS_((FSSpecPtr theSpec, + int *length, Handle *fullPath)); +EXTERN void GetGlobalMouse _ANSI_ARGS_((Point *mouse)); + +/* + * Prototypes of Mac only internal functions. + */ + +EXTERN void TclCreateMacEventSource _ANSI_ARGS_((void)); +EXTERN char * TclMacConvertTextResource _ANSI_ARGS_((Handle resource)); +EXTERN int TclMacConsoleInit _ANSI_ARGS_((void)); +EXTERN int TclMacEvalResource _ANSI_ARGS_((Tcl_Interp *interp, + char *resourceName, int resourceNumber, char *fileName)); +EXTERN void TclMacExitHandler _ANSI_ARGS_((void)); +EXTERN Handle TclMacFindResource _ANSI_ARGS_((Tcl_Interp *interp, + char *resourceType, char *resourceName, + int resourceNumber, char *resFileRef)); +EXTERN void TclMacFlushEvents _ANSI_ARGS_((Tcl_Time *timePtr)); +EXTERN void TclMacInitExitToShell _ANSI_ARGS_((int usePatch)); +EXTERN OSErr TclMacInstallExitToShellPatch _ANSI_ARGS_(( + ExitToShellProcPtr newProc)); +EXTERN int TclMacNotifySocket _ANSI_ARGS_((void)); +EXTERN int TclMacOSErrorToPosixError _ANSI_ARGS_((int error)); +EXTERN void TclMacRemoveTimer _ANSI_ARGS_((void *timerToken)); +EXTERN void TclMacSetEventProc _ANSI_ARGS_((TclMacConvertEventPtr procPtr)); +EXTERN int TclMacSocketReady _ANSI_ARGS_((Tcl_File file, int mask)); +EXTERN void * TclMacStartTimer _ANSI_ARGS_((long ms)); +EXTERN int TclMacTimerExpired _ANSI_ARGS_((void *timerToken)); +EXTERN void TclMacWatchSocket _ANSI_ARGS_((Tcl_File file, int mask)); +#endif /* _TCLMACINT */ diff --git a/tcl7.6/mac/tclMacInterupt.c b/tcl7.6/mac/tclMacInterupt.c new file mode 100644 index 0000000..3fe829d --- /dev/null +++ b/tcl7.6/mac/tclMacInterupt.c @@ -0,0 +1,289 @@ +/* + * tclMacInterupt.c -- + * + * This file contains routines that deal with the Macintosh's low level + * time manager. This code provides a better resolution timer than what + * can be provided by WaitNextEvent. + * + * Copyright (c) 1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclMacInterupt.c 1.15 96/06/24 17:22:35 + */ + +#include "tclInt.h" +#include "tclMacInt.h" +#include +#include +#include + +/* + * Data structure for timer tasks. + */ +typedef struct TMInfo { + TMTask tmTask; + ProcessSerialNumber psn; + Point lastPoint; + Point newPoint; + long currentA5; + long ourA5; + int installed; +} TMInfo; + +/* + * Globals used within this file. + */ + +static TimerUPP sleepTimerProc = NULL; +static int interuptsInited = false; +static ProcessSerialNumber applicationPSN; +#define MAX_TIMER_ARRAY_SIZE 16 +static TMInfo timerInfoArray[MAX_TIMER_ARRAY_SIZE]; +static int topTimerElement = 0; + +/* + * Prototypes for procedures that are referenced only in this file: + */ + +#if !GENERATINGCFM +static TMInfo * GetTMInfo(void) ONEWORDINLINE(0x2E89); /* MOVE.L A1,(SP) */ +#endif +static void SleepTimerProc _ANSI_ARGS_((void)); +static pascal void CleanUpExitProc _ANSI_ARGS_((void)); +static void InitInteruptSystem _ANSI_ARGS_((void)); + +/* + *---------------------------------------------------------------------- + * + * InitInteruptSystem -- + * + * Does various initialization for the functions used in this + * file. Sets up Universial Pricedure Pointers, installs a trap + * patch for ExitToShell, etc. + * + * Results: + * None. + * + * Side effects: + * Various initialization. + * + *---------------------------------------------------------------------- + */ + +void +InitInteruptSystem() +{ + int i; + + sleepTimerProc = NewTimerProc(SleepTimerProc); + GetCurrentProcess(&applicationPSN); + for (i = 0; i < MAX_TIMER_ARRAY_SIZE; i++) { + timerInfoArray[i].installed = false; + } + + /* + * Install the ExitToShell patch. We use this patch instead + * of the Tcl exit mechanism because we need to ensure that + * these routines are cleaned up even if we crash or are forced + * to quit. There are some circumstances when the Tcl exit + * handlers may not fire. + */ + + TclMacInstallExitToShellPatch(CleanUpExitProc); + interuptsInited = true; +} + +/* + *---------------------------------------------------------------------- + * + * TclMacStartTimer -- + * + * Install a Time Manager task to wake our process up in the + * future. The process should get a NULL event after ms + * milliseconds. + * + * Results: + * None. + * + * Side effects: + * Schedules our process to wake up. + * + *---------------------------------------------------------------------- + */ + +void * +TclMacStartTimer(ms) + long ms; +{ + TMInfo *timerInfoPtr; + + if (!interuptsInited) { + InitInteruptSystem(); + } + + /* + * Obtain a pointer for the timer. We only allocate up + * to MAX_TIMER_ARRAY_SIZE timers. If we are past that + * max we return NULL. + */ + if (topTimerElement < MAX_TIMER_ARRAY_SIZE) { + timerInfoPtr = &timerInfoArray[topTimerElement]; + topTimerElement++; + } else { + return NULL; + } + + /* + * Install timer to wake process in ms milliseconds. + */ + timerInfoPtr->tmTask.tmAddr = sleepTimerProc; + timerInfoPtr->tmTask.tmWakeUp = 0; + timerInfoPtr->tmTask.tmReserved = 0; + timerInfoPtr->psn = applicationPSN; + timerInfoPtr->installed = true; + + InsTime((QElemPtr) timerInfoPtr); + PrimeTime((QElemPtr) timerInfoPtr, (long) ms); + + return (void *) timerInfoPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclMacRemoveTimer -- + * + * Remove the timer event from the Time Manager. + * + * Results: + * None. + * + * Side effects: + * A scheduled timer would be removed. + * + *---------------------------------------------------------------------- + */ + +void +TclMacRemoveTimer(timerToken) + void * timerToken; +{ + TMInfo *timerInfoPtr = (TMInfo *) timerToken; + + if (timerInfoPtr == NULL) { + return; + } + + RmvTime((QElemPtr) timerInfoPtr); + timerInfoPtr->installed = false; + topTimerElement--; +} + +/* + *---------------------------------------------------------------------- + * + * TclMacTimerExpired -- + * + * Check to see if the installed timer has expired. + * + * Results: + * True if timer has expired, false otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclMacTimerExpired(timerToken) + void * timerToken; +{ + TMInfo *timerInfoPtr = (TMInfo *) timerToken; + + if ((timerInfoPtr == NULL) || + !(timerInfoPtr->tmTask.qType & kTMTaskActive)) { + return true; + } else { + return false; + } +} + +/* + *---------------------------------------------------------------------- + * + * SleepTimerProc -- + * + * Time proc is called by the is a callback routine placed in the + * system by Tcl_Sleep. The routine is called at interupt time + * and threrfor can not move or allocate memory. This call will + * schedule our process to wake up the next time the process gets + * around to consider running it. + * + * Results: + * None. + * + * Side effects: + * Schedules our process to wake up. + * + *---------------------------------------------------------------------- + */ + +static void +SleepTimerProc() +{ + /* + * In CFM code we can access our code directly. In 68k code that + * isn't based on CFM we must do a glorious hack. The function + * GetTMInfo is an inline assembler call that moves the pointer + * at A1 to the top of the stack. The Time Manager keeps the TMTask + * info record there before calling this call back. In order for + * this to work the infoPtr argument must be the *last* item on the + * stack. If we "piggyback" our data to the TMTask info record we + * can get access to the information we need. While this is really + * ugly - it's the way Apple recomends it be done - go figure... + */ + +#if GENERATINGCFM + WakeUpProcess(&applicationPSN); +#else + TMInfo * infoPtr; + + infoPtr = GetTMInfo(); + WakeUpProcess(&infoPtr->psn); +#endif +} + +/* + *---------------------------------------------------------------------- + * + * CleanUpExitProc -- + * + * This procedure is invoked as an exit handler when ExitToShell + * is called. It removes the system level timer handler if it + * is installed. This must be called or the Mac OS will more than + * likely crash. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static pascal void +CleanUpExitProc() +{ + int i; + + for (i = 0; i < MAX_TIMER_ARRAY_SIZE; i++) { + if (timerInfoArray[i].installed) { + RmvTime((QElemPtr) &timerInfoArray[i]); + timerInfoArray[i].installed = false; + } + } +} diff --git a/tcl7.6/mac/tclMacLibrary.c b/tcl7.6/mac/tclMacLibrary.c new file mode 100644 index 0000000..598c757 --- /dev/null +++ b/tcl7.6/mac/tclMacLibrary.c @@ -0,0 +1,189 @@ +/* + * tclMacLibrary.c -- + * + * This file should be included in Tcl extensions that want to + * automatically oepn their resource forks when the code is linked. + * These routines should not be exported but should be compiled + * locally by each fragment. Many thanks to Jay Lieske + * who provide an initial version of this + * file. + * + * Copyright (c) 1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclMacLibrary.c 1.2 96/09/11 21:08:15 + */ + +#include +#include +#include +#include "tclMacInt.h" + +/* + * These function are not currently defined in any header file. The + * only place they should be used is in the Initialization and + * Termination entry points for a code fragment. The prototypes + * are included here to avoid compile errors. + */ + +OSErr TclMacInitializeFragment _ANSI_ARGS_(( + struct CFragInitBlock* initBlkPtr)); +void TclMacTerminateFragment _ANSI_ARGS_((void)); + +/* + * Static functions in this file. + */ + +static OSErr OpenLibraryResource _ANSI_ARGS_(( + struct CFragInitBlock* initBlkPtr)); +static void CloseLibraryResource _ANSI_ARGS_((void)); + +/* + * The refnum of the opened resource fork. + */ +static short ourResFile = kResFileNotOpened; + +/* + *---------------------------------------------------------------------- + * + * TclMacInitializeFragment -- + * + * Called by MacOS CFM when the shared library is loaded. All this + * function really does is give Tcl a chance to open and register + * the resource fork of the library. + * + * Results: + * MacOS error code if loading should be canceled. + * + * Side effects: + * Opens the resource fork of the shared library file. + * + *---------------------------------------------------------------------- + */ + +OSErr +TclMacInitializeFragment( + struct CFragInitBlock* initBlkPtr) /* Pointer to our library. */ +{ + OSErr err = noErr; + +#ifdef __MWERKS__ + { + extern OSErr __initialize( CFragInitBlock* initBlkPtr); + err = __initialize(initBlkPtr); + } +#endif + if (err == noErr) + err = OpenLibraryResource( initBlkPtr); + return err; +} + +/* + *---------------------------------------------------------------------- + * + * TclMacTerminateFragment -- + * + * Called by MacOS CFM when the shared library is unloaded. + * + * Results: + * None. + * + * Side effects: + * The resource fork of the code fragment is closed. + * + *---------------------------------------------------------------------- + */ + +void +TclMacTerminateFragment() +{ + CloseLibraryResource(); + +#ifdef __MWERKS__ + { + extern void __terminate(void); + __terminate(); + } +#endif +} + +/* + *---------------------------------------------------------------------- + * + * OpenLibraryResource -- + * + * This routine can be called by a MacOS fragment's initialiation + * function to open the resource fork of the file. + * Call it with the same data passed to the initialization function. + * If the fragment loading should fail if the resource fork can't + * be opened, then the initialization function can pass on this + * return value. + * + * Results: + * It returns noErr on success and a MacOS error code on failure. + * + * Side effects: + * The resource fork of the code fragment is opened read-only and + * is installed at the head of the resource chain. + * + *---------------------------------------------------------------------- + */ + +static OSErr +OpenLibraryResource( + struct CFragInitBlock* initBlkPtr) +{ + FSSpec* fileSpec = NULL; + OSErr err = noErr; + + if (initBlkPtr->fragLocator.where == kOnDiskFlat) { + fileSpec = initBlkPtr->fragLocator.u.onDisk.fileSpec; + } else if (initBlkPtr->fragLocator.where == kOnDiskSegmented) { + fileSpec = initBlkPtr->fragLocator.u.inSegs.fileSpec; + } else { + err = resFNotFound; + } + + /* + * Open the resource fork for this library in read-only mode. + * This will make it the current res file, ahead of the + * application's own resources. + */ + if (fileSpec != NULL) { + ourResFile = FSpOpenResFile( fileSpec, fsRdPerm); + if (ourResFile == kResFileNotOpened) { + err = ResError(); + } + } + + return err; +} + +/* + *---------------------------------------------------------------------- + * + * CloseLibraryResource -- + * + * This routine should be called by a MacOS fragment's termination + * function to close the resource fork of the file + * that was opened with OpenLibraryResource. + * + * Results: + * None. + * + * Side effects: + * The resource fork of the code fragment is closed. + * + *---------------------------------------------------------------------- + */ + +static void +CloseLibraryResource() +{ + if (ourResFile != kResFileNotOpened) { + CloseResFile(ourResFile); + ourResFile = kResFileNotOpened; + } +} diff --git a/tcl7.6/mac/tclMacLibrary.r b/tcl7.6/mac/tclMacLibrary.r new file mode 100644 index 0000000..31ae6f5 --- /dev/null +++ b/tcl7.6/mac/tclMacLibrary.r @@ -0,0 +1,221 @@ +/* + * tclMacLibrary.r -- + * + * This file creates resources used by the Tcl shared library. + * Many thanks go to "Jay Lieske, Jr." who + * wrote the initial version of this file. + * + * Copyright (c) 1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclMacLibrary.r 1.3 96/09/12 17:40:07 + */ + +#include +#include + +/* + * The folowing include and defines help construct + * the version string for Tcl. + */ + +#define RESOURCE_INCLUDED +#include "tcl.h" + +#if (TCL_RELEASE_LEVEL == 0) +# define RELEASE_LEVEL alpha +#elif (TCL_RELEASE_LEVEL == 1) +# define RELEASE_LEVEL beta +#elif (TCL_RELEASE_LEVEL == 2) +# define RELEASE_LEVEL final +#endif + +#if (TCL_RELEASE_LEVEL == 2) +# define MINOR_VERSION (TCL_MINOR_VERSION * 16) + TCL_RELEASE_SERIAL +#else +# define MINOR_VERSION TCL_MINOR_VERSION * 16 +#endif + +resource 'vers' (1) { + TCL_MAJOR_VERSION, MINOR_VERSION, + RELEASE_LEVEL, 0x00, verUS, + TCL_PATCH_LEVEL, + TCL_PATCH_LEVEL ", by Ray Johnson © Sun Microsystems" +}; + +resource 'vers' (2) { + TCL_MAJOR_VERSION, MINOR_VERSION, + RELEASE_LEVEL, 0x00, verUS, + TCL_PATCH_LEVEL, + "Tcl Library " TCL_PATCH_LEVEL " © 1996" +}; + +/* + * Currently the creator for all Tcl/Tk libraries and extensions + * should be 'TclL'. This will allow those extension and libraries + * to use the common icon for Tcl extensions. However, this signature + * still needs to be approved by the signature police at Apple and may + * change. + */ +#define TCL_CREATOR 'TclL' +#define TCL_LIBRARY_RESOURCES 2000 + +/* + * The 'BNDL' resource is the primary link between a file's + * creator/type and its icon. This resource acts for all Tcl shared + * libraries; other libraries will not need one and ought to use + * custom icons rather than new file types for a different appearance. + */ + +resource 'BNDL' (TCL_LIBRARY_RESOURCES, "Tcl bundle", purgeable) +{ + TCL_CREATOR, + 0, + { /* array TypeArray: 2 elements */ + /* [1] */ + 'FREF', + { /* array IDArray: 1 elements */ + /* [1] */ + 0, TCL_LIBRARY_RESOURCES + }, + /* [2] */ + 'ICN#', + { /* array IDArray: 1 elements */ + /* [1] */ + 0, TCL_LIBRARY_RESOURCES + } + } +}; + +resource 'FREF' (TCL_LIBRARY_RESOURCES, purgeable) +{ + 'shlb', 0, "" +}; + +type TCL_CREATOR as 'STR '; +resource TCL_CREATOR (0, purgeable) { + "Tcl Library " TCL_PATCH_LEVEL " © 1996" +}; + +/* + * The 'kind' resource works with a 'BNDL' in Macintosh Easy Open + * to affect the text the Finder displays in the "kind" column and + * file info dialog. This information will be applied to all files + * with the listed creator and type. + */ + +resource 'kind' (TCL_LIBRARY_RESOURCES, "Tcl kind", purgeable) { + TCL_CREATOR, + 0, /* region = USA */ + { + 'shlb', "Tcl Library" + } +}; + + +/* + * The -16397 string will be displayed by Finder when a user + * tries to open the shared library. The string should + * give the user a little detail about the library's capabilities + * and enough information to install the library in the correct location. + * A similar string should be placed in all shared libraries. + */ +resource 'STR ' (-16397, purgeable) { + "Tcl Library\n\n" + "This is the core library needed to run Tool Command Language programs. " + "To work properly, it should be placed in the ÔTool Command LanguageÕ folder " + "within the Extensions folder." +}; + +/* + * The mechanisim below loads Tcl source into the resource fork of the + * application. The example below creates a TEXT resource named + * "Init" from the file "init.tcl". This allows applications to use + * Tcl to define the behavior of the application without having to + * require some predetermined file structure - all needed Tcl "files" + * are located within the application. To source a file for the + * resource fork the source command has been modified to support + * sourcing from resources. In the below case "source -rsrc {Init}" + * will load the TEXT resource named "Init". + */ + +read 'TEXT' (TCL_LIBRARY_RESOURCES, "Init", purgeable) "::library:init.tcl"; + +/* + * The following are icons for the shared library. + */ + +data 'icl4' (2000, "Tcl Shared Library", purgeable) { + $"0FFF FFFF FFFF FFFF FFFF FFFF FFFF 0000" + $"F000 0000 0000 0000 0000 0000 000C F000" + $"F0CC CFFF CCCC CCC6 66CC CCCC CCCC F000" + $"F0CC CFFF FFFF FF66 F6CC CCCC CCCC F000" + $"F0CC CFFF 2000 0D66 6CCC CCCC CCCC F000" + $"F0CC CFFF 0202 056F 6E5C CCCC CCCC F000" + $"F0CC CFFF 2020 C666 F66F CCCC CCCC F000" + $"F0CC CFFF 0200 B66F 666B FCCC CCCC F000" + $"F0FC CFFF B020 55F6 6F52 BFCC CCCC F000" + $"FF0F 0CCC FB02 5665 66D0 2FCC CCCC F0F0" + $"F00F 0CCC CFB0 BF55 F6CF FFCC CCCC FFCF" + $"000F 0CCC CCFB 06C9 66CC CCCC CCCC F0CF" + $"000F 0CCC CCCF 56C6 6CCC CCCC CCCC CCCF" + $"000F 0CCC CCCC 6FC6 FCCC CCCC CCCC CCCF" + $"000F 0CCC CCCC 65C5 65CC CCCC CCCC CCCF" + $"000F 0CCC CCCC 55D6 57CC CCCC CCCC CCCF" + $"000F 0CCC CCCC 65CF 6CCC CCCC CCCC CCCF" + $"000F 0CCC CCCC 5AC6 6CFF CCCC CCCC CCCF" + $"000F 0CCC CCCC 65C5 6CF0 FCCC CCCC CCCF" + $"000F 0CCC CCCC CECF CCF0 0FCC CCCC CCCF" + $"000F 0CCC CCCC C5C6 CCCF 20FC CCCC FCCF" + $"F00F 0CCC CCCF FFD5 CCCC F20F CCCC FFCF" + $"FF0F 0CCC CCCF 20CF CCCC F020 FCCC F0F0" + $"F0F0 CCCC CCCF B2C2 FFFF 0002 0FFC F000" + $"F00C CCCC CCCC FBC0 2000 0020 2FFC F000" + $"F0CC CCCC CCCC CFCB 0202 0202 0FFC F000" + $"F0CC CCCC CCCC CCCF B020 2020 2FFC F000" + $"F0CC CCCC CCCC CCDC FBBB BBBB BFFC F000" + $"F0CC CCCC CCCC CCCC CFFF FFFF FFFC F000" + $"F0CC CCCC CCCC CCCC CCCC CCCC CFFC F000" + $"FCCC CCCC CCCC CCCC CCCC CCCC CCCC F000" + $"0FFF FFFF FFFF FFFF FFFF FFFF FFFF 0000" +}; + +data 'ICN#' (2000, "Tcl Shared Library", purgeable) { + $"7FFF FFF0 8000 0008 8701 C008 87FF C008" + $"8703 8008 8707 E008 8707 F008 870F F808" + $"A78F EC08 D0CF C40A 906F DC0D 1035 C009" + $"101D 8001 100D 8001 100D C001 100D C001" + $"100D 8001 100D B001 100D A801 1005 2401" + $"1005 1209 901D 090D D011 088A A018 F068" + $"800C 0068 8005 0068 8001 8068 8000 FFE8" + $"8000 7FE8 8000 0068 8000 0008 7FFF FFF0" + $"7FFF FFF0 FFFF FFF8 FFFF FFF8 FFFF FFF8" + $"FFFF FFF8 FFFF FFF8 FFFF FFF8 FFFF FFF8" + $"FFFF FFF8 DFFF FFFA 9FFF FFFF 1FFF FFFF" + $"1FFF FFFF 1FFF FFFF 1FFF FFFF 1FFF FFFF" + $"1FFF FFFF 1FFF FFFF 1FFF FFFF 1FFF FFFF" + $"1FFF FFFF 9FFF FFFF DFFF FFFA FFFF FFF8" + $"FFFF FFF8 FFFF FFF8 FFFF FFF8 FFFF FFF8" + $"FFFF FFF8 FFFF FFF8 FFFF FFF8 7FFF FFF0" +}; + +data 'ics#' (2000, "Tcl Shared Library", purgeable) { + $"FFFE B582 BB82 B3C2 BFA2 43C3 4381 4381" + $"4381 4763 4392 856E 838E 81AE 811E FFFE" + $"FFFE FFFE FFFE FFFE FFFE FFFF 7FFF 7FFF" + $"7FFF 7FFF 7FFF FFFE FFFE FFFE FFFE FFFE" +}; + +data 'ics4' (2000, "Tcl Shared Library", purgeable) { + $"FFFF FFFF FFFF FFF0 FCFF DED5 6CCC CCF0" + $"FCFF C0D6 ECCC CCF0 FCFF 2056 65DC CCF0" + $"FDFE D256 6DAC CCFF FFCC DDDE 5DDC CCEF" + $"0FCC CD67 5CCC CCCF 0FCC CC5D 6CCC CCCF" + $"0FCC CC5D 5CCC CCCF 0FCC CCD5 5CCC CCCF" + $"FFCC CFFD CCFF CCFF FCCC CF2D DF20 FCFC" + $"FCCC CCFD D202 FEF0 FCCC CC0D 2020 FEF0" + $"FCCC CCCD FBBB FEF0 FFFF FFFF FFFF FFE0" +}; + diff --git a/tcl7.6/mac/tclMacLoad.c b/tcl7.6/mac/tclMacLoad.c new file mode 100644 index 0000000..4480702 --- /dev/null +++ b/tcl7.6/mac/tclMacLoad.c @@ -0,0 +1,234 @@ +/* + * tclMacLoad.c -- + * + * This procedure provides a version of the TclLoadFile for use + * on the Macintosh. This procedure will only work with systems + * that use the Code Fragment Manager. + * + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclMacLoad.c 1.17 96/10/06 14:30:47 + */ + +#include +#include +#include +#include +#include +#include "tclPort.h" +#include "tclInt.h" +#include "tclMacInt.h" + +#if GENERATINGPOWERPC + #define OUR_ARCH_TYPE kPowerPCCFragArch +#else + #define OUR_ARCH_TYPE kMotorola68KCFragArch +#endif + +/* + * The following data structure defines the structure of a code fragment + * resource. We can cast the resource to be of this type to access + * any fields we need to see. + */ +struct CfrgHeader { + long res1; + long res2; + long version; + long res3; + long res4; + long filler1; + long filler2; + long itemCount; + char arrayStart; /* Array of externalItems begins here. */ +}; +typedef struct CfrgHeader CfrgHeader, *CfrgHeaderPtr, **CfrgHeaderPtrHand; + +/* + * The below structure defines a cfrag item within the cfrag resource. + */ +struct CfrgItem { + OSType archType; + long updateLevel; + long currVersion; + long oldDefVersion; + long appStackSize; + short appSubFolder; + char usage; + char location; + long codeOffset; + long codeLength; + long res1; + long res2; + short itemSize; + Str255 name; /* This is actually variable sized. */ +}; +typedef struct CfrgItem CfrgItem; + +/* + *---------------------------------------------------------------------- + * + * TclLoadFile -- + * + * This procedure is called to carry out dynamic loading of binary + * code for the Macintosh. This implementation is based on the + * Code Fragment Manager & will not work on other systems. + * + * Results: + * The result is TCL_ERROR, and an error message is left in + * interp->result. + * + * Side effects: + * New binary code is loaded. + * + *---------------------------------------------------------------------- + */ + +int +TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *fileName; /* Name of the file containing the desired + * code. */ + char *sym1, *sym2; /* Names of two procedures to look up in + * the file's symbol table. */ + Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; + /* Where to return the addresses corresponding + * to sym1 and sym2. */ +{ + ConnectionID connID; + Ptr dummy; + OSErr err; + SymClass symClass; + FSSpec fileSpec; + short fragFileRef, saveFileRef; + Handle fragResource; + UInt32 offset = 0; + UInt32 length = kWholeFork; + char packageName[255]; + Str255 errName; + + /* + * First thing we must do is infer the package name from the sym1 + * variable. This is kind of dumb since the caller actually knows + * this value, it just doesn't give it to us. + */ + strcpy(packageName, sym1); + *packageName = (char) tolower(*packageName); + packageName[strlen(packageName) - 5] = NULL; + + err = FSpLocationFromPath(strlen(fileName), fileName, &fileSpec); + if (err != noErr) { + interp->result = "could not locate shared library"; + return TCL_ERROR; + } + + /* + * See if this fragment has a 'cfrg' resource. It will tell us were + * to look for the fragment in the file. If it doesn't exist we will + * assume we have a ppc frag using the whole data fork. If it does + * exist we find the frag that matches the one we are looking for and + * get the offset and size from the resource. + */ + saveFileRef = CurResFile(); + SetResLoad(false); + fragFileRef = FSpOpenResFile(&fileSpec, fsRdPerm); + SetResLoad(true); + if (fragFileRef != -1) { + UseResFile(fragFileRef); + fragResource = Get1Resource(kCFragResourceType, kCFragResourceID); + HLock(fragResource); + if (ResError() == noErr) { + CfrgItem* srcItem; + long itemCount, index; + Ptr itemStart; + + itemCount = (*(CfrgHeaderPtrHand)fragResource)->itemCount; + itemStart = &(*(CfrgHeaderPtrHand)fragResource)->arrayStart; + for (index = 0; index < itemCount; + index++, itemStart += srcItem->itemSize) { + srcItem = (CfrgItem*)itemStart; + if (srcItem->archType != OUR_ARCH_TYPE) continue; + if (!strncasecmp(packageName, (char *) srcItem->name + 1, + srcItem->name[0])) { + offset = srcItem->codeOffset; + length = srcItem->codeLength; + } + } + } + /* + * Close the resource file. If the extension wants to reopen the + * resource fork it should use the tclMacLibrary.c file during it's + * construction. + */ + HUnlock(fragResource); + ReleaseResource(fragResource); + CloseResFile(fragFileRef); + UseResFile(saveFileRef); + } + + /* + * Now we can attempt to load the fragement using the offset & length + * obtained from the resource. We don't worry about the main entry point + * as we are going to search for specific entry points passed to us. + */ + + c2pstr(packageName); + err = GetDiskFragment(&fileSpec, offset, length, (StringPtr) packageName, + kLoadLib, &connID, &dummy, errName); + if (err != fragNoErr) { + p2cstr(errName); + Tcl_AppendResult(interp, "couldn't load file \"", fileName, + "\": ", errName, (char *) NULL); + return TCL_ERROR; + } + + c2pstr(sym1); + err = FindSymbol(connID, (StringPtr) sym1, (Ptr *) proc1Ptr, &symClass); + p2cstr((StringPtr) sym1); + if (err != fragNoErr || symClass == kDataCFragSymbol) { + interp->result = + "could not find Initialization routine in library"; + return TCL_ERROR; + } + + c2pstr(sym2); + err = FindSymbol(connID, (StringPtr) sym2, (Ptr *) proc2Ptr, &symClass); + p2cstr((StringPtr) sym2); + if (err != fragNoErr || symClass == kDataCFragSymbol) { + *proc2Ptr = NULL; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclGuessPackageName -- + * + * If the "load" command is invoked without providing a package + * name, this procedure is invoked to try to figure it out. + * + * Results: + * Always returns 0 to indicate that we couldn't figure out a + * package name; generic code will then try to guess the package + * from the file name. A return value of 1 would have meant that + * we figured out the package name and put it in bufPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclGuessPackageName(fileName, bufPtr) + char *fileName; /* Name of file containing package (already + * translated to local form if needed). */ + Tcl_DString *bufPtr; /* Initialized empty dstring. Append + * package name to this if possible. */ +{ + return 0; +} diff --git a/tcl7.6/mac/tclMacNotify.c b/tcl7.6/mac/tclMacNotify.c new file mode 100644 index 0000000..05bd3f6 --- /dev/null +++ b/tcl7.6/mac/tclMacNotify.c @@ -0,0 +1,615 @@ +/* + * tclMacNotify.c -- + * + * This file contains Macintosh-specific procedures for the notifier, + * which is the lowest-level part of the Tcl event loop. This file + * works together with ../generic/tclNotify.c. + * + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclMacNotify.c 1.32 96/08/15 16:18:01 + */ + +#include "tclInt.h" +#include "tclPort.h" +#include "tclMacInt.h" +#include +#include +#include +#include +#include + +/* + * The following variable is a backdoor for use by Tk. It is set when + * Tk needs to process events on the Tcl event queue without reentering + * the system event loop. Tk uses it to flush the Tcl event queue. + */ + +static int ignoreEvents = 0; + +static Point lastMousePosition; /* The last known position of the cursor. */ +TclMacConvertEventPtr convertEventProcPtr = NULL; + /* This pointer holds the address of the + * function that will handle all incoming + * Macintosh events. */ +static RgnHandle utilityRgn = NULL; + /* Region used as the mouse region for + * WaitNextEvent and the update region when + * checking for events. */ + +/* + * Prototypes for procedures that are referenced only in this file: + */ + +static int CheckEventsAvail _ANSI_ARGS_((void)); +static void EventCheckProc _ANSI_ARGS_((ClientData clientData, + int flags)); +static void EventSetupProc _ANSI_ARGS_((ClientData clientData, + int flags)); +static int HandleMacEvents _ANSI_ARGS_((int flags)); + +/* + *---------------------------------------------------------------------- + * + * TclMacFlushEvents -- + * + * This function is a special purpose hack to allow Tk to + * process queued Window events during a recursive event loop + * without looking for new events on the system event queue. + * + * Results: + * None. + * + * Side effects: + * Services any pending Tcl events and calls idle handlers. + * + *---------------------------------------------------------------------- + */ + +void +TclMacFlushEvents(timePtr) + Tcl_Time *timePtr; /* Specifies the maximum amount of time + * that this procedure should spend processing + * events. The time is given as an + * interval, not an absolute wakeup time. + * NULL means return when queue is empty. */ +{ + long ms; + void * timerToken; + + ms = (timePtr->sec * 1000) + (timePtr->usec / 1000); + timerToken = TclMacStartTimer((long) ms); + ignoreEvents = 1; + + while (Tcl_DoOneEvent(TCL_DONT_WAIT|TCL_WINDOW_EVENTS| + TCL_TIMER_EVENTS|TCL_IDLE_EVENTS)) { + if (TclMacTimerExpired(timerToken)) { + break; + } + } + + TclMacRemoveTimer(timerToken); + ignoreEvents = 0; +} + +/* + *---------------------------------------------------------------------- + * + * EventSetupProc -- + * + * This procedure is part of the event source for the Macintosh. + * It is invoked by Tcl_DoOneEvent before it calls select to check + * for events on all displays. + * + * Results: + * None. + * + * Side effects: + * Tells the notifier which files should be waited for. + * + *---------------------------------------------------------------------- + */ + +static void +EventSetupProc(clientData, flags) + ClientData clientData; /* Not used. */ + int flags; /* Flags passed to Tk_DoOneEvent: + * if it doesn't include + * TCL_WINDOW_EVENTS then we do + * nothing. */ +{ + static Tcl_Time dontBlock = {0, 0}; + + if (!(flags & TCL_WINDOW_EVENTS)) { + return; + } + + if (CheckEventsAvail() == true) { + Tcl_SetMaxBlockTime(&dontBlock); + } +} + +/* + *---------------------------------------------------------------------- + * + * EventCheckProc -- + * + * This procedure is the second part of the "event source" for + * the Macintosh. It is invoked by Tcl_DoOneEvent after it calls + * WaitNextEvent (or whatever it uses to wait for events). + * + * Results: + * None. + * + * Side effects: + * Makes entries on the Tcl event queue for all the events + * available on the Macintosh event queue. + * + *---------------------------------------------------------------------- + */ + +static void +EventCheckProc(clientData, flags) + ClientData clientData; /* Not used. */ + int flags; /* Flags passed to Tk_DoOneEvent: + * if it doesn't include + * TCL_WINDOW_EVENTS then we do + * nothing. */ +{ + if (!(flags & TCL_WINDOW_EVENTS)) { + return; + } + + if (CheckEventsAvail() == false) { + return; + } + + HandleMacEvents(TCL_DONT_WAIT); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_WatchFile -- + * + * Arrange for Tcl_DoOneEvent to include this file in the masks + * for the next call to select. This procedure is invoked by + * event sources, which are in turn invoked by Tcl_DoOneEvent + * before it invokes select. + * + * Results: + * None. + * + * Side effects: + * + * The notifier will generate a file event when the I/O channel + * given by fd next becomes ready in the way indicated by mask. + * If fd is already registered then the old mask will be replaced + * with the new one. Once the event is sent, the notifier will + * not send any more events about the fd until the next call to + * Tcl_NotifyFile. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_WatchFile(file, mask) + Tcl_File file; /* Opaque identifier for a stream. */ + int mask; /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, and TCL_EXCEPTION: + * indicates conditions to wait for + * in select. */ +{ + int fd, type; + + fd = (int) Tcl_GetFileInfo(file, &type); + + if (type == TCL_MAC_SOCKET) { + TclMacWatchSocket(file, mask); + } else if (type == TCL_MAC_FILE) { + Tcl_Time timeout = { 0, 0 }; + + /* + * Currently, files are always ready under the Macintosh, + * so we just set a 0 timeout. + */ + + Tcl_SetMaxBlockTime(&timeout); + } else if (type == TCL_UNIX_FD) { + Tcl_Time timeout = { 0, 0 }; + + /* + * The only types of files that should use TCL_UNIX_FD + * should be stdio files associated with a console. For, + * example CodeWarrior's SIOUX. In this case these files + * are non-blocking and always deemed ready. + */ + + Tcl_SetMaxBlockTime(&timeout); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FileReady -- + * + * Indicates what conditions (readable, writable, etc.) were + * present on a file the last time the notifier invoked select. + * This procedure is typically invoked by event sources to see + * if they should queue events. + * + * Results: + * The return value is 0 if none of the conditions specified by mask + * was true for fd the last time the system checked. If any of the + * conditions were true, then the return value is a mask of those + * that were true. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_FileReady(file, mask) + Tcl_File file; /* File handle for a stream. */ + int mask; /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, and TCL_EXCEPTION: + * indicates conditions caller cares about. */ +{ + int type; + int fd; + + fd = (int) Tcl_GetFileInfo(file, &type); + + if (type == TCL_MAC_SOCKET) { + return TclMacSocketReady(file, mask); + } else if (type == TCL_MAC_FILE) { + /* + * Under the Macintosh, files are always ready, so we just + * return the mask that was passed in. + */ + + return mask; + } else if (type == TCL_UNIX_FD) { + /* + * Under the Macintosh, stdio files are always ready, + * so we just return the mask that was passed in. + */ + + return mask; + } + + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_WaitForEvent -- + * + * This procedure does the lowest level wait for events in a + * platform-specific manner. It uses information provided by + * previous calls to Tcl_WatchFile, plus the timePtr argument, + * to determine what to wait for and how long to wait. + * + * Results: + * The return value is normally TCL_OK. However, if there are + * no events to wait for (e.g. no files and no timers) so that + * the procedure would block forever, then it returns TCL_ERROR. + * + * Side effects: + * May put the process to sleep for a while, depending on timePtr. + * When this procedure returns, an event of interest to the application + * has probably, but not necessarily, occurred. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_WaitForEvent(timePtr) + Tcl_Time *timePtr; /* Specifies the maximum amount of time + * that this procedure should block before + * returning. The time is given as an + * interval, not an absolute wakeup time. + * NULL means block forever. */ +{ + int numFound, notDone = true; + EventRecord macEvent; + long sleepTime = 5; + long ms; + Point currentMouse; + void * timerToken; + Rect mouseRect; + + /* + * If we are ignoring events from the system, just return immediately. + */ + + if (ignoreEvents) { + return TCL_OK; + } + + /* + * Calculate the end time, start the WaitNextEvent timer, and + * create any other data structures we may need. + */ + ms = (timePtr->sec * 1000) + (timePtr->usec / 1000); + if (ms < 10) { + notDone = true; + } + timerToken = TclMacStartTimer((long) ms); + if (utilityRgn == NULL) { + utilityRgn = NewRgn(); + } + + do { + /* + * Poll for file events. + */ + numFound = TclMacNotifySocket(); + + if (numFound > 0) { + notDone = false; + } + + /* + * Check for time out. + */ + if (TclMacTimerExpired(timerToken)) { + notDone = false; + } + + /* + * Check for mouse moved events. We need to do this seprately + * from and before WaitNextEvent to avoid waiting. + */ + GetGlobalMouse(¤tMouse); + if (!EqualPt(currentMouse, lastMousePosition)) { + lastMousePosition = currentMouse; + macEvent.what = nullEvent; + if (convertEventProcPtr != NULL) { + if ((*convertEventProcPtr)(&macEvent) == true) { + notDone = false; + } + } + } + + /* + * Set up mouse region so we will wake if the mouse is moved. We + * do this by defining the smallest possible region around the + * current mouse position. + */ + SetRect(&mouseRect, currentMouse.h, currentMouse.v, + currentMouse.h + 1, currentMouse.v + 1); + RectRgn(utilityRgn, &mouseRect); + + /* + * Check for window events. We may receive a NULL event for various + * reasons. 1) the timer has expired, 2) a mouse moved event is + * occuring or 3) the os is giving us time for idle events. + */ + if ((notDone == true) || (CheckEventsAvail() == true)) { + WaitNextEvent(everyEvent, &macEvent, sleepTime, utilityRgn); + if (convertEventProcPtr != NULL) { + if ((*convertEventProcPtr)(&macEvent) == true) { + notDone = false; + } + } + } + } while(notDone == true); + + TclMacRemoveTimer(timerToken); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Sleep -- + * + * Delay execution for the specified number of milliseconds. This + * is not a very good call to make. It will block the system - + * you will not even be able to switch applications. + * + * Results: + * None. + * + * Side effects: + * Time passes. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_Sleep(ms) + int ms; /* Number of milliseconds to sleep. */ +{ + EventRecord dummy; + int done = false; + void *timerToken; + + if (ms <= 0) { + return; + } + + timerToken = TclMacStartTimer((long) ms); + do { + WaitNextEvent(0, &dummy, (ms / 16.66) + 1, NULL); + + if (TclMacTimerExpired(timerToken)) { + break; + } + } while(!done); + TclMacRemoveTimer(timerToken); +} + +/* + *---------------------------------------------------------------------- + * + * CheckEventsAvail -- + * + * Checks to see if events are available on the Macintosh queue. + * This function looks for both queued events (eg. key & button) + * and generated events (update & mouse moved). + * + * Results: + * True is events exist, false otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +CheckEventsAvail() +{ + QHdrPtr evPtr; + WindowRef windowRef; + Point currentMouse; + + evPtr = GetEvQHdr(); + if (evPtr->qHead != NULL) { + return true; + } + + if (utilityRgn == NULL) { + utilityRgn = NewRgn(); + } + + windowRef = FrontWindow(); + while (windowRef != NULL) { + GetWindowUpdateRgn(windowRef, utilityRgn); + if (!EmptyRgn(utilityRgn)) { + return true; + } + windowRef = GetNextWindow(windowRef); + } + + GetGlobalMouse(¤tMouse); + if (!EqualPt(currentMouse, lastMousePosition)) { + return true; + } + + return false; +} + +/* + *---------------------------------------------------------------------- + * + * TclCreateMacEventSource -- + * + * This procedure is called during Tcl initialization to create + * the event source for Macintosh window events. + * + * Results: + * None. + * + * Side effects: + * A new event source is created. + * + *---------------------------------------------------------------------- + */ + +void +TclCreateMacEventSource() +{ + static int initialized = 0; + + if (!initialized) { + Tcl_CreateEventSource(EventSetupProc, EventCheckProc, + (ClientData) NULL); + initialized = 1; + } +} + +/* + *---------------------------------------------------------------------- + * + * HandleMacEvents -- + * + * This function checks for events from the Macintosh event queue. + * It also is the point at which the Tcl application must provide + * cooprative multitasking with other Macintosh applications. Mac + * events are then translated into the appropiate X events and + * placed on the Tk event queue. + * + * Results: + * Returns 1 if event found, 0 otherwise. + * + * Side effects: + * May change the grab module settings. + * + *---------------------------------------------------------------------- + */ + +int +HandleMacEvents(flags) + int flags; +{ + EventRecord theEvent; + int eventFound = false; + int eventToProcess = false; + Point currentMouse; + + /* + * If the TCL_DONT_WAIT flag is set then we first check to see + * events are available and simple return if none will be found. + * If the event in question is a motion event we need to handle + * it first - otherwise, GetNextEvent may block. + */ + + GetGlobalMouse(¤tMouse); + if (!EqualPt(currentMouse, lastMousePosition) && + (convertEventProcPtr != NULL)) { + lastMousePosition = currentMouse; + theEvent.what = nullEvent; + eventFound |= (*convertEventProcPtr)(&theEvent); + } + + if (flags & TCL_DONT_WAIT) { + if (CheckEventsAvail() == false) { + return eventFound; + } + } + + do { + GetNextEvent(everyEvent, &theEvent); + if (convertEventProcPtr != NULL) { + eventFound |= (*convertEventProcPtr)(&theEvent); + } + } while (CheckEventsAvail() == true); + + return eventFound; +} + +/* + *---------------------------------------------------------------------- + * + * TclMacSetEventProc -- + * + * This function sets the event handling procedure for the + * application. This function will be passed all incoming Mac + * events. This function usually controls the console or some + * other entity like Tk. + * + * Results: + * None. + * + * Side effects: + * Changes the event handling function. + * + *---------------------------------------------------------------------- + */ + +void +TclMacSetEventProc(procPtr) + TclMacConvertEventPtr procPtr; +{ + convertEventProcPtr = procPtr; +} diff --git a/tcl7.6/mac/tclMacPanic.c b/tcl7.6/mac/tclMacPanic.c new file mode 100644 index 0000000..afc02b4 --- /dev/null +++ b/tcl7.6/mac/tclMacPanic.c @@ -0,0 +1,234 @@ +/* + * tclMacPanic.c -- + * + * Source code for the "panic" library procedure used in "Simple Shell"; + * other Mac applications will probably override this with a more robust + * application-specific panic procedure. + * + * Copyright (c) 1993-1994 Lockheed Missle & Space Company, AI Center + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclMacPanic.c 1.11 96/04/01 20:56:27 + */ + + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include "tclInt.h" + +/* + * constants for panic dialog + */ +#define PANICHEIGHT 150 /* Height of dialog */ +#define PANICWIDTH 350 /* Width of dialog */ +#define PANIC_BUTTON_RECT {125, 260, 145, 335} /* Rect for button. */ +#define PANIC_ICON_RECT {10, 20, 42, 52} /* Rect for icon. */ +#define PANIC_TEXT_RECT {10, 65, 140, 330} /* Rect for text. */ +#define ENTERCODE (0x03) +#define RETURNCODE (0x0D) + +/* + * The panicProc variable contains a pointer to an application + * specific panic procedure. + */ + +void (*panicProc) _ANSI_ARGS_(TCL_VARARGS(char *,format)) = NULL; + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetPanicProc -- + * + * Replace the default panic behavior with the specified functiion. + * + * Results: + * None. + * + * Side effects: + * Sets the panicProc variable. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetPanicProc(proc) + void (*proc) _ANSI_ARGS_(TCL_VARARGS(char *,format)); +{ + panicProc = proc; +} + +/* + *---------------------------------------------------------------------- + * + * MacPanic -- + * + * Displays panic info.. + * + * Results: + * None. + * + * Side effects: + * Sets the panicProc variable. + * + *---------------------------------------------------------------------- + */ + +static void +MacPanic(msg) + char *msg; +{ + WindowRef macWinPtr, foundWinPtr; + Rect macRect; + Rect buttonRect = PANIC_BUTTON_RECT; + Rect iconRect = PANIC_ICON_RECT; + Rect textRect = PANIC_TEXT_RECT; + ControlHandle okButtonHandle; + EventRecord event; + Handle stopIconHandle; + int part; + Boolean done = false; + + + /* + * Put up an alert without using the Resource Manager (there may + * be no resources to load). Use the Window and Control Managers instead. + * We want the window centered on the main monitor. The following + * should be tested with multiple monitors. Look and see if there is a way + * not using qd.screenBits. + */ + + macRect.top = (qd.screenBits.bounds.top + qd.screenBits.bounds.bottom) + / 2 - (PANICHEIGHT / 2); + macRect.bottom = (qd.screenBits.bounds.top + qd.screenBits.bounds.bottom) + / 2 + (PANICHEIGHT / 2); + macRect.left = (qd.screenBits.bounds.left + qd.screenBits.bounds.right) + / 2 - (PANICWIDTH / 2); + macRect.right = (qd.screenBits.bounds.left + qd.screenBits.bounds.right) + / 2 + (PANICWIDTH / 2); + + macWinPtr = NewWindow(NULL, &macRect, "\p", true, dBoxProc, (WindowRef) -1, + false, 0); + if (macWinPtr == NULL) { + goto exitNow; + } + + okButtonHandle = NewControl(macWinPtr, &buttonRect, "\pOK", true, + 0, 0, 1, pushButProc, 0); + if (okButtonHandle == NULL) { + CloseWindow(macWinPtr); + goto exitNow; + } + + SelectWindow(macWinPtr); + SetCursor(&qd.arrow); + stopIconHandle = GetIcon(kStopIcon); + + while (!done) { + if (WaitNextEvent(mDownMask | keyDownMask | updateMask, + &event, 0, NULL)) { + switch(event.what) { + case mouseDown: + part = FindWindow(event.where, &foundWinPtr); + + if ((foundWinPtr != macWinPtr) || (part != inContent)) { + SysBeep(1); + } else { + SetPortWindowPort(macWinPtr); + GlobalToLocal(&event.where); + part = FindControl(event.where, macWinPtr, + &okButtonHandle); + + if ((inButton == part) && + (TrackControl(okButtonHandle, + event.where, NULL))) { + done = true; + } + } + break; + case keyDown: + switch (event.message & charCodeMask) { + case ENTERCODE: + case RETURNCODE: + HiliteControl(okButtonHandle, 1); + HiliteControl(okButtonHandle, 0); + done = true; + } + break; + case updateEvt: + SetPortWindowPort(macWinPtr); + TextFont(systemFont); + + BeginUpdate(macWinPtr); + if (stopIconHandle != NULL) { + PlotIcon(&iconRect, stopIconHandle); + } + TextBox(msg, strlen(msg), &textRect, teFlushDefault); + DrawControls(macWinPtr); + EndUpdate(macWinPtr); + } + } + } + + CloseWindow(macWinPtr); + + exitNow: +#ifdef TCL_DEBUG + Debugger(); +#else + abort(); +#endif +} + +/* + *---------------------------------------------------------------------- + * + * panic -- + * + * Print an error message and kill the process. + * + * Results: + * None. + * + * Side effects: + * The process dies, entering the debugger if possible. + * + *---------------------------------------------------------------------- + */ + +#pragma ignore_oldstyle on +void +panic(char * format, ...) +{ + va_list varg; + char errorText[256]; + + if (panicProc != NULL) { + va_start(varg, format); + + (void) (*panicProc)(format, varg); + + va_end(varg); + } else { + va_start(varg, format); + + vsprintf(errorText, format, varg); + + va_end(varg); + + MacPanic(errorText); + } + +} +#pragma ignore_oldstyle reset diff --git a/tcl7.6/mac/tclMacPort.h b/tcl7.6/mac/tclMacPort.h new file mode 100644 index 0000000..8dabc15 --- /dev/null +++ b/tcl7.6/mac/tclMacPort.h @@ -0,0 +1,263 @@ +/* + * tclMacPort.h -- + * + * This header file handles porting issues that occur because of + * differences between the Mac and Unix. It should be the only + * file that contains #ifdefs to handle different flavors of OS. + * + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclMacPort.h 1.68 96/10/10 10:11:50 + */ + +#ifndef _MACPORT +#define _MACPORT + +#ifndef _TCL +#include "tcl.h" +#endif + +#include "tclErrno.h" + +/* Includes */ +#ifdef THINK_C + /* + * The Symantic C code has not been tested + * and probably will not work. + */ +# include +# include +# include +# include +# include +# include +# include +# include +# include +#elif defined(__MWERKS__) +# include +# include +# include + +/* + * MetroWerks stat.h file is rather weak. The defines + * after the include are needed to fill in the missing + * defines. + */ +# include +# ifndef S_IFIFO +# define S_IFIFO 0x0100 +# endif +# ifndef S_IFBLK +# define S_IFBLK 0x0600 +# endif +# ifndef S_ISLNK +# define S_ISLNK(m) (((m)&(S_IFMT)) == (S_IFLNK)) +# endif +# ifndef S_ISSOCK +# define S_ISSOCK(m) (((m)&(S_IFMT)) == (S_IFSOCK)) +# endif +# ifndef S_IRWXU +# define S_IRWXU 00007 /* read, write, execute: owner */ +# define S_IRUSR 00004 /* read permission: owner */ +# define S_IWUSR 00002 /* write permission: owner */ +# define S_IXUSR 00001 /* execute permission: owner */ +# define S_IRWXG 00007 /* read, write, execute: group */ +# define S_IRGRP 00004 /* read permission: group */ +# define S_IWGRP 00002 /* write permission: group */ +# define S_IXGRP 00001 /* execute permission: group */ +# define S_IRWXO 00007 /* read, write, execute: other */ +# define S_IROTH 00004 /* read permission: other */ +# define S_IWOTH 00002 /* write permission: other */ +# define S_IXOTH 00001 /* execute permission: other */ +# endif + +# define isatty(arg) 1 + +/* + * Defines used by access function. This function is provided + * by Mac Tcl as the function TclMacAccess. + */ + +# define F_OK 0 /* test for existence of file */ +# define X_OK 0x01 /* test for execute or search permission */ +# define W_OK 0x02 /* test for write permission */ +# define R_OK 0x04 /* test for read permission */ + +#endif + +/* + * waitpid doesn't work on a Mac - the following makes + * Tcl compile without errors. These would normally + * be defined in sys/wait.h on UNIX systems. + */ + +#define WNOHANG 1 +#define WIFSTOPPED(stat) (1) +#define WIFSIGNALED(stat) (1) +#define WIFEXITED(stat) (1) +#define WIFSTOPSIG(stat) (1) +#define WIFTERMSIG(stat) (1) +#define WIFEXITSTATUS(stat) (1) +#define WEXITSTATUS(stat) (1) +#define WTERMSIG(status) (1) +#define WSTOPSIG(status) (1) + +/* + * These defines are for functions that are now obsolete. The only + * Tcl code that still uses then is not called by the Mac. The interfaces + * should go away soon. + */ +#define TclOpenFile(fname, mode) ((Tcl_File)NULL) +#define TclCloseFile(file) (-1) +#define TclReadFile(file, shouldBlock, buf, toRead) (toRead) +#define TclWriteFile(file, shouldBlock, buf, toWrite) (-1) +#define TclSeekFile(file, offset, whence) (-1) + +/* + * Define "NBBY" (number of bits per byte) if it's not already defined. + */ + +#ifndef NBBY +# define NBBY 8 +#endif + +/* + * These functions always return dummy values on Mac. + */ +#ifndef geteuid +# define geteuid() 1 +#endif +#ifndef getpid +# define getpid() -1 +#endif + +#define NO_SYS_ERRLIST +#define WAIT_STATUS_TYPE int + +/* + * Make sure that MAXPATHLEN is defined. + */ + +#ifndef MAXPATHLEN +# ifdef PATH_MAX +# define MAXPATHLEN PATH_MAX +# else +# define MAXPATHLEN 2048 +# endif +#endif + +/* + * The following functions are declared in tclInt.h but don't do anything + * on Macintosh systems. + */ + +#define TclSetSystemEnv(a,b) + +/* + * Many signals are not supported on the Mac and are thus not defined in + * . They are defined here so that Tcl will compile with less + * modification. + */ + +#ifndef SIGQUIT +#define SIGQUIT 300 +#endif + +#ifndef SIGPIPE +#define SIGPIPE 13 +#endif + +#ifndef SIGHUP +#define SIGHUP 100 +#endif + +extern char **environ; + +/* + * Prototypes needed for compatability + */ + +EXTERN int TclMacCreateEnv _ANSI_ARGS_((void)); +EXTERN int strncasecmp _ANSI_ARGS_((CONST char *s1, + CONST char *s2, size_t n)); +#if (defined(THINK_C) || defined(__MWERKS__)) +double hypot(double x, double y); +#endif + +/* + * The following declarations belong in tclInt.h, but depend on platform + * specific types (e.g. struct tm). + */ + +EXTERN struct tm * TclpGetDate _ANSI_ARGS_((const time_t *tp, + int useGMT)); +EXTERN size_t TclStrftime _ANSI_ARGS_((char *s, size_t maxsize, + const char *format, const struct tm *t)); +#define TclStrftime(s,m,f,t) (strftime((s),(m),(f),(t))) + +/* + * The following prototypes and defines replace the Macintosh version + * of the POSIX functions "stat" and "access". The various compilier + * vendors don't implement this function well nor consistantly. + */ +EXTERN int TclMacStat _ANSI_ARGS_((char *path, struct stat *buf)); +#define stat(path, bufPtr) TclMacStat(path, bufPtr) +#define lstat(path, bufPtr) TclMacStat(path, bufPtr) +EXTERN int TclMacAccess _ANSI_ARGS_((const char *filename, int mode)); +#define access(path, mode) TclMacAccess(path, mode) +EXTERN FILE * TclMacFOpenHack _ANSI_ARGS_((const char *path, + const char *mode)); +#define fopen(path, mode) TclMacFOpenHack(path, mode) +EXTERN int TclMacReadlink _ANSI_ARGS_((char *path, char *buf, int size)); +#define readlink(fileName, buffer, size) TclMacReadlink(fileName, buffer, size) +#ifdef TCL_TEST +#define chmod(path, mode) TclMacChmod(path, mode) +EXTERN int TclMacChmod(char *path, int mode); +#endif + +/* + * Defines for Tcl internal commands that aren't really needed on + * the Macintosh. They all act as no-ops. + */ +#define TclCreateCommandChannel(out, in, err, num, pidPtr) NULL +#define TclClosePipeFile(x) + +/* + * These definitions force putenv & company to use the version + * supplied with Tcl. + */ +#ifndef putenv +# define unsetenv TclUnsetEnv +# define putenv Tcl_PutEnv +# define setenv TclSetEnv +void TclSetEnv(CONST char *name, CONST char *value); +int Tcl_PutEnv(CONST char *string); +void TclUnsetEnv(CONST char *name); +#endif + +/* + * The default platform eol translation on Mac is TCL_TRANSLATE_CR: + */ + +#define TCL_PLATFORM_TRANSLATION TCL_TRANSLATE_CR + +/* + * Declare dynamic loading extension macro. + */ + +#define TCL_SHLIB_EXT ".shlb" + +/* + * The following define should really be in tclInt.h, but tclInt.h does + * not include tclPort.h, which includes the "struct stat" definition. + */ + +EXTERN int TclpSameFile _ANSI_ARGS_((char *file1, char *file2, + struct stat *sourceStatBufPtr, + struct stat *destStatBufPtr)) ; + +#endif /* _MACPORT */ diff --git a/tcl7.6/mac/tclMacProjects.sit.hqx b/tcl7.6/mac/tclMacProjects.sit.hqx new file mode 100644 index 0000000..8738b52 --- /dev/null +++ b/tcl7.6/mac/tclMacProjects.sit.hqx @@ -0,0 +1,668 @@ +(This file must be converted with BinHex 4.0) + +:%R4ME%eKBe"bEfTPBh4c,R0TG!"6594%8dP8)3!!!!"m4J!!!!"V@P0*9#%!!3! +!I%Cb6'&e!J!!!!!@!Q3J)!jdBfa0B@03FQpUC@0dF`!!!!!!!!!!!!!!!!!!!!! +!SkJ!!!(B!+)#Q!)%!!!!#!!!!!!!!!!!!!!!!!!!!)B!!!%Jrrrrr`%!V6C3$+j +,)Id!!!!!!!)a`3!!!!!!!([!!'S!1!!!!!!!!(TE$3d00MKVT8aTBR*KFRNZZ3! +!!!!!!!!!!!!!!!!!!!!!!1!F!!!!!!!!!!!!!!!!!!!!!!!@!!!CU!!!!"B!D!$ +!68e38N0A588"!+YZchkZ5b*%!!!li3!!56)!!!RC!!!1f@m$0'J!!!!!!!$ld!h +!VFr@[-lXqG%fl6IPlTAG2YeXXi[+kDE'+DHFmL2XE@9HjUCZkUEIfEBR0$`e221 +XpBfXGMaDjd9iINFii8NfSCaXYLAm#5HE$FKq`JME6lENf'h#m`QV)l`McmLcIHc +fNAe'YTf8X0b-l#HE2#1EE,)*IlGZ9q#VleK1#$rPfUeGDjZ`,6h#0YZRK00Y%Zj +q`J8J'hJpJG22(S!"328fJ'[aheb@6-l1fIiMI)+460TbIZifFV2jGhj9pDU[0J8 +lBe*XYIY4%jM!jr1hH0ZAe#'1([MHX6c9r%`52bCV1!#q(YPe+m#5#S$VRkfQ"c1 +19VJmQDbfr[%PRM0M,ZITHhM1J6PBdF"cNc&RZhdIcdfK'KfrjlR,k0eLa)C452@ +qfF0c*CKMHG0jELV9f2SVRTZ'rbDBK&qjB$%B`[J!Pm9I``SQ,'6'6$pq[9ic%bC +%N5X!3'&%)c%b5A)VLIMT+J[SJj12(rVh8YE2l+CEALj6H!1LBC!!KbR'qT!!+CM +8X1LDm[*"8&[ZAI[L`N98br1F[5XD#dEL+pf"YhPNRZFhcYMq`EDkj@dqIkXVLB' +[LSj@-DXa"-M!4TMaIaGb0)e6901U"&E*m4SX8*2Q`JkEBE1d-KV@UX-8Z!iq$JR +i%RcCiHq490P9iET4LFL[-P,5)Uef05Sp%9@*r%aeqD3!JP*8VGPJC+54GkMfQ!! +ihk5lQmlV,LFLalXkhe%GBAKKBrkI(Tr3hC6MZM1i%+'S,LEhbB(rUHl!TZmhl48 +%U-lJ3XbKZRpi$*[+5EmS1qEjmrS$(jXmSEUTae@AjN,-SEYEcq[1UA1YaVZ#bVr +8ac`[EYKaj6d6ZR[I5GfPZ""cU'r0HI8jG-EMJHLr1arc(&arS1Q1#I9GF9*p1KF +#&HdPZYl4hPr%!pV6Z4#JD#rIi$XH$,dP2ZCjDF-2IHqGd0ld)HeTA!K4R2CU0D4 +drpGT*cI9cLN6"6MY&"F#&0hCd9KeKa,ba5PU*@ai[1)K3F!80Ff&#%9hL8L`,a5 +m1%GPP3clAD8J3(GT,N3FZR-MYlSLaJSlMPBUaRb(b@cU-*G#2V"2IJM-Ybc(Gq9 +JC3C+MTG48'UkpNRa`!-!mj2didpS0m*Zp5N4+D"N1,$"E-KP6jTZ5hdINcF*DJ! +Q&D+-QPYG9G8IF68&)k[Nf,J@rhrYDK@QeIRr6fedQ&5[`[cBD$BN"F2Km63Z +cGCbi$H4D%SiUX6K4Hk+'cpp8,`M!dHkPVL`!i,@PY@83i"XiU+HEhCdp!98Y"hE +J6R!dTMGYE&YicV&3#S88*H*UN!"$8D0Rh2FJ6l(@TrVTQh#BcKJ-KkrGjEhD1hI +ZN!!k0"`@Gf$ZA#%!$V-l-%c)hh%BY&rL0CS"FJk(h"IGrFKYQPkrYDFRqI`#4[R +LTa(%kQp!Lh`cp`ffa9eFSlZr8iM[(fDl(eh"[R"jC9U[+Erd&Kq&+4c$mS"ma1' +Ae)!81N@XaQY88N8"1!)CCV1mNN%L(&E#FES6MH-`ZBrlT-0K44`Nf8aS106K2Qe +&'QV9-1r6aY0MIAUjYhR8aa45NIS4*p1P""*C(0NJra(M3`-4!!ke*p5CVH2deje +K&A(%%i)!("3@0kVN2lck5BYC6bi!FGa)lBND&ach%!jKJ10ZAYMS'ZA$jfr2mL( +kF1iR@EhJh%G`R(2ZScM'R2XSVf212B[MM(1Rd*dlqfca#K'!FarNBm+j$a(lKR2 +2iKKclS-`hR6Z)cM%!FlGiPEPlRGe,rj`h(Kfi850#ill*!i+3B$MEJp'2"@Z[ZU +UeabhrCq1#B%-GiCaac5#ijc6'H9Mc1PNFBahmN%FEhEb%4aQpdMAXb%1&2kS0EH +iFANPdkN16541+B4`+*fp'4c0REeC((EIb6@-&+NqVhCYj0difr&Xb!CAiKNFf'& +#'DpB4$K#NUUk[%Si'J`GBpG302CkHD83J0G,RL(YT8Fmq6L1E1I-kLcGmH)CQId +YmKUPQk4-MmRRddFTmJ41PBDQ8+p'HJUeYcmeI43#i2#'9"@``f$r'-+4JlfH%hY +k6XkRKN)!2[Ld6`L!`jMfCA#-6rXQZAZ4r9-icZT$Rii%SkGeCXE45"E(M8[m,R$ +I2)cM,"pm1L)%d"QIMJJ"F&"BK3"pL-)L"0!(UV%BVb+&FGR2a2EM"QR0[ALkUX4 +PQ[`6fK%b5qSUQQkATZV[EhX2flr8J[qT0`!ECi,cK8ZQ3P!3Y*0kZhB)kK"r$a8 +6I`D(@Rjp!hlIK4S`PG4Sba@YL5Mjl*S'@HU5BfU03%8$H!hVXTSDRa+6kp&RUki +2Zb[G(ShqZ`k#mcGla"3-dlN[0T!!k&q`$ZBX@,HYKcdbI`rPGQ,J6V%GbjM`rHq +JB)%0#ZBIj,2@JF5c1hHb!A$qZR6E'ME!"Mk0h[@RGp)qVmQ"ZlGjB6Q1`fNe,S9 +(*Z*#Nf$3S)5(CNNLP8#IK"[4Y(DYlf$V#pLjqKXYli3FV8#U`Jr`PTijVbd3+X- +4pCNai9$-ed-F31CK,'(f$(['p'0+EF@4BXRJ2P-PEI"c8JYml4h)TqD,AYQ81,, +ERS[lrL3(,JRf&,mTH,UFU#Fk1Y#Ma$,(%-8(`FVTa#,HC-5KK1K'Uc6EDUaG9SZ +TBZU'[#mH+8'H)QdUd%%m+3ET%-Am(UQ)*Kl61qI`090bE0T1,m042[h65'Fj[d- +V1T!!l5'[q-Ve9,aqJMGRm*qqAJGN%FCB2NdaKqrc(VPCE#ViI&rK((a5bTi!Fh3 +CRm,-M-C``D88h2@YG@eBmHl@YTEhirGp,d1c2-`A4kb8mdk"+r#cQ(,4qq%Ur,b +"FLe,JFi8mfhUMPm!V6MKfL&ZGqb$6q'q$9mfQI%*R!e$dB18keCK,HDf8+laHX$ +Ea8AFPS4kiBZBHijbDm*`2aiVjT[9a60K2F#F@C3V@JZic9JfMh+cGX&@J+XrbM% +9`AFaaaGfJJ#l-FGli(8aq#AQ2NHjH9q"hq)T(&k[H4mJcR,qEZ&1KRkLI"hP`RE +Q!+MJKhZ@1GK8!-mQR[XfZa*cMh%ZlfBihI$XS*bpP+(rUZ3cm0Plf4+!DcC6lUT +CE#P!&HI$[jhKV+B+qF6B342'Dlr'qEJ$QP&[r'bdq3rmh3E+&IKM5UmFL,Y3TfT +3L6L-[#qS"TamLbbeZj4(Hi4HT8YH,%GbdcZ&r*PH9Mm&9aB,bQ%T8U$[b4S!M(b +l&)X%)pfUd`"EeaH25DUeVLXB9f+@HL85YlC*X@ijlUJ0"'4FRr*,m4jmcm[Nd3% +"RBC#bLd+UVLD))Fl%@*ZqVS!Vk-MG'TlG3B4HYVJ`HUYpf%a"emmd#[Qd@%J!bA +P$U0-A`h+S45ZG2*kHQf(GV`#@B[))3GZMU5!ram1!#[,58kX-rHa[,`SYcGD!eS +6QpMVj9NHTbHlP4mp6MRPEqIKfASb$mmdr-AaACI("fCRCj-mpdNif@3I18iifB5 +6jq6fkGU@(#I(b5Dhl3JRab1EE-)*)j[`cSj``XQ!2q&*0YQ%2aP`1l)*)jcF2JB +%d2PV!lb8RkHI-T9H[5ZRQpaQQf`bf*)42ccC+cZ!#`J!k21L%F1)%8)#q2m83QT +rLrrI`9dBrdr'rlr$kA`bLC60#jYUa1L)Dc&0MCE@UNT80FN9K1cD82%!@38NrTY +Nidd,+C(5TNL-"0liMIMfH(DHd3I(m'DZ9AA9e'a-rT[,cLGmLVFJC*KUDBd@8a2 +RPPD"'#9CZJcJmH[)G#$die&1MZ!e2`8Cc+9`4T+3!,FdSiiF4dMCIV$l%h`dbp) +)SpJL*h6$4T!!C8ZK2"jTka2"`1p4GPk5@Yhl)9ja+XiIiE`dYIVR[m*j)HiraVQ +8R8pMjd@Tjrp8Kr2T2pYEmMV1Tr6@NbM1*rI@"fEM["Mh6q$F6&V`ZZ-B,C3ILkR +Cb8LX`9#Lk`aG,BpNbF([Zqcm@'rpR%IlhYG,RX0AF`kq#q+ZM-@-b1&hl@ERXe1 +RlU[!HbjPjl)pTqei#HIcf2QF91-'HMihpIbI9q&mmCl0#bR15[Dpe-Ab9'VK6h( +QI"Qpp92+5#!`06!GVceCmMA,jUZU6G%2dd9ZCHHVfEYAXc2Rlh+(4a2kIE'2c`Y +50hj-[m[bZTjp*rP0T*jpLqVi-RCIl["m2[-*c[GY[IA(rD92TfIeeNpq'qGPZ*m ++(9`GU!#,T9)(-fdG"2@Z84Q3!*-bZT9mAq(`IXNaADpLjiXF(@6pm-+#2UlXVGj +kAjp1iZbHqkE8$I10)If8"qJmX#6M)h5%'"93icFqSM$H3Z`XpG6![Y[)c[i$rX* +eiaZJPkU1k+KHIZ$icH2Xr9QGe,2[T9kbrL0e)[8KrBIlM@q"AXM[bDYJqm5-AZT +d,6QUP`@&ZHTV2qBki,ac[jAcPZ6hVq4[B'1qj(-Zjc1TQTha2+G4KmmEfEXPVf[ +CZFAKpDCMmaDI1kSFIQpQ1&QHAb#r!%XP'Gd'ZchGG[X'c-0Ef&Rp8Tq"CB%b[(U +aj'f1cGXk)kPYkA'CZk'J6cQrq!rSG!A,5lJrFcq@qZ@q,(9Fp1@rNre@'M+FGi3 +9A4[01r5-6YVC@FicA#IA(0@*e%Ff2iTPI)hR5)j2"24!(+`YbrKDSa&T(r@e9RC +ZHrDArk$[P(2[0QIqjEVBbZkcqXMQ+dRfI5Il6N[pq-Vqh%AUTi[Kr@G1jMV+cRp +Iqmb[b8Yd2-VSV8RV+13,ecXq`h@5R4q+[PR-PpB&D$Um0-2IpEV@2FVILCPmC%d +K*q%qF*@62hRc2pG""I[1QcIi(&bjCqNIkIGb(TEkU@E[jrP6N!#GDc*jP*c2QJ- +d[cdpUkHN&K[9dlaMHC2-6qSF2I'j41C3I%lK1MXc&AfRqPrj&0HITcZTYpV-R#[ +c2HQlMj([3a8cD)VIVk[TTYUUGXF,)5Kq21rRrLTpp*K[LTcHi@-'G&kCk0&(KdX ++amjbcXr`60qe4NN8KPD,%Em"RM0m8$qVDPI'DJ1LlH%I`-F2bBr`QTN(p9%&-JV +6,5&0arM)jXe(G@,adK'YV29iSIdFA`6G-MlU'M`qT[JXm"'kbH0MUPm#(mH$MfS +P@4MDmG[NPm$(G2!aA[,!MlHVI"(d'Za5p8)k5XMhI!IiH)VeYMl6Dl!lESi*C*V +$aaRJB9rIh1YVi#IMT3Rm+,S[`Ta%jlDD@N@2HVfACYq#15R$#mePD4PRR9))c'K +Dj5qJ%pklbr[[@RA-l3$N1m",*PqJIP+V*0V'#1(Yc+2j![@&@Lf40-c$lB&dfp2 +h`+GS[mdUQhM4c[`-(ca(pah`mfQ8PrAMGN#Zp91BaqV@(aN`V[0,i-25lIVaQ*0 +XpP2`b`C0(iZ&i%$$IZQq#hhFXAGp*r1Z@kd%BI,"Gi88V9"ZaDr$HCI-6I2k(#m +*iEI16m'r`SUC'!YFC[NPm%(Rd,#4d,SENk1C![r@pm#rk2`CEQmG(cJfr0Zr,*j +00D'DAD25Zq@r[KJf[9#B%T!!H9Fq4cNb9G#'Zdq#6e"G0L[MX4-DKRi$I,54VAK +0316&A%iGf)L`K5j%+)mD,LQ2X206l0mZkhrlRhf6[Rq3!!S[r9,Q()QNU8H8K"V +T'*h0Hrl(['`Sc3R3E(1Kj'&+9$mL2rcZB@H[5C0Yd2#QfVe1`qrEKVaXa-J'k(f +XJEH60H+i6YiNEi20Nk3H5USe,2@J!8k9%AHRZp[CfG2"eieMcYmZeZMKMDVlMcD +Uq+B+KpmC0"iX8'[plXM`kc9cC31Xb0Fr,AS@5,jQeM6'lG8N"F,ZG2MLMFUX,RQ +M5cE$L`eGcjGNdr5"![mC2jT4daR$D*mFLbV[BZGLiqeEIj*0H-j[GZ-%ErJlr-k +P1fLUe84ldSL(@[1Mb2D#(mR'F&'[R,qL6ch)cVa*)If+mQQYe#N)pZj[r,A!NfL +N1[bF)2J*GLG0CB5P(HaFE#SrA2"Ef9"p+11rXXPFE$"RIBShPZ9F+(fjS+HU"EL +cfSCH9a)*iTV!28h"PLCk!d`,e@Xd!UY#S&E`c89HAa&B$3+e!9SAU'jE$PLe!V8 +@(E9qe&bR$9L0!V846E*qe&cc$&KKJ4T'ImK#pIT'`0SN8$HK&@)VVp!L!GB'JES +"QBYiUp[e!&CFS-D489QSAT-$@$'"'N2Z,GlUjZ6!DK1SECJHK)EFp"CB23+e"jQ +IH+ZE%3+V8k"fmTe9AJ))V*d#G5IIl1(PG-$D,P#hmakrelS$eVX#p9edA)Abh%i +XX))#0FKhaRK0Hr5ITh(8+G23$ap!c3S#'GTHMMTj,kCc#pAE'J@Xe`6UDh`,M0I +&!CXYJYF@0"l5MT*[5!"VYd$Gc6GeH([1J2@N3(d5U8Zr'R,EGU#F&8*$+rK@-DT +bm&UHhI9'%pM!$KX9@Hc##JYe@L)CeB`F+,(563[9ZPR%8(ZkP&JLMdUh`pQSp1B +8Qk%TB'J%de*$P$1%pJIE#N2eHTdpkKh#"YB6![8*XS3a&%Rfa0A$[(iSH2f3!*a +USdk2D4eDFS4BDpX,4rf)P$*8D#LQEAC4qc9dQN!e0EfeL,Sdr9E&G&'43M08h*a +ZSakrF46@fVjLS9ShCc!0EBNCb2YF$Hd6$1dMCpUS8cYS5MBLFkZKDU25'lEEaCU +L$$2h@TUH#rHD5XiDF-SF--hH15T5q$,'Ujd,j5Lb%JS,eETCcP#EB#LZjp%m`qD +9hTaYSmkV-[5SPY3-AD&-QBEc!LXpX9(Tc6NfkXb3!0DY4N0'010J9[CLSp+EFjR ++ecI5#5V(NCA3-&I'cAR-88)UfKBp1@)G0C3cP9ZlB2)U(h5[&GbpY&B)SHL[jc2 +86Kd*3,6SH4F`0Da9%dNPPR-8+qqb8HR0K8aj6@Th-UmL4`dA-BBD)kD'2@*(0A3 +aHqZeR9UN2@SUfc*[TFQBM8T[9YUS*3+98[8TX[2@5aJU4N1-83QMdi`FG$%(p9, +'Ue@1cmp$Jqje'9-HfQDBE(+`cPX[jfme6F2mkUeAX,I@'$(X1#fqG496APi*Rk& +H@@(eTG)GJ1((dS5564Zi)9FaAQXd(3`9[H&UaQYP6%-VUFMVDXCVC6`H8jZ8@2X +A[&EBU$2#5U4GDFdpeN'YC203Sp'TMjJbX6B8fDMdCSf01SZ@5*!!KQ4GaAPV&Cq +p-'f-5%LL9R1pmSl0&hS0fUKpcB(K['%3YFC'(FVc(@`(G5fI4!hAAL@[YAa'`@, +NL4QPMMZPeKh+MqB1kM@-SEU)S8m`9$qK2"[9ZQQB8&iIDQM#PIY3ek96*EFjM#c +T'C%U282@-qA4S&G0j(cC88-iR3+kfb$``PI&@ep&epj@AU'E$kcR"1TcD-5,$0Y +Yd!2V"B(k![S$r6P+ERmXdT-h11VN0l"e5,c9h9+%&liXh[SbGX2e[c@h5`kCTXJ +TTma'-eHJZTXqm-)ha9[Ia&j)#pAE)`Nf2a#mIN"Df-6@B'a$+&+Ff'jN8a55RU4 +Tj1)A"r8QjUmK9HqFm0HEQCIIJ*R5f$Bb(3iQ"a[5#E(E[SCbAKFDHKeGDH&HEVF +D@2X%kMjX!ZKAH@kc0I6fL9$H*f6Ma"69jq@EdYQKZq8)[,`L'(U&+'cD5$FD2jm +f0[He"r)E)I$#!q+Y"p#V6fXShm-(e[X#pAeNhaDUYk8@rVK)118LS[*Cf96L%ik +bK@FfDU[9ErKb1Q`G8(PZ$bGiQ5mBQNrDl,I1VBa'B5L*PTK#Jp'K*eY0B3[9ZY& +i6SQKS5SmNJr4AV'&DYeXCEa@UeeD,ZFC5TAD1DUQa)b[%U`BQ`"S)"G%f[[P"0# +4GLph4`BFBEr`K[hBj#SFaGhm#Vd4S6cmf3!$MCPF634BC3+eM-4YTj`99K)4*4C +%1H)3V*0Yh*DH$K(TkGPb#Hh(mlHL+@rbcN%%3DAE18$lRQHp,j+%M6S95@qqU%# +XVVk05Qq5c&(U990AmfRdS$GdfUMc)+!f69H$h4%e6[h,F3P(j9dfkK`kr+2'JL$ +l80EZ[(@EM9T5K3T!MDQdGJ`(CXjEZ`GF1EIe'GTH+95q%Ndffe%+Qa#Jd[H%AYm +MYp[Hi2Ad(@qi3qC$QH4J%2A1SBPYH2BD4,e,jN2CP',aFXlViZ9NZihUpD'GYpi +pP'"pcY#1c06VB$ZSppMHi'f-52hK%jCYd"YbVidkLl8LJVGeITkrlTbB[GKEkHa +ehm5FCk0DFplp`mU6U)iDGKhbS5'L(03(*M+!2Y3(EG6TMDTL4NBk6JlU3db[0Bd +KYrhQ+1pK0Jp9DiRfL@Rq%HEPKIdTm2dk-3(8BEYKHQ,,Ed2%r2QdQ%5IaYq1BDZ +mm,GQp0E2hX04Cqr""KTlXZP([H5bqNrI1ZI4`)j3U+U@hU"4f6rej[kq#l$C,(K +YaUiE-@'l@`[4+*[(832cm$FI$'5L@@#mm"EaeP[)ia-qP%k9*TAXaQE*`",kYhb +%'a,ifck`(k$NBHc31"ZEYTEX$GI%%QRX!2i+%M)TM+6Q`!(a%Ei*%2S0h3RmI`! +0$3mf1'ZP8fPYF'aP9'0X,VN!!!!!!!!!!!!!!!!!!!!!"X-!!!!!!!!!!!!!!!! +!!!!!!)B!!#Kk!!!!&J"S!8"069"53eG*43%!Ufl2Ikj,)M`!!#f(!!!52J!!#$d +!!!BPe&l(a3!!!!!!!2)a$F$9CABH@l[0cU)pSGY@G[QEAVCAG[Q%%EVT2V+CemU +mhT46#6hCHB346Sk'TiER+Y0m[PVmc1p0`Sl`!H'%%aSj4MJjGS5IK"pj4Si6eK0 +f%4EK%h,m##HFF-))*mmb1m)*2m+2F%)*Ib1-F-,*-m*2`XLaMK`MI!@qqSkGf4& +qbM90YXB*kqJ4&MRZ%4BCE(+F2$X!`S(A%`K!Vl-(B!!`E4e!#IkEE2&iFIDVqr% +*4MaZcIl3C@$&r$Y[EPRlMSC!4b5Sq2a"emX551$aH1[GMBZVN!"*fbQ899$1qq, +i-9EM!I"dk*el!8Er$q"IpjI4JiQp'FE%if@@)ppcc)4BpXF2Fmb1'+aBa,'aL&N +hI-'aFC5Mq5Z1MDCh#fGa,*rb2G['X8,%Q1e'MSfR((XqiGJ%r*FJ#lpb`8b9S-G +NAKBrK`8N6'4#T!ZrIXfC#JPCj!S!@"K43iTNbDj`Cf`J#kp4XrkKIbpPA5a(@YZ +6a`9@(4R4fGkEU3!B@m,f5VZNEf!8X&Y,`,5f#Gr0"![$$Q1NLFFC"8%hDTm8@lF +#c)[6McmKEA-XRR")pSG6'PLK'(,C'p,ka(G[%*[#EXM+pmMqZJERh,)PcYT!U&f +*RNjNC2"kh6pPQ&$TpGCH,pS9q&mCL36&!$`mRYVjQ6b1fN#,Fh&(*"b0NE4RFhL +mYG@#!"k0lJ9L!&hV'qVl#&lQiDYUmTPF,@eq9Cd*l,Z0B+p*GNVV6SlCjm["B$J +FFLj5JK'MCcbkM81XiB-ZqLBHNXZIESDH4UGlKVZdY,mk0"jQPlqd9!M!`q6b$`V +b'`p$pZZk4P*%,[&39NF1[,KHUpGGRlE&Me8``JXq4K*h2F-6N@q`,QcP0AVJTAa +m[jXGH(N&Hf6-R'5pDYE`rhVN*hJ-PJH-3KjH@IA,`I2#DVT'C&88`-1I8MDM+aN +NiQ%K(J1GD)5(j$VMNhV#JMcUP6@$163HkQ#IYU!-P@S(lp2'dp0pZXPG0q4MmLP +*GGV*Y)EpR4NHQ5$r%9@MDG-`c%0Y#lCNmMLm94G844ka6N%!$`Uc#k[N6efp9)X +C6bi!FG`SlGNF9aah2`pKJ11ZQerM(0,$ifh-k#(kF1lR9,hLh0-m,MRh)4l$cRe +)ef(RRZ&abEQc638V4!$1[8q22jal[l#ARAZ'al"clk0aeEQRH@5FZbPMfa1kUXV ++Dh8[rR$FZ$Ca0XF9ahf1"i8J`(%h"N+cCcPAPmhpbA(Rr1kBN!$)B'FBF8aT(TH +FcT!!(X01*m0MT*2hmEMDbG-m6+jdel-L$bcm)@YZGJ8$UACeFL*a[N+)4lKP9BT +(AFZU$)mFclNeM)5S(VHf,A3Y,RBm+kV"+r%#$q```C4Ar"[a#-UUkR5(1b+"i'P +eMBV'AUrF*J63pETR5(VTY#FIiC(TR*Nk5hDm@+V-IJPEMAb(R1SaSrMd83kpKP1 +PrLR8Mj'F3RhHPCJq#J&iZ)1U#YKKX(rdmmM'AXq&(CL6mkQK%%!22Zd6![!`TRd +T(L26[LcA+P6r2)q,pD&24`+4J6UMk8L'ar,&ALHieJcbZ+J(Rii)!HU-6dH%!$` +S,%+!2N4K&J,8"bl[&H&@Sa1ArFcX-'iKPQr'eG0#Tc6f2GS4-XPU1dfhLa,j$rY +ZB)HABUkPL6F!6di#alIA6B@J)1)B'l4&cK2kEI14ISD''Vlp+$[mQ"9V3#SXejB +V'MSMj,2,&bPbUa*9bm8U06#qY`C`I"'9S`(&U!)a5Je-k+d"4(YDJ3#P"KL`dHA +PRR"8UFCjLqUmf6A(09[6rS(Mi$MdUCK#B9VECYfGA49EB&V&PZIEf)[cYa#f$`0 +bm)Hlj2Mq5mLVX%,H[10mjYlGqGQqID`E(!H,RPr(ZPRhR6M$H(mMlA9,GYc"YR8 +S-9a58'0b4hSc3QJ5$"D&1rTRLL+9+1$h%'MpAYr&eaIaFr8h'Zk!E%41CRJ6Eb* +![RBK`SNR)Tc&Z'45FTNmjG8fqf`[0ChCf,mDmc!5"Gi&pALUi@l#pZ"SZC!!ll@ +C[Za013HlSLCURUHa'3A460%2'c1REKcNBYqPFZ!P`6lJYb%'dSPkSVNC28SdGG4 +#I""X*Th+`0XD1*`5hG3Uc6KV+TG9)P4!hC!!pmC6+FK6*%d&1SJha#!GSS$IP4( +4a#Ykjabm5N116A1!$2dIrG0)TqPe%8,CR[#+I9G`*2bLXdFMK-c#'-ZR98c2RD9 +6YkHN[!GpqG2`54(E#9*N'Cr#6)K%FG'T#+Bfq1T[`S`E6P)blqD,3cKa!'MI#(r +(c`,#21r#G2cm,f(rIJ,Sc"6IT[FT3#YZZ(D+#kIP8)Gmq&QVf(jS4Q`jBD9(!!m ++-EkHGP-9h'0`lM`)Qa"lJE$Q#$b%J[*M5FX,B$-HP6T%@&i9E!Ii"pHMHMVX`10 +@0a!fU45H3icIdQTi#Y$H616De*VJEF4Z)5cVFIJ)-r&m*4-"ja'6q,['fA!-X9X +*Zld#m#l@C,i30fmTX`&-i6U0fmX+%H-kMGP,QNlKH`mcMV,C!&2TaK+XFl2r!2b +6Zp@j*@`K3$(ABfS6mb'QV@fm4C2&NK""TUmjaTHamVc4m#V&(h0L6DU"F-KZi*k +!kRI`cF(%[TU0GNIGi9CPS4,+6Hk4mQGkfMap'pT)DH#0FM38#+e8(3DpUY@aU+a +DUPS$XA$8A"d1a5`q1ET5LGNVrAi&Pq5mFU`0hr-d0MS6S422*fa"3-8&&+@M"5R +Q*Qp)m$`k3iHf2@N)SF1'$KChY3H6fIPkLCl44ZHI$*D%pE"-hSE+*JJAGhNq2EG +G1e'#US@8S"hhJa,%r`)!!!!-!0ACa1YXQTeTep[+cVF'%8BSSC`m[FM+P0!MDh) +UGld)1r+F(#0Vq'3HRSZR'X&hp5XCF-+1(#2()J2@NfG(MT-C2c*JK*[Liq6TN4Q +,(1@8$2JCiH4C4rJ46LDFm#2(b9%H1EB**p`S*j6`)mF*&lK*9#CCMp1,8%kpC+G +F`XP6IQ6##6)i!&Q"$im&l'@VU+S+3NL!hed)9Ad'[pp$c`HrKI$l%95(N!!*1@T +pQL5UNa&CND@3!(e3#SBN,3U!hjq*mNS$SQ,h6dL+mXZ9j,Id&54aM&H,H5ie*0R +El5HPU$UPL9)89#Qm"`AR*ZHcHNrCKq8a,DM*8[4HreAKl8mrlVrKIZ8VpPCQrSX +R[&1"8-GGaR5JAar5'35Zhfpa`5S)TZSI'PG&Rafe$B9MLL'FFb*0Z(hMJcRL-[V +XrH#"fG'5JI051,D'@kHf-ZU`HX%V6@j6fbLec+@'BjUUE%bESZkKe'+[&*l+#N5 +T3#TF3'AS,IM!ZMb$LA3U[DI1J,RTbR"'a-`SKeKYdIX5$f!++p5,8&IUIHqp$h8 +ap(q#ZTc9&D`Zd@Fq(i+kkYe2E&p#ACV`S"$843Q28!je'I5[3rdDHJ1Q+e[H*P5 +IdTLS"+4Sc#PZ#--HhSIiGB)HGf#H,[hfehJZ'p1KJqPd11'TZ!Ee`B5Ri0ZN$M8 +*6q%h8&G$[`MU"I3rQ+BZVBF9p2!'a@H5Y,1kAQrjX4rQD@0e#kYVTeX[B8Fl%bG +H[J,e2YEI`HS'hIm5VK[eQ5qHKpSq2GD%ZDhXqcfXhX[U!kbZdr@Q@e!l@*rVhFh +Qj(V[6hM-$ULAd-qJ8N0DCa[9qAJN-K5@Fe+E8cTcIEN2ZFlrkYUNKrk2ICMf-GF +hl@Hq9p+qjMURrHe'J`AI3@fN(DUl"CCKel'HFdj&(RZbElKIcL+m-XhT15UTIhM +QF'SEFqaNpHjEpJAXJqCEGfrLHKIS0*r8PH[&pa`6S"5'(2(rU4E0N!$iVFj"[Lc +h$if-RRBHkr%i)BKYcX&erQ11qZ-[q)IF3FGcFRG2k)!V1p#4Th-dHS1a#3!$hfk +-mhL5SmX+idcdc"(kc0bE`Q@[EpL01f!MBU5mla1HjMj+a4e83'I0ZdDIrE#@c3S +Gd*M-QXmdi2KAKFZ"JG-"h)(G3UMjM3alVSe6c@fSL&*,J!VK0a-4mCB8,P%Ul-[ +LIN)YMXC#XTV0P@3A%bVTP$"Ur(``%f#*mb!*8LVZP&+&c+"3PNRF%1)+`5CN#G% +#e*25Z(3aXXl'UG+JANF@TT!!')Y(T#Hk2M"dIB#XP&ULb*2bjKf!*'&1A86PM!S +HJQ@5Sclb8)9"eH6`q$E94UP&!APb8pBdYA*CSD#@Qa85&U0#TiT55mmmaC+F6kL +N8lfmmhbUPPP%1*8CHkJ)e9!U5pXC--jdR!VTVTDjh#dVMkmmr*'%5DLN8mHS!9J +0ZHf&FbGe!ql88fS0h'e#FNa@`d'XP+DQ*L"TQ&*aTi&5,9ljSK6b`N&YI9k5N5N +9GaUCmdEmSc%jZf&*SQEl&6SlQ-[K'+9UmBb`+6Fd-6I3C*0e!dlRG&EFf8RpQNq +pN!"-A0b[CKIF0!QeZVFA&L8Frq+p-Sif-%4k0m`EZf%H0Dri041X5BiQ90,C6DP +PrRJd"bBTR&*aTi9jD1X5Q(+jRERma5PC2"I5JKI@`H6b3Cf(1kf8DM1S!HRLfYT +,qE@0+k4TU[Dh3RZB3TXhdE9Cpl*CrD)Q4l+C-NAGah6GZX'QU1dV#5!6Pf([,aS +*B"(YAdk(3-d%Ah`6-[D3!!-jrXN0P%S81X#fXTmNYJ`hTHY"UP!C+!5@$@q%E(c +&iJV"2DZ$1@mU,%2kfNjXR8cAXb*B,jGki9,(UAG3&mZ8d9J`kh'JiVXFTH+1Xjp +F!LeZIm3&rd6B3*-V*089GlSTeHS,4X@J-J""HchR!BZj!92aI`a`fYLkA5FmjG2 +F3qA6k$#PfKj4iA+ckVb+Dm)PVpFeL$[S#,hdj1pDqXcpQd!P9kAl0p&45XeIXH! +#YF5TFdXQfqY`!cHjmEhH0ab0BB,*GR83(0`*'f2HjeD5IqS`RF#&cbq02haSI!6 +r%M%jm$Iih[FI!!!!$3d0F("MT8aTBR*KFRNZZ5kj!!!!!!!!!!!!!!!!!!!!!*h +*!!!!!!!!!!!!!!!!!!!!!"QS!!!rr!!!!"B!R!$!68e38N0A588"!+dX0k@Z5b* +,!!!VI`!!5m3!!!J"!!!2%A1@0Yd!!!!!!!"S@`h!e59cB(Bm+6r+Rp"bj9j(Xr- +iRYYjK%8*j8H1$Z6d-P01jI6jdHXkFM3ma9-m1kdeRka@Xccj%AENf%@14@MN'1& +(@)364Sk6Cq3iBB4&f285lRAN1H'%%8DHNfH4Bi3riH6iNk1%jC&MK*-"Ph!biNq +1r`TmV@I(MqC&q'PRQPQ%T8GBj,K(@13i'6#b#DF!K!2M6b!![FiZ!!B!"8'!QIJ +hCB4#B1li#+m!I%2BLM5#3U8FZ`mJdqpAGpHk@`0+B)hmVJ351*fZHNI6`NVNm5T +m-)"6pZG#H,L0Fm*iSqMKh3#,MJ!8EJ3cAVMR6)DC9Z,U3683bq6B0X+k'FFiSap +F($[*%jB3eMQ9BmpbV*6R6Z9B'mI51,D'jr"bE#rAp8Xm5*!!JUGdVS84pr+bZ"3 +@N!!`N3Q4(MaGb4N2#9QN#`"B'&&$LU3SXUq,9p2j++-$&am2NI16V)HP5H[kmXL +3!"T"*R5fpQI+36`JP8Q,6%XJ%pJcXm#dVKR[c3%,!kc+5)4#M)+JZf-%GZi%+-9 +'9"VLGdME0)[6je98Ae`$-a4!1MXXG8I2r8&XFRXK*GZTU(80GTI,BDpeHeGSJB& +%Pc,F9Hjbe8i@l9,mPr[p(M%!$kHcYL+CaiEGh,k`dqm,"%RDFcQFVYSU33#2*XG +MBJ"Gka[U"`PHip&BfGaSNP[E99fI!qb(6@#YLAA+e$dFXeBS(Sr2jl9ADakrd60 +HHS9$V1'c(MS6$dP@%mh3f@4h21!S,"bUMM!2Xk`@&JS"H*KNG853!$pj',*2kZU +2%lR+3e[Y2hD`1eb[qikhKliVBi6RI)%NeZb&HQdYp`fT#lMhBmF1CH2prHcBZd[ +CLlI1Lp9VqrrV06[+Bk3m)"0jZ"4G96`AK3hVkPGd83!20DjX8PFb5-6$3Mb'1p% +%$dNqkj2k`S)mU'6M%HDKMr4T#mT3VRIb2QeF(HM6cBkk-4q668QU%NkQcDGf*AN +NJra(3!mN6--i$lhGdjV-Bh09MUU+2)*GJJ!H&'BCUq5QVLkUaE$MRPqm5&cLZ&( +DFcQZ1qiK(X)!aeeA8@-Idm2TDNVU)IT`lKG8[HlF%cbZ1[Fa(Z21I8cAFHHHj$( +Uh#NLcTeYcPNU!R$ZJhVmlGb(K,hQh*-maThl))dEcMh"3acJh-fbVLhrYql&(ij +lI['+FcQZ1qi,2#J%!BklbHfGqj!!IAAar2111qd[ai4%4MV$K'0+m,MUG-Ed'(F +k54i6RAb3!-H06TlJBC)6A5m9H@$KMePcXqaaap[9Va1*La9#2(bY(A%HGDdG54j +TcJYV'&&4RBlUQqf`Vk+6(5m9eH#91-S$1i`RlK9[)4iH4GIY$PqRhqdC80HSD1c +efM)KJ+k6RL(QT41HI)*(XR-Qkbc@mB,a-[XM-QU8P8Umaf6bkD2LI4qR5N06U0m +M0S8kd41G2JS"H$JmZJlBBE"r$2'BJVfH#cXm*qG63b'!(RcD*`6JB8cliM`QTRd +TFJHUIj((jIU)6%IFrZ%k-q&S*-PMb8+A(H5e)c`Zkm'R)d+!1Z26%5%!$`U,%+! +28CL&!2@"eCL$Qi!ZA2D6f'PJV'4l-@lpfDAE2UBG)C1LVk$TGPidrqR'fpRT*mh +iMpi"H'dkf,kI0"@#JJKKp08MefrAKk5IS@%Bhh8!rdH`"U6FN["b481ARhaf5E@ +QY'N"[85J8J--f2p+5TbqJ&D&2PZh2bM2NqH'jGrb)pK1(4G9+&`'V,HVTf`(c#l +EFD#G(5aI6pK4$%M$$hH)mIlAN!"9PJTCT6rb@@Y[eeG(Ml*HX*h-1l#HpE,H9HK +G2pe%qlb5&AG[-cUe)!kRpD$5QCL)#df#3E@[FfL@*&)*p%R'cRAImRBkZLDmJNf +68"Y-3B6r)RQ1i#lmT9hcd5M&#'pdXHlQXj[Drr#*JVr[Y#22rT6cX#Z'4Feb0V8 +dUTk`,rTYdqh-ERXklZl6dMVpJAh'h`3B6LIULCB@p#L"Q`e'!""X$Mf4J(d1Ka+ +LQeUPf9C0q92P#1@!LCSMfBHcRL*Q+Y""("D$G)JFrTk)L#EH`mjTbN"(G6qD+9S +N+F$cV2iNj0MkA*Y!S@arBBe[P,!6TVN%[Bh,*lNd'j64hp(l,(5k3XJXM,&miBV +THerRc*Y$8YE@iZcCH#@2l3(*ra5I`YcP$q##5alN0c6@cm#-crp+bEbI,icJa!( +Jm3UJYhpb#&Y@#89iI*5`pN1!-elJ@p5@V8$f(GF0mH'BI9#(I!S)Hf)aY##fK,# +0R`!q*-2i@Y,8`l$"i,cUBpL-f$Z%HAq#&e"3VZ6d60J1F1FT`PEZKPdShmq%UDm +$[Qmdc8EBKXA`*Q,jK"@G!,3hdrJfii0h!,ka0)eV8l3(2JH`mhaY5q&Va2Lp@pq +#la"V*#br#*!!fh5CX&Slb`#B`GH`(YGB,Q*m"G2b-QNkB`Z[MpN-ZpHpY0!(mY2 +X%B$lq&*0mckf!0P`24Uf-H5@6qr[!(a)Nm@CI+()p#h(q"JrbaA`G@KUd)ieUEY +pAUZ"1pfkDZ-EBp%pT3cD'A6ifV3&QMFpYMr)VdA5CN@fB)f8"YkN",aZlh,GCY# +VA"d-+,UPXXdGp!A-96j[d0+S"*CV3@ZjUQUi(195JZeiRkI*S1F")X5c#A[-VH2 +LJGECLK66Bfm(m$`4KVE`eT`K4!3fG,!iUTbBc-VA#L)C-qMC(i-PBAdXBfm#65% +)&cCj[NKZDrKT#P60UhQXZ"F5*IiI$J!Vbl1KGC5lI8GbHk0e4VX'0Y9VcI)i2GQ +YV$9ZpPiRRUdRmr#FiLRqi[LZbq-$Xl1cDADXb(lbf`JRcmPqAGZ5iq3ifH5f(H( +N1"PX`JNRQr$1hL3$RQ5IK"01q*-"Yb1EF-,*l@2!AIjkY5VPVrLNbP4kp95qER, +Fb#D$,4Ra`j1pXJ1iJ!#!2LmDdh89)45!rqFMe,)4rNr"A36qR`Mrr`j1+p!%9(0 +Xa*!!BhTA3P%919lG*%Yaf8LZRp!(',RI""0[FPL+9EI&e'4(G63Kaj4Y5JbKU44 +M@KD1iNeI)fZbS4"-r[&hk2QiMr#1#qZ'h+LSFR*CG4"iN9,95`!lXAYqh9eSq3% +mc-PK["h[)&6aB`c(IdFKG0UEk",d8lLE364#+FDrfH%VV`1b6#R8*Q)GJe+J[qr +5mi,dU[jhi48,iI`HR%p-VrVPEq"m!Ybr$qG&p&a0ch266rfT'Fk,Ir&#jFY`RYI +IJZ*`2Vkr*6!6c[2KIJqFqp'6m,TCP"E-$f&UCLUQJJMV99@2eB,iR0rhk(PTHY' +q1RM2ZI4mkYi6Gci,jfAdI&SkZJQI6dmrpHH,i(cfhUec-Fijp(["Addk2IIRF(k +i[fA@Sh!fqPXQeD"!S#)`"9jlJZ"VKXPAX%25$Y'&VU2R#qQl,k*RaYrj&SrGS,0 +RXRbZ5&re2[iZcfZ%ILIil8Nrm6HXYr2Sr4N@cmZTRKRIUIk@Srk4eHZ5rTD*Vm( +j&,L[!"eF'UJ$&UZ&$UDE1JKT25-b3-IDZK9mAfca[[+)VLqPjl-X(H4pkmbL2S, +p$GIING9*NYicIa1kSEiaU*rD`!TJIk(Y)pMV4`68pSf2E+@mYG+cd&-,r@i,2IX +2q![6M@q!AS*Gm4'pl,(mjK(krVa1,U2I#lhNr8IS41K$q!rc'pm#[D!hd*[!pKb +KPpQQATUeP'ad*e,$QT%Y[9a0H4,c95-pAfATiTSMm`RckATkCMVB4('B$J6[[dF +[!N[(f,l3V#N&MJHQmrcmq2AF`I61p-hQ#M&A#MkI4Vm#0LTY2N1p(Tm2qJE-`qh +d['fFYlqJ[m+VUfcH@R@Tk-mk25H+Fic`ikrQ3+C(`5Ic9i[A`**!$8ir"+qc6&l +AkLPP@jr,,'45Kha8c'Aq!hjD5r-D0RH`182i,*XhK0q@jSerSJq)Q`lP1"&*8dC +bR"YXRDMd,(b!kD4jA#G#(rRmUXZH2eL1CIPI3!XNJ,8PYZp&p9MRL1qai%ejiYI +r`Zm8mlc`3kD,6RUIedFq0lU2IRmrrHlkp)mZ(XL6K(iHS(KIcIp-4rQjpQZIq5e +k&SqaYYlDP+jLER+&j60-*rNjSZ5ETGaXE3#RdiYYrUl3P0i4rSkaFjqkmERT!LY +Amh)0TS0,k(IH[-(QhP9l&rm4IbrQAk'IeI6p,&GVS1H3!*fcLIPX3`"2@#IPpC4 +5e"%p94h*d83Ze'6TLFdP)PpMF`V6fFRTq0mErT1l-IejZK0k@e1FGd8Zchch3C, +m6m-YJJ&G66(NGVNh83ahiFIk"XaIKBmHm8fdJ8c54`NqTS(1kj0pfXK`LH(S@H3 +A0XriADZPC(&S*Bci$I"Xmi(p,0JTMGBKd0'q!hcm!2d3AM2p%hd%JBcLG)Y!Yer +bNFr4ah9#H1Q+ecGj[1"qN!![JQiT(mfY(Kq6I"Ei#&rYm9(KPm$(91#M38S9KhE +i5Ai*I%`"2XE++r#ElDHJee#2V"96Ai6@qJl`m42D'rYBVk(HK$%UN!$*&KmR!3r +lXR1[Vi'IM*9"i2Gp[i3j#FpYM8f5&[Ik2&Ik&Xa*0LmiPm8PSl95-6"ElcZJ%pE +l+rM['RR8l3$)Gi!A1er!IY)N*6Y'#@(Yd2&m!IY#Nj*-kFDKpN#QEHTli&1iYdG ++39kd-mIQJqAS[J0q2KRcXQl-$Y$PIJRc'0(*ZV&B%E'[I4(Q`qCeK`HHU*q#AlB +UfQJX"!idj*IZZdC,42"MV@[aVQ[4&[KUiLI[#NY+XE3,2mekPmK0#hia9K+#hcS +r"Eq)5%Cb0(#CiCIJ&hMHLh5fMaRmjLrp!Xqh82T2bNE2#0AArYH()SBA`Q)#l(I +CZL4mk8QP0jSDb9ELIJNqJANq21AJjVj2!KrB*cC)Bl%60#Ip"[L)N!$*-X$cBLE +[,YM)X!e[C+L0kbiT$jR(`+cX2j`GcXfmb'4i8P`l6#rmYY1cee6*0e4B%baX0HL +qEGD,aSPSMZkJ$EGED11-+I$IK2lMK4kQ0dB6jUk,SLTkk9Ndj2*kB!dGdH`Y05i +p(BMQi+h&4Y1Vk$9JleM"rl6'EK9'YG4Sp-5fQ*3D6%`(AcHD4C1CmC[IM-#5C+& +[[Y1N52#0PViCRekMQI&6E*6a4Tl&cp'FRe"[bT!!KPQkLCj,6FhEL[iN'RSlEEm +56Fj5Jc1[DpEB&,iYI-aVk0Pq9YQJ`")H((J'pB5EKZbfpHiIi&q-ehXSAkb"Z'Z +FAp[2MQQ'p"5D,*cQ2-9hIH0RpaEjBCXI,(kQ4'A*L)d&fHMZFIepZaNKh`Mep(F +R2E20$aE2Xl&[0mM*cT5H#,FA4ZSlLMS8cI,5(-Ki,2N*ij0Y3KUF!f%'+9SQqGh +qMDpmjB1lL90-&Ac06+B-,5BPj9MA5*IJj[mP05+KQ3MrNhDRedf&a(Cei,Dfd-B +fI!1B"09VN!!#9Ke(VB0FLU1kr9$!DZ@SVF!44hAELB$9a&'ES"-iJ1Td#!%VbP' +Md0`E3(@DIS!9iDJ4k'X49+rI"9KE11S@D1'BbLZfGJ"V%dIG"*l"hqTfD`!V`9% +6N!!*%P5[130B+NG9S@I!hqVf%J#VJk0f`(6(0H5QjB$9ae(l)22PEh8cBX$UjUM +GE2HCPlJ#eLk1ZSYYL2&b8F$D`9&hX,d*AXX4X&lRU+p$TjJVcqdJ!eD)SiEB6Kj +[X`(dc5Fce%Q6f3BCVlm2-m!,$(AL#j!!0K"8ErXBB,h%89pLfj'mlK1`ZC(cZK% +D*KP(+645!1XKM[S3ficLl58#$5cRDPJ1U5MA+c"8Qpr5Kl2V`%i6&9,X%qS)kZ4 +N+UlS$LJLFaC"*6Gc+@TIMk3Q#kKiVjq*LQrQQ3a0!SD'-BNDiS`Kk$$-cbM[FR0 +S1iJ0@(XikKkdJ$)85r8Pj%1m[XYjI4FY0&'RU%UANKSQPZc*BDM[S888&65N+PY +Ge!%09A083p(D5kJRCYiU'5iUc--8&@i@QkK6VaZ"*AYV##Uj1BPUD*ZU3l,ZDQJ +ICfJI1YP%VHM#HI5`c%Qhed6&0kGNjb(GF&k,jhMZAK9XP`je5JFBT`!-&I+!8bQ +[CU,X8%3b%)*+EQSSDKXBLZYj1#%aHF8h5dh8UU#ZaC@8SQX5CXV3V4H3!2c&4-8 +hTjQSdm0+Va`2kh(E`8JkBk,LQp1TbYG&m5cNF%5b(1V+F,1-1NTBKTj+Rd1XTBB +cU-V*&Tf#bR2Z9F[F5fN()C6mG6P&lGCJPSqA2'm&9F-D1CQ59-G45$*TSZ+E-kR +bfZ6H9%&&PKV1SJa&BiB#Qr,'0A3fIH[kELA@'6HNlICEFACSSZ+EFdc85Sk+UIS +)fAVV5SS+Sb'-88QpfiKpiQ)@kVQ89l*@S$!2jGcV2+Smk+I"C12!@QmpRlh9-(6 +MLlGH3&%E&3e[TaeAhS@8SAT9JI5aa0"&9+reLB3UYdPUjfIHF$&pDk1Z!N1PYej +LSNk,5,&1UGfKb%+pP$*882M(U+[SC"29Zl9KHd9N5j1*LQrU603CZ(LPDiir@'q +YCe-8c!h$FK@SUqY)abq6E`m"il5CcRP`Ji)-PE@M2N0Y-&'cRD1K[#'('M*4"jY +!&VD&fXJQ8Gfe9k''0@a'JCA@j4QPLIQ3!0)E,ScQ&QScCDJjTQYPKLiVkp9%*6F +YCH9P89[,+XqLKUPldHN`G%2hTqke0T2eZTY@))&kM'G4Md&IQbGBEVmEX"lRU)q +M#&8jMSIPT$1P@!bY0prUlHb!&ll)hrSLp&C0P4Fh+!$@Nace5HJ2F$@iH`8!kfQ +1qM4X)al)E*cYaC!!e,c#8#Hq!V[i"P#GhAf3!)6bG(256'KQCrS0K3e8`-YcR+( +RB,m+IkZlM`@`AZ@SVd,D5e#pECr!jMZFehI39A4qEG@h3`"6QPq[TY-KT%ST3hH +L(J[e'ZVPB9RV,R[j*MShA!N6YVjpH(l0T45E-fQdfpN(jEc-0I3b01bjHlQ0I-$ +Dae(h`Cld!@p`pUU$hMlNb[X3E5P2E0Qj3FVNP1iZ+Z$PHFl3mfJVR@`b2H92*jY +BYR03f#-#,pc2hlSI%[1-KJTE!J$VEBlk0Za`*UMHcQG`eARFAqHKE@bD0k4%f9( +D@6iNYj0@a1H6D-F"P6[E8S'A1CbK18JahcUl2Ki(3dPZ9#8F`JiqQI60#5UjZCj +PSM"U"#2$@44ZTa08FY0*H@f3!(X8*hXC6,"8KUT)U[j&@YC&*`!FrS8J@Ijm!Y! +blZ9Z-J&(q)"l``H`EhP!H8k4"9ce$Hk[Ek!%64b$%&mh'P*lee"%C$&d3mDph&h +!S'h%9Bk3!('Jdq28A`#VKU2@S+6TbM-L8M)QU5%SI4b%Y6+E9$B$-!`YAjV"$86 +f9ZJLGV-Z43`#@,G,!Ie'PQ%rJhT-e!V)+!S&$%6DN!!Q+VlCEU*k@b,5IrL3!%k +Lq!Ee$XiS3p0'6Jep)Rh*6pJ,PM)e,&L+EKa-HMjpkdhfa'CK@kJh8dFTGNe"T@p +a[Ek&ELP2!&4$H!,B8Cif6&3bEGaDRJkc[1kN+Qq-KYdfPH@[Ye%IDP#5RH@*lAD +4jpNUcc'dbd39,@[aD![eML(8`8NdKhURLFUDkdll,BHkfd6epJeBU(HCU&k,hd+ +p1mH3!*1)j&$[1FM3),d@kVejKR,!&ZTpe20DC%16#qfFh2ak[iPD"8lCS@KbU$F +Q*l$V@HjL1FS$*ZSX(&"#V3q+23Hl4pCE(c``L6Tri3"-Gb[jR,F5'TAQ"&$F``0 +Bc4be'AB,Q9jHr1Y(qPYQlQ@S-rHLKdh8bJ(85#6id9YR24VB'3i(Qr!0r'8L!e1 +[mjH-!#mE1%-EB#mPRqEG2CE3P+YLU)%Uk%BHb&rc`2$#cIbYQp%MC4r+*&J6+Zr +H#rZ-&Z+r,LA5QX4rE`ZD8(RIca"D"MYM&fQ44M@C`3l!hq@#*N3J&GUrRhm%hm" +L*IJ'EiRq2`!0$3p`F'1P8fPYF'aP9'0X,VN!!!!!!!!!!!!!!!!!!!!!lp`!!!! +!!!!!!!!!!!!!!!!!+(S!!%pq!!!!&J#F!8"069"53eG*43%!V5`h`Uj,)M8!!#b +$!!!6`!!!#)N!!!D*U&H9qJ!!!!!!!+e2$F$9*9Xl,h1c@hQ8@fbIH,BGD)2`l,B +HB5HRqmLQhmUmc%hG&,rTme[E%ND1(TiDIM2aY28pXPVlD"hK4RNQZAd5hK(D*TY +XFMc###Hhb@h**XF*2l+0E(,ElmNQR(#bMa`RQp`q3XNQQh"bqb4(#G[Xb$'bbB" +,'0RNYdPZRb[`93-@EE!p,qh@$%mME"mp`MDjVB4(ET-")jYX"N!f--%I%)"HC`r +!!'$Y1%!$IMf"A!kmSlr%*`#[%EDhQU"F-mGZ!kLcV-56[8E+5ZTpLD6bJJ35a'* +U6c5qU`fC($b*XKE+rP!1IflJR$#HfE$Y*B!9,`*XH"Lmq'$eb3aVJX3eQH9B,FH +q5YJ%iaMQ"AK$jGJ4RV#*X05(1IB!ajTjEMr(KMP@cE&p2%HDBdpcA9r&(`QUm+m +'[&3*qEL9Pm@Pm)'%L6b)61,I2h+@3d)@03)!&K5N45Ip9@Q+1FDVkGhJ08U&5$r +jrl[C*+Z@lTr*Si$r",I,%6b9+B,iJqchl)LR!@U"l9i,R[[lmGdQm$(!UXa(,XF +S#2U)md[aq1-!cGL)QR2m#@PElBZCD5eKPMA`3`28X*HNLH,rfi952`e9iCL@k1k +9968UGaRT[AVQG+*,'@jU9G@Zki8lL0p@bdU+!AM%BPhEh6bK,Q0)hT@bc%b@T$f +E)kCfY3X#H-5M1m3!Z[EdpT`Mq"k2[VEq2Smb0*+`l8h!h[J5"$Y,RG,r&-H#fl9 +NdM66FSHHY!Spij[IiK$VI@@5rSQ(T#3Uc6!@Pk-ESq[AceD(`m1V*0D[&`,`m#L +*18(qbD-Jqh9GV6+4+ccdF@[UZ3QRAVphD#6hHJXM22)l*,([DHM4lq1q`Eq6Hcm +fpA`Bhcr,TPiBC&pEXD98Vb2rVGG`NFGFH8!YmP!e1k%P,`MVk'TTYLL!4k+XV+X +V'56Li5-H&c[4%Jp*1H16CX*$p6SI$JplVNrl8)C@1mAlG1(Tk6lG(qeHm$&K5Y* +HF6,$CQ,-jH%'qBq-RDQBKN8HpNKbb-d68Y[Q988Hf6&"!!m+Vi*9FNeAP@V4FGa +E'cmP,R(F+1hC(&FGpb`2BB$MlYlH+5rS%92MVKkL$qGqAY@VcVh#iiTcAq#ak0` +AG&edlLk2HHG1NAIZl*()S!M!ZCr6ipr1I9EBpjblbf24ZCqMmEjcVr"`REX2HEM +QhG(9e[ImVql&(ijlDq2HXcQZ1Zlc2#J%!BilEU3hhbQ20fjpeh&ArmXa)C'jcV$ +NQ#SmVMLG"6d@RBl,BkQ6Rq2aILH[m2!SPDlR4ajBq![@h+XNMA+lHQXLFD&#L)F +j0&VQd6ddk[+SMTeI`bL+'SYfA'Z(-aAYGM`rUX%VFCi(GTKNf5YqJ(JN0GZ@SfE ++-T+Re5e802CkrA0#!&f[HiD5PkjimL8HEZGdkkc8mE,P-[Yl"$Uecf[P(P2,Tip +DqUFi9CUG3Vd6T5R8iFRLp&%)`#1DY'h!$S2pBjE(-ZceA0L,Fh)q043#k-'RI8) +!(S9TAjR(dV5[5KP&p5r`Z&`IqHQ)B9fX-pTVF(RFZdZ93EP[MXGP2IKd4!K3Ch` +k)J6J3H%6![3K#Um3S$k3!-@0Z08iMXYq(RB-''Xkd)KEIl*d`kpT4mLMfAYTZVf +UQ2pBh`ICXEZpq#fq!IMf4b(djqZQ3P!31Bcm)ZF*r3lqK23VD1MJ"hq$hjHa"U6 +k*QHjSRI-)TrGe+&V`hV'EK+Ve-$+8c@!iiZ-PM(d3K8)8'U!!9[He"3c-hSlcKT +Xq@2+&Q@c)rkAr`+KSiIqaK(AY@pqm8r22,cR9r"D,cAl4YL'Edi%QmDIQcIJpfL +,HR`jX1Fq1F@Q+Hra-'b$%,jGKfp[2*f666qi#Eri[fqLj5%[FI0$095hI-0C!XC +hB6BppJH1)5FCT)'MAdH`hS`3eVX&KQA+X[c3EXSe)VdkdR+m39T"#A'aqB%r[Rk +fDU3JlKm(8RS@"r4f9NY9YJ+%*X'J`dc0cY0%+K%Th3+B@@#[3HH)6l"T%KU#CBM +`6cl2cr!H`+9pqrPSaR#ffYK%rjPYpIr`+B,[l28Mce-TYf$IG85YLm8(m-k$i`h +Ih[BlZGpIJpF3-,!LU%aHiAF4,UB6pF6!!(U8c,8')`!)YSRF&2Bj(-b)EQU9jRZ +GVIHd)K3"Mq5iKG**#`Vb`J3i#Mk-)(cS%0R`FLl50'pN1,6emCJAKFSH)i%d +958M6%(j%R62Xh-q4XFlN"M49DdmPqB*KMcJ1-2!m$LGThS%MRAjqq8C`%1b%9cc +!$N[-`kAj!5lJe00m91%e65GrPJKjK6'@ckQBQ4Y$*qmZ5A9Ik3q[`bHVf&-J@II +`TRZ6PF%PRe9`HfpIcbfBmBY[8I)qbjGQF1+!f(H"lKp&#+Yk&($d"TmJc2pAR-i +"m%ebDa,)[Z2+*F"RRi"Zj00!f)F'B3#aH`N,r"c`Q!lMUeRa)l#r`(RrBr!)BMm +NE2-Gm#J+bJm&$8EK!-$+Si4Yh!p2i"SR9hV&&$`*)#mRV#%!hdH-Y)@9'U#pN8N +6'!J#hTQ51`REm@2i,8i@H6lM1i!GEc9rTpi&1,*E66H#S'i0[!P`bjf%hE'1"I" +)%eq!qX`[@$eLU"8@c&fNkDf2%EEQ6EBCi,Bq`V*Ml1-!Yr2pJ-K'YK0IFcdqR@A +iIXeZAP![dqbdJ@[[1FiaIMqN6XfBShSL+f00fSDC$KE`Q'%R3RaVVVLV&D#pbDJ +jV1r8dc@P(8Vq,*qf,Vm*A%KC`10D*QfNppLK!Vffm@a'XheY`dE@c(MEcA6@ekG +PpZMCB'XLSH1#Q+TP4r!p6a1J%`PjiQ(#GKJf,PrSU5'N@&1kRm$cj"Q'R-h"JK" +jZ+#$,pSH`f4"[PU4caLJddF&PS60X#cG49T'%#kYmRcjh%(R2!HUPYD63Gb0+4, +r2`!-!&9VC`kb[%CHJjACa!E+c$S**bc*-BqXl&E#*'XbjDl(#*-m*mF)RZ+IRAK +qH+Tar005F[c)dFJa`JNMamRaNc`MBhCN`)p`ZpAiN@0(CU`MM$$br!JRamKam[` +**a0'Z13BiAEN14Q`+$I#Md`Bm2@9l0GM(6Pfkl19HA,*K(AN1*Pb-Z@%ia2im%# +M9NRA08+)!1pPK,5Ri*f"A3,Hmq$p+h'6AZ)Lh3X5KL,TiaP98a8jY&F4CF8`Ym# +ATFI&m*T6NKC+MLQDpYZ*`VIXD5M!FEc@Z'lTKUk*S5&ee"#05Ici9T@I2hk3!#1 +TLRRekYAl1%@mTDJ(TaB5dh*S[f,U%iDNQ2Iam2d2RZ!9hKDm,JhHVm(lGF%(1ar +X21BP"L+F)VID6K)[@3$,!H&,q-,cbLR"Bl(2Zdlfi[HY5A8mSbNKT!lBecB8UHk +#Cb#4'!,d+IBQrB5-F)lrDI!)b*c[HPf$`YQ'R4JBcmdRT1Fkml2l8a)JCf(RTeR +#V%%hVI'$Kd"4&KRKM$4@C[NXR`2fVYa0B0%#mc6-mqeG(hi-Fc2XIiBjb1G@2R[ +Ymem0`YcfrTAJ0c$lFM%L`qc*aB3!c(lBRiEj&dJc3KE2C!V6*fK*@Pb8"M+C`E4 +UKD@+#jVi[0KHq9-rm&R&jbfJcd@B&fCA69f#ZB225qcNLcJ[YFprr6c-AGR4$X4 +EcEpIbqF0Y[aM)mbppJIISNkGA0G&YYea$ZCPA2rYZ9M,QB+qi9bXiAT"jdfjQ,X +EjJ@jf,aV-,I$GmMV,A)+921@G'm'h91+@91F2BemGR3Zk965Tk4,5BmEj!GJXl# +NKjrjm)NN'iXqA&2dSq2$VERG,jf!HIfr[Pc(jaiq1hlFc2H1hRfFCmQ(qfL,%JT +YKqVXdp64F5JlB9QIGGicI)lQIhXE[Vr$KrQQLI2j-m@hjIN`(YM[#VA-2jLf&11 +`+#P3HakhJ3S2qQ8J16KmB#5F5%6#Xd6FXcbDiU)e0LF&I4`r2164%MmBf6q4YY4 +aC9B3*ir+2!Ef*3G$N5I#GKGj1$Tc(MiS3ce)!Rcl@&H(rf'#PFPGiY(+mY,TT@' +Mc'-jRd2R3MF`jeDHqraGR&G!APfHk41hEa1KRhUTRJ6CiAIkKH1Q06'+'q*LU(@ +IfHFrq8ii(Nm-4A&$'KKUhHAC,pki"&c(Y&(FJ#HS5qXHbX@@CaPAh"!hieT2*[[ +#Cb0F)GK!lk&Fkcd*h(051*lD-j,#$E4%LPT[PG!4ZKa8GaIa-&32S),j`Z@1M!e +$Q'+Sd$@DqbPUNfR*UPi"*E5R895kmA,8bD1LCMj#a9E08((MB`Uj3D%U*R@$l#J +%UH,RIJA8rFS4j9MQ!6Bfp$cUD4,J#NR@C%CjV1[0[+ih53Y$p@MUZ'T9KD9A"3G +eQJ3j+RJ)`U5'HXG$VAP83ddIHBSkIiDVD043S8pc90Ld-G6Q3l1`p2T"8HQQI5D +p%VT4L46Xj2P%DB6l&%APAE`#M)hH3B9Z[j!!qc@UDXUM4+'pQD,5c5+1QJ+6eh) +)@cGc!fi@-p6fL*k@98[9db)UCHK&"[3@`&"aXi5KqZ,U-8@1kr,$9+'A!BD+QkA +FHF2*!jCDc8Tk4q"*#CX1l[+i-UiENa9KLflSC+L0+Ha2eB!Y*XSbcR8LV8)k2%f +8jFcPp3B*c56LZ0`G)5XBDYZ1(4#8H"IGS@+e!4+P4,QF6j6,C19GPeG++ZfN&*9 +Z3Jc9Qj`dDm#dd6*8h+cLEYKc9%RA'X#pE1MLfI$#K#Up,"[LU`q!kC@)q48hUaP +U-)qD8Slp%CC&Pkpa&$)-hIK,SE9FSI`0qU&#plLZieb6NU&QUTfbL,UHk`Se&#T +EK@m4YC[I!1CZ*2D&cMjKLMAXcMkbJ@F$kqA9"S$h8HB'h'bmfe%Ue4bDbA5qSdb +66600&&!V*4Y[GrR-kbDErfif$*@kSBIhKL4YKaAFSSI#6#%[+!6aN!!Z&hUmVMS ++`Cee#eISX!5'VA9PZ0dk$H!LkH9Y`l6%DM)!+Pjk'5TZY[E6Qj3[QXa%i,mJC@K +k$f8+iDD2SIS6SLQ*fKkSj`mk*@"aA4&e'h0$rEUCfqTl6jJDL3a(F3-h8qEbZ4X +VH(YRhZ8liCm(V!r0r9-K&`YN(G4!PQaRU-%lU""m[h0Y131C&irXaBdVq1B9Z1" +&m4m6L5'6rJ%%[[N)FYS2ZXQ*U&EiKiPV0`k*T()%VR21!rr6FAAM0hL*r4m!!!d +0$R"`Bk98Bfa6D%aTBLkjZ3!!!!!!!!!!!!!!!!!!!!!aA`!!!!!!!!!!!!!!!!! +!!!!rr!!!@V`!!!!@!0!!J%e08&*$9dP&!3#Y,$I#VNXL+!!!,)-!!!F8!!!)43! +!!SNflF4E!!!!!!!!-#)0`09PCajEZmd)EE2Y%FSlr$l2MMEB+lZY%4BPkcjbp&X +j[Gj0C8VSmeXCi8Q1KUGiLYpXPBE[[)frfNHjZBhY0h+FF,+08%k1NIf5if56fq3 +jiH3fiCdA1Gk6I@566IBa`XPcmQb6if366RJ6FT6`)i`F)icm2NBiZAhNf*BFleE +JUqYCY!(KRPbl0F26#0Y(Ml"0EV-M2(+-$"MCc`$)"Pj2)!#pcKk!!F$U#B!fr!p +%LN8)M[d5R`$mNE$GBB++(4aE"4#c,2AT)G8Bc2ET)r%ICb@3!##95JmN-pZkNFR +,*e$B4pQr@-52&C`6aRIAhAd!S,i&B0fA)BJ22R`L`ae4iQS81,D-Bim6YSpal1H +%[CRQf#'H-%&BlKD1ICjM(6ah!mG'14EQf)-m4jjMch*GIimI%Y6K9b-%U4+mZ)f +AaF8)JB5*!SK-iYFrFPC$3KD0!J!@&+4&,hh9+A&cR&I6Zp&*(e5)p1&phmXQ@9K +kD$T2("U1FlX8dC1C@K$rKE46@K9i"TB"Hf!e""lDJHmf3)J"9U8Aa5+M)1L$lLI +&Ndm#G'!MkLMb*k4Y1*3bmiTU9M9SJ$CSC!HNIHA[G`TPj4680DF8YAp36UH6FTq +HhkhCTa*Gc("c9cVGGk0`Gq*rPf8CBJ!HU96ICMp2$"Zj[#eRQAD"T$fE)jAZka% +%m-JNla%$k$S`1$"$m!U2SHiG3i(i5&CeR1H"[IN)4"2F,lLG`rScEf+E&F-`cEb +m961X8Xri`FrHi0rUTf6k*Kj5A+de`e4'6Uj2VPdl@adZMf"FAEY@#-!M%&IR"2N +RMj,X0h5eUN3Zmp!QV29l1YekIHkeE2&BTd4ibqq3!-5$cm+!YSIlKSBY[*EalF[ +iEdRVpmVX$kpbJq2@DrBrpGTFjM&A(V!-HD394e@-mm+kZPU+)`VJS9D9pA8PJd3 +m3X6M3LGDiL(&6rZNk3K3[Fk(bm1Ckp-KP+(,bI%qAATkUNr[52B[q*KQ5Y*6Fc+ +MTMVZmr#$r)IYf$A6X-M$b4SMITjBZRYH9H44'"F%m+!)aV&+VZZDTPTd(IHQpNq ++5a`h5RXfaeA(2FY$'1#iqcIhmJikTdFURI(e%(diph1UARAZ04kARIX#MdAR[U$ +VSR2hHF`lG`V2ZE0$[piJ!R$Z-hVmflR2#R[&ZIXm&Thl$)hhR(Z0KqrF3mM$0qq +ZVSkfkhpe,rj`h*[DGjr0FG9aRq0")3K`h"Np[r&1HD*pdlZ11r`[ai4%jMV$NQ1 +UmEMXG"Ed@(3k2SqP6Ml$ile1AZ-4L0HkAJ2b`-*IX1E"Z+&AfpAE%iRc&8)mc*' +a+SrqN6'I4cKeEJfM,'SUZI9k1jbZD,rM0D!D[",RH@#(-DTHmAh%`e!F4dkD18X +h6UPEUQMXpGURK3#kh[!-&5pGmq4,22c1kGGCTH-9UQAfpiMd+Tp9UMeQ'Cmq@Rr +DMP1Pf5R8QDK-SAE*jHQM%)"(dR!F`!k$r@1@4chfHLlXK6NjRaS+!I6JdciK!)r +5Y+r+BfRD9aFI3rA2mlK8(pjd4,FZe"RY0IJmlYq@PL'qCil(*6hiG%3)8'Gm1L) +%i%%4%J,d)BUJ%+!qN!$&"h#VF3+Ar3,X+$#@H+)GYrjNDF@[L%p!FAC6RYCbrU0 +$lfG(l`hLIrN0`,Fr!V'rh$!9JS)SBRL,R-IeHqURT&p*3aGrkKAmI`PV3&UCF*F +V"XFYmYQ*VCSbUYP13Ua5!cHGV!%FApL+V@ZP+K#Je!!$YMb45*QfeS1c"NIq@2b +Zq%CAr%IIJYMKem39#V1TmFR1rE#QFrm,@IDM&k1%(F5!-2j`k3rI(i'QcJCSkRL +,jXf)[hl`)*Z#f+(@&rDb+6Ee1I6[Vca#1me5&2H2)cQYJ!0kTk$NDPX"!T2!AP# +heFc0cY0%+Y&5Z38`[F$HL-i4Rf#K%"U$HN6iRjIR4E`(F((IIMik-0bY0VC[aqP +Yp@YmbZ#C[AlNH6,PAGJ929&6Q@'mpZ"k`hHfr8lXpcGLhmA!LU!bHCAI4EL3!%l +8%m2$k&(Xk`e'!""X!jf*`$k(JaR46Dh5I+qhkliZK&SJ)(RfiE5RU*J+G"!(X-, +e[&l3&82ISeeV%IrY%-2$"Fh1kAQPF)dqUYQ#0e@N8kp#"G@i1hjq+d5)%Mr"cXN +Lk+L`$R#Ih4KT3e1eqQ35FQbApXX%"-'1Hm@C#c"8dh6bCiN3ULef+IGbZ"@$0iD +1e`Eq9qiZ58f2rUCj$6jTCGm"bEU26f&ZYQaFmQQ&f`H("Ql&M&pkQe,`HEidJa- +(a*i"ZRq%0jA3Pcd'kr$c%i3er"9`cJemNpbD",,[Z()*m2!AS"rjY"'f0`2$L0e +2f)Hq$RK-Kr(9V,'[`F-PcSh2`9F3qb&K28IJ-458+lRQ-r!%`%f(#FXIJ@rK'LG +AH[-hi'N!H6PKfeq(lb0'fS,4#AMl55C0i*E[!GkCNRZjCQRi,4k#i[Q#B6L#'(m +AIKb1)8BhJQ"j2I`0i0Bl#@YIcL*iT)N[3!dFCLX43kh`r00qd[5fVa+fmD0X)m# +U)F*@E'-I"lLGl`HdpV)YH"'+kc(q6BE[lhL!&p4,0&PXipS(hZ!Bhc9S5Y[QQ+B +@C+a*4cIcd4+HdKdeaVIQbVYD%GUE6*UMfKBYheMCSH62[,40hLC`+@8*cbKfAXr +[FQ)PHYd6"9Ya3YfMHX'dJceQ[K!D8ZaG@L(DTDSD,SLPP8)@hr-d%6U4i"&[*Z` +HhF(P#bdhJK3E+rF6H"k2BFcG(#`*iF%P(8,*RK3QLr,9#LpMK%iIP9J50XfbFKH +TRL"F@ZAj[0a4pc`(UTEAM#MZaT5*ram+`&@1T0eD4aJCXC2F5KLCd-Ja*5Xl-Q( +N+6Qf(PRCi3PE#IAB#N!S2NBBRJcAChKfiXRK#mpZp5Kj4SiG16`Pa`JM+cP'RNQ +HNDGNaXJa`XK4mZZ6!C1-QH3C18S'M"`McmL8(@(N'$Rf"!'-2#-6#RaiMjU-(#A +(b,-M0-,dC%H3!%3*!eL"m8"TZ6BGa`B!K[-83'`Gjb[81-i*R'X3J4`S-+2@QRD +QE$ADpIEGGrK`pqG6K&mF[9U1j`$lpJ"k8!")[iB8N9DIJ2V$El*bAH*CTM[LShN +)JYrI[#0R-`$26T!!a&,X-8XT0Xjl11mc&689YB5l+FcB+R`phX(mbDr!hZ*'iXi +U5hKLrA3R4rY6ZY@kECXC3NI[$fIfN!![iLY`ANChAdc)!aL5m9#$aiKFDMQPa*j +'jUJ`,K`$Q2e)Yi!RX`C*Z",jM%e#Uq+8!S8ZDCEcBYDf'JH85"%m6A,3*3ijiZJ +I0%Vi%[+E`d,3E!-1NB`U1E)hR1B"4h+3!-IZ6b5cNj4-jQMKUPl+&,-8-PE'Eb* +Ue1m*lh%Fd8[9DmBr$)MZF`4INk8PcfcIV$I0%FEJ8RrP%Dr8[F8a`K"lRf0+*iU +&j5A2DTPrSSf21,$$*F3iP0KZ`[Q!)Eb)E[9jRUfihR+$&&#%DjKrpmh$6A4GY"Z +NB&V"(B4pejqIlV+9#LpVT-#%B!dlT,GamMccbC88L!VAX$&k'e['MZZ@!6&j$H- +lkVeiQ@3qj8S+a)9VH-AST8K@9,#&JfX)@lYr6PeR[P'XDU4JjiSE'RGdIcikarc +DCD0'LT*qC'"(D23[K*IGi%q9NZjm`F*pMaA`L@Zf1bbV5r6"GI2@p[CJ#Irl+M1 +d3jhi(`d0$e*&384045j`FQpUC@0dF`!!!!!!!!!!!!!!!!!!!!"P"!!!!!!!!!! +!!!!!!!!!!!"2IJ!!ANS!!!!@!$`"!e4&@&4"6%C"!3#Y0PP#VNXKlJ!!!Ai!!!1 +1!!!"%3!!!JdJ&PZ4!!!!!!!!f5m4!!JF$$S%84%iK@G%)qN4PST$+HQi2aGBTP( +X*bQqZ,JfN3*GNa)5r8QqU1!$D)V-p$LK@P,28%+R0JP1NbA[U811(EDCSPRXID$ +qTUd!B[C`@Zr5c9M,4D'"1*0RL45+L8K*L`bL2ScE5ja#'1j(R3efX$!QXR&FR,H +rM$DZ@G0K*CNCk4'I-pDLD&DrQY)TXBfNe1a(*HNcL)V-#'HCFA(Yqq1K6LmjRI1 +"HY&@kBbj041(H8T@"Q85$h8'8F(VjibNF,J[R!C3F,4b(RQMhk4b%,XYZ[2SHj5 +#@1HE"al2C'I[+2pJal,21c[1bFES(59[LG`DZUIJD%HK8"[!(`KfG63aCSV6"h1 +qA'+)"3"43R-SM"(R`AiB#S--L)!(CV(qS$q8#9bHB%iLBAc!k[BN#i8Q2`TM!$1 +!1aL8J@c)J5ah0XM`Klc!Mi(2(IEl##i#I6L#F@!d"),3lBd,q#%-`i``iN0KBNX +D&%6,XLX!`T!!3aiIF#-2iiriNJ%`Bq"aKd#kMh3`)S)@eJU&54QBe5S8j%d2C`A +pbD5X-XZP+c#4',Jp#U(3R-(h%K2a+-#AD'&LkBG*'cDAj3[KR0EklSJ2X!LQZp1 +$fD6-f1IfCJ-ZK0h)jaAbVD$3GR+M4#[S2b*$'@9Nq2Jkd3ITlrXmQ*36H%RTf+I +3cQ[@K9f)k-62$`@EYNQBqf6%P8-3m[%@8Fj#mS&J0clbaBd6j-[4CPRZ!!Q05*) +J0[6k!,((rBRpA,"N32ZGA@5EXRKd#ZYK%!M"+'$)[l"%0-j!p-0p`3`JAc03PQJ +19Ja80X)*eFIe`L#,mc#aUD0e&`)ZR0Z0'r)%BCJdQdk$jr5"p-!,XL!C(%)'I#% +%'j+PK9JBQjP$QVFa40PNppPXVUB5T@1h2j6l*BQ3!-rN$j*''1[f"0bCa#b+IlC +N&@PPD020f@U+i8a1'IK*mFQBF82SaR)q%*LeXR`Jk)[iL$M256cTKJR6b#JTfM( +U$&BMqI!&[)U)i0GRKK+Ic3(T#G0i'VMjcb[b1q4Vq6CN3Q%B%U)qZBH[q%+Cb@% +Za(r,PJd0$R0ST90TEA"XC94ME#kjF`!!!!!!!!!!!!!!!!!!!!$*f`!!!!!!!!! +!!!!!!!!!!!"D[!!!E4!!!!!@!0!"!%e08&*$9dP&!3#Y,$I#VNXL,J!!,)-!!") +q!!!)23!!"KPjLFSr!!!!!!!!(1d0`08PmlhXZ&&qP(Z%EJr2cd'd[&CZrQBRSI` +)Tpr+k@9b+U&bq[cS%GB46MQH'Tl6`p0c)&NYIM3Mr,cHb((##"pij2L4jdFiiB4 +ej$MKj2JCi8mi18liK($##51F2#-$IS346MMKj2L6Bi4eNZ1%NHG(#Ar#bI%RalS +9q#SlGMBJl1@D*PZ,X)iHBC(M*q&(q*%")ja`!3J(*[J$!Y$Vl!%B!-cT"bM$Vmd +CMi1pjaem![!&BEej"-8V16B,`'ed2p@XKI5JfK))HPj9*C!!`1Ic0hPEPpFJNke +l8H)'F'FFImlK%-CcmjCX"TKk&F#mZm'1$blFQq&L&h%0aMK@`,(l#9[$12B@BGr +l1ED$*k`J,23rMYh1X8UH1jGMR4c,ipK+RL2-X8eFeira4i)Fr-X(ZkN@MjQm,)k +(!b4-C%0N2IlpNM-G%V,)&`#`S#!YkZN[4r&%qRJer449p%1&5$q*rq[BHTBRV4V ++ii(FhGa1K'YITQ,%9l02f!jE'43!Zh%1f&DeiE[ji'#!9CQ)H*a4%(5qq8[ab#- +!PGL)+Z2m#@QEjr"&`NSJNYBJ&mSJRff@eL6r$aC+b6E)+I)TJFCQfHrhbJeDZ&H +0lNpd2-2dDVqri8cKhScIDPd2LJ&iq(`05l0jh!eDKl`mT%HL-C,fF!kI[k&@%-# +MeAZe'%$ATZDQBB+rmfLTD@ZaH6Uk!iBa(pMhDm(9a2f#f6RU(Z*0E+N5$%BLBEP +1$HT@crMQD`ka*arB52r%3r)%-Xh3ebTl,r21R6Y5(5B2ZbF`Gki3J)I0%aJ6j&F +HPZaRG0A64%lb82[eb`DUc(TpIRYhr0XULI$LMj!!a-T0d+31Q2@lM0HbB[6+q0k +Xemmri!E(V0IZIqUe+-PMV$bJ!(Ri&51J")m+DqUU+iBSJ%FJV@a@9c*)a-0"2%B +ld532bA2!*`f&cDVAd6"j''0pfS%b9"XKhUHYTr[lG*ZhFGc(&&'5fSb6kB`%qV) +mXN(q)fT%-kCKJSI4(Hc)jR(lDikTLMaLIB)!(K4f$eE*D9hp9)ZQiejFISfia(' +MY)GcR(,F)cb%!BklF@Qp2+k(cpqDe82diGb2U(V+Z@GiR(6Zic`QR2ZiVK212F[ +MQ(1h*SX#!HFqV-HIcRe%f0qGHjE(K(-IT['(Fmr`b$Th"r,)QRG69d2YqVIZa4q +1Hh&jlq%FTach%4i8JJ$(hDU&&bk3!2[,&rrNZ20qFda)C+`c6$UQ$)q66QGFM`Q +RNq8afFQ(HIc4b6-mE*j-emY&(PMiipEFlJPUkADeCb*aY%+)4k5M*mfMXD-Rbb2 +2Gf30)bQUceYhZKd19A5fiq@L'V`5Mr(!$K0-Hm@cL%G3-3cC'`RT@R#rZPC&Bkp +AEa%#k(V'-k5mG-D66r,)GXjXRD8kALaGCMq(Xekj98RhQ!)qIAaKpVXi94UC3Kf ++e"6UdBh*kD-3J)FhD"L!(3Ela`L2+GMVZE#MFh)q043#k-'RI8)!(YDd,meMFYU +AiqP"pBrb1&%ILHQ)TSr@'HdeC(QX@1kA`6-`aZ1%(R`k)J5S-ciG%3,`S(!)!IS +3K9d)8"r)iMcFDZc(1C10$3*M&4[+FHY2PXjjMrMBD1+%rkA*r)-Yjl,"kqci6Ei +"H1)LF(phaP3)#L+1N9MNh+hIBfq3!(k@KLEqf2[ihB)e)*98Q-X9cAdkqHb+1PA +T9+0'K9LP"UEYU`%FAd59U+CD95"!U3%'E'T&K5m59@YaeQ$)PhX@H4DDiYql#pb +IE4GA+-bfpDf[@[2QNj!!Yr'5USIJ%RbkCfpD`[FlSE!U&`SVGp'm'I&2!*jY![H +18XV*YYf'r[hpYE66,,P`rpJC8Q-iS$GL5LLc&5!`#H`&1A@4d-Jm6D35aDPE!%- +,l2RS(2%*&JUKETL##2mNmVb0p`#1lpXILdS-FkZ0V@NlX+hq0jmNH'L[(hRZ5lN +)Zk)TDU'[Y4d22CMHm1#fhplprRcXZaKB%93Q(r#l#+2T4$h4hSiH*AUk`3J!JXf +R-a(Bjh!`)lUT9CV[e9GIAie3-GLNK(dii#P5TJ)G""j(DGI#@Na6JYU!+QMS%1d +a04V5`NVX,rV8)BVaTSSNT'N)Ve(R20XmS#1MXC,,M1j,G6d`Cdq5eZ9'RHN!RDr +JF()R2X'46KZrI#-i#,EE+fjJRdV-aR9j#4G`5QJqkZ%e65Gr*JRCK6'@ck`B[$' +dZcE`QlUl*"8qZ,f)TPLPl"Q3!26Vq44QZKl&*Cp5Q0hFdM3$-pkeKj,p"EidJa- +(a*i'ZRp86&M11TL([eF5P[X$i*`Eq#Dj[Kl)[Z2+*4Db%aU46aPKEDp!1f)V#2[ +r(-"M1Sb[CPfl%qk`11Gq!IFJpM*K5ck(G5JS9h,e`l!"B0TRK&d8KmIaB!pAqUC +"H!T!RNTBlcTi%6(5&KC["E3h-QN#Phi+H'G+VLHXj`,i%!p"mAa,G`&f[![jZl) +Pm#eLG#-)DQk!(`&Q,#"-HCijm8J6Ai"DF38V33be`U0!Vj1Q-qmM,0c,&J,-DL& +XB4Hl!Q!fh`qSFV0PH"'+kk&maI$pa6IbJYT#Nm8bVVhY5ilaAB0#Ic65S`CL-YD +NS8A#,J[hD8E!cEIQNVYD6YUEp%Bke@9U1$qe3mQI*G)@*MD"VC3@hUT%`eUibh" +Ep'VkBe(&F04dDV&)e&iE#FFF,8Ud5ifjUJ-"&4I%r%UX'prc0%ikNC!!)&j%f0@ +DJFXADUJ$+HDRlLI`2!Q'ER0cd")L!9Xk1,be2NcQiUX9LBa11ReNX54XL'AU,Y) +8JR"TPHG,j(DCjcP3YE!DG1&Z6*,iI`!!$!$9fGPjRAdcQkaGEcCCZbjbr!RP4ij +jC'8HS8I@*"62UFF)Nh$#b6'#TrLNMkFF6c@1IeT+4M4bM("#bA&bR$$bM-`iH8D +H2cR@VFE*8c*N[B55%5I(bA&bI%3QR($*-A+X)mm)*dFjj8riN3N$[VkMcef2$`K +0MkhXP2!Ma`RVb)364($#m332I(JXB#r$blUZ%8)%H1mLT2%MH(m$24(HPI$qNAK +**r'3!2BQ8GDRdUUQ+XP3[b)P&F-NT!1qc$mHa[-PC#dqS@LDm02&P@rC8l'#ic` +rm%+$kUJK'60I`22,A,RjDSB98jmfC-8-YB8LHP*"%3-#%9kprIA[[%$X$"p29Fb +(mq(l6elPDe#JGrlL#6d0K26lDHYMH2YHZ#6i,2CYke`RqEjTVL'Z6U8e*B4@%(c +QM81j%8l#db1+Jd#IC@r56FM)pB+@rah`#$Jjlh9k"S3V&8rM`RLbNC!!BcHCRbY +[N9Tb"AS"ZNZB,@LR)AEQ,#M+PNBi,8qX6hQFelAfbH`L61'(HJRUH[[Nfqp!A3A +plk!1m,U1epAfr#F$8!IIr#$i1G5qE*3NSICQSd)Ge$A3[`ce+q356VHmXjJq0CD +X*466#XXE,R#feM(3iaV-%lEIqK,RfXCef-je1T'0KLDK2TU09YaFdD%a'kfm!A8 +$p+ZJ[N9`8fh*ka%!2@+5r)FNHhQpbGllE6I-XirAcEaZbE6-ASHk)hYUmL,8EEb +rPGHElIKc@'qajcpp#ZUGQG&Qj1lLhqrRp3&H(q4eNfdhAi@kPIFG[6[jR)lHS@c +8f`le$j!!)JMCPYFjb(6Z5DF(8QT*DX`KUcSlqMSqG(6q9pFGG[)fqM$[BdII[*q +G[C,hYD0chYppT,rL+kMGY-0dak6c42MaX$QKM6lB0iraHScJb[5k2R$f+[12Ni2 +#a[SFlE`qI$9d#he`k1VlEf"p"(4D@0(9dFYlGmjkF1M`G-T5Tj3`**bLAVYjI@m +15%KmM!G6%,+R-!HY!J-T5c('*,NmKj0$lZP4(C1XLBd49XDQ%h96,jF9b!bphLe +F-+hT8H`3$k1@jmemq0*eS-*@`!jX$6Th1Cf!GqH%#iRHN34fB%G3DRQh`XCUGDM +H9R!'TIU!#Y+'ea-DlMYKPP&Kme9e8fUeD599[3!PG+Y5+Ze8FqV-18Ncle-adc% +UGRa-)5mS9'450b3GK@#Re6#U(kM$bVKb2Vh'aRcS8Lq6@Uk3!'c0T*8(ZLkkZLi +52k2k0(9+YBV#dNcV8*G)J&2"3jSk@U+ZHUM1T4TUD[`4YAjj9XNS85(eF#TdJSa +DFrBKPQC[5U@GKZAY*HT'BD9J8R)h5K9TC&5HJ!YJc&N1&4*A%rGV!ZaDfLLBkTL +Zf0R%U*XLHLUT@UUHNR"Q3mp03,-QSf*R-k2kBqTj*4Q$Xp2D[$5"-LTfYR!2$F9 +2@fTakp'mbRFHG,Cb[mD8+GfB+3K,dbbPdXif4Ue+B&iVVXVFEYM1Cje1UH$c4lY +K"hGHI'$Sp-Kpjf(1CP6X020CHmmTUG+Q[1ZmRGajcdbVm[0*3hTa$8bc2R-$GRB +aDY#P*T6c[bf9R)GfXm4@6Vlfr,ZI#E-aFE!21f326iFE1GHHIkp'Q-@FKafiiUc +Z[%,8Jdfhj1km*4*D6MC!,B3f[%`i9,K4Y(#rpUPDD92Qh0$k$jA05URl(*FEKQl +mlI,ph1AZGIHHbqmUG)$2'TF009h-VcPU'pm0i"k)Ki9jFp5$I*I(DIBU#*ZMYM1 +rPQmfi0+)kpF)1I4cXLNFH1JpKe*Tjc#MeXCRc"+BAS-B&6Y(Q%*0A9d342%+hkA +Lk3!%bbNN,,L*EB%FCG4D`)$48qYR!,bB195iR4hMZSl*B,e5`SElRT-fVT%`6cD +Q*48p$P5mjM%UGMUkkGh-haG24q!2KR8d[9dbKE$6bDJ"86*P5HZ&8,q@4)(&G8A +UFHlbMBYh0PUAFGa3Pb%R'$@i5KA&b+mH#Ne#fSK&qV%$ed'f+6HZLGPSbl-XE@$ +(%jc,`%'V$qreiU"*Icr`"&qq$&im#LjH%2Xdq+h$H6bRX"$Mb[LG1qj(m*H)Taf +r`I[Dr`!0$3T8Bfa6D'9XE#kjBf`ZZA-!!!!!!!!!!!!!!!!!!!!!,ii!!!!!!!! +!!!!!!!!!!!!!ANS!!([@!!!!&J$5!AP069"53eG*43%!V5`h`Uj,)P%!!#b$!!! +4I!!!#(N!!!AGH6Kh+`!!!!!!!*ZQ$F$9C8kbbdhj8Ika%XmDdD)42*1I4pK*k$k +bkEGbHTQEZUQ%2Mpk@d,*dBfRKYr8kh`MUl@2*[rSmHc)EF)*MfcD*TcF*T`F*r[ +)*Vr*2X)*[ijY`XRY0l,*-m,**Xr*EE+2F-,**Mc#Rfa+f&CbP'bbb9C#b5DrMC( +Mh3Tme@@FFRTY&MfZDBDR%ED2(Q'Eh&E#)lI*J*&00J8J'jMJ$`K!Vl-(B!#`Ha5 +J#Vmf6cS0pU&Ii"1!0`JEGK'8VZIBE3$ZVP#d-ka&SmTcB3NN#!5#(IlZ)dh)iL9 +f&-kp!(JiM6rAF%iBcq`jq$c!MJF"pM`#GRb`kjd-GhL*Dc6&X4+1IB@`#FDa%i5 +G#A,X&%pB4eMX4Sipa,&kRY[*X3'1Z6M'eB!iajlQZVk'2a)8iCmEl&3*QEL9PmA +&F)#%L@b)61,I2h,Q3d)@EJ%!#`V5STAqLP4&(q(9p&idd!m9)[eNrZpPNm`P26# +I4`(R(,G,i9h)9)(i12XY1f@VJK*J[E["pN!2[UX""`1XbNbNdib#S)qB[a422!& +3MifS2XfIN!#f,NG!MkXK2Dq"%kV!cCkA*QErca9+j438P3A88(ZR(!ckjEC)I&K +,,LDkQ1''aQ#`EEY`2ihIaN3L+JEJ%3Ld(E,bq0SLrI+4@%*2TNMDT4b"B&Zc))" +(YrmH-B#Z(CdGb`6Ijp(9e00P8rV$)F1S!AEQLq$Yi(l"l"`YMr-QGNL04R8p,VG +Sd86QUE4hM%2X0pFHThrL)5QK3M--G-[q[IlUkTAU-(RBP9"eY4#!Kdd*V3Rb6aj +CfEGe6H5*A1DKM5EfMM@BpIVpNq(dQ`eBM`e3m5U512SdG'KMh$Fi$r0DaVF[8Ve ++Haq8f4pHjJE(V0I`IqZeE*E(@RP!#I))UNC)M9i3eY3eS4UL!"kK[,+@VQ53!)L +(JhLXGU)Y(T*beLI0KihUG6e-(XCDRhDJ$)e'M2ITl02&2YhMEpr`-@@8T,RJC!E +dd)M&``Vb(dNM@6!0Qcb-F,6IbZ-,0UfVLMa5)i)!(K4f"D[NUUj"UNA6F4qSrB5 +ia('MY%XjVMMZ&4l#!-IGIUK9hY!M%1bfp""p12IcUPjalJ8HPjhl"Sp0jlkKkkC +cYhLX1hH+M(0RThjG)`*`lXYkr0ZjV`Ml[R1hH'`kpf8D(cMh!Jr,Z6Z3!)GPhNe +G$@h`Ih8[rR$F"fU(Ph*FFGcRH9!)!KahGb5qlfjjY2E!HilEp5r(K%6@1X1@BbV +`Z1ad0[6BG$S@Mke1[XcMJdjHi'&6#Ph2L6b`m$HXZ9f*4[,YkZf*a)8+)4jkre# +H4h[rN!$&`a8i[iBa+fV!hh+e(FjAY0AaR+J'Vm4e(YKKSRQ[Z)0i4&A$N!$pHL` +4L5kUQkeSl2ADCi3!ZQjlKTbA,RMb,4j@jl6U,0Ia8[NbqhYi@YA2U[NH8m+RMlr +rhK5keC8Te,Z4Qd,GI(afqLJ%i1'2'JCJKm(qXF+M'(Xp&hCe6XkRKN)!2ILd6`M +!)c[Ybr2BQ[B9+81SrJ8HPqSM-af**&EVM2BD,"lh(`R+S)bYmELN"jq1#!(UM%p +(K!!m+"a#J$j%B4F#e!HbZ!kh'NGafFr'6J0MGFGUFHY2PUjjLIMB9'1BTYXlXrR +CkDjVfHPllILGI32`VC["pqGY8b%SL$4'CT&c6VmRIdVkC68dm5GrKGmAX!DNbMT +cZD*c*%%qZkj&8`HdT&%R9UQ"kaGU!-FA568CdE*9)%#T!3DX[+iZS#HeCT`e'2* +GbRjPRbRqPpm#hr6*[h(%GHfE6[cTQ8F'I`P[G&+cVi@$q'BZf"6qh,3([p-0`CP +bB$rkq)YXL[,1P-&"m1(E1r(YGBXjfG4i$AlarqK%`m0fiZB%&lJD(MHAJ2&G'CX +Dq4h(N!#6$&,Ip0F3V03V#1[F$`-bC5Nrf8Zj`Y*ViBDC+ZP$P"#Rb!rpmFfPUT' +mZ(rXL@NT(0!E+69@f!S3Q!6fJU)@2EBb6a1T4%AZ&X$m!VXER5-q`8)Ke!I&L2" +2*Xr2m"l!aAhlpDM(-,IDf%62f@herr#C"GrGkdHH#bRhBpme45d0G2IKa3I6'jl +EpRYR[pq0ea!`X#+S6&lQGa&@diPkSUm228VbDS-4!!5V)6H&I3i(-k+E@UAjAQ[ +MIBd)9B"0bYL(XjiLCbV33H"a&"&)KkM!QbU5N!#Q)Ib%1QFT1LUC(p'4$bS(qZr +D[C!!j(-4)f`k3-q2F6K*m`iFkI6`bcHLJl+GmiV(f1X5Xh&TRX8&R%UDMbUmTZR +XcaBKZc$'mTN9JcH'jQS$[lQl5e,T9lpEGLFqfFQH!LPa(jr#h*!!51+5cdki[E1 +ViaE-q)@h+GQ2mk8CR$JJpKfJqdF9K"8p#MKkJim4j[`,6ZF!q#CjBK,)[Z2+*Ek +EK(EN8d9B[`4pL0e2f2KMJ-Gd'&r0+Mm$Rmpb(Kq",b(f3m*FSr!S#XU9V(S9MJ& +F2dhBMPIJ'lM'bC@q[35q$5#A%rE*jq!(L*'f82a03(XMNbE`U4l!1e0b+f%IES9 +AF,,)mphiGF#1YiZrmdd$MZafdBdJD(N,rJT`bpf%pCBc$ajTiJY3i41X%M(8#YQ +r6TVHqKKK*I[B2S$EZJMErh2f895&l`FS%ABB,d*a25UICIMqMPjH8#r3l,5+Dfq +Ei4MI05J0*[8K,C55X5D0L"lhC[&!a!Mjq0EFl+k@KrBQrIU!GPL,Zh-lP2aC*Qe +TCK-iQc+,Gk[*H#3qD2Lbp*T'8dR9F$304&*kdYkXae11,M8jU+@mMD'3!)B,BN% +e&FEh2)f(6L4NL*F4GNr%`18,,GD2&0fjq`Nm6iDKcp`Fc!U4JE-k12c0!8cQjDX +9QB`H1Rf8C8RB2-[FAD4LJR"TPHI,j2DDjcP3YEJ@pH*Zc#car`-!!!`!9EljRBd +DQ0HYA@mf@CPN3MNPaimFI8*63SqX55LH8im4*Z'%Nf-%6r(*2$`06c@1IeVdb2% +MYc*bM("#bA&br#62b*b4!5I("a3I*dr*L"2@8c,KC-,*FI*m3LDFF-Qa#(rbR!` +STr`*2c*K`0GAPq(M6ikQalb8m#-$eT(MC-V*P"1q%Mc`K3AXCDZXkaSK4)"[#b& +eYI!p$6d4[R[Jqc-T*eh%3cSE4814pCQdUUP+-M5N5%R&-+20A`(MrXr$H&8*@3[ +&Ta40qqADqP[f+e[(FCiIH52UK#%Cmer!lpHjh2N#X3XFTbVQRlb'-FA8C`eC#A@ +%ZRXZK`EdT%,U8(R3Thk$KpprH)*2H&A`H66i[J$I&`8rp2c3mjV,$#*F*cr@,a! +IDB4Q[r!a[2!qGeh`@Zajqd)A[Uq0Uc0T63QK&B"pqi3VC5rmqN9a"1JCpL9pK)c +c'Ir6i#IJj,cAj4N@ETBpK3ZM"ra`jJlcmji230fEd![3AF+X36ZeX3XA39'f-X* +TH@TVbM#[IAC[GJ@Qm%1p#R@0hI[fZe"A32m(U!1mVZCeTEhdb6$8`6Fr$(i1Y6F +E*8QSbl04S4VU+ZMIJ2SRf'D%l-YY)Dj2d*+eQ#6hTp2$+G8+b`8Ai$l%Ak0pq2X +qQ+HCebG"ReY3ebqfCCDKhXIV*M[q,0CllD92Ri6ki1*%-r*Dq2Y$['kcNpp93(h ++IZY,e'NrelA"YT[IJ2S!erpX0KUDAYIh4$CDGQGGjb2CD(NRe(ACk*lE80I#1jc +V&A)GACAA[3Td6bMQYZ,hYl@MFekR[$jjAI*kI%fqK@QDmRS%Q!rrN!#NhI9KUqY +(aiHRXqHQVd%GqYHAKhPpM0H1(irb[U2h'6jRhSF4-P6f$G5jY-0daU6c4,JlE%j +T%cZqkq+e-iHcIlKa!X-T5c%Z5E)#1@KRHaIQS#mVBj)eY6[#4RTl-%F0E0#afC5 +PcLMKRA'12jS$NKdIBeH86RH1FMGhV+HTcZkHD$j0jAiGDdlTSeiY1@Yap,8qiDT +Tc8jJKhJBYH5MaBpH@JBUZ"ilX"@SRdTE'(EpJR!e-6LH`!jiK9*,Q38f8,Y$,@m +(Ce#U&kJJEAJVJH(q%M+-#TZXSSp5+ddVUHS&++%TJ&*TTj*6jkp)Q[Q3!)UCM9' +aif8+PB0#45Ce3p*4#$*3&D2kJ6UQ6#Tck8dfjVmFp3EaFB9NDckYl1LkNY0eKIJ +CeDZT-kT9&*CQ9SHk5J+F#Kl5e)PYkMd29HHSKTUDI%bY@CY9-VDTN!$@1"8k38D +YZ[J)5l-eTG*1lGVf%R@MX&)`mH8f5JAF6bL9*ld#'21L3iAN@-rp'P%ejH&'SDQ +-8QQRJ9-6B2,Y2B5CMVN"1if-fM#JTj+UTHST#C8bG(F#QM3C&6Y0M1U2UA0+-JD +ASXejDHjN91cXjFiEMCqhe1+ZT#Q9EdVSl1-ZMbNcZM&I%0Ce`hj'V8KJ1LXZ@(H +M(1#ccUC8f!k20dScT`jH89,EQr+qK`jb$cdpUmUANiEdr#DBCR@Q+hCD'$@BSbD +8ZGqALZZ'9NFK`p#0[a3ka"9b,S-2`1kXKrQXFGP3dmAXj9*$A&H)Da"Y#[1ke$D +qmq,$SqI((qim[$FaAE(6[V'9#f%8G[&UELZ[NL0Vf3ZSK9L*Ya#(#PH4Shr[FND +PZKlMQc*1me#"klUKJbP8ZJ0NSkh[#"QmUf+(('GT[R60X*IHqdc)a-54#(C)*k1 +@EKIfd[Y93JC[!0JK*jK#2[!3V+,89XM'HjVM)ELXRH3HZL6$FYM1Vh#YFlEb,A+ ++*`$6NSTE#+Kiff08l*cZSpFCIb5H(S$VraDDAX#B3YJj`kJ"86*P54Z%b,bCmi$ +&G89UQ2YepekFM9B[1QkSAL4R'69iMbU+!lpj+$30ISd0$''(rLF!GGfpa@@MEFm +`[f,(%eai(Dj,%EafLb-Q2GjlJLr$9ENb!#i1L4(0A'0lcQ%KaTA*ZhGcMq!r&Tj +1I)0AZIm"!!!K)3jdBfa0B@03FQpUC@0dF`!!!!!!!!!!!!!!!!!!!!!!!!!!!!( +B!+)#Q!)%!!!!!3!!E4!!!!!!!!!!&J!!!)B!!!%Jrrrrr`%!V6C3$+j,)Id!!!! +!!!)a`3!!!!!!!(Y3!'S!1!!!!!!!!*ScHk!!!!: diff --git a/tcl7.6/mac/tclMacResource.c b/tcl7.6/mac/tclMacResource.c new file mode 100644 index 0000000..07fd34b --- /dev/null +++ b/tcl7.6/mac/tclMacResource.c @@ -0,0 +1,875 @@ +/* + * tclMacResource.c -- + * + * This file contains several commands that manipulate or use + * Macintosh resources. Included are extensions to the "source" + * command, the mac specific "beep" and "resource" commands, and + * administration for open resource file references. + * + * Copyright (c) 1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclMacResource.c 1.6 96/10/08 14:33:54 + */ + +#include +#include +#include +#include + +#include "tcl.h" +#include "tclInt.h" +#include "tclMacInt.h" + +/* + * Hash table to track open resource files. + */ +static Tcl_HashTable nameTable; /* Id to process number mapping. */ +static Tcl_HashTable resourceTable; /* Process number to id mapping. */ +static int newId = 0; /* Id source. */ +static int initialized = 0; /* 0 means static structures haven't + * been initialized yet. */ +/* + * Procedures defined for just this file. + */ +static void ResourceInit _ANSI_ARGS_((void)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_ResourceCmd -- + * + * This procedure is invoked to process the "resource" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ResourceCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + char **argv) /* Argument strings. */ +{ + int c, result; + size_t length; + long fileRef; + FSSpec fileSpec; + Tcl_DString buffer; + char *nativeName; + Tcl_HashEntry *resourceHashPtr; + Tcl_HashEntry *nameHashPtr; + Handle resource; + OSErr err; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + c = argv[1][0]; + length = strlen(argv[1]); + result = TCL_OK; + + if (!initialized) { + ResourceInit(); + } + + if ((c == 'c') && (strncmp(argv[1], "close", length) == 0)) { + nameHashPtr = Tcl_FindHashEntry(&nameTable, argv[2]); + if (nameHashPtr == NULL) { + Tcl_AppendResult(interp, "invalid resource file reference \"", + argv[2], "\"", (char *) NULL); + return TCL_ERROR; + } + fileRef = (long) Tcl_GetHashValue(nameHashPtr); + if (fileRef == 0) { + Tcl_AppendResult(interp, "can't close system resource", + (char *) NULL); + return TCL_ERROR; + } + Tcl_DeleteHashEntry(nameHashPtr); + resourceHashPtr = Tcl_FindHashEntry(&resourceTable, (char *) fileRef); + if (resourceHashPtr == NULL) { + panic("how did this happen"); + } + ckfree(Tcl_GetHashValue(resourceHashPtr)); + Tcl_DeleteHashEntry(resourceHashPtr); + + CloseResFile((short) fileRef); + return TCL_OK; + } else if ((c == 'g') && (strncmp(argv[1], "getSTR", length) == 0)) { + int rsrcId; + unsigned char size; + char *resourceName = NULL, *stringPtr, *resFileRef = NULL; + + if (!((argc == 3) || (argc == 4))) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ", argv[1], " resourceId ?resourceRef?\"", + (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[2], &rsrcId) != TCL_OK) { + Tcl_ResetResult(interp); + resourceName = argv[2]; + } + + if (argc == 4) { + resFileRef = argv[3]; + } + + resource = TclMacFindResource(interp, "STR ", resourceName, + rsrcId, resFileRef); + + if (resource != NULL) { + size = (*resource)[0]; + stringPtr = (char *) ckalloc(size + 1); + strncpy(stringPtr, (*resource) + 1, size); + stringPtr[size] = '\0'; + Tcl_SetResult(interp, stringPtr, TCL_DYNAMIC); + ReleaseResource(resource); + return TCL_OK; + } else { + Tcl_AppendResult(interp, "could not load 'STR ' resource: \"", + argv[2], "\"", (char *) NULL); + return TCL_ERROR; + } + } else if ((c == 'g') && (strncmp(argv[1], "getSTR#", length) == 0)) { + int rsrcId, index, total, i; + char *resourceName = NULL, *stringPtr, *resFileRef = NULL; + char * ptr; + + if (!((argc == 4) || (argc == 5))) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ", argv[1], " resourceId index ?resourceRef?\"", + (char *) NULL); + } + if (Tcl_GetInt(interp, argv[2], &rsrcId) != TCL_OK) { + Tcl_ResetResult(interp); + resourceName = argv[2]; + } + if ((Tcl_GetInt(interp, argv[3], &index) != TCL_OK) || (index <= 0)) { + Tcl_AppendResult(interp, "invalid STR# index \"", + argv[3], "\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 5) { + resFileRef = argv[4]; + } + + resource = TclMacFindResource(interp, "STR#", resourceName, rsrcId, + resFileRef); + + if (resource != NULL) { + total = * (short *) resource; + if (index > total) { + Tcl_ResetResult(interp); + return TCL_OK; + } + HLock(resource); + ptr = *resource + 2; + for (i = 1; i != index; i++) { + ptr += *ptr + 1; + } + stringPtr = (char *) ckalloc(*ptr + 1); + strncpy(stringPtr, ptr + 1, *ptr); + stringPtr[*ptr] = '\0'; + Tcl_SetResult(interp, stringPtr, TCL_DYNAMIC); + HUnlock(resource); + ReleaseResource(resource); + return TCL_OK; + } else { + Tcl_AppendResult(interp, "could not load 'STR#' resource: \"", + argv[2], "\"", (char *) NULL); + return TCL_ERROR; + } + } else if ((c == 'g') && (strncmp(argv[1], "getTEXT", length) == 0)) { + int rsrcId; + char *resourceName = NULL, *stringPtr, *resFileRef = NULL; + + if (!((argc == 3) || (argc == 4))) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ", argv[1], " resourceId ?resourceRef?\"", + (char *) NULL); + } + if (Tcl_GetInt(interp, argv[2], &rsrcId) != TCL_OK) { + Tcl_ResetResult(interp); + resourceName = argv[2]; + } + + if (argc == 4) { + resFileRef = argv[3]; + } + + resource = TclMacFindResource(interp, "TEXT", resourceName, rsrcId, + resFileRef); + + if (resource != NULL) { + stringPtr = TclMacConvertTextResource(resource); + Tcl_SetResult(interp, stringPtr, TCL_DYNAMIC); + ReleaseResource(resource); + return TCL_OK; + } else { + Tcl_AppendResult(interp, "could not load 'TEXT' resource: \"", + argv[2], "\"", (char *) NULL); + return TCL_ERROR; + } + } else if ((c == 'l') && (strncmp(argv[1], "list", length) == 0)) { + int count, i, limitSearch = false; + short id, saveRef; + Str255 theName; + ResType rezType; + + if (!((argc == 3) || (argc == 4))) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ", argv[1], " resourceType ?resourceRef?\"", + (char *) NULL); + } + if (strlen(argv[2]) != 4) { + Tcl_AppendResult(interp, "not a valid resourceType: \"", + argv[2], "\"", (char *) NULL); + } + rezType = *((long *) argv[2]); + + if (argc == 4) { + nameHashPtr = Tcl_FindHashEntry(&nameTable, argv[3]); + if (nameHashPtr == NULL) { + Tcl_AppendResult(interp, "invalid resource file reference \"", + argv[3], "\"", (char *) NULL); + return TCL_ERROR; + } + fileRef = (long) Tcl_GetHashValue(nameHashPtr); + saveRef = CurResFile(); + UseResFile((short) fileRef); + limitSearch = true; + } + + Tcl_ResetResult(interp); + if (limitSearch) { + count = Count1Resources(rezType); + } else { + count = CountResources(rezType); + } + SetResLoad(false); + for (i = 1; i <= count; i++) { + if (limitSearch) { + resource = Get1IndResource(rezType, i); + } else { + resource = GetIndResource(rezType, i); + } + if (resource != NULL) { + GetResInfo(resource, &id, &rezType, theName); + if (theName[0] != 0) { + theName[theName[0]+1] = '\0'; + Tcl_AppendElement(interp, (char *) theName + 1); + } else { + sprintf((char *) theName, "%d", id); + Tcl_AppendElement(interp, (char *) theName); + } + ReleaseResource(resource); + } + } + SetResLoad(true); + + if (limitSearch) { + UseResFile(saveRef); + } + + return TCL_OK; + } else if ((c == 'o') && (strncmp(argv[1], "open", length) == 0)) { + int new; + char *resourceId; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"resource open fileName\"", NULL); + return TCL_ERROR; + } + nativeName = Tcl_TranslateFileName(interp, argv[2], &buffer); + if (nativeName == NULL) { + return TCL_ERROR; + } + err = FSpLocationFromPath(strlen(nativeName), nativeName, &fileSpec) ; + Tcl_DStringFree(&buffer); + if ( err != noErr ) { + Tcl_AppendResult(interp, "path doesn't lead to a file", NULL); + return TCL_ERROR; + } + + fileRef = (long) FSpOpenResFileCompat(&fileSpec, fsRdPerm); + if (fileRef == -1) { + return TCL_ERROR; + } + + resourceHashPtr = Tcl_CreateHashEntry(&resourceTable, + (char *) fileRef, &new); + if (!new) { + resourceId = (char *) Tcl_GetHashValue(resourceHashPtr); + Tcl_AppendResult(interp, resourceId, NULL); + return TCL_OK; + } + + resourceId = (char *) ckalloc(15); + sprintf(resourceId, "resource%d", newId); + Tcl_SetHashValue(resourceHashPtr, resourceId); + newId++; + + nameHashPtr = Tcl_CreateHashEntry(&nameTable, resourceId, &new); + if (!new) { + panic("resource id has repeated itself"); + } + Tcl_SetHashValue(nameHashPtr, fileRef); + + Tcl_AppendResult(interp, resourceId, NULL); + return TCL_OK; + } else if ((c == 't') && (strncmp(argv[1], "types", length) == 0)) { + int count, i, limitSearch = false; + short saveRef; + Str255 theName; + ResType rezType; + + if (!((argc == 2) || (argc == 3))) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ", argv[1], " ?resourceRef?\"", (char *) NULL); + } + + if (argc == 3) { + nameHashPtr = Tcl_FindHashEntry(&nameTable, argv[2]); + if (nameHashPtr == NULL) { + Tcl_AppendResult(interp, "invalid resource file reference \"", + argv[2], "\"", (char *) NULL); + return TCL_ERROR; + } + fileRef = (long) Tcl_GetHashValue(nameHashPtr); + saveRef = CurResFile(); + UseResFile((short) fileRef); + limitSearch = true; + } + + Tcl_ResetResult(interp); + if (limitSearch) { + count = Count1Types(); + } else { + count = CountTypes(); + } + for (i = 1; i <= count; i++) { + if (limitSearch) { + Get1IndType(&rezType, i); + } else { + GetIndType(&rezType, i); + } + sprintf((char *) theName, "%-4.4s", &rezType); + Tcl_AppendElement(interp, (char *) theName); + } + + if (limitSearch) { + UseResFile(saveRef); + } + + return TCL_OK; + } else { + Tcl_AppendResult(interp, "unknown option \"", argv[1], + "\": should be close, getSTR, getSTR#, getTEXT, ", + "list, open or types", (char *) NULL); + return TCL_ERROR; + } + + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_MacSourceCmd -- + * + * This procedure is invoked to process the "source" Tcl command. + * See the user documentation for details on what it does. In addition, + * it supports sourceing from the resource fork of type 'TEXT'. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_MacSourceCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + char **argv) /* Argument strings. */ +{ + char *errNum = "wrong # args: "; + char *errBad = "bad argument: "; + char *errStr; + char *fileName = NULL, *rsrcName = NULL; + int rsrcID = -1; + + if (argc < 2 || argc > 4) { + errStr = errNum; + goto sourceFmtErr; + } + + if (argc == 2) { + return Tcl_EvalFile(interp, argv[1]); + } + + /* + * The following code supports a few older forms of this command + * for backward compatability. + */ + if (!strcmp(argv[1], "-rsrc") || !strcmp(argv[1], "-rsrcname")) { + rsrcName = argv[2]; + } else if (!strcmp(argv[1], "-rsrcid")) { + if (Tcl_GetInt(interp, argv[2], &rsrcID) != TCL_OK) { + return TCL_ERROR; + } + } else { + errStr = errBad; + goto sourceFmtErr; + } + + if (argc == 4) { + fileName = argv[3]; + } + + return TclMacEvalResource(interp, rsrcName, rsrcID, fileName); + + sourceFmtErr: + Tcl_AppendResult(interp, errStr, "should be \"", argv[0], + " fileName\" or \"", argv[0], " -rsrc name ?fileName?\" or \"", + argv[0], " -rsrcid id ?fileName?\"", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_MacBeepCmd -- + * + * This procedure makes the beep sound. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Makes a beep. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_MacBeepCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + char **argv) /* Argument strings. */ +{ + Handle sound; + Str255 sndName; + int volume = -1; + char * sndArg = NULL; + long curVolume; + + if (argc == 1) { + SysBeep(1); + return TCL_OK; + } else if (argc == 2) { + if (!strcmp(argv[1], "-list")) { + int count, i; + short id; + Str255 theName; + ResType rezType; + + Tcl_ResetResult(interp); + count = CountResources('snd '); + for (i = 1; i <= count; i++) { + sound = GetIndResource('snd ', i); + if (sound != NULL) { + GetResInfo(sound, &id, &rezType, theName); + if (theName[0] == 0) { + continue; + } + theName[theName[0]+1] = '\0'; + Tcl_AppendElement(interp, (char *) theName + 1); + } + } + return TCL_OK; + } else { + sndArg = argv[1]; + } + } else if (argc == 3) { + if (!strcmp(argv[1], "-volume")) { + volume = atoi(argv[2]); + } else { + goto beepUsage; + } + } else if (argc == 4) { + if (!strcmp(argv[1], "-volume")) { + volume = atoi(argv[2]); + sndArg = argv[3]; + } else { + goto beepUsage; + } + } else { + goto beepUsage; + } + + /* + * Set Volume + */ + if (volume >= 0) { + GetSysBeepVolume(&curVolume); + SetSysBeepVolume((short) volume); + } + + /* + * Play the sound + */ + if (sndArg == NULL) { + SysBeep(1); + } else { + strcpy((char *) sndName + 1, sndArg); + sndName[0] = strlen(sndArg); + sound = GetNamedResource('snd ', sndName); + if (sound != NULL) { +#if (THINK_C == 7) + SndPlay(NULL, sound, false); +#else + SndPlay(NULL, (SndListHandle) sound, false); +#endif + return TCL_OK; + } else { + if (volume >= 0) { + SetSysBeepVolume(curVolume); + } + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, " \"", sndArg, + "\" is not a valid sound. (Try ", argv[0], + " -list)", NULL); + return TCL_ERROR; + } + } + + /* + * Reset Volume + */ + if (volume >= 0) { + SetSysBeepVolume(curVolume); + } + return TCL_OK; + + beepUsage: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " [-volume num] [-list | sndName]?\"", (char *) NULL); + return TCL_ERROR; +} + +/* + *----------------------------------------------------------------------------- + * + * TclMacEvalResource -- + * + * Used to extend the source command. Sources Tcl code from a Text + * resource. Currently only sources the resouce by name file ID may be + * supported at a later date. + * + * Side Effects: + * Depends on the Tcl code in the resource. + * + * Results: + * Returns a Tcl result. + * + *----------------------------------------------------------------------------- + */ + +int +TclMacEvalResource( + Tcl_Interp *interp, /* Interpreter in which to process file. */ + char *resourceName, /* Name of TEXT resource to source, + NULL if number should be used. */ + int resourceNumber, /* Resource id of source. */ + char *fileName) /* Name of file to process. + NULL if application resource. */ +{ + Handle sourceText; + Str255 rezName; + char msg[200]; + int result; + short saveRef, fileRef = -1; + char idStr[64]; + FSSpec fileSpec; + Tcl_DString buffer; + char *nativeName; + + saveRef = CurResFile(); + + if (fileName != NULL) { + OSErr err; + + nativeName = Tcl_TranslateFileName(interp, fileName, &buffer); + if (nativeName == NULL) { + return TCL_ERROR; + } + err = FSpLocationFromPath(strlen(nativeName), nativeName, &fileSpec); + Tcl_DStringFree(&buffer); + if (err != noErr) { + Tcl_AppendResult(interp, "Error finding the file: \"", + fileName, "\".", NULL); + return TCL_ERROR; + } + + fileRef = FSpOpenResFileCompat(&fileSpec, fsRdPerm); + if (fileRef == -1) { + Tcl_AppendResult(interp, "Error reading the file: \"", + fileName, "\".", NULL); + return TCL_ERROR; + } + + UseResFile(fileRef); + } else { + /* + * The default behavior will search through all open resource files. + * This may not be the behavior you desire. If you want the behavior + * of this call to *only* search the application resource fork, you + * must call UseResFile at this point to set it to the application + * file. This means you must have already obtained the application's + * fileRef when the application started up. + */ + } + + /* + * Load the resource by name or ID + */ + if (resourceName != NULL) { + strcpy((char *) rezName + 1, resourceName); + rezName[0] = strlen(resourceName); + sourceText = GetNamedResource('TEXT', rezName); + } else { + sourceText = GetResource('TEXT', (short) resourceNumber); + } + + if (sourceText == NULL) { + result = TCL_ERROR; + } else { + char *sourceStr = NULL; + + sourceStr = TclMacConvertTextResource(sourceText); + ReleaseResource(sourceText); + + /* + * We now evaluate the Tcl source + */ + result = Tcl_Eval(interp, sourceStr); + ckfree(sourceStr); + if (result == TCL_RETURN) { + result = TCL_OK; + } else if (result == TCL_ERROR) { + sprintf(msg, "\n (rsrc \"%.150s\" line %d)", resourceName, + interp->errorLine); + Tcl_AddErrorInfo(interp, msg); + } + + goto rezEvalCleanUp; + } + + rezEvalError: + sprintf(idStr, "ID=%d", resourceNumber); + Tcl_AppendResult(interp, "The resource \"", + (resourceName != NULL ? resourceName : idStr), + "\" could not be loaded from ", + (fileName != NULL ? fileName : "application"), + ".", NULL); + + rezEvalCleanUp: + if (fileRef != -1) { + CloseResFile(fileRef); + } + + UseResFile(saveRef); + + return result; +} + +/* + *----------------------------------------------------------------------------- + * + * TclMacConvertTextResource -- + * + * Converts a TEXT resource into a Tcl suitable string. + * + * Side Effects: + * Mallocs the returned memory, converts '\r' to '\n', and appends a NULL. + * + * Results: + * A new malloced string. + * + *----------------------------------------------------------------------------- + */ + +char * +TclMacConvertTextResource( + Handle resource) /* Handle to TEXT resource. */ +{ + int i, size; + char *resultStr; + + size = SizeResource(resource); + + resultStr = ckalloc(size + 1); + + for (i=0; i +#include + +/* + * The folowing include and defines help construct + * the version string for Tcl. + */ + +#define RESOURCE_INCLUDED +#include "tcl.h" + +#if (TCL_RELEASE_LEVEL == 0) +# define RELEASE_LEVEL alpha +#elif (TCL_RELEASE_LEVEL == 1) +# define RELEASE_LEVEL beta +#elif (TCL_RELEASE_LEVEL == 2) +# define RELEASE_LEVEL final +#endif + +#if (TCL_RELEASE_LEVEL == 2) +# define MINOR_VERSION (TCL_MINOR_VERSION * 16) + TCL_RELEASE_SERIAL +#else +# define MINOR_VERSION TCL_MINOR_VERSION * 16 +#endif + +resource 'vers' (1) { + TCL_MAJOR_VERSION, MINOR_VERSION, + RELEASE_LEVEL, 0x00, verUS, + TCL_PATCH_LEVEL, + TCL_PATCH_LEVEL ", by Ray Johnson © Sun Microsystems" +}; + +resource 'vers' (2) { + TCL_MAJOR_VERSION, MINOR_VERSION, + RELEASE_LEVEL, 0x00, verUS, + TCL_PATCH_LEVEL, + "Simple Tcl Shell " TCL_PATCH_LEVEL " © 1996" +}; + + +/* + * The mechanisim below loads Tcl source into the resource fork of the + * application. The example below creates a TEXT resource named + * "Init" from the file "init.tcl". This allows applications to use + * Tcl to define the behavior of the application without having to + * require some predetermined file structure - all needed Tcl "files" + * are located within the application. To source a file for the + * resource fork the source command has been modified to support + * sourcing from resources. In the below case "source -rsrc {Init}" + * will load the TEXT resource named "Init". + */ +read 'TEXT' (0, "Init", purgeable, preload) "::library:init.tcl"; + +/* + * The following resource is used when creating the 'env' variable in + * the Macintosh environment. The creation mechanisim looks for the + * 'STR#' resource named "Tcl Environment Variables" rather than a + * specific resource number. (In other words, feel free to change the + * resource id if it conflicts with your application.) Each string in + * the resource must be of the form "KEYWORD=SOME STRING". See Tcl + * documentation for futher information about the env variable. + * + * A good example of something you may want to set is: "TCL_LIBRARY=My + * disk:etc." + */ + +resource 'STR#' (128, "Tcl Environment Variables") { + { "SCHEDULE_NAME=Agent Controller Schedule", + "SCHEDULE_PATH=Lozoya:System Folder:Tcl Lib:Tcl-Scheduler" + }; +}; + diff --git a/tcl7.6/mac/tclMacSock.c b/tcl7.6/mac/tclMacSock.c new file mode 100644 index 0000000..0db45b8 --- /dev/null +++ b/tcl7.6/mac/tclMacSock.c @@ -0,0 +1,2168 @@ +/* + * tclMacSock.c + * + * Channel drivers for Macintosh sockets. + * + * Copyright (c) 1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclMacSock.c 1.31 96/08/27 19:45:09 + */ + +#include "tclInt.h" +#include "tclPort.h" +#include "tclMacInt.h" +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +/* + * This is the size of the channel name for File based channels + */ + +#define CHANNEL_NAME_SIZE 64 +static char channelName[CHANNEL_NAME_SIZE+1]; + +/* + * The preferred buffer size for Macintosh channels. + */ + +#define CHANNEL_BUF_SIZE 8192 + +/* + * Port information structure. Used to match service names + * to a Tcp/Ip port number. + */ +typedef struct { + char *name; /* Name of service. */ + int port; /* Port number. */ +} PortInfo; + +/* + * This structure describes per-instance state of a tcp based channel. + */ + +typedef struct TcpState { + TCPiopb pb; /* Parameter block used by this stream. + This must be in the first position. */ + ProcessSerialNumber psn; /* PSN used to wake up process. */ + StreamPtr tcpStream; /* Macintosh tcp stream pointer. */ + int port; /* The port we are connected to. */ + int flags; /* Bit field comprised of the flags + * described below. */ + int checkMask; /* OR'ed combination of TCL_READABLE and + * TCL_WRITABLE as set by an asynchronous + * event handler. */ + int watchMask; /* OR'ed combination of TCL_READABLE and + * TCL_WRITABLE as set by Tcl_WatchFile. */ + Tcl_File sock; /* The file handle for the socket. */ + Tcl_TcpAcceptProc *acceptProc; /* Proc to call on accept. */ + ClientData acceptProcData; /* The data for the accept proc. */ + rdsEntry rdsarray[5+1]; /* Array used when cleaning out recieve + * buffers on a closing socket. */ + struct TcpState *nextPtr; /* The next socket on the global socket + * list. */ +} TcpState; + +/* + * This structure is used by domain name resolver callback. + */ + +typedef struct DNRState { + struct hostInfo hostInfo; /* Data structure used by DNR functions. */ + int done; /* Flag to determine when we are done. */ + ProcessSerialNumber psn; /* Process to wake up when we are done. */ +} DNRState; + +/* + * The following macros may be used to set the flags field of + * a TcpState structure. + */ + +#define TCP_ASYNC_SOCKET (1<<0) /* The socket is in async mode. */ +#define TCP_ASYNC_CONNECT (1<<1) /* The socket is trying to connect. */ +#define TCP_CONNECTED (1<<2) /* The socket is connected. */ +#define TCP_WATCH (1<<3) /* TclMacWatchSocket has been called + * since thelast time we entered + * Tcl_WaitForEvent. */ +#define TCP_LISTENING (1<<4) /* This socket is listening for + * a connection. */ +#define TCP_LISTEN_CONNECT (1<<5) /* Someone has connect to the + * listening port. */ +#define TCP_REMOTE_CLOSED (1<<6) /* The remote side has closed + * the connection. */ +#define TCP_RELEASE (1<<7) /* The socket may now be released. */ + +/* + * Static routines for this file: + */ + +static pascal void CleanUpExitProc _ANSI_ARGS_((void)); +static void CloseCompletionRoutine _ANSI_ARGS_((TCPiopb *pb)); +static TcpState * CreateSocket _ANSI_ARGS_((Tcl_Interp *interp, + int port, char *host, char *myAddr, int myPort, + int server, int async)); +static pascal void DNRCompletionRoutine _ANSI_ARGS_(( + struct hostInfo *hostinfoPtr, + DNRState *dnrStatePtr)); +static long GetBufferSize _ANSI_ARGS_((void)); +static OSErr GetHostFromString _ANSI_ARGS_((char *name, + ip_addr *address)); +static OSErr GetLocalAddress _ANSI_ARGS_((unsigned long *addr)); +static void IOCompletionRoutine _ANSI_ARGS_((TCPiopb *pb)); +static void InitMacTCPParamBlock _ANSI_ARGS_((TCPiopb *pBlock, + int csCode)); +static int InitSockets _ANSI_ARGS_((void)); +static TcpState * NewSocketInfo _ANSI_ARGS_((Tcl_File file)); +static OSErr ResolveAddress _ANSI_ARGS_((ip_addr tcpAddress, + Tcl_DString *dsPtr)); +static void SocketFreeProc _ANSI_ARGS_((ClientData clientData)); +static void TcpAccept _ANSI_ARGS_((ClientData data, int mask)); +static int TcpBlockMode _ANSI_ARGS_((ClientData instanceData, int mode)); +static int TcpClose _ANSI_ARGS_((ClientData instanceData, + Tcl_Interp *interp)); +static Tcl_File TcpGetFile _ANSI_ARGS_((ClientData instanceData, + int direction)); +static int TcpGetOptionProc _ANSI_ARGS_((ClientData instanceData, + char *optionName, Tcl_DString *dsPtr)); +static int TcpInput _ANSI_ARGS_((ClientData instanceData, + char *buf, int toRead, int *errorCode)); +static int TcpOutput _ANSI_ARGS_((ClientData instanceData, + char *buf, int toWrite, int *errorCode)); +static int TcpReady _ANSI_ARGS_((ClientData instanceData, + int mask)); +static void TcpWatch _ANSI_ARGS_((ClientData instanceData, + int mask)); + +/* + * This structure describes the channel type structure for TCP socket + * based IO: + */ + +static Tcl_ChannelType tcpChannelType = { + "tcp", /* Type name. */ + TcpBlockMode, /* Set blocking or + * non-blocking mode.*/ + TcpClose, /* Close proc. */ + TcpInput, /* Input proc. */ + TcpOutput, /* Output proc. */ + NULL, /* Seek proc. */ + NULL, /* Set option proc. */ + TcpGetOptionProc, /* Get option proc. */ + TcpWatch, /* Initialize notifier. */ + TcpReady, /* Are there events? */ + TcpGetFile /* Get Tcl_Files out of channel. */ +}; + +/* + * Universal Procedure Pointers (UPP) for various callback + * routines used by MacTcp code. + */ +ResultUPP resultUPP = NULL; +TCPIOCompletionUPP completeUPP = NULL; +TCPIOCompletionUPP closeUPP = NULL; + +/* + * Built-in commands, and the procedures associated with them: + */ + +static PortInfo portServices[] = { + {"echo", 7}, + {"discard", 9}, + {"systat", 11}, + {"daytime", 13}, + {"netstat", 15}, + {"chargen", 19}, + {"ftp-data", 20}, + {"ftp", 21}, + {"telnet", 23}, + {"telneto", 24}, + {"smtp", 25}, + {"time", 37}, + {"whois", 43}, + {"domain", 53}, + {"gopher", 70}, + {"finger", 79}, + {"hostnames", 101}, + {"sunrpc", 111}, + {"nntp", 119}, + {"exec", 512}, + {"login", 513}, + {"shell", 514}, + {"printer", 515}, + {"courier", 530}, + {"uucp", 540}, + {NULL, 0}, +}; + +/* + * Every open socket has an entry on the following list. + */ + +static TcpState *socketList = NULL; + +/* + * Globals for holding information about OS support for sockets. + */ +static int socketsTestInited = false; +static int hasSockets = false; +static int socketsInitalized = false; +static short driverRefNum = 0; +static int socketNumber = 0; +static int socketBufferSize = CHANNEL_BUF_SIZE; +static ProcessSerialNumber applicationPSN; + +/* + *---------------------------------------------------------------------- + * + * InitMacTCPParamBlock-- + * + * Initialize a MacTCP parameter block. + * + * Results: + * None. + * + * Side effects: + * Initializes the parameter block. + * + *---------------------------------------------------------------------- + */ + +static void +InitMacTCPParamBlock( + TCPiopb *pBlock, /* Tcp parmeter block. */ + int csCode) /* Tcp operation code. */ +{ + memset(pBlock, 0, sizeof(TCPiopb)); + pBlock->ioResult = 1; + pBlock->ioCRefNum = driverRefNum; + pBlock->csCode = (short) csCode; +} + +/* + *---------------------------------------------------------------------- + * + * TcpBlockMode -- + * + * Set blocking or non-blocking mode on channel. + * + * Results: + * 0 if successful, errno when failed. + * + * Side effects: + * Sets the device into blocking or non-blocking mode. + * + *---------------------------------------------------------------------- + */ + +static int +TcpBlockMode( + ClientData instanceData, /* Channel state. */ + int mode) /* The mode to set. */ +{ + TcpState *statePtr = (TcpState *) instanceData; + + if (mode == TCL_MODE_BLOCKING) { + statePtr->flags |= TCP_ASYNC_SOCKET; + } else { + statePtr->flags &= ~TCP_ASYNC_SOCKET; + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * TcpClose -- + * + * Close the socket. + * + * Results: + * 0 if successful, the value of errno if failed. + * + * Side effects: + * Closes the socket. + * + *---------------------------------------------------------------------- + */ + +static int +TcpClose( + ClientData instanceData, /* The socket to close. */ + Tcl_Interp *interp) /* Interp for error messages. */ +{ + TcpState *statePtr = (TcpState *) instanceData; + int errorCode = 0, done = false; + StreamPtr tcpStream; + OSErr err; + + tcpStream = statePtr->tcpStream; + statePtr->flags &= ~TCP_CONNECTED; + + InitMacTCPParamBlock(&statePtr->pb, TCPClose); + statePtr->pb.tcpStream = tcpStream; + statePtr->pb.ioCompletion = closeUPP; + statePtr->pb.csParam.close.userDataPtr = (Ptr) statePtr; + err = PBControlAsync((ParmBlkPtr) &statePtr->pb); + if (err != noErr) { + statePtr->flags |= TCP_RELEASE; + return errorCode; + } + + /* + * Delete a file handler that may be active for this socket. + * Channel handlers are already deleted in the generic IO close + * code which called this function. + */ + + Tcl_DeleteFileHandler(statePtr->sock); + + /* + * Free the file handle. As a side effect, this will call the + * SocketFreeProc to release the SocketInfo associated with this file. + */ + + Tcl_FreeFile(statePtr->sock); + + return errorCode; +} + +/* + *---------------------------------------------------------------------- + * + * CloseCompletionRoutine -- + * + * Handles the close protocol for a Tcp socket. This will do + * a series of calls to release all data currently buffered for + * the socket. This is important to do to as it allows the remote + * connection to recieve and issue it's own close on the socket. + * Note that this function is running at interupt time and can't + * allocate memory or do much else except set state. + * + * Results: + * None. + * + * Side effects: + * The buffers for the socket are flushed. + * + *---------------------------------------------------------------------- + */ + +static void +CloseCompletionRoutine( + TCPiopb *pbPtr) /* Tcp parameter block. */ +{ + TcpState *statePtr; + OSErr err; + + statePtr = (TcpState *) pbPtr; + + /* + * If there is an error we assume the remote side has already + * close. We are done closing as soon as we decide that the + * remote connection has closed. + */ + if (pbPtr->ioResult != noErr) { + statePtr->flags |= TCP_RELEASE; + return; + } + + if (statePtr->flags & TCP_REMOTE_CLOSED) { + statePtr->flags |= TCP_RELEASE; + return; + } + + /* + * If we just did a recieve we need to return the buffers. + * Otherwise, attempt to recieve more data until we recieve an + * error. + */ + if (statePtr->pb.csCode == TCPNoCopyRcv) { + InitMacTCPParamBlock(&statePtr->pb, TCPRcvBfrReturn); + statePtr->pb.ioCompletion = closeUPP; + statePtr->pb.csParam.receive.rdsPtr = (Ptr) statePtr->rdsarray; + err = PBControlAsync((ParmBlkPtr) &statePtr->pb); + } else { + InitMacTCPParamBlock(&statePtr->pb, TCPNoCopyRcv); + statePtr->pb.ioCompletion = closeUPP; + statePtr->pb.csParam.receive.commandTimeoutValue = 1; + statePtr->pb.csParam.receive.rdsPtr = (Ptr) statePtr->rdsarray; + statePtr->pb.csParam.receive.rdsLength = 5; + err = PBControlAsync((ParmBlkPtr) &statePtr->pb); + } + + if (err != noErr) { + statePtr->flags |= TCP_RELEASE; + return; + } +} + +/* + *---------------------------------------------------------------------- + * + * TcpInput -- + * + * Reads input from the IO channel into the buffer given. Returns + * count of how many bytes were actually read, and an error + * indication. + * + * Results: + * A count of how many bytes were read is returned. A value of -1 + * implies an error occured. A value of zero means we have reached + * the end of data (EOF). + * + * Side effects: + * Reads input from the actual channel. + * + *---------------------------------------------------------------------- + */ + +int +TcpInput( + ClientData instanceData, /* Channel state. */ + char *buf, /* Where to store data read. */ + int bufSize, /* How much space is available + * in the buffer? */ + int *errorCode) /* Where to store error code. */ +{ + TcpState *statePtr = (TcpState *) instanceData; + StreamPtr tcpStream; + OSErr err; + int timeOut, mask; + + *errorCode = 0; + errno = 0; + tcpStream = statePtr->tcpStream; + + if (bufSize == 0) { + return 0; + } + + /* + * If an asynchronous connect is in progress, attempt to wait for it + * to complete before reading. + */ + + if (statePtr->flags & TCP_ASYNC_CONNECT) { + if (statePtr->flags & TCP_ASYNC_SOCKET) { + timeOut = 0; + } else { + timeOut = -1; + } + mask = TclWaitForFile(statePtr->sock, TCL_WRITABLE, timeOut); + if (mask & TCL_WRITABLE) { + statePtr->flags &= (~(TCP_ASYNC_CONNECT)); + } else if (timeOut == 0) { + *errorCode = errno = EWOULDBLOCK; + return -1; + } + } + + statePtr->pb.ioCRefNum = driverRefNum; + statePtr->pb.tcpStream = tcpStream; + statePtr->pb.csCode = TCPStatus; + err = PBControlSync((ParmBlkPtr) &(statePtr->pb)); + if (err != noErr) { + /* Debugger(); */ + statePtr->flags |= TCP_REMOTE_CLOSED; + return 0; /* EOF */ + } + if (statePtr->pb.csParam.status.amtUnreadData < bufSize) { + bufSize = statePtr->pb.csParam.status.amtUnreadData; + } + + /* EWOULDBLOCK ??? */ + if (bufSize == 0) { + SInt8 connectionState = statePtr->pb.csParam.status.connectionState; + if (connectionState == 14) { + statePtr->flags |= TCP_REMOTE_CLOSED; + return 0; + } + if (connectionState != 8) { + /* Debugger(); */ + } + *errorCode = EWOULDBLOCK; + statePtr->checkMask &= ~TCL_READABLE; + return -1; + } + + InitMacTCPParamBlock(&statePtr->pb, TCPRcv); + statePtr->pb.tcpStream = tcpStream; + statePtr->pb.csParam.receive.rcvBuff = buf; + statePtr->pb.csParam.receive.rcvBuffLen = bufSize; + err = PBControlSync((ParmBlkPtr) &(statePtr->pb)); + switch (err) { + case noErr: + return statePtr->pb.csParam.receive.rcvBuffLen; + case connectionClosing: + *errorCode = errno = ESHUTDOWN; + statePtr->flags |= TCP_REMOTE_CLOSED; + return 0; + case connectionDoesntExist: + case connectionTerminated: + *errorCode = errno = ENOTCONN; + statePtr->flags |= TCP_REMOTE_CLOSED; + return 0; + case invalidStreamPtr: + default: + return -1; + } +} + +/* + *---------------------------------------------------------------------- + * + * TcpGetFile -- + * + * Called from Tcl_GetChannelFile to retrieve Tcl_Files from inside + * a file based channel. + * + * Results: + * The appropriate Tcl_File or NULL if not present. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tcl_File +TcpGetFile(instanceData, direction) + ClientData instanceData; /* The file state. */ + int direction; /* Which Tcl_File to retrieve? */ +{ + TcpState *statePtr = (TcpState *) instanceData; + + if ((direction == TCL_READABLE) || (direction == TCL_WRITABLE)) { + return statePtr->sock; + } + return (Tcl_File) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TcpOutput-- + * + * Writes the given output on the IO channel. Returns count of how + * many characters were actually written, and an error indication. + * + * Results: + * A count of how many characters were written is returned and an + * error indication is returned in an output argument. + * + * Side effects: + * Writes output on the actual channel. + * + *---------------------------------------------------------------------- + */ + +static int +TcpOutput( + ClientData instanceData, /* Channel state. */ + char *buf, /* The data buffer. */ + int toWrite, /* How many bytes to write? */ + int *errorCode) /* Where to store error code. */ +{ + TcpState *statePtr = (TcpState *) instanceData; + StreamPtr tcpStream; + OSErr err; + int amount; + wdsEntry dataSegment[2]; + int timeOut, mask; + + *errorCode = 0; + tcpStream = statePtr->tcpStream; + + /* + * If an asynchronous connect is in progress, attempt to wait for it + * to complete before reading. + */ + + if (statePtr->flags & TCP_ASYNC_CONNECT) { + if (statePtr->flags & TCP_ASYNC_SOCKET) { + timeOut = 0; + } else { + timeOut = -1; + } + mask = TclWaitForFile(statePtr->sock, TCL_WRITABLE, timeOut); + if (mask & TCL_WRITABLE) { + statePtr->flags &= (~(TCP_ASYNC_CONNECT)); + } else if (timeOut == 0) { + *errorCode = EWOULDBLOCK; + Tcl_SetErrno(EWOULDBLOCK); + return -1; + } + } + + statePtr->pb.ioCRefNum = driverRefNum; + statePtr->pb.tcpStream = tcpStream; + statePtr->pb.csCode = TCPStatus; + err = PBControlSync((ParmBlkPtr) &(statePtr->pb)); + if (err != noErr) { + return -1; + } + amount = statePtr->pb.csParam.status.sendWindow - + statePtr->pb.csParam.status.amtUnackedData; + if (amount <= 0) { + statePtr->checkMask &= ~TCL_WRITABLE; + *errorCode = EWOULDBLOCK; + return -1; + } else if (toWrite < amount) { + amount = toWrite; + } + + dataSegment[0].length = amount; + dataSegment[0].ptr = buf; + dataSegment[1].length = 0; + InitMacTCPParamBlock(&statePtr->pb, TCPSend); + statePtr->pb.tcpStream = tcpStream; + statePtr->pb.csParam.send.wdsPtr = (Ptr) dataSegment; + statePtr->pb.csParam.send.pushFlag = 1; + err = PBControlSync((ParmBlkPtr) &(statePtr->pb)); + switch (err) { + case noErr: + return amount; + case connectionClosing: + *errorCode = errno = ESHUTDOWN; + statePtr->flags |= TCP_REMOTE_CLOSED; + return -1; + case connectionDoesntExist: + case connectionTerminated: + *errorCode = errno = ENOTCONN; + statePtr->flags |= TCP_REMOTE_CLOSED; + return -1; + case invalidStreamPtr: + default: + return -1; + } +} + +/* + *---------------------------------------------------------------------- + * + * TcpGetOptionProc -- + * + * Computes an option value for a TCP socket based channel, or a + * list of all options and their values. + * + * Note: This code is based on code contributed by John Haxby. + * + * Results: + * A standard Tcl result. The value of the specified option or a + * list of all options and their values is returned in the + * supplied DString. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TcpGetOptionProc( + ClientData instanceData, /* Socket state. */ + char *optionName, /* Name of the option to + * retrieve the value for, or + * NULL to get all options and + * their values. */ + Tcl_DString *dsPtr) /* Where to store the computed + * value; initialized by caller. */ +{ + TcpState *statePtr = (TcpState *) instanceData; + int doPeerName = false, doSockName = false, doAll = false; + ip_addr tcpAddress; + char buffer[128]; + OSErr err; + Tcl_DString dString; + int timeOut, mask; + + /* + * If an asynchronous connect is in progress, attempt to wait for it + * to complete before reading. + */ + + if (statePtr->flags & TCP_ASYNC_CONNECT) { + if (statePtr->flags & TCP_ASYNC_SOCKET) { + timeOut = 0; + } else { + timeOut = -1; + } + mask = TclWaitForFile(statePtr->sock, TCL_WRITABLE, timeOut); + if (mask & TCL_WRITABLE) { + statePtr->flags &= (~(TCP_ASYNC_CONNECT)); + } else if (timeOut == 0) { + Tcl_SetErrno(EWOULDBLOCK); + return -1; + } + } + + /* + * Determine which options we need to do. Do all of them + * if optionName is NULL. + */ + if (optionName == (char *) NULL || optionName[0] == '\0') { + doAll = true; + } else { + if (!strcmp(optionName, "-peername")) { + doPeerName = true; + } else if (!strcmp(optionName, "-sockname")) { + doSockName = true; + } else { + Tcl_SetErrno(EINVAL); + return TCL_ERROR; + } + } + + /* + * Get status on the stream. + */ + statePtr->pb.ioCRefNum = driverRefNum; + statePtr->pb.tcpStream = statePtr->tcpStream; + statePtr->pb.csCode = TCPStatus; + err = PBControlSync((ParmBlkPtr) &(statePtr->pb)); + if (err != noErr) { + Debugger(); /* TODO */ + return TCL_ERROR; + } + + Tcl_DStringInit(&dString); + /* + * Get the sockname for the socket. + */ + if (doAll || doSockName) { + if (doAll) { + Tcl_DStringAppendElement(dsPtr, "-sockname"); + Tcl_DStringStartSublist(dsPtr); + } + tcpAddress = statePtr->pb.csParam.status.localHost; + sprintf(buffer, "%d.%d.%d.%d", tcpAddress>>24, + tcpAddress>>16 & 0xff, tcpAddress>>8 & 0xff, + tcpAddress & 0xff); + Tcl_DStringAppendElement(dsPtr, buffer); + if (ResolveAddress(tcpAddress, &dString) == noErr) { + Tcl_DStringAppendElement(dsPtr, dString.string); + } else { + Tcl_DStringAppendElement(dsPtr, ""); + } + sprintf(buffer, "%d", statePtr->pb.csParam.status.localPort); + Tcl_DStringAppendElement(dsPtr, buffer); + if (doAll) { + Tcl_DStringEndSublist(dsPtr); + } + } + + /* + * Get the peername for the socket. + */ + if ((doAll || doPeerName) && (statePtr->flags & TCP_CONNECTED)) { + if (doAll) { + Tcl_DStringAppendElement(dsPtr, "-peername"); + Tcl_DStringStartSublist(dsPtr); + } + tcpAddress = statePtr->pb.csParam.status.remoteHost; + sprintf(buffer, "%d.%d.%d.%d", tcpAddress>>24, + tcpAddress>>16 & 0xff, tcpAddress>>8 & 0xff, + tcpAddress & 0xff); + Tcl_DStringAppendElement(dsPtr, buffer); + Tcl_DStringSetLength(&dString, 0); + if (ResolveAddress(tcpAddress, &dString) == noErr) { + Tcl_DStringAppendElement(dsPtr, dString.string); + } else { + Tcl_DStringAppendElement(dsPtr, ""); + } + sprintf(buffer, "%d", statePtr->pb.csParam.status.remotePort); + Tcl_DStringAppendElement(dsPtr, buffer); + if (doAll) { + Tcl_DStringEndSublist(dsPtr); + } + } + + Tcl_DStringFree(&dString); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TcpReady -- + * + * Called by the notifier to check whether events of interest are + * present on the channel. + * + * Results: + * Returns OR-ed combination of TCL_READABLE, TCL_WRITABLE and + * TCL_EXCEPTION to indicate which events of interest are present. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TcpReady(instanceData, mask) + ClientData instanceData; /* The file state. */ + int mask; /* Events of interest; an OR-ed + * combination of TCL_READABLE, + * TCL_WRITABLE and TCL_EXCEPTION. */ +{ + TcpState *statePtr = (TcpState *) instanceData; + + return (statePtr->checkMask & mask); +} + +/* + *---------------------------------------------------------------------- + * + * TcpWatch -- + * + * Initialize the notifier to watch Tcl_Files from this channel. + * + * Results: + * None. + * + * Side effects: + * Sets the watchMask for the channel. + * + *---------------------------------------------------------------------- + */ + +static void +TcpWatch(instanceData, mask) + ClientData instanceData; /* The file state. */ + int mask; /* Events of interest; an OR-ed + * combination of TCL_READABLE, + * TCL_WRITABLE and TCL_EXCEPTION. */ +{ + TcpState *statePtr = (TcpState *) instanceData; + + statePtr->watchMask = mask; +} + +/* + *---------------------------------------------------------------------- + * + * SocketFreeProc -- + * + * This callback is invoked by Tcl_FreeFile in order to delete + * the notifier data associated with a file handle. + * + * Results: + * None. + * + * Side effects: + * Removes the SocketInfo from the global socket list. + * + *---------------------------------------------------------------------- + */ + +static void +SocketFreeProc( + ClientData clientData) /* Channel state. */ +{ + TcpState *statePtr = (TcpState *) clientData; + OSErr err; + + if (!(statePtr->flags & TCP_RELEASE)) { + return; + } + + /* + * The Close request is made async. We know it's + * OK to release the socket when the TCP_RELEASE flag + * gets set. + */ + InitMacTCPParamBlock(&statePtr->pb, TCPRelease); + statePtr->pb.tcpStream = statePtr->tcpStream; + err = PBControlSync((ParmBlkPtr) &statePtr->pb); + if (err != noErr) { + Debugger(); /* should panic */ + } + + /* + * Free the buffer space used by the socket. + */ + ckfree((char *) statePtr->pb.csParam.create.rcvBuff); + + /* + * Remove the socket from socketList. + */ + + if (statePtr == socketList) { + socketList = statePtr->nextPtr; + } else { + TcpState *p; + for (p = socketList; p != NULL; p = p->nextPtr) { + if (p->nextPtr == statePtr) { + p->nextPtr = statePtr->nextPtr; + break; + } + } + } + ckfree((char *) statePtr); +} + +/* + *---------------------------------------------------------------------- + * + * NewSocketInfo -- + * + * This function allocates and initializes a new SocketInfo + * structure. + * + * Results: + * Returns a newly allocated SocketInfo. + * + * Side effects: + * Adds the socket to the global socket list. + * + *---------------------------------------------------------------------- + */ + +static TcpState * +NewSocketInfo( + Tcl_File file) /* Channel file. */ +{ + TcpState *statePtr; + + statePtr = (TcpState *) ckalloc((unsigned) sizeof(TcpState)); + statePtr->tcpStream = (StreamPtr) Tcl_GetFileInfo(file, NULL); + statePtr->psn = applicationPSN; + statePtr->sock = file; + statePtr->flags = 0; + statePtr->checkMask = 0; + statePtr->watchMask = 0; + statePtr->acceptProc = (Tcl_TcpAcceptProc *) NULL; + statePtr->acceptProcData = (ClientData) NULL; + statePtr->nextPtr = socketList; + socketList = statePtr; + Tcl_SetNotifierData(file, SocketFreeProc, (ClientData) statePtr); + return statePtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_MakeTcpClientChannel -- + * + * Creates a Tcl_Channel from an existing client TCP socket. + * + * Results: + * The Tcl_Channel wrapped around the preexisting TCP socket. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_MakeTcpClientChannel( + ClientData sock) /* The socket to wrap up into a channel. */ +{ + TcpState *statePtr; + Tcl_File sockFile; + char channelName[20]; + Tcl_Channel chan; + + if (!socketsInitalized) { + if (InitSockets() == 0) { + return NULL; + } + } + + sockFile = Tcl_GetFile(sock, TCL_MAC_SOCKET); + statePtr = NewSocketInfo(sockFile); + /* TODO: do we need to set the port??? */ + + sprintf(channelName, "sock%d", socketNumber); + + chan = Tcl_CreateChannel(&tcpChannelType, channelName, + (ClientData) statePtr, (TCL_READABLE | TCL_WRITABLE)); + if (chan != (Tcl_Channel) NULL) { + Tcl_SetChannelBufferSize(chan, socketBufferSize); + Tcl_SetChannelOption(NULL, chan, "-translation", "auto crlf"); + } + return chan; +} + +/* + *---------------------------------------------------------------------- + * + * CreateSocket -- + * + * This function opens a new socket and initializes the + * SocketInfo structure. + * + * Results: + * Returns a new SocketInfo, or NULL with an error in interp. + * + * Side effects: + * Adds a new socket to the socketList. + * + *---------------------------------------------------------------------- + */ + +static TcpState * +CreateSocket( + Tcl_Interp *interp, /* For error reporting; can be NULL. */ + int port, /* Port number to open. */ + char *host, /* Name of host on which to open port. */ + char *myaddr, /* Optional client-side address */ + int myport, /* Optional client-side port */ + int server, /* 1 if socket should be a server socket, + * else 0 for a client socket. */ + int async) /* 1 create async, 0 do sync. */ +{ + ip_addr macAddr; + OSErr err; + TCPiopb pb; + StreamPtr tcpStream; + Tcl_File handle; + TcpState *statePtr; + char * buffer; + + /* + * Figure out the ip address from the host string. + */ + if (host == NULL) { + err = GetLocalAddress(&macAddr); + } else { + err = GetHostFromString(host, &macAddr); + } + if (err != noErr) { + Tcl_SetErrno(0); + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "couldn't open socket: ", + Tcl_PosixError(interp), (char *) NULL); + } + return (TcpState *) NULL; + } + + /* + * Create a MacTCP stream and create the state used for socket + * transactions from here on out. + */ + + buffer = ckalloc(socketBufferSize); + InitMacTCPParamBlock(&pb, TCPCreate); + pb.csParam.create.rcvBuff = buffer; + pb.csParam.create.rcvBuffLen = socketBufferSize; + err = PBControlSync((ParmBlkPtr) &pb); + if (err != noErr) { + Tcl_SetErrno(0); /* TODO: set to ENOSR - maybe?*/ + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "couldn't open socket: ", + Tcl_PosixError(interp), (char *) NULL); + } + return (TcpState *) NULL; + } + + tcpStream = pb.tcpStream; + handle = Tcl_GetFile((ClientData) tcpStream, TCL_MAC_SOCKET); + statePtr = NewSocketInfo(handle); + statePtr->port = port; + + if (server) { + /* + * Set up server connection. + */ + + InitMacTCPParamBlock(&statePtr->pb, TCPPassiveOpen); + statePtr->pb.tcpStream = tcpStream; + statePtr->pb.csParam.open.localPort = statePtr->port; + statePtr->pb.ioCompletion = completeUPP; + statePtr->pb.csParam.open.userDataPtr = (Ptr) statePtr; + statePtr->flags |= TCP_LISTENING; + err = PBControlAsync((ParmBlkPtr) &(statePtr->pb)); + Tcl_SetErrno(EINPROGRESS); + } else { + /* + * Attempt to connect. The connect may fail at present with an + * EINPROGRESS but at a later time it will complete. The caller + * will set up a file handler on the socket if she is interested in + * being informed when the connect completes. + */ + + InitMacTCPParamBlock(&statePtr->pb, TCPActiveOpen); + statePtr->pb.tcpStream = tcpStream; + statePtr->pb.csParam.open.remoteHost = macAddr; + statePtr->pb.csParam.open.remotePort = port; + statePtr->pb.csParam.open.localHost = 0; + statePtr->pb.csParam.open.localPort = myport; + statePtr->pb.csParam.open.userDataPtr = (Ptr) statePtr; + statePtr->pb.ioCompletion = completeUPP; + if (async) { + statePtr->flags |= TCP_ASYNC_CONNECT; + err = PBControlAsync((ParmBlkPtr) &(statePtr->pb)); + Tcl_SetErrno(EINPROGRESS); + } else { + err = PBControlSync((ParmBlkPtr) &(statePtr->pb)); + } + } + + switch (err) { + case noErr: + if (!async) { + statePtr->flags |= TCP_CONNECTED; + } + return statePtr; + case duplicateSocket: + Tcl_SetErrno(EADDRINUSE); + break; + case openFailed: + Tcl_SetErrno(ECONNREFUSED); + break; + default: + /* Debugger(); */ + Tcl_SetErrno(err); + } + + /* + * We had error during the connection. Release the stream + * and file handle. Also report to the interp. + */ + pb.ioCRefNum = driverRefNum; + pb.csCode = TCPRelease; + pb.tcpStream = tcpStream; + pb.ioCompletion = NULL; + err = PBControlSync((ParmBlkPtr) &pb); + + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "couldn't open socket: ", + Tcl_PosixError(interp), (char *) NULL); + } + + Tcl_FreeFile(handle); + ckfree(buffer); + ckfree((char *) statePtr); + return (TcpState *) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_OpenTcpClient -- + * + * Opens a TCP client socket and creates a channel around it. + * + * Results: + * The channel or NULL if failed. On failure, the routine also + * sets the output argument errorCodePtr to the error code. + * + * Side effects: + * Opens a client socket and creates a new channel. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_OpenTcpClient( + Tcl_Interp *interp, /* For error reporting; can be NULL. */ + int port, /* Port number to open. */ + char *host, /* Host on which to open port. */ + char *myaddr, /* Client-side address */ + int myport, /* Client-side port */ + int async) /* If nonzero, attempt to do an + * asynchronous connect. Otherwise + * we do a blocking connect. + * - currently ignored */ +{ + Tcl_Channel chan; + TcpState *statePtr; + char channelName[20]; + + if (TclHasSockets(interp) != TCL_OK) { + return NULL; + } + + if (!socketsInitalized) { + if (InitSockets() == 0) { + return NULL; + } + } + + /* + * Create a new client socket and wrap it in a channel. + */ + + statePtr = CreateSocket(interp, port, host, myaddr, myport, 0, async); + if (statePtr == NULL) { + return NULL; + } + + sprintf(channelName, "sock%d", socketNumber++); + chan = Tcl_CreateChannel(&tcpChannelType, channelName, + (ClientData) statePtr, (TCL_READABLE | TCL_WRITABLE)); + Tcl_SetChannelOption(NULL, chan, "-translation", "auto crlf"); + Tcl_SetChannelBufferSize(chan, socketBufferSize); + + return chan; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_OpenTcpServer -- + * + * Opens a TCP server socket and creates a channel around it. + * + * Results: + * The channel or NULL if failed. + * + * Side effects: + * Opens a server socket and creates a new channel. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_OpenTcpServer( + Tcl_Interp *interp, /* For error reporting - may be + * NULL. */ + int port, /* Port number to open. */ + char *host, /* Name of local host. */ + Tcl_TcpAcceptProc *acceptProc, /* Callback for accepting connections + * from new clients. */ + ClientData acceptProcData) /* Data for the callback. */ +{ + Tcl_Channel chan; + TcpState *statePtr; + char channelName[20]; + + if (TclHasSockets(interp) != TCL_OK) { + return NULL; + } + + if (!socketsInitalized) { + if (InitSockets() == 0) { + return NULL; + } + } + + /* + * Create a new client socket and wrap it in a channel. + */ + + statePtr = CreateSocket(interp, port, host, NULL, 0, 1, 1); + if (statePtr == NULL) { + return NULL; + } + + statePtr->acceptProc = acceptProc; + statePtr->acceptProcData = acceptProcData; + + /* + * Set up the callback mechanism for accepting connections + * from new clients. The caller will use Tcl_TcpRegisterCallback + * to register a callback to call when a new connection is + * accepted. + */ + + Tcl_CreateFileHandler(statePtr->sock, TCL_READABLE, TcpAccept, + (ClientData) statePtr); + + sprintf(channelName, "sock%d", socketNumber++); + + chan = Tcl_CreateChannel(&tcpChannelType, channelName, + (ClientData) statePtr, 0); + Tcl_SetChannelOption(NULL, chan, "-translation", "auto crlf"); + Tcl_SetChannelBufferSize(chan, socketBufferSize); + + return chan; +} + +/* + *---------------------------------------------------------------------- + * + * TclMacWatchSocket -- + * + * This function imlements the socket specific portion of the + * Tcl_WatchFile function in the notifier. + * + * Results: + * None. + * + * Side effects: + * The watched socket will be placed into non-blocking mode, and + * an entry on the asynch handler list will be created if necessary. + * + *---------------------------------------------------------------------- + */ + +void +TclMacWatchSocket( + Tcl_File file, /* Socket to watch. */ + int mask) /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, and TCL_EXCEPTION: + * indicates conditions to wait for + * in select. */ +{ + TcpState *statePtr = (TcpState *) Tcl_GetNotifierData(file, NULL); + + /* + * Create socket info on demand if necessary. We should only enter this + * code if the socket was created outside of Tcl. Since this may be + * the first time that the socket code has been called, we need to invoke + * TclHasSockets to ensure that everything is initialized properly. + * + * Note: This may not work as certain state may be incorrect. + */ + + if (statePtr == NULL) { + if (TclHasSockets(NULL) != TCL_OK) { + return; + } + if (!socketsInitalized) { + InitSockets(); + } + + statePtr = NewSocketInfo(file); + } + + statePtr->watchMask = mask; +} + +/* + *---------------------------------------------------------------------- + * + * TclMacNotifySocket -- + * + * Look through the currently opened socket channels. For each + * channel we get the Tcp streams current status. Based on the + * status we determine if the channel should be made readable or + * writeable. The channel is also made read/write-able if there + * is an error while getting the status. + * + * Results: + * None. + * + * Side effects: + * May set a channel to be readable or writeable. + * + *---------------------------------------------------------------------- + */ + +int +TclMacNotifySocket() +{ + TcpState *statePtr; + TcpState *deadPtr = NULL; + TCPiopb statusPB; + int numFound = 0; + int foundSomething; + int amount; + int didStatus; + OSErr err; + + if (socketList == NULL) { + return 0; + } + + /* + * Establish or remove any notifiers. + */ + + for (statePtr = socketList; statePtr != NULL; + statePtr = statePtr->nextPtr) { + /* + * Check to see if this socket is dead and needs to be + * cleaned up. + */ + if (statePtr->flags & TCP_RELEASE) { + deadPtr = statePtr; + continue; + } + foundSomething = false; + didStatus = false; + if (statePtr->watchMask & TCL_READABLE) { + if (statePtr->checkMask & TCL_READABLE) { + foundSomething = true; + } else if (statePtr->flags & TCP_CONNECTED) { + statusPB.ioCRefNum = driverRefNum; + statusPB.tcpStream = statePtr->tcpStream; + statusPB.csCode = TCPStatus; + err = PBControlSync((ParmBlkPtr) &statusPB); + didStatus = true; + /* + * If there is an error or there is more data available + * we make the channel readable. + */ + if ((err != noErr) || + (statusPB.csParam.status.amtUnreadData > 0)) { + statePtr->checkMask |= TCL_READABLE; + foundSomething = true; + } + } + } + if (statePtr->watchMask & TCL_WRITABLE) { + if (statePtr->checkMask & TCL_WRITABLE) { + foundSomething = true; + } else if (statePtr->flags & TCP_CONNECTED) { + if (!didStatus) { + statusPB.ioCRefNum = driverRefNum; + statusPB.tcpStream = statePtr->tcpStream; + statusPB.csCode = TCPStatus; + err = PBControlSync((ParmBlkPtr) &statusPB); + } + /* + * If there is an error or there if there is room to + * send more data we make the channel writeable. + */ + amount = statusPB.csParam.status.sendWindow - + statusPB.csParam.status.amtUnackedData; + if ((err != noErr) || (amount > 0)) { + statePtr->checkMask |= TCL_WRITABLE; + foundSomething = true; + } + } + } + if (foundSomething) { + numFound++; + } + } + + /* + * If we need to clean - do it now. + */ + if (deadPtr != NULL) { + SocketFreeProc(deadPtr); + } + + return numFound; +} + +/* + *---------------------------------------------------------------------- + * + * TclMacSocketReady -- + * + * This function is invoked by Tcl_FileReady to check whether + * the specified conditions are present on a socket. + * + * Results: + * The return value is 0 if none of the conditions specified by + * mask were true for socket the last time the system checked. + * If any of the conditions were true, then the return value is a + * mask of those that were true. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclMacSocketReady( + Tcl_File file, /* File handle for a stream. */ + int mask) /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, and TCL_EXCEPTION: + * indicates conditions caller cares about. */ +{ + TcpState *statePtr = (TcpState *) Tcl_GetNotifierData(file, NULL); + + return (statePtr->checkMask & mask); +} + +/* + *---------------------------------------------------------------------- + * + * TcpAccept -- + * Accept a TCP socket connection. This is called by the event + * loop, and it in turns calls any registered callbacks for this + * channel. + * + * Results: + * None. + * + * Side effects: + * Evals the Tcl script associated with the server socket. + * + *---------------------------------------------------------------------- + */ + +static void +TcpAccept( + ClientData data, /* Callback token. */ + int mask) /* Not used. */ +{ + TcpState *statePtr; + TcpState *newStatePtr; + Tcl_File handle; + StreamPtr tcpStream; + Tcl_Channel chan; + char remoteHostname[255]; + OSErr err; + + statePtr = (TcpState *) data; + + Tcl_DeleteFileHandler(statePtr->sock); + statePtr->flags &= ~TCP_LISTEN_CONNECT; + statePtr->checkMask &= ~TCL_READABLE; + + /* + * Transfer sever stream to new connection. + */ + tcpStream = statePtr->tcpStream; + handle = Tcl_GetFile((ClientData) tcpStream, TCL_MAC_SOCKET); + newStatePtr = NewSocketInfo(handle); + newStatePtr->tcpStream = tcpStream; + sprintf(channelName, "sock%d", socketNumber++); + chan = Tcl_CreateChannel(&tcpChannelType, channelName, + (ClientData) newStatePtr, (TCL_READABLE | TCL_WRITABLE)); + newStatePtr->flags |= TCP_CONNECTED; + Tcl_SetChannelOption(NULL, chan, "-translation", "auto crlf"); + Tcl_SetChannelBufferSize(chan, socketBufferSize); + + /* + * Reopen passive connect. Make new tcpStream the server. + */ + InitMacTCPParamBlock(&statePtr->pb, TCPCreate); + statePtr->pb.csParam.create.rcvBuff = ckalloc(socketBufferSize); + statePtr->pb.csParam.create.rcvBuffLen = socketBufferSize; + err = PBControlSync((ParmBlkPtr) &statePtr->pb); + if (err != noErr) { + /* + * Hmmm... We can't reopen the server. We'll go ahead + * an continue - but we are kind of broken now... + */ + } + + tcpStream = statePtr->tcpStream = statePtr->pb.tcpStream; + statePtr->sock = Tcl_GetFile((ClientData) tcpStream, TCL_MAC_SOCKET); + Tcl_SetNotifierData(statePtr->sock, SocketFreeProc, (ClientData) statePtr); + + InitMacTCPParamBlock(&statePtr->pb, TCPPassiveOpen); + statePtr->pb.tcpStream = tcpStream; + statePtr->pb.csParam.open.localHost = 0; + statePtr->pb.csParam.open.localPort = statePtr->port; + statePtr->pb.ioCompletion = completeUPP; + statePtr->pb.csParam.open.userDataPtr = (Ptr) statePtr; + statePtr->flags |= TCP_LISTENING; + err = PBControlAsync((ParmBlkPtr) &(statePtr->pb)); + /* + * TODO: deal with case where we can't recreate server socket... + */ + + /* + * Remove old file handler & create new one. + */ + Tcl_CreateFileHandler(statePtr->sock, TCL_READABLE, TcpAccept, + (ClientData) statePtr); + + /* + * Finally we run the accept procedure. We must do this last to make + * sure we are in a nice clean state. This Tcl code can do anything + * including closing the server or client sockets we've just delt with. + */ + if (statePtr->acceptProc != NULL) { + ip_addr ourAddress = statePtr->pb.csParam.open.remoteHost; + + sprintf(remoteHostname, "%d.%d.%d.%d", ourAddress>>24, + ourAddress>>16 & 0xff, ourAddress>>8 & 0xff, + ourAddress & 0xff); + + (statePtr->acceptProc)(statePtr->acceptProcData, chan, + remoteHostname, statePtr->pb.csParam.open.remotePort); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetHostName -- + * + * Returns the name of the local host. The result is cached to + * be speedy after the first call. + * + * Results: + * Returns a string containing the host name, or NULL on error. + * The returned string must be freed by the caller. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_GetHostName() +{ + static int hostnameInited = 0; + static char hostname[255]; + ip_addr ourAddress; + Tcl_DString dString; + OSErr err; + + if (hostnameInited) { + return hostname; + } + + if (TclHasSockets(NULL) != TCL_OK) { + hostname[0] = '\0'; + hostnameInited = 1; + return hostname; + } + + if (!socketsInitalized) { + if (InitSockets() == 0) { + return NULL; + } + } + + err = GetLocalAddress(&ourAddress); + + if (err == noErr) { + /* + * Search for the doman name and return it if found. Otherwise, + * just print the IP number to a string and return that. + */ + Tcl_DStringInit(&dString); + err = ResolveAddress(ourAddress, &dString); + if (err == noErr) { + strcpy(hostname, dString.string); + } else { + sprintf(hostname, "%d.%d.%d.%d", ourAddress>>24, ourAddress>>16 & 0xff, + ourAddress>>8 & 0xff, ourAddress & 0xff); + } + Tcl_DStringFree(&dString); + + hostnameInited = 1; + return hostname; + } + + return (char *) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * ResolveAddress -- + * + * This function is used to resolve an ip address to it's full + * domain name address. + * + * Results: + * An os err value. + * + * Side effects: + * Treats client data as int we set to true. + * + *---------------------------------------------------------------------- + */ + +static OSErr +ResolveAddress( + ip_addr tcpAddress, /* Address to resolve. */ + Tcl_DString *dsPtr) /* Returned address in string. */ +{ + int i; + EventRecord dummy; + DNRState dnrState; + OSErr err; + + /* + * Call AddrToName to resolve our ip address to our domain name. + * The call is async, so we must wait for a callback to tell us + * when to continue. + */ + for (i = 0; i < NUM_ALT_ADDRS; i++) { + dnrState.hostInfo.addr[i] = 0; + } + dnrState.done = 0; + GetCurrentProcess(&(dnrState.psn)); + err = AddrToName(tcpAddress, &dnrState.hostInfo, resultUPP, (Ptr) &dnrState); + if (err == cacheFault) { + while (!dnrState.done) { + WaitNextEvent(0, &dummy, 1, NULL); + } + } + + /* + * If there is no error in finding the domain name we set the + * result into the dynamic string. We also work around a bug in + * MacTcp where an extranious '.' may be found at the end of the name. + */ + if (dnrState.hostInfo.rtnCode == noErr) { + i = strlen(dnrState.hostInfo.cname) - 1; + if (dnrState.hostInfo.cname[i] == '.') { + dnrState.hostInfo.cname[i] = '\0'; + } + Tcl_DStringAppend(dsPtr, dnrState.hostInfo.cname, -1); + } + + return dnrState.hostInfo.rtnCode; +} + +/* + *---------------------------------------------------------------------- + * + * DNRCompletionRoutine -- + * + * This function is called when the Domain Name Server is done + * seviceing our request. It just sets a flag that we can poll + * in functions like Tcl_GetHostName to let them know to continue. + * + * Results: + * None. + * + * Side effects: + * Treats client data as int we set to true. + * + *---------------------------------------------------------------------- + */ + +static pascal void +DNRCompletionRoutine( + struct hostInfo *hostinfoPtr, /* Host infor struct. */ + DNRState *dnrStatePtr) /* Completetion state. */ +{ + dnrStatePtr->done = true; + WakeUpProcess(&(dnrStatePtr->psn)); +} + +/* + *---------------------------------------------------------------------- + * + * TclHasSockets -- + * + * This function determines whether sockets are available on the + * current system and returns an error in interp if they are not. + * Note that interp may be NULL. This call uses the Macintosh + * gestalt function to determine the existance of Mac Tcp. + * + * Results: + * Returns TCL_OK if the system supports sockets, or TCL_ERROR with + * an error in interp. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#define gestaltMacTCPVersion 'mtcp' +int +TclHasSockets( + Tcl_Interp *interp) /* Interp for error messages. */ +{ + long response; + +static int socketsTestInited = false; +static int hasSockets = false; + if (!socketsTestInited) { + if (Gestalt(gestaltMacTCPVersion, &response) == noErr) { + hasSockets = true; + } else { + hasSockets = false; + } + socketsTestInited = true; + } + if (hasSockets) { + return TCL_OK; + } + if (interp != NULL) { + Tcl_AppendResult(interp, "sockets are not available on this system", + NULL); + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * InitSockets -- + * + * Load the MacTCP driver and open the name resolver. We also + * create several UPP's used by our code. Lastly, we install + * a patch to ExitToShell to clean up socket connections if + * we are about to exit. + * + * Results: + * 1 if successful, 0 on failure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +InitSockets() +{ + ParamBlockRec pb; + OSErr err; + + if (socketsInitalized) { + return 1; + } + + /* + * Load MacTcp driver and name server resolver. + */ + + + pb.ioParam.ioCompletion = 0L; + pb.ioParam.ioNamePtr = "\p.IPP"; + pb.ioParam.ioPermssn = fsCurPerm; + err = PBOpenSync(&pb); + if (err != noErr) { + return 0; + } + driverRefNum = pb.ioParam.ioRefNum; + + socketBufferSize = GetBufferSize(); + err = OpenResolver(NULL); + if (err != noErr) { + return 0; + } + + GetCurrentProcess(&applicationPSN); + /* + * Create UPP's for various callback routines. + */ + resultUPP = NewResultProc(DNRCompletionRoutine); + completeUPP = NewTCPIOCompletionProc(IOCompletionRoutine); + closeUPP = NewTCPIOCompletionProc(CloseCompletionRoutine); + + /* + * Install an ExitToShell patch. We use this patch instead + * of the Tcl exit mechanism because we need to ensure that + * these routines are cleaned up even if we crash or are forced + * to quit. There are some circumstances when the Tcl exit + * handlers may not fire. + */ + TclMacInstallExitToShellPatch(CleanUpExitProc); + + socketsInitalized = true; + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * CleanUpExitProc -- + * + * This procedure is invoked as an exit handler when ExitToShell + * is called. It aborts any lingering socket connections. This + * must be called or the Mac OS will more than likely crash. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static pascal void +CleanUpExitProc() +{ + TcpState *statePtr; + + while (socketList != NULL) { + statePtr = socketList; + socketList = statePtr->nextPtr; + + /* + * Close and Release the connection. + */ + statePtr->pb.ioCRefNum = driverRefNum; + statePtr->pb.csCode = TCPClose; + statePtr->pb.tcpStream = statePtr->tcpStream; + statePtr->pb.csParam.close.ulpTimeoutValue = 60 /* seconds */; + statePtr->pb.csParam.close.ulpTimeoutAction = 1 /* 1:abort 0:report */; + statePtr->pb.csParam.close.validityFlags = timeoutValue | timeoutAction; + statePtr->pb.ioCompletion = NULL; + PBControlSync((ParmBlkPtr) &(statePtr->pb)); + + statePtr->pb.ioCRefNum = driverRefNum; + statePtr->pb.csCode = TCPRelease; + statePtr->pb.tcpStream = statePtr->tcpStream; + statePtr->pb.ioCompletion = NULL; + PBControlSync((ParmBlkPtr) &(statePtr->pb)); + } +} + +/* + *---------------------------------------------------------------------- + * + * GetHostFromString -- + * + * Looks up the passed in domain name in the domain resolver. It + * can accept strings of two types: 1) the ip number in string + * format, or 2) the domain name. + * + * Results: + * We return a ip address or 0 if there was an error or the + * domain does not exist. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static OSErr +GetHostFromString( + char *name, /* Host in string form. */ + ip_addr *address) /* Returned IP address. */ +{ + OSErr err; + int i; + EventRecord dummy; + DNRState dnrState; + + if (TclHasSockets(NULL) != TCL_OK) { + return 0; + } + + if (!socketsInitalized) { + if (InitSockets() == 0) { + return -1; + } + } + + /* + * Call StrToAddr to get the ip number for the passed in domain + * name. The call is async, so we must wait for a callback to + * tell us when to continue. + */ + for (i = 0; i < NUM_ALT_ADDRS; i++) { + dnrState.hostInfo.addr[i] = 0; + } + dnrState.done = 0; + GetCurrentProcess(&(dnrState.psn)); + err = StrToAddr(name, &dnrState.hostInfo, resultUPP, (Ptr) &dnrState); + if (err == cacheFault) { + while (!dnrState.done) { + WaitNextEvent(0, &dummy, 1, NULL); + } + } + + /* + * For some reason MacTcp may return a cachFault a second time via + * the hostinfo block. This seems to be a bug in MacTcp. In this case + * we run StrToAddr again - which seems to then work just fine. + */ + if (dnrState.hostInfo.rtnCode == cacheFault) { + dnrState.done = 0; + err = StrToAddr(name, &dnrState.hostInfo, resultUPP, (Ptr) &dnrState); + if (err == cacheFault) { + while (!dnrState.done) { + WaitNextEvent(0, &dummy, 1, NULL); + } + } + } + + if (dnrState.hostInfo.rtnCode == noErr) { + *address = dnrState.hostInfo.addr[0]; + } + + return dnrState.hostInfo.rtnCode; +} + +/* + *---------------------------------------------------------------------- + * + * IOCompletionRoutine -- + * + * This function is called when a client or server socket gets a + * connection from a remote host. It will then simply set state + * to tell the notifier that this socket is now ready for action. + * Note that this function is running at interupt time and can't + * allocate memory or do much else except set state. + * + * Results: + * None. + * + * Side effects: + * Sets some state in the socket state. May also wake the process + * if we are not currently running. + * + *---------------------------------------------------------------------- + */ + +static void +IOCompletionRoutine( + TCPiopb *pbPtr) /* Tcp parameter block. */ +{ + TcpState *statePtr; + + statePtr = (TcpState *) pbPtr->csParam.open.userDataPtr; + + /* + * Always wake the process in case it's in WaitNextEvent. + * If an error has a occured - just return. We will deal + * with the problem later. + */ + WakeUpProcess(&statePtr->psn); + if (pbPtr->ioResult != noErr) { + return; + } + + if (statePtr->flags & TCP_ASYNC_CONNECT) { + statePtr->flags &= ~TCP_ASYNC_CONNECT; + statePtr->flags |= TCP_CONNECTED; + statePtr->checkMask |= TCL_READABLE & TCL_WRITABLE; + } else if (statePtr->flags & TCP_LISTENING) { + statePtr->flags &= ~TCP_LISTENING; + statePtr->flags |= TCP_LISTEN_CONNECT; + statePtr->checkMask |= TCL_READABLE; + } +} + +/* + *---------------------------------------------------------------------- + * + * GetLocalAddress -- + * + * Get the IP address for this machine. The result is cached so + * the result is returned quickly after the first call. + * + * Results: + * Macintosh error code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static OSErr +GetLocalAddress( + unsigned long *addr) /* Returns host IP address. */ +{ + struct GetAddrParamBlock pBlock; + OSErr err = noErr; + static unsigned long localAddress = 0; + + if (localAddress == 0) { + memset(&pBlock, 0, sizeof(pBlock)); + pBlock.ioResult = 1; + pBlock.csCode = ipctlGetAddr; + pBlock.ioCRefNum = driverRefNum; + err = PBControlSync((ParmBlkPtr) &pBlock); + + if (err != noErr) { + return err; + } + localAddress = pBlock.ourAddress; + } + + *addr = localAddress; + return noErr; +} + +/* + *---------------------------------------------------------------------- + * + * GetBufferSize -- + * + * Get the appropiate buffer size for our machine & network. This + * value will be used by the rest of Tcl & the MacTcp driver for + * the size of its buffers. If out method for determining the + * optimal buffer size fails for any reason - we return a + * reasonable default. + * + * Results: + * Size of optimal buffer in bytes. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static long +GetBufferSize() +{ + UDPiopb iopb; + OSErr err = noErr; + long bufferSize; + + memset(&iopb, 0, sizeof(iopb)); + err = GetLocalAddress(&iopb.csParam.mtu.remoteHost); + if (err != noErr) { + return CHANNEL_BUF_SIZE; + } + iopb.ioCRefNum = driverRefNum; + iopb.csCode = UDPMaxMTUSize; + err = PBControlSync((ParmBlkPtr)&iopb); + if (err != noErr) { + return CHANNEL_BUF_SIZE; + } + bufferSize = (iopb.csParam.mtu.mtuSize * 4) + 1024; + if (bufferSize < CHANNEL_BUF_SIZE) { + bufferSize = CHANNEL_BUF_SIZE; + } + return bufferSize; +} + +/* + *---------------------------------------------------------------------- + * + * TclSockGetPort -- + * + * Maps from a string, which could be a service name, to a port. + * Used by socket creation code to get port numbers and resolve + * registered service names to port numbers. + * + * Results: + * A standard Tcl result. On success, the port number is + * returned in portPtr. On failure, an error message is left in + * interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclSockGetPort( + Tcl_Interp *interp, /* Interp for error messages. */ + char *string, /* Integer or service name */ + char *proto, /* "tcp" or "udp", typically - + * ignored on Mac - assumed to be tcp */ + int *portPtr) /* Return port number */ +{ + PortInfo *portInfoPtr = NULL; + + if (Tcl_GetInt(interp, string, portPtr) == TCL_OK) { + if (*portPtr > 0xFFFF) { + Tcl_AppendResult(interp, "couldn't open socket: port number too high", + (char *) NULL); + return TCL_ERROR; + } + if (*portPtr < 0) { + Tcl_AppendResult(interp, "couldn't open socket: negative port number", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; + } + for (portInfoPtr = portServices; portInfoPtr->name != NULL; portInfoPtr++) { + if (!strcmp(portInfoPtr->name, string)) { + break; + } + } + if (portInfoPtr != NULL && portInfoPtr->name != NULL) { + *portPtr = portInfoPtr->port; + Tcl_ResetResult(interp); + return TCL_OK; + } + + return TCL_ERROR; +} diff --git a/tcl7.6/mac/tclMacTest.c b/tcl7.6/mac/tclMacTest.c new file mode 100644 index 0000000..8f54be9 --- /dev/null +++ b/tcl7.6/mac/tclMacTest.c @@ -0,0 +1,235 @@ +/* + * tclMacTest.c -- + * + * Contains commands for platform specific tests for + * the Macintosh platform. + * + * Copyright (c) 1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclMacTest.c 1.6 96/10/03 14:43:25 + */ + +#define TCL_TEST + +#include "tclInt.h" +#include "tclMacInt.h" +#include "tclMacPort.h" +#include "Files.h" +#include +#include +#include +#include +#include + +/* + * Forward declarations of procedures defined later in this file: + */ + +int TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp)); +static int DebuggerCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int WriteTextResource _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); + + +/* + *---------------------------------------------------------------------- + * + * TclplatformtestInit -- + * + * Defines commands that test platform specific functionality for + * Unix platforms. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Defines new commands. + * + *---------------------------------------------------------------------- + */ + +int +TclplatformtestInit(interp) + Tcl_Interp *interp; /* Interpreter to add commands to. */ +{ + /* + * Add commands for platform specific tests on MacOS here. + */ + + Tcl_CreateCommand(interp, "debugger", DebuggerCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testWriteTextResource", WriteTextResource, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * DebuggerCmd -- + * + * This procedure simply calls the low level debugger. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +DebuggerCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Not used. */ + int argc; /* Not used. */ + char **argv; /* Not used. */ +{ + Debugger(); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * WriteTextResource -- + * + * This procedure will write a text resource out to the + * application or a given file. The format for this command is + * textwriteresource + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +WriteTextResource(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char *errNum = "wrong # args: "; + char *errBad = "bad argument: "; + char *errStr; + char *fileName = NULL, *rsrcName = NULL; + char *data = NULL; + int rsrcID = -1, i; + short fileRef = -1; + OSErr err; + Handle dataHandle; + Str255 resourceName; + FSSpec fileSpec; + + /* + * Process the arguments. + */ + for (i = 1 ; i < argc ; i++) { + if (!strcmp(argv[i], "-rsrc")) { + rsrcName = argv[i + 1]; + i++; + } else if (!strcmp(argv[i], "-rsrcid")) { + rsrcID = atoi(argv[i + 1]); + i++; + } else if (!strcmp(argv[i], "-file")) { + fileName = argv[i + 1]; + i++; + } else { + data = argv[i]; + } + } + + if ((rsrcName == NULL && rsrcID < 0) || + (fileName == NULL) || (data == NULL)) { + errStr = errBad; + goto sourceFmtErr; + } + + /* + * Open the resource file. + */ + err = FSpLocationFromPath(strlen(fileName), fileName, &fileSpec); + if (!(err == noErr || err == fnfErr)) { + Tcl_AppendResult(interp, "couldn't validate file name", (char *) NULL); + return TCL_ERROR; + } + + if (err == fnfErr) { + FSpCreateResFile(&fileSpec, 'WIsH', 'rsrc', smSystemScript); + } + fileRef = FSpOpenResFileCompat(&fileSpec, fsRdWrPerm); + if (fileRef == -1) { + Tcl_AppendResult(interp, "couldn't open resource file", (char *) NULL); + return TCL_ERROR; + } + + UseResFile(fileRef); + + /* + * Prepare data needed to create resource. + */ + if (rsrcID < 0) { + rsrcID = UniqueID('TEXT'); + } + + strcpy((char *) resourceName, rsrcName); + c2pstr((char *) resourceName); + + dataHandle = NewHandle(strlen(data) + 1); + HLock(dataHandle); + strcpy(*dataHandle, data); + HUnlock(dataHandle); + + /* + * Add the resource to the file and close it. + */ + AddResource(dataHandle, 'TEXT', rsrcID, resourceName); + UpdateResFile(fileRef); + CloseResFile(fileRef); + return TCL_OK; + + sourceFmtErr: + Tcl_AppendResult(interp, errStr, "error in \"", argv[0], "\"", + (char *) NULL); + return TCL_ERROR; +} + +int +TclMacChmod( + char *path, + int mode) +{ + HParamBlockRec hpb; + OSErr err; + + c2pstr(path); + hpb.fileParam.ioNamePtr = (unsigned char *) path; + hpb.fileParam.ioVRefNum = 0; + hpb.fileParam.ioDirID = 0; + + if (mode & 0200) { + err = PBHRstFLockSync(&hpb); + } else { + err = PBHSetFLockSync(&hpb); + } + p2cstr((unsigned char *) path); + + if (err != noErr) { + errno = TclMacOSErrorToPosixError(err); + return -1; + } + + return 0; +} + diff --git a/tcl7.6/mac/tclMacTime.c b/tcl7.6/mac/tclMacTime.c new file mode 100644 index 0000000..edd6b5c --- /dev/null +++ b/tcl7.6/mac/tclMacTime.c @@ -0,0 +1,285 @@ +/* + * tclMacTime.c -- + * + * Contains Macintosh specific versions of Tcl functions that + * obtain time values from the operating system. + * + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclMacTime.c 1.13 96/07/25 13:30:46 + */ + +#include "tclInt.h" +#include "tclPort.h" +#include +#include +#include + +/* + * Static variables used by the TclpGetTime function. + */ + +static int initalized = false; +static unsigned long baseSeconds; +static UnsignedWide microOffset; + +/* + * Prototypes for procedures that are private to this file: + */ + +static void SubtractUnsignedWide _ANSI_ARGS_((UnsignedWide *x, + UnsignedWide *y, UnsignedWide *result)); + +/* + *----------------------------------------------------------------------------- + * + * TclpGetSeconds -- + * + * This procedure returns the number of seconds from the epoch. On + * the Macintosh the epoch is Midnight Jan 1, 1904. Unfortunatly, + * the Macintosh doesn't tie the epoch to a paticular time zone. For + * Tcl we tie the epoch to GMT. This makes the time zone date parsing + * code work. The epoch for Mac-Tcl is: Midnight Jan 1, 1904 GMT. + * + * Results: + * Number of seconds from the epoch. + * + * Side effects: + * None. + * + *----------------------------------------------------------------------------- + */ + +unsigned long +TclpGetSeconds() +{ + unsigned long seconds; + MachineLocation loc; + long int offset; + + ReadLocation(&loc); + offset = loc.u.gmtDelta & 0x00ffffff; + if (offset & 0x00800000) { + offset = offset | 0xff000000; + } + + if (ReadDateTime(&seconds) == noErr) { + return (seconds + offset); + } else { + panic("Can't get time."); + return 0; + } +} + +/* + *----------------------------------------------------------------------------- + * + * TclpGetClicks -- + * + * This procedure returns a value that represents the highest resolution + * clock available on the system. There are no garantees on what the + * resolution will be. In Tcl we will call this value a "click". The + * start time is also system dependant. + * + * Results: + * Number of clicks from some start time. + * + * Side effects: + * None. + * + *----------------------------------------------------------------------------- + */ + +unsigned long +TclpGetClicks() +{ + UnsignedWide micros; + + Microseconds(µs); + return micros.lo; +} + +/* + *---------------------------------------------------------------------- + * + * TclpGetTimeZone -- + * + * Get the current time zone. + * + * Results: + * Minutes east of GMT. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclpGetTimeZone (currentTime) + unsigned long currentTime; +{ + MachineLocation loc; + long int offset; + + ReadLocation(&loc); + offset = loc.u.gmtDelta & 0x00ffffff; + if (offset & 0x00700000) { + offset |= 0xff000000; + } + + /* + * Convert the Mac offset from seconds to minutes and + * add an hour if we have daylight savings time. + */ + offset /= 60; + if (loc.u.dlsDelta < 0) { + offset += 60; + } + + return offset; +} + +/* + *---------------------------------------------------------------------- + * + * TclpGetTime -- + * + * Gets the current system time in seconds and microseconds + * since the beginning of the epoch: 00:00 UCT, January 1, 1970. + * + * Results: + * Returns the current time in timePtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclpGetTime(timePtr) + Tcl_Time *timePtr; /* Location to store time information. */ +{ + UnsignedWide micro; + + if (initalized == false) { + if (ReadDateTime(&baseSeconds) != noErr) { + /* + * This should never happen! + */ + return; + } + Microseconds(µOffset); + initalized = true; + } + + Microseconds(µ); + SubtractUnsignedWide(µ, µOffset, µ); + + /* + * This lovely computation is equal to: base + (micro / 1000000) + * For the .hi part the ratio of 0x100000000 / 1000000 has been + * reduced to avoid overflow. This computation certainly has + * problems as the .hi part gets large. However, your application + * would have to run for a long time to make that happen. + */ + timePtr->sec = baseSeconds + (micro.lo / 1000000) + + (long) (micro.hi * ((double) 33554432.0 / 15625.0)); + timePtr->usec = micro.lo % 1000000; +} + +/* + *---------------------------------------------------------------------- + * + * SubtractUnsignedWide -- + * + * Subtracts one UnsignedWide value from another. + * + * Results: + * The subtracted value. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +SubtractUnsignedWide(x, y, result) + UnsignedWide *x; + UnsignedWide *y; + UnsignedWide *result; +{ + result->hi = x->hi - y->hi; + if (x->lo < y->lo) { + result->hi--; + } + result->lo = x->lo - y->lo; +} + +/* + *---------------------------------------------------------------------- + * + * TclpGetDate -- + * + * Converts raw seconds to a struct tm data structure. The + * returned time will be for Grenich Mean Time if the useGMT flag + * is set. Otherwise, the returned time will be for the local + * time zone. This function is meant to be used as a replacement + * for localtime and gmtime which is broken on most ANSI libs + * on the Macintosh. + * + * Results: + * None. + * + * Side effects: + * The passed in struct tm data structure is modified. + * + *---------------------------------------------------------------------- + */ + +struct tm * +TclpGetDate(tp, useGMT) + const time_t *tp; + int useGMT; +{ + DateTimeRec dtr; + MachineLocation loc; + long int offset; + static struct tm statictime; + static const short monthday[12] = + {0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334}; + + ReadLocation(&loc); + + if (useGMT) { + SecondsToDate(*tp, &dtr); + } else { + offset = loc.u.gmtDelta & 0x00ffffff; + if (offset & 0x00700000) { + offset |= 0xff000000; + } + + SecondsToDate(*tp - offset, &dtr); + } + + statictime.tm_sec = dtr.second; + statictime.tm_min = dtr.minute; + statictime.tm_hour = dtr.hour; + statictime.tm_mday = dtr.day; + statictime.tm_mon = dtr.month - 1; + statictime.tm_year = dtr.year - 1900; + statictime.tm_wday = dtr.dayOfWeek - 1; + statictime.tm_yday = monthday[statictime.tm_mon] + + statictime.tm_mday - 1; + if (1 < statictime.tm_mon && !(statictime.tm_year & 3)) { + ++statictime.tm_yday; + } + statictime.tm_isdst = loc.u.dlsDelta; + return(&statictime); +} + diff --git a/tcl7.6/mac/tclMacUnix.c b/tcl7.6/mac/tclMacUnix.c new file mode 100644 index 0000000..074bc10 --- /dev/null +++ b/tcl7.6/mac/tclMacUnix.c @@ -0,0 +1,660 @@ +/* + * tclMacUnix.c -- + * + * This file contains routines to implement several features + * available to the Unix implementation, but that require + * extra work to do on a Macintosh. These include routines + * Unix Tcl normally hands off to the Unix OS. + * + * Copyright (c) 1993-1994 Lockheed Missle & Space Company, AI Center + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclMacUnix.c 1.55 96/09/14 19:14:17 + */ + +#include +#include +#include +#include +#include +#include +#include + +#include "tclInt.h" +#include "tclMacInt.h" + +/* + * The following two Includes are from the More Files package + */ +#include "FileCopy.h" +#include "MoreFiles.h" +#include "MoreFilesExtras.h" + +/* + * The following may not be defined in some versions of + * MPW header files. + */ +#ifndef kIsInvisible +#define kIsInvisible 0x4000 +#endif +#ifndef kIsAlias +#define kIsAlias 0x8000 +#endif + +/* + * Missing error codes + */ +#define usageErr 500 +#define noSourceErr 501 +#define isDirErr 502 + +/* + * Static functions in this file. + */ + +static int GlobArgs _ANSI_ARGS_((Tcl_Interp *interp, + int *argc, char ***argv)); + +/* + *---------------------------------------------------------------------- + * + * GlobArgs -- + * + * The following function was taken from Peter Keleher's Alpha + * Editor. *argc should only count the end arguments that should + * be globed. argv should be incremented to point to the first + * arg to be globed. + * + * Results: + * Returns 'true' if it worked & memory was allocated, else 'false'. + * + * Side effects: + * argv will be alloced, the call will need to release the memory + * + *---------------------------------------------------------------------- + */ + +static int +GlobArgs( + Tcl_Interp *interp, /* Tcl interpreter. */ + int *argc, /* Number of arguments. */ + char ***argv) /* Argument strings. */ +{ + int res, len; + char *list; + + /* + * Places the globbed args all into 'interp->result' as a list. + */ + res = Tcl_GlobCmd(NULL, interp, *argc + 1, *argv - 1); + if (res != TCL_OK) { + return false; + } + len = strlen(interp->result); + list = (char *) ckalloc(len + 1); + strcpy(list, interp->result); + Tcl_ResetResult(interp); + + res = Tcl_SplitList(interp, list, argc, argv); + ckfree((char *) list); + if (res != TCL_OK) { + return false; + } + return true; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CpCmd -- + * + * This procedure is invoked to process the "cp" Tcl command. + * See the user documentation for the "file copy" command for + * details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ +int +Tcl_CpCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + char **argv) /* Argument strings. */ +{ + return TclFileCopyCmd(interp, argc-1, argv+1); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_EchoCmd -- + * + * Implements the TCL echo command: + * echo ?str ...? + * + * Results: + * Always returns TCL_OK. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_EchoCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + char **argv) /* Argument strings. */ +{ + Tcl_Channel chan; + int mode, result, i; + + chan = Tcl_GetChannel(interp, "stdout", &mode); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + for (i = 1; i < argc; i++) { + result = Tcl_Write(chan, argv[i], -1); + if (result < 0) { + Tcl_AppendResult(interp, "echo: ", Tcl_GetChannelName(chan), + ": ", Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + if (i < (argc - 1)) { + Tcl_Write(chan, " ", -1); + } + } + Tcl_Write(chan, "\n", -1); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LsCmd -- + * + * This procedure is invoked to process the "ls" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ +int +Tcl_LsCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + char **argv) /* Argument strings. */ +{ +#define STRING_LENGTH 80 +#define CR '\n' + int i, j; + int fieldLength, len = 0, maxLen = 0, perLine; + char **origArgv = argv; + OSErr err; + CInfoPBRec paramBlock; + HFileInfo *hpb = (HFileInfo *)¶mBlock; + DirInfo *dpb = (DirInfo *)¶mBlock; + char theFile[256]; + char theLine[STRING_LENGTH + 2]; + int fFlag = false, pFlag = false, aFlag = false, lFlag = false, + cFlag = false, hFlag = false; + + /* + * Process command flags. End if argument doesn't start + * with a dash or is a dash by itself. The remaining arguments + * should be files. + */ + for (i = 1; i < argc; i++) { + if (argv[i][0] != '-') { + break; + } + + if (!strcmp(argv[i], "-")) { + i++; + break; + } + + for (j = 1 ; argv[i][j] ; ++j) { + switch(argv[i][j]) { + case 'a': + case 'A': + aFlag = true; + break; + case '1': + cFlag = false; + break; + case 'C': + cFlag = true; + break; + case 'F': + fFlag = true; + break; + case 'H': + hFlag = true; + break; + case 'p': + pFlag = true; + break; + case 'l': + pFlag = false; + lFlag = true; + break; + default: + Tcl_AppendResult(interp, "error - unknown flag ", + "usage: ls -apCFHl1 ?files? ", NULL); + return TCL_ERROR; + } + } + } + + argv += i; + argc -= i; + + /* + * No file specifications means we search for all files. + * Glob will be doing most of the work. + */ + if (!argc) { + argc = 1; + argv = origArgv; + strcpy(argv[0], "*"); + } + + if (!GlobArgs(interp, &argc, &argv)) { + Tcl_ResetResult(interp); + return TCL_ERROR; + } + + /* + * There are two major methods for listing files: the long + * method and the normal method. + */ + if (lFlag) { + char creator[5], type[5], time[16], date[16]; + char lineTag; + long size; + unsigned short flags; + + /* + * Print the header for long listing. + */ + if (hFlag) { + sprintf(theLine, "T %7s %8s %8s %4s %4s %6s %s", + "Size", "ModTime", "ModDate", + "CRTR", "TYPE", "Flags", "Name"); + Tcl_AppendResult(interp, theLine, "\n", NULL); + Tcl_AppendResult(interp, + "-------------------------------------------------------------\n", + NULL); + } + + for (i = 0; i < argc; i++) { + strcpy(theFile, argv[i]); + + c2pstr(theFile); + hpb->ioCompletion = NULL; + hpb->ioVRefNum = 0; + hpb->ioFDirIndex = 0; + hpb->ioNamePtr = (StringPtr) theFile; + hpb->ioDirID = 0L; + err = PBGetCatInfoSync(¶mBlock); + p2cstr((StringPtr) theFile); + + if (hpb->ioFlAttrib & 16) { + /* + * For directories use zero as the size, use no Creator + * type, and use 'DIR ' as the file type. + */ + if ((aFlag == false) && (dpb->ioDrUsrWds.frFlags & 0x1000)) { + continue; + } + lineTag = 'D'; + size = 0; + IUTimeString(dpb->ioDrMdDat, false, (unsigned char *)time); + p2cstr((StringPtr)time); + IUDateString(dpb->ioDrMdDat, shortDate, (unsigned char *)date); + p2cstr((StringPtr)date); + strcpy(creator, " "); + strcpy(type, "DIR "); + flags = dpb->ioDrUsrWds.frFlags; + if (fFlag || pFlag) { + strcat(theFile, ":"); + } + } else { + /* + * All information for files should be printed. This + * includes size, modtime, moddate, creator type, file + * type, flags, anf file name. + */ + if ((aFlag == false) && + (hpb->ioFlFndrInfo.fdFlags & kIsInvisible)) { + continue; + } + lineTag = 'F'; + size = hpb->ioFlLgLen + hpb->ioFlRLgLen; + IUTimeString(hpb->ioFlMdDat, false, (unsigned char *)time); + p2cstr((StringPtr)time); + IUDateString(hpb->ioFlMdDat, shortDate, (unsigned char *)date); + p2cstr((StringPtr)date); + strncpy(creator, (char *) &hpb->ioFlFndrInfo.fdCreator, 4); + creator[4] = 0; + strncpy(type, (char *) &hpb->ioFlFndrInfo.fdType, 4); + type[4] = 0; + flags = hpb->ioFlFndrInfo.fdFlags; + if (fFlag) { + if (hpb->ioFlFndrInfo.fdFlags & kIsAlias) { + strcat(theFile, "@"); + } else if (hpb->ioFlFndrInfo.fdType == 'APPL') { + strcat(theFile, "*"); + } + } + } + + sprintf(theLine, "%c %7ld %8s %8s %-4.4s %-4.4s 0x%4.4X %s", + lineTag, size, time, date, creator, type, flags, theFile); + + Tcl_AppendResult(interp, theLine, "\n", NULL); + + } + + if ((interp->result != NULL) && (*(interp->result) != '\0')) { + int slen = strlen(interp->result); + if (interp->result[slen - 1] == '\n') { + interp->result[slen - 1] = '\0'; + } + } + } else { + /* + * Not in long format. We only print files names. If the + * -C flag is set we need to print in multiple coloumns. + */ + int argCount, linePos; + Boolean needNewLine = false; + + /* + * Fiend the field length: the length each string printed + * to the terminal will be. + */ + if (!cFlag) { + perLine = 1; + fieldLength = STRING_LENGTH; + } else { + for (i = 0; i < argc; i++) { + len = strlen(argv[i]); + if (len > maxLen) { + maxLen = len; + } + } + fieldLength = maxLen + 3; + perLine = STRING_LENGTH / fieldLength; + } + + argCount = 0; + linePos = 0; + memset(theLine, ' ', STRING_LENGTH); + while (argCount < argc) { + strcpy(theFile, argv[argCount]); + + c2pstr(theFile); + hpb->ioCompletion = NULL; + hpb->ioVRefNum = 0; + hpb->ioFDirIndex = 0; + hpb->ioNamePtr = (StringPtr) theFile; + hpb->ioDirID = 0L; + err = PBGetCatInfoSync(¶mBlock); + p2cstr((StringPtr) theFile); + + if (hpb->ioFlAttrib & 16) { + /* + * Directory. If -a show hidden files. If -f or -p + * denote that this is a directory. + */ + if ((aFlag == false) && (dpb->ioDrUsrWds.frFlags & 0x1000)) { + argCount++; + continue; + } + if (fFlag || pFlag) { + strcat(theFile, ":"); + } + } else { + /* + * File: If -a show hidden files, if -f show links + * (aliases) and executables (APPLs). + */ + if ((aFlag == false) && + (hpb->ioFlFndrInfo.fdFlags & kIsInvisible)) { + argCount++; + continue; + } + if (fFlag) { + if (hpb->ioFlFndrInfo.fdFlags & kIsAlias) { + strcat(theFile, "@"); + } else if (hpb->ioFlFndrInfo.fdType == 'APPL') { + strcat(theFile, "*"); + } + } + } + + /* + * Print the item, taking into account multi- + * coloum output. + */ + strncpy(theLine + (linePos * fieldLength), theFile, + strlen(theFile)); + linePos++; + + if (linePos == perLine) { + theLine[STRING_LENGTH] = '\0'; + if (needNewLine) { + Tcl_AppendResult(interp, "\n", theLine, NULL); + } else { + Tcl_AppendResult(interp, theLine, NULL); + needNewLine = true; + } + linePos = 0; + memset(theLine, ' ', STRING_LENGTH); + } + + argCount++; + } + + if (linePos != 0) { + theLine[STRING_LENGTH] = '\0'; + if (needNewLine) { + Tcl_AppendResult(interp, "\n", theLine, NULL); + } else { + Tcl_AppendResult(interp, theLine, NULL); + } + } + } + + ckfree((char *) argv); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_MkdirCmd -- + * + * This procedure is invoked to process the "mkdir" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ +int +Tcl_MkdirCmd ( + 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], + " path ?path ...?", (char *) NULL); + return TCL_ERROR; + } + + if ((argc > 2) && (!strcmp(argv[1], "-path"))) { + argv++; + argc--; + } + + return TclFileMakeDirsCmd(interp, argc-1, argv+1); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_MvCmd -- + * + * This procedure is invoked to process the "cp" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_MvCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + char **argv) /* Argument strings. */ +{ + return TclFileRenameCmd(interp, argc-1, argv+1); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RmCmd -- + * + * This procedure is invoked to process the "rm" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_RmCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + char **argv) /* Argument strings. */ +{ + int newArgc, result; + char **newArgv; + char *list; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: ", argv[0], + " ?-force? path ?path ...?", (char *) NULL); + return TCL_ERROR; + } + if ((argc > 2) && (!strcmp(argv[1], "-nocomplain"))) { + argv++; + argc--; + } + + if ((argc > 2) && (!strcmp(argv[1], "-force"))) { + result = Tcl_GlobCmd(NULL, interp, argc + 1, argv - 1); + if (result != TCL_OK) { + return result; + } + list = (char *) ckalloc(strlen(interp->result) + strlen("-force ") + 1); + strcpy(list, "-force "); + strcpy(list + strlen("-force "), interp->result); + Tcl_ResetResult(interp); + + result = Tcl_SplitList(interp, list, &newArgc, &newArgv); + ckfree((char *) list); + if (result != TCL_OK) { + return result; + } + + result = TclFileDeleteCmd(interp, newArgc, newArgv); + ckfree((char *) newArgv); + } else { + newArgc = argc-1; + newArgv = argv+1; + if (!GlobArgs(interp, &newArgc, &newArgv)) { + return TCL_OK; + } + result = TclFileDeleteCmd(interp, newArgc, newArgv); + ckfree((char *) newArgv); + } + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RmdirCmd -- + * + * Implements the Tcl rmdir command: + * + * Results: + * Standard TCL results, may return the UNIX system error message. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_RmdirCmd (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: ", argv[0], + " ?-force? path ?path ...?", (char *) NULL); + return TCL_ERROR; + } + if ((argc > 2) && (!strcmp(argv[1], "-nocomplain"))) { + argv++; + argc--; + } + + return TclFileDeleteCmd(interp, argc-1, argv+1); +} diff --git a/tcl7.6/mac/tclMacUtil.c b/tcl7.6/mac/tclMacUtil.c new file mode 100644 index 0000000..2dda356 --- /dev/null +++ b/tcl7.6/mac/tclMacUtil.c @@ -0,0 +1,438 @@ +/* + * tclMacUtil.c -- + * + * This contains utility functions used to help with + * implementing Macintosh specific portions of the Tcl port. + * + * Copyright (c) 1993-1994 Lockheed Missle & Space Company, AI Center + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclMacUtil.c 1.50 96/10/04 05:07:15 + */ + +#include "tcl.h" +#include "tclInt.h" +#include "tclMacInt.h" +#include + +#include +#include +#include +#include +#include +#include +#include +#include + +/* + * The following two Includes are from the More Files package. + */ +#include +#include + +/* + *---------------------------------------------------------------------- + * + * hypot -- + * + * The standard math function hypot is not supported by Think C. + * It is included here so everything works. + * + * Results: + * Result of computation. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#if defined(THINK_C) || GENERATING68K +double hypot(double x, double y); + +double +hypot( + double x, /* X value */ + double y) /* Y value */ +{ + double sum; + + sum = x*x + y*y; + return sqrt(sum); +} +#endif + +/* + *---------------------------------------------------------------------- + * + * FSpGetDefaultDir -- + * + * This function gets the current default directory. + * + * Results: + * The provided FSSpec is changed to point to the "default" + * directory. The function returns what ever errors + * FSMakeFSSpecCompat may encounter. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +FSpGetDefaultDir( + FSSpecPtr dirSpec) /* On return the default directory. */ +{ + OSErr err; + short vRefNum = 0; + long int dirID = 0; + + err = HGetVol(NULL, &vRefNum, &dirID); + + if (err == noErr) { + err = FSMakeFSSpecCompat(vRefNum, dirID, (ConstStr255Param) NULL, + dirSpec); + } + + return err; +} + +/* + *---------------------------------------------------------------------- + * + * FSpSetDefaultDir -- + * + * This function sets the default directory to the directory + * pointed to by the provided FSSpec. + * + * Results: + * The function returns what ever errors HSetVol may encounter. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +FSpSetDefaultDir( + FSSpecPtr dirSpec) /* The new default directory. */ +{ + OSErr err; + + /* + * The following special case is needed to work around a bug + * in the Macintosh OS. (Acutally PC Exchange.) + */ + + if (dirSpec->parID == fsRtParID) { + err = HSetVol(NULL, dirSpec->vRefNum, fsRtDirID); + } else { + err = HSetVol(dirSpec->name, dirSpec->vRefNum, dirSpec->parID); + } + + return err; +} + +/* + *---------------------------------------------------------------------- + * + * FSpFindFolder -- + * + * This function is a version of the FindFolder function that + * returns the result as a FSSpec rather than a vRefNum and dirID. + * + * Results: + * Results will be simaler to that of the FindFolder function. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +OSErr +FSpFindFolder( + short vRefNum, /* Volume reference number. */ + OSType folderType, /* Folder type taken by FindFolder. */ + Boolean createFolder, /* Should we create it if non-existant. */ + FSSpec *spec) /* Pointer to resulting directory. */ +{ + short foundVRefNum; + long foundDirID; + OSErr err; + + err = FindFolder(vRefNum, folderType, createFolder, + &foundVRefNum, &foundDirID); + if (err != noErr) { + return err; + } + + err = FSMakeFSSpecCompat(foundVRefNum, foundDirID, "\p", spec); + return err; +} + +/* + *---------------------------------------------------------------------- + * + * FSpLocationFromPath -- + * + * This function obtains an FSSpec for a given macintosh path. + * Unlike the More Files function FSpLocationFromFullPath, this + * function will also accept partial paths and resolve any aliases + * along the path. + * + * Results: + * OSErr code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +FSpLocationFromPath( + int length, /* Length of path. */ + char *path, /* The path to convert. */ + FSSpecPtr fileSpecPtr) /* On return the spec for the path. */ +{ + Str255 fileName; + OSErr err; + short vRefNum; + long dirID; + int pos, cur; + Boolean isDirectory; + Boolean wasAlias; + + /* + * Check to see if this is a full path. If partial + * we assume that path starts with the current working + * directory. (Ie. volume & dir = 0) + */ + vRefNum = 0; + dirID = 0; + cur = 0; + if (length == 0) { + return fnfErr; + } + if (path[cur] == ':') { + cur++; + if (cur >= length) { + /* + * If path = ":", just return current directory. + */ + FSMakeFSSpecCompat(0, 0, NULL, fileSpecPtr); + return noErr; + } + } else { + while (path[cur] != ':' && cur < length) { + cur++; + } + if (cur > 255) { + return bdNamErr; + } + if (cur < length) { + /* + * This is a full path + */ + cur++; + strncpy((char *) fileName + 1, path, cur); + fileName[0] = cur; + err = FSMakeFSSpecCompat(0, 0, fileName, fileSpecPtr); + if (err != noErr) return err; + FSpGetDirectoryID(fileSpecPtr, &dirID, &isDirectory); + vRefNum = fileSpecPtr->vRefNum; + } else { + cur = 0; + } + } + + isDirectory = 1; + while (cur < length) { + if (!isDirectory) { + return dirNFErr; + } + pos = cur; + while (path[pos] != ':' && pos < length) { + pos++; + } + if (pos == cur) { + /* Move up one dir */ + /* cur++; */ + strcpy((char *) fileName + 1, "::"); + fileName[0] = 2; + } else if (pos - cur > 255) { + return bdNamErr; + } else { + strncpy((char *) fileName + 1, &path[cur], pos - cur); + fileName[0] = pos - cur; + } + err = FSMakeFSSpecCompat(vRefNum, dirID, fileName, fileSpecPtr); + if (err != noErr) return err; + err = ResolveAliasFile(fileSpecPtr, true, &isDirectory, &wasAlias); + if (err != noErr) return err; + FSpGetDirectoryID(fileSpecPtr, &dirID, &isDirectory); + vRefNum = fileSpecPtr->vRefNum; + cur = pos; + if (path[cur] == ':') { + cur++; + } + } + + return noErr; +} + +/* + *---------------------------------------------------------------------- + * + * FSpPathFromLocation -- + * + * This function obtains a full path name for a given macintosh + * FSSpec. Unlike the More Files function FSpGetFullPath, this + * function will return a C string in the Handle. It also will + * create paths for FSSpec that do not yet exist. + * + * Results: + * OSErr code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +OSErr +FSpPathFromLocation( + FSSpec *spec, /* The location we want a path for. */ + int *length, /* Length of the resulting path. */ + Handle *fullPath) /* Handle to path. */ +{ + OSErr err; + FSSpec tempSpec; + CInfoPBRec pb; + + *fullPath = NULL; + + /* + * Make a copy of the input FSSpec that can be modified. + */ + BlockMoveData(spec, &tempSpec, sizeof(FSSpec)); + + if (tempSpec.parID == fsRtParID) { + /* + * The object is a volume. Add a colon to make it a full + * pathname. Allocate a handle for it and we are done. + */ + tempSpec.name[0] += 2; + tempSpec.name[tempSpec.name[0] - 1] = ':'; + tempSpec.name[tempSpec.name[0]] = '\0'; + + err = PtrToHand(&tempSpec.name[1], fullPath, tempSpec.name[0]); + } else { + /* + * The object isn't a volume. Is the object a file or a directory? + */ + pb.dirInfo.ioNamePtr = tempSpec.name; + pb.dirInfo.ioVRefNum = tempSpec.vRefNum; + pb.dirInfo.ioDrDirID = tempSpec.parID; + pb.dirInfo.ioFDirIndex = 0; + err = PBGetCatInfoSync(&pb); + + if ((err == noErr) || (err == fnfErr)) { + /* + * If the file doesn't currently exist we start over. If the + * directory exists everything will work just fine. Otherwise we + * will just fail later. If the object is a directory, append a + * colon so full pathname ends with colon. + */ + if (err == fnfErr) { + BlockMoveData(spec, &tempSpec, sizeof(FSSpec)); + } else if ( (pb.hFileInfo.ioFlAttrib & ioDirMask) != 0 ) { + tempSpec.name[0] += 1; + tempSpec.name[tempSpec.name[0]] = ':'; + } + + /* + * Create a new Handle for the object - make it a C string. + */ + tempSpec.name[0] += 1; + tempSpec.name[tempSpec.name[0]] = '\0'; + err = PtrToHand(&tempSpec.name[1], fullPath, tempSpec.name[0]); + if (err == noErr) { + /* + * Get the ancestor directory names - loop until we have an + * error or find the root directory. + */ + pb.dirInfo.ioNamePtr = tempSpec.name; + pb.dirInfo.ioVRefNum = tempSpec.vRefNum; + pb.dirInfo.ioDrParID = tempSpec.parID; + do { + pb.dirInfo.ioFDirIndex = -1; + pb.dirInfo.ioDrDirID = pb.dirInfo.ioDrParID; + err = PBGetCatInfoSync(&pb); + if (err == noErr) { + /* + * Append colon to directory name and add + * directory name to beginning of fullPath. + */ + ++tempSpec.name[0]; + tempSpec.name[tempSpec.name[0]] = ':'; + + (void) Munger(*fullPath, 0, NULL, 0, &tempSpec.name[1], + tempSpec.name[0]); + err = MemError(); + } + } while ( (err == noErr) && + (pb.dirInfo.ioDrDirID != fsRtDirID) ); + } + } + } + + /* + * On error Dispose the handle, set it to NULL & return the err. + * Otherwise, set the length & return. + */ + if (err == noErr) { + *length = GetHandleSize(*fullPath) - 1; + } else { + if ( *fullPath != NULL ) { + DisposeHandle(*fullPath); + } + *fullPath = NULL; + *length = 0; + } + + return err; +} + +/* + *---------------------------------------------------------------------- + * + * GetGlobalMouse -- + * + * This procedure obtains the current mouse position in global + * coordinates. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +GetGlobalMouse( + Point *mouse) /* Mouse position. */ +{ + EventRecord event; + + OSEventAvail(0, &event); + *mouse = event.where; +} diff --git a/tcl7.3/tests/README b/tcl7.6/tests/README similarity index 93% rename from tcl7.3/tests/README rename to tcl7.6/tests/README index 593174a..7dce2a2 100644 --- a/tcl7.3/tests/README +++ b/tcl7.6/tests/README @@ -1,6 +1,8 @@ Tcl Test Suite -------------- +SCCS: @(#) README 1.6 96/04/17 10:51:11 + 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 @@ -8,14 +10,15 @@ 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. + (a) type "make test" in ../unix; 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. +messages will appear in the format described below. Note: don't +run the tests as superuser, since this will cause several of the tests +to fail. The rest of this file provides additional information on the features of the testing environment. diff --git a/tcl7.3/tests/all b/tcl7.6/tests/all similarity index 53% rename from tcl7.3/tests/all rename to tcl7.6/tests/all index 890e9a2..b50794c 100644 --- a/tcl7.3/tests/all +++ b/tcl7.6/tests/all @@ -2,9 +2,15 @@ # 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) +# SCCS: @(#) all 1.7 96/02/16 08:55:38 foreach i [lsort [glob *.test]] { + if [string match l.*.test $i] { + # This is an SCCS lock file; ignore it. + continue + } puts stdout $i - source $i + if [catch {source $i} msg] { + puts $msg + } } diff --git a/tcl7.3/tests/append.test b/tcl7.6/tests/append.test similarity index 63% rename from tcl7.3/tests/append.test rename to tcl7.6/tests/append.test index e7f86b5..2be7194 100644 --- a/tcl7.3/tests/append.test +++ b/tcl7.6/tests/append.test @@ -5,26 +5,12 @@ # 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. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) append.test 1.14 96/04/05 15:28:42 if {[string compare test [info procs test]] == 1} then {source defs} @@ -37,6 +23,10 @@ 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-1.3 {append command} { + set x "abcd" + append x +} abcd test append-2.1 {long appends} { set x "" @@ -52,14 +42,15 @@ test append-2.1 {long appends} { test append-3.1 {append errors} { list [catch {append} msg] $msg -} {1 {wrong # args: should be "append varName value ?value ...?"}} +} {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-3.3 {append errors} { + catch {unset x} + list [catch {append x} msg] $msg +} {1 {can't read "x": no such variable}} test append-4.1 {lappend command} { catch {unset x} @@ -80,14 +71,58 @@ test append-4.3 {lappend command} { rename foo {} set result } {new} -test append-4.3 {lappend command} { +test append-4.4 {lappend command} { set x {} lappend x \{\ abc } {\{\ abc} -test append-4.3 {lappend command} { +test append-4.5 {lappend command} { set x {} lappend x \{ abc } {\{ abc} +test append-4.6 {lappend command} { + set x {1 2 3} + lappend x +} {1 2 3} +test append-4.7 {lappend command} { + set x "a\{" + lappend x abc +} "a{ abc" +test append-4.8 {lappend command} { + set x "\\\{" + lappend x abc +} "\\{ abc" +test append-4.9 {lappend command} { + set x " \{" + lappend x abc +} " {abc" +test append-4.10 {lappend command} { + set x " \{" + lappend x abc +} " {abc" +test append-4.11 {lappend command} { + set x "\{\{\{" + lappend x abc +} "{{{abc" +test append-4.12 {lappend command} { + set x "x \{\{\{" + lappend x abc +} "x {{{abc" +test append-4.13 {lappend command} { + set x "x\{\{\{" + lappend x abc +} "x{{{ abc" +test append-4.14 {lappend command} { + set x " " + lappend x abc +} " abc" +test append-4.15 {lappend command} { + set x "\\ " + lappend x abc +} "\\ abc" +test append-4.16 {lappend command} { + set x "x " + lappend x abc +} "x abc" proc check {var size} { set l [llength $var] @@ -97,7 +132,7 @@ proc check {var size} { 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 "element $i should have been \"item $i\", was \"$j\"" } } return ok @@ -112,11 +147,12 @@ test append-5.1 {long lappends} { test append-6.1 {lappend errors} { list [catch {lappend} msg] $msg -} {1 {wrong # args: should be "lappend varName value ?value ...?"}} +} {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}} +test append-6.3 {lappend errors} { + catch {unset x} + list [catch {lappend x} msg] $msg +} {1 {can't read "x": no such variable}} diff --git a/tcl7.6/tests/assocd.test b/tcl7.6/tests/assocd.test new file mode 100644 index 0000000..20e8223 --- /dev/null +++ b/tcl7.6/tests/assocd.test @@ -0,0 +1,57 @@ +# This file tests the AssocData facility of Tcl +# +# 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-1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# "@(#) assocd.test 1.5 95/08/02 17:11:37" + +if {[string compare test [info procs test]] == 1} then {source defs} + +if {[string compare testsetassocdata [info commands testsetassocdata]] != 0} { + puts "This application hasn't been compiled with the tests for assocData," + puts "therefore I am skipping all of these tests." + return +} + +test assocd-1.1 {testing setting assoc data} { + testsetassocdata a 1 +} "" +test assocd-1.2 {testing setting assoc data} { + testsetassocdata a 2 +} "" +test assocd-1.3 {testing setting assoc data} { + testsetassocdata 123 456 +} "" +test assocd-1.4 {testing setting assoc data} { + testsetassocdata abc "abc d e f" +} "" + +test assocd-2.1 {testing getting assoc data} { + testgetassocdata a +} 2 +test assocd-2.2 {testing getting assoc data} { + testgetassocdata 123 +} 456 +test assocd-2.3 {testing getting assoc data} { + testgetassocdata abc +} {abc d e f} +test assocd-2.4 {testing getting assoc data} { + testgetassocdata xxx +} "" + +test assocd-3.1 {testing deleting assoc data} { + testdelassocdata a +} "" +test assocd-3.2 {testing deleting assoc data} { + testdelassocdata 123 +} "" +test assocd-3.3 {testing deleting assoc data} { + list [catch {testdelassocdata nonexistent} msg] $msg +} {0 {}} diff --git a/tcl7.3/tests/async.test b/tcl7.6/tests/async.test similarity index 76% rename from tcl7.3/tests/async.test rename to tcl7.6/tests/async.test index dc11c24..cfc572c 100644 --- a/tcl7.3/tests/async.test +++ b/tcl7.6/tests/async.test @@ -5,26 +5,12 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1993 The Regents of the University of California. -# All rights reserved. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) async.test 1.5 96/04/05 15:29:38 if {[info commands testasync] == {}} { puts "This application hasn't been compiled with the \"testasync\"" diff --git a/tcl7.3/tests/case.test b/tcl7.6/tests/case.test similarity index 50% rename from tcl7.3/tests/case.test rename to tcl7.6/tests/case.test index 6b1cb4a..9224372 100644 --- a/tcl7.3/tests/case.test +++ b/tcl7.6/tests/case.test @@ -5,55 +5,12 @@ # 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. +# Copyright (c) 1994 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) case.test 1.13 96/02/16 08:55:41 if {[string compare test [info procs test]] == 1} then {source defs} diff --git a/tcl7.6/tests/clock.test b/tcl7.6/tests/clock.test new file mode 100644 index 0000000..9d077fd --- /dev/null +++ b/tcl7.6/tests/clock.test @@ -0,0 +1,108 @@ +# Commands covered: clock +# +# 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) 1995-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) clock.test 1.7 96/08/27 13:06:42 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test clock-1.1 {clock tests} { + list [catch {clock} msg] $msg +} {1 {wrong # args: should be "clock option ?arg ...?"}} +test clock-1.2 {clock tests} { + list [catch {clock foo} msg] $msg +} {1 {unknown option "foo": must be clicks, format, scan, or seconds}} + +# clock clicks +test clock-2.1 {clock clicks tests} { + expr [clock clicks]+1 + concat {} +} {} +test clock-2.2 {clock clicks tests} { + list [catch {clock clicks foo} msg] $msg +} {1 {wrong # arguments: must be "clock clicks"}} +test clock-2.3 {clock clicks tests} { + set start [clock clicks] + after 10 + set end [clock clicks] + expr "$end > $start" +} {1} + +# clock format +test clock-3.1 {clock format tests} {unixOnly} { + set clockval 657687766 + clock format $clockval -format {%a %b %d %I:%M:%S %p %Y} -gmt true +} {Sun Nov 04 03:02:46 AM 1990} +test clock-3.2 {clock format tests} { + list [catch {clock format} msg] $msg +} {1 {wrong # args: clock format clockval ?-format string? ?-gmt boolean?}} +test clock-3.3 {clock format tests} { + list [catch {clock format foo} msg] $msg +} {1 {expected unsigned time but got "foo"}} +test clock-3.4 {clock format tests} {unixOrPc} { + set clockval 657687766 + clock format $clockval -format "%a %b %d %I:%M:%S %p %Y" -gmt true +} "Sun Nov 04 03:02:46 AM 1990" +test clock-3.5 {clock format tests} { + list [catch {clock format a b c d e g} msg] $msg +} {1 {wrong # args: clock format clockval ?-format string? ?-gmt boolean?}} +test clock-3.6 {clock format tests} {unixOrPc nonPortable} { + set clockval -1 + clock format $clockval -format "%a %b %d %I:%M:%S %p %Y" -gmt true +} "Wed Dec 31 11:59:59 PM 1969" + +# clock scan +test clock-4.1 {clock scan tests} { + list [catch {clock scan} msg] $msg +} {1 {wrong # args: clock scan dateString ?-base clockValue? ?-gmt boolean?}} +test clock-4.2 {clock scan tests} { + list [catch {clock scan "bad-string"} msg] $msg +} {1 {unable to convert date-time string "bad-string"}} +test clock-4.3 {clock scan tests} { + clock format [clock scan "14 Feb 92" -gmt true] \ + -format {%m/%d/%y %I:%M:%S %p} -gmt true +} {02/14/92 12:00:00 AM} +test clock-4.4 {clock scan tests} { + clock format [clock scan "Feb 14, 1992 12:20 PM" -gmt true] \ + -format {%m/%d/%y %I:%M:%S %p} -gmt true +} {02/14/92 12:20:00 PM} +test clock-4.5 {clock scan tests} { + clock format \ + [clock scan "Feb 14, 1992 12:20 PM" -base 319363200 -gmt true] \ + -format {%m/%d/%y %I:%M:%S %p} -gmt true +} {02/14/92 12:20:00 PM} +test clock-4.6 {clock scan tests} { + set time [clock scan "Oct 23,1992 15:00"] + clock format $time -format {%b %d,%Y %H:%M} +} {Oct 23,1992 15:00} +test clock-4.7 {clock scan tests} { + set time [clock scan "Oct 23,1992 15:00 GMT"] + clock format $time -format {%b %d,%Y %H:%M GMT} -gmt true +} {Oct 23,1992 15:00 GMT} +test clock-4.8 {clock scan tests} { + set time [clock scan "Oct 23,1992 15:00" -gmt true] + clock format $time -format {%b %d,%Y %H:%M GMT} -gmt true +} {Oct 23,1992 15:00 GMT} + +# clock seconds +test clock-5.1 {clock seconds tests} { + expr [clock seconds]+1 + concat {} +} {} +test clock-5.2 {clock seconds tests} { + list [catch {clock seconds foo} msg] $msg +} {1 {wrong # arguments: must be "clock seconds"}} +test clock-5.3 {clock seconds tests} { + set start [clock seconds] + after 2000 + set end [clock seconds] + expr "$end > $start" +} {1} + diff --git a/tcl7.6/tests/cmdAH.test b/tcl7.6/tests/cmdAH.test new file mode 100644 index 0000000..e5f034f --- /dev/null +++ b/tcl7.6/tests/cmdAH.test @@ -0,0 +1,1148 @@ +# The file tests the tclCmdAH.c 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) 1996 by Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) cmdAH.test 1.13 96/10/08 15:55:00 + +if {[string compare test [info procs test]] == 1} then {source defs} + +global env +set platform [testgetplatform] + +test cmdah-1.1 {Tcl_FileCmd} { + list [catch file msg] $msg +} {1 {wrong # args: should be "file option name ?arg ...?"}} +test cmdah-1.2 {Tcl_FileCmd} { + list [catch {file x} msg] $msg +} {1 {wrong # args: should be "file option name ?arg ...?"}} + +# dirname + +test cmdah-2.1 {Tcl_FileCmd: dirname} { + testsetplatform unix + list [catch {file dirname a b} msg] $msg +} {1 {wrong # args: should be "file dirname name"}} +test cmdah-2.2 {Tcl_FileCmd: dirname} { + testsetplatform unix + file dirname /a/b +} /a +test cmdah-2.3 {Tcl_FileCmd: dirname} { + testsetplatform unix + file dirname {} +} . +test cmdah-2.4 {Tcl_FileCmd: dirname} { + testsetplatform mac + file dirname {} +} : +test cmdah-2.5 {Tcl_FileCmd: dirname} { + testsetplatform win + file dirname {} +} . +test cmdah-2.6 {Tcl_FileCmd: dirname} { + testsetplatform unix + file dirname .def +} . +test cmdah-2.7 {Tcl_FileCmd: dirname} { + testsetplatform mac + file dirname a +} : +test cmdah-2.8 {Tcl_FileCmd: dirname} { + testsetplatform win + file dirname a +} . +test cmdah-2.9 {Tcl_FileCmd: dirname} { + testsetplatform unix + file d a/b/c.d +} a/b +test cmdah-2.10 {Tcl_FileCmd: dirname} { + testsetplatform unix + file dirname a/b.c/d +} a/b.c +test cmdah-2.11 {Tcl_FileCmd: dirname} { + testsetplatform unix + file dirname /. +} / +test cmdah-2.12 {Tcl_FileCmd: dirname} { + testsetplatform unix + list [catch {file dirname /} msg] $msg +} {0 /} +test cmdah-2.13 {Tcl_FileCmd: dirname} { + testsetplatform unix + list [catch {file dirname /foo} msg] $msg +} {0 /} +test cmdah-2.14 {Tcl_FileCmd: dirname} { + testsetplatform unix + list [catch {file dirname //foo} msg] $msg +} {0 /} +test cmdah-2.15 {Tcl_FileCmd: dirname} { + testsetplatform unix + list [catch {file dirname //foo/bar} msg] $msg +} {0 /foo} +test cmdah-2.16 {Tcl_FileCmd: dirname} { + testsetplatform unix + list [catch {file dirname {//foo\/bar/baz}} msg] $msg +} {0 {/foo\/bar}} +test cmdah-2.17 {Tcl_FileCmd: dirname} { + testsetplatform unix + list [catch {file dirname {//foo\/bar/baz/blat}} msg] $msg +} {0 {/foo\/bar/baz}} +test cmdah-2.18 {Tcl_FileCmd: dirname} { + testsetplatform unix + list [catch {file dirname /foo//} msg] $msg +} {0 /} +test cmdah-2.19 {Tcl_FileCmd: dirname} { + testsetplatform unix + list [catch {file dirname ./a} msg] $msg +} {0 .} +test cmdah-2.20 {Tcl_FileCmd: dirname} { + testsetplatform unix + list [catch {file dirname a/.a} msg] $msg +} {0 a} +test cmdah-2.21 {Tcl_FileCmd: dirname} { + testsetplatform windows + list [catch {file dirname c:foo} msg] $msg +} {0 c:} +test cmdah-2.22 {Tcl_FileCmd: dirname} { + testsetplatform windows + list [catch {file dirname c:} msg] $msg +} {0 c:} +test cmdah-2.23 {Tcl_FileCmd: dirname} { + testsetplatform windows + list [catch {file dirname c:/} msg] $msg +} {0 c:/} +test cmdah-2.24 {Tcl_FileCmd: dirname} { + testsetplatform windows + list [catch {file dirname {c:\foo}} msg] $msg +} {0 c:/} +test cmdah-2.25 {Tcl_FileCmd: dirname} { + testsetplatform windows + list [catch {file dirname {//foo/bar/baz}} msg] $msg +} {0 //foo/bar} +test cmdah-2.26 {Tcl_FileCmd: dirname} { + testsetplatform windows + list [catch {file dirname {//foo/bar}} msg] $msg +} {0 //foo/bar} +test cmdah-2.27 {Tcl_FileCmd: dirname} { + testsetplatform mac + list [catch {file dirname :} msg] $msg +} {0 :} +test cmdah-2.28 {Tcl_FileCmd: dirname} { + testsetplatform mac + list [catch {file dirname :Foo} msg] $msg +} {0 :} +test cmdah-2.29 {Tcl_FileCmd: dirname} { + testsetplatform mac + list [catch {file dirname Foo:} msg] $msg +} {0 Foo:} +test cmdah-2.30 {Tcl_FileCmd: dirname} { + testsetplatform mac + list [catch {file dirname Foo:bar} msg] $msg +} {0 Foo:} +test cmdah-2.31 {Tcl_FileCmd: dirname} { + testsetplatform mac + list [catch {file dirname :Foo:bar} msg] $msg +} {0 :Foo} +test cmdah-2.32 {Tcl_FileCmd: dirname} { + testsetplatform mac + list [catch {file dirname ::} msg] $msg +} {0 :} +test cmdah-2.33 {Tcl_FileCmd: dirname} { + testsetplatform mac + list [catch {file dirname :::} msg] $msg +} {0 ::} +test cmdah-2.34 {Tcl_FileCmd: dirname} { + testsetplatform mac + list [catch {file dirname /foo/bar/} msg] $msg +} {0 foo:} +test cmdah-2.35 {Tcl_FileCmd: dirname} { + testsetplatform mac + list [catch {file dirname /foo/bar} msg] $msg +} {0 foo:} +test cmdah-2.36 {Tcl_FileCmd: dirname} { + testsetplatform mac + list [catch {file dirname /foo} msg] $msg +} {0 foo:} +test cmdah-2.37 {Tcl_FileCmd: dirname} { + testsetplatform mac + list [catch {file dirname foo} msg] $msg +} {0 :} +test cmdah-2.38 {Tcl_FileCmd: dirname} { + testsetplatform unix + list [catch {file dirname ~/foo} msg] $msg +} {0 ~} +test cmdah-2.39 {Tcl_FileCmd: dirname} { + testsetplatform unix + list [catch {file dirname ~bar/foo} msg] $msg +} {0 ~bar} +test cmdah-2.40 {Tcl_FileCmd: dirname} { + testsetplatform mac + list [catch {file dirname ~bar/foo} msg] $msg +} {0 ~bar:} +test cmdah-2.41 {Tcl_FileCmd: dirname} { + testsetplatform mac + list [catch {file dirname ~/foo} msg] $msg +} {0 ~:} +test cmdah-2.42 {Tcl_FileCmd: dirname} { + testsetplatform mac + list [catch {file dirname ~:baz} msg] $msg +} {0 ~:} +test cmdah-2.43 {Tcl_FileCmd: dirname} { + global env + set temp $env(HOME) + set env(HOME) "/home/test" + testsetplatform unix + set result [list [catch {file dirname ~} msg] $msg] + set env(HOME) $temp + set result +} {0 /home} +test cmdah-2.44 {Tcl_FileCmd: dirname} { + global env + set temp $env(HOME) + set env(HOME) "~" + testsetplatform unix + set result [list [catch {file dirname ~} msg] $msg] + set env(HOME) $temp + set result +} {0 ~} +test cmdah-2.45 {Tcl_FileCmd: dirname} { + global env + set temp $env(HOME) + set env(HOME) "/home/test" + testsetplatform windows + set result [list [catch {file dirname ~} msg] $msg] + set env(HOME) $temp + set result +} {0 /home} +test cmdah-2.46 {Tcl_FileCmd: dirname} { + global env + set temp $env(HOME) + set env(HOME) "/home/test" + testsetplatform mac + set result [list [catch {file dirname ~} msg] $msg] + set env(HOME) $temp + set result +} {0 home:} + +# tail + +test cmdah-3.1 {Tcl_FileCmd: tail} { + testsetplatform unix + list [catch {file tail a b} msg] $msg +} {1 {wrong # args: should be "file tail name"}} +test cmdah-3.2 {Tcl_FileCmd: tail} { + testsetplatform unix + file tail /a/b +} b +test cmdah-3.3 {Tcl_FileCmd: tail} { + testsetplatform unix + file tail {} +} {} +test cmdah-3.4 {Tcl_FileCmd: tail} { + testsetplatform mac + file tail {} +} {} +test cmdah-3.5 {Tcl_FileCmd: tail} { + testsetplatform win + file tail {} +} {} +test cmdah-3.6 {Tcl_FileCmd: tail} { + testsetplatform unix + file tail .def +} .def +test cmdah-3.7 {Tcl_FileCmd: tail} { + testsetplatform mac + file tail a +} a +test cmdah-3.8 {Tcl_FileCmd: tail} { + testsetplatform win + file tail a +} a +test cmdah-3.9 {Tcl_FileCmd: tail} { + testsetplatform unix + file ta a/b/c.d +} c.d +test cmdah-3.10 {Tcl_FileCmd: tail} { + testsetplatform unix + file tail a/b.c/d +} d +test cmdah-3.11 {Tcl_FileCmd: tail} { + testsetplatform unix + file tail /. +} . +test cmdah-3.12 {Tcl_FileCmd: tail} { + testsetplatform unix + file tail / +} {} +test cmdah-3.13 {Tcl_FileCmd: tail} { + testsetplatform unix + file tail /foo +} foo +test cmdah-3.14 {Tcl_FileCmd: tail} { + testsetplatform unix + file tail //foo +} foo +test cmdah-3.15 {Tcl_FileCmd: tail} { + testsetplatform unix + file tail //foo/bar +} bar +test cmdah-3.16 {Tcl_FileCmd: tail} { + testsetplatform unix + file tail {//foo\/bar/baz} +} baz +test cmdah-3.17 {Tcl_FileCmd: tail} { + testsetplatform unix + file tail {//foo\/bar/baz/blat} +} blat +test cmdah-3.18 {Tcl_FileCmd: tail} { + testsetplatform unix + file tail /foo// +} foo +test cmdah-3.19 {Tcl_FileCmd: tail} { + testsetplatform unix + file tail ./a +} a +test cmdah-3.20 {Tcl_FileCmd: tail} { + testsetplatform unix + file tail a/.a +} .a +test cmdah-3.21 {Tcl_FileCmd: tail} { + testsetplatform windows + file tail c:foo +} foo +test cmdah-3.22 {Tcl_FileCmd: tail} { + testsetplatform windows + file tail c: +} {} +test cmdah-3.23 {Tcl_FileCmd: tail} { + testsetplatform windows + file tail c:/ +} {} +test cmdah-3.24 {Tcl_FileCmd: tail} { + testsetplatform windows + file tail {c:\foo} +} foo +test cmdah-3.25 {Tcl_FileCmd: tail} { + testsetplatform windows + file tail {//foo/bar/baz} +} baz +test cmdah-3.26 {Tcl_FileCmd: tail} { + testsetplatform windows + file tail {//foo/bar} +} {} +test cmdah-3.27 {Tcl_FileCmd: tail} { + testsetplatform mac + file tail : +} : +test cmdah-3.28 {Tcl_FileCmd: tail} { + testsetplatform mac + file tail :Foo +} Foo +test cmdah-3.29 {Tcl_FileCmd: tail} { + testsetplatform mac + file tail Foo: +} {} +test cmdah-3.30 {Tcl_FileCmd: tail} { + testsetplatform mac + file tail Foo:bar +} bar +test cmdah-3.31 {Tcl_FileCmd: tail} { + testsetplatform mac + file tail :Foo:bar +} bar +test cmdah-3.32 {Tcl_FileCmd: tail} { + testsetplatform mac + file tail :: +} :: +test cmdah-3.33 {Tcl_FileCmd: tail} { + testsetplatform mac + file tail ::: +} :: +test cmdah-3.34 {Tcl_FileCmd: tail} { + testsetplatform mac + file tail /foo/bar/ +} bar +test cmdah-3.35 {Tcl_FileCmd: tail} { + testsetplatform mac + file tail /foo/bar +} bar +test cmdah-3.36 {Tcl_FileCmd: tail} { + testsetplatform mac + file tail /foo +} {} +test cmdah-3.37 {Tcl_FileCmd: tail} { + testsetplatform mac + file tail foo +} foo +test cmdah-3.38 {Tcl_FileCmd: tail} { + testsetplatform mac + file tail ~:foo +} foo +test cmdah-3.39 {Tcl_FileCmd: tail} { + testsetplatform mac + file tail ~bar:foo +} foo +test cmdah-3.40 {Tcl_FileCmd: tail} { + testsetplatform mac + file tail ~bar/foo +} foo +test cmdah-3.41 {Tcl_FileCmd: tail} { + testsetplatform mac + file tail ~/foo +} foo +test cmdah-3.42 {Tcl_FileCmd: tail} { + global env + set temp $env(HOME) + set env(HOME) "/home/test" + testsetplatform unix + set result [file tail ~] + set env(HOME) $temp + set result +} test +test cmdah-3.43 {Tcl_FileCmd: tail} { + global env + set temp $env(HOME) + set env(HOME) "~" + testsetplatform unix + set result [file tail ~] + set env(HOME) $temp + set result +} {} +test cmdah-3.44 {Tcl_FileCmd: tail} { + global env + set temp $env(HOME) + set env(HOME) "/home/test" + testsetplatform windows + set result [file tail ~] + set env(HOME) $temp + set result +} test +test cmdah-3.45 {Tcl_FileCmd: tail} { + global env + set temp $env(HOME) + set env(HOME) "/home/test" + testsetplatform mac + set result [file tail ~] + set env(HOME) $temp + set result +} test +test cmdah-3.46 {Tcl_FileCmd: tail} { + testsetplatform unix + file tail {f.oo\bar/baz.bat} +} baz.bat +test cmdah-3.47 {Tcl_FileCmd: tail} { + testsetplatform windows + file tail c:foo +} foo +test cmdah-3.48 {Tcl_FileCmd: tail} { + testsetplatform windows + file tail c: +} {} +test cmdah-3.49 {Tcl_FileCmd: tail} { + testsetplatform windows + file tail c:/foo +} foo +test cmdah-3.50 {Tcl_FileCmd: tail} { + testsetplatform windows + file tail {c:/foo\bar} +} bar +test cmdah-3.51 {Tcl_FileCmd: tail} { + testsetplatform windows + file tail {foo\bar} +} bar + +# rootname + +test cmdah-4.1 {Tcl_FileCmd: rootname} { + testsetplatform unix + list [catch {file rootname a b} msg] $msg +} {1 {wrong # args: should be "file rootname name"}} +test cmdah-4.2 {Tcl_FileCmd: rootname} { + testsetplatform unix + file rootname {} +} {} +test cmdah-4.3 {Tcl_FileCmd: rootname} { + testsetplatform unix + file ro foo +} foo +test cmdah-4.4 {Tcl_FileCmd: rootname} { + testsetplatform unix + file rootname foo. +} foo +test cmdah-4.5 {Tcl_FileCmd: rootname} { + testsetplatform unix + file rootname .foo +} {} +test cmdah-4.6 {Tcl_FileCmd: rootname} { + testsetplatform unix + file rootname abc.def +} abc +test cmdah-4.7 {Tcl_FileCmd: rootname} { + testsetplatform unix + file rootname abc.def.ghi +} abc.def +test cmdah-4.8 {Tcl_FileCmd: rootname} { + testsetplatform unix + file rootname a/b/c.d +} a/b/c +test cmdah-4.9 {Tcl_FileCmd: rootname} { + testsetplatform unix + file rootname a/b.c/d +} a/b.c/d +test cmdah-4.10 {Tcl_FileCmd: rootname} { + testsetplatform unix + file rootname a/b.c/ +} a/b.c/ +test cmdah-4.11 {Tcl_FileCmd: rootname} { + testsetplatform mac + file ro foo +} foo +test cmdah-4.12 {Tcl_FileCmd: rootname} { + testsetplatform mac + file rootname {} +} {} +test cmdah-4.13 {Tcl_FileCmd: rootname} { + testsetplatform mac + file rootname foo. +} foo +test cmdah-4.14 {Tcl_FileCmd: rootname} { + testsetplatform mac + file rootname .foo +} {} +test cmdah-4.15 {Tcl_FileCmd: rootname} { + testsetplatform mac + file rootname abc.def +} abc +test cmdah-4.16 {Tcl_FileCmd: rootname} { + testsetplatform mac + file rootname abc.def.ghi +} abc.def +test cmdah-4.17 {Tcl_FileCmd: rootname} { + testsetplatform mac + file rootname a:b:c.d +} a:b:c +test cmdah-4.18 {Tcl_FileCmd: rootname} { + testsetplatform mac + file rootname a:b.c:d +} a:b.c:d +test cmdah-4.19 {Tcl_FileCmd: rootname} { + testsetplatform mac + file rootname a/b/c.d +} a/b/c +test cmdah-4.20 {Tcl_FileCmd: rootname} { + testsetplatform mac + file rootname a/b.c/d +} a/b.c/d +test cmdah-4.21 {Tcl_FileCmd: rootname} { + testsetplatform mac + file rootname /a.b +} /a +test cmdah-4.22 {Tcl_FileCmd: rootname} { + testsetplatform mac + file rootname foo.c: +} foo.c: +test cmdah-4.23 {Tcl_FileCmd: rootname} { + testsetplatform windows + file rootname {} +} {} +test cmdah-4.24 {Tcl_FileCmd: rootname} { + testsetplatform windows + file ro foo +} foo +test cmdah-4.25 {Tcl_FileCmd: rootname} { + testsetplatform windows + file rootname foo. +} foo +test cmdah-4.26 {Tcl_FileCmd: rootname} { + testsetplatform windows + file rootname .foo +} {} +test cmdah-4.27 {Tcl_FileCmd: rootname} { + testsetplatform windows + file rootname abc.def +} abc +test cmdah-4.28 {Tcl_FileCmd: rootname} { + testsetplatform windows + file rootname abc.def.ghi +} abc.def +test cmdah-4.29 {Tcl_FileCmd: rootname} { + testsetplatform windows + file rootname a/b/c.d +} a/b/c +test cmdah-4.30 {Tcl_FileCmd: rootname} { + testsetplatform windows + file rootname a/b.c/d +} a/b.c/d +test cmdah-4.31 {Tcl_FileCmd: rootname} { + testsetplatform windows + file rootname a\\b.c\\ +} a\\b.c\\ +test cmdah-4.32 {Tcl_FileCmd: rootname} { + testsetplatform windows + file rootname a\\b\\c.d +} a\\b\\c +test cmdah-4.33 {Tcl_FileCmd: rootname} { + testsetplatform windows + file rootname a\\b.c\\d +} a\\b.c\\d +test cmdah-4.34 {Tcl_FileCmd: rootname} { + testsetplatform windows + file rootname a\\b.c\\ +} a\\b.c\\ +set num 35 +foreach outer { {} a .a a. a.a } { + foreach inner { {} a .a a. a.a } { + set thing [format %s/%s $outer $inner] + test cmdah-4.$num {Tcl_FileCmd: rootname and extension options} { + testsetplatform unix + format %s%s [file rootname $thing] [file ext $thing] + } $thing + set num [expr $num+1] + } +} + +# extension + +test cmdah-5.1 {Tcl_FileCmd: extension} { + testsetplatform unix + list [catch {file extension a b} msg] $msg +} {1 {wrong # args: should be "file extension name"}} +test cmdah-5.2 {Tcl_FileCmd: extension} { + testsetplatform unix + file extension {} +} {} +test cmdah-5.3 {Tcl_FileCmd: extension} { + testsetplatform unix + file ext foo +} {} +test cmdah-5.4 {Tcl_FileCmd: extension} { + testsetplatform unix + file extension foo. +} . +test cmdah-5.5 {Tcl_FileCmd: extension} { + testsetplatform unix + file extension .foo +} .foo +test cmdah-5.6 {Tcl_FileCmd: extension} { + testsetplatform unix + file extension abc.def +} .def +test cmdah-5.7 {Tcl_FileCmd: extension} { + testsetplatform unix + file extension abc.def.ghi +} .ghi +test cmdah-5.8 {Tcl_FileCmd: extension} { + testsetplatform unix + file extension a/b/c.d +} .d +test cmdah-5.9 {Tcl_FileCmd: extension} { + testsetplatform unix + file extension a/b.c/d +} {} +test cmdah-5.10 {Tcl_FileCmd: extension} { + testsetplatform unix + file extension a/b.c/ +} {} +test cmdah-5.11 {Tcl_FileCmd: extension} { + testsetplatform mac + file ext foo +} {} +test cmdah-5.12 {Tcl_FileCmd: extension} { + testsetplatform mac + file extension {} +} {} +test cmdah-5.13 {Tcl_FileCmd: extension} { + testsetplatform mac + file extension foo. +} . +test cmdah-5.14 {Tcl_FileCmd: extension} { + testsetplatform mac + file extension .foo +} .foo +test cmdah-5.15 {Tcl_FileCmd: extension} { + testsetplatform mac + file extension abc.def +} .def +test cmdah-5.16 {Tcl_FileCmd: extension} { + testsetplatform mac + file extension abc.def.ghi +} .ghi +test cmdah-5.17 {Tcl_FileCmd: extension} { + testsetplatform mac + file extension a:b:c.d +} .d +test cmdah-5.18 {Tcl_FileCmd: extension} { + testsetplatform mac + file extension a:b.c:d +} {} +test cmdah-5.19 {Tcl_FileCmd: extension} { + testsetplatform mac + file extension a/b/c.d +} .d +test cmdah-5.20 {Tcl_FileCmd: extension} { + testsetplatform mac + file extension a/b.c/d +} {} +test cmdah-5.21 {Tcl_FileCmd: extension} { + testsetplatform mac + file extension /a.b +} .b +test cmdah-5.22 {Tcl_FileCmd: extension} { + testsetplatform mac + file extension foo.c: +} {} +test cmdah-5.23 {Tcl_FileCmd: extension} { + testsetplatform windows + file extension {} +} {} +test cmdah-5.24 {Tcl_FileCmd: extension} { + testsetplatform windows + file ext foo +} {} +test cmdah-5.25 {Tcl_FileCmd: extension} { + testsetplatform windows + file extension foo. +} . +test cmdah-5.26 {Tcl_FileCmd: extension} { + testsetplatform windows + file extension .foo +} .foo +test cmdah-5.27 {Tcl_FileCmd: extension} { + testsetplatform windows + file extension abc.def +} .def +test cmdah-5.28 {Tcl_FileCmd: extension} { + testsetplatform windows + file extension abc.def.ghi +} .ghi +test cmdah-5.29 {Tcl_FileCmd: extension} { + testsetplatform windows + file extension a/b/c.d +} .d +test cmdah-5.30 {Tcl_FileCmd: extension} { + testsetplatform windows + file extension a/b.c/d +} {} +test cmdah-5.31 {Tcl_FileCmd: extension} { + testsetplatform windows + file extension a\\b.c\\ +} {} +test cmdah-5.32 {Tcl_FileCmd: extension} { + testsetplatform windows + file extension a\\b\\c.d +} .d +test cmdah-5.33 {Tcl_FileCmd: extension} { + testsetplatform windows + file extension a\\b.c\\d +} {} +test cmdah-5.34 {Tcl_FileCmd: extension} { + testsetplatform windows + file extension a\\b.c\\ +} {} +set num 35 +foreach value {a..b a...b a.c..b ..b} result {..b ...b ..b ..b} { + foreach p {unix mac windows} { + test cmdah-5.$num {Tcl_FileCmd: extension} " + testsetplatform $p + file extension $value + " $result + incr num + } +} + +# pathtype + +test cmdah-6.1 {Tcl_FileCmd: pathtype} { + testsetplatform unix + list [catch {file pathtype a b} msg] $msg +} {1 {wrong # args: should be "file pathtype name"}} +test cmdah-6.2 {Tcl_FileCmd: pathtype} { + testsetplatform unix + file pathtype /a +} absolute +test cmdah-6.3 {Tcl_FileCmd: pathtype} { + testsetplatform unix + file p a +} relative +test cmdah-6.4 {Tcl_FileCmd: pathtype} { + testsetplatform windows + file pathtype c:a +} volumerelative + +# split + +test cmdah-7.1 {Tcl_FileCmd: split} { + testsetplatform unix + list [catch {file split a b} msg] $msg +} {1 {wrong # args: should be "file split name"}} +test cmdah-7.2 {Tcl_FileCmd: split} { + testsetplatform unix + file split a +} a +test cmdah-7.3 {Tcl_FileCmd: split} { + testsetplatform unix + file split a/b +} {a b} + +# join + +test cmdah-8.1 {Tcl_FileCmd: join} { + testsetplatform unix + file join a +} a +test cmdah-8.2 {Tcl_FileCmd: join} { + testsetplatform unix + file join a b +} a/b +test cmdah-8.3 {Tcl_FileCmd: join} { + testsetplatform unix + file join a b c d +} a/b/c/d + +# error handling of Tcl_TranslateFileName + +test cmdah-9.1 {Tcl_FileCmd} { + testsetplatform unix + list [catch {file readable ~_bad_user} msg] $msg +} {1 {user "_bad_user" doesn't exist}} + +testsetplatform $platform +makeFile abcde gorp.file +makeDirectory dir.file + +# readable +# Can't run on macintosh - requires chmod +if {$tcl_platform(platform) != "macintosh"} { + +test cmdah-10.1 {Tcl_FileCmd: readable} { + list [catch {file readable a b} msg] $msg +} {1 {wrong # args: should be "file readable name"}} +catch {exec chmod 444 gorp.file} +test cmdah-10.2 {Tcl_FileCmd: readable} {unixExecs} {file readable gorp.file} 1 +catch {exec chmod 333 gorp.file} +if {$user != "root"} { + test cmdah-10.3 {Tcl_FileCmd: readable} {unixOnly} { + file reada gorp.file + } 0 +} +} + +# writable +# Can't run on macintosh - requires chmod +if {$tcl_platform(platform) != "macintosh"} { + +test cmdah-11.1 {Tcl_FileCmd: writable} { + list [catch {file writable a b} msg] $msg +} {1 {wrong # args: should be "file writable name"}} +catch {exec chmod 555 gorp.file} +if {$user != "root"} { + test cmdah-11.2 {Tcl_FileCmd: writable} {unixExecs} { + file writable gorp.file + } 0 +} +catch {exec chmod 222 gorp.file} +test cmdah-11.3 {Tcl_FileCmd: writable} {unixExecs} {file w gorp.file} 1 +} + +# executable +# Can't run on macintosh - requires chmod +if {$tcl_platform(platform) != "macintosh"} { + +test cmdah-12.1 {Tcl_FileCmd: executable} {unixExecs} { + list [catch {file executable a b} msg] $msg +} {1 {wrong # args: should be "file executable name"}} +catch {exec chmod 000 dir.file} +if {$user != "root"} { + test cmdah-12.2 {Tcl_FileCmd: executable} {unixOnly} { + file executable gorp.file + } 0 +} +catch {exec chmod 775 gorp.file} +test cmdah-12.3 {Tcl_FileCmd: executable} {unixExecs} {file exe gorp.file} 1 +} + +# exists + +test cmdah-13.1 {Tcl_FileCmd: exists} { + list [catch {file exists a b} msg] $msg +} {1 {wrong # args: should be "file exists name"}} +catch {exec chmod 777 dir.file} +file delete -force dir.file +file delete gorp.file +file delete link.file +test cmdah-13.2 {Tcl_FileCmd: exists} {file exists gorp.file} 0 +test cmdah-13.3 {Tcl_FileCmd: exists} { + file exists [file join dir.file gorp.file] +} 0 +catch { + makeFile abcde gorp.file + makeDirectory dir.file + makeFile 12345 [file join dir.file gorp.file] +} +test cmdah-13.4 {Tcl_FileCmd: exists} {unixExecs} {file exists gorp.file} 1 +test cmdah-13.5 {Tcl_FileCmd: exists} {unixExecs} { + file exists [file join 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. + +if {$tcl_platform(platform) == "unix"} { + file delete /tmp/tcl.foo.dir/file + removeDirectory /tmp/tcl.foo.dir + makeDirectory /tmp/tcl.foo.dir + makeFile 12345 /tmp/tcl.foo.dir/file + exec chmod 000 /tmp/tcl.foo.dir + if {$user != "root"} { + test cmdah-13.6 {Tcl_FileCmd: exists} { + file exists /tmp/tcl.foo.dir/file + } 0 + } + exec chmod 775 /tmp/tcl.foo.dir + file delete /tmp/tcl.foo.dir/file + removeDirectory /tmp/tcl.foo.dir +} + +# Stat related commands + +testsetplatform $platform +file delete gorp.file +makeFile "Test string" gorp.file +catch {exec chmod 765 gorp.file} + +# atime + +test cmdah-14.1 {Tcl_FileCmd: atime} { + list [catch {file atime a b} msg] $msg +} {1 {wrong # args: should be "file atime name"}} +test cmdah-14.2 {Tcl_FileCmd: atime} { + catch {unset stat} + file stat gorp.file stat + list [expr {[file mtime gorp.file] == $stat(mtime)}] \ + [expr {[file atime gorp.file] == $stat(atime)}] +} {1 1} +test cmdah-12.1 {Tcl_FileCmd: atime} { + 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}}} + +# isdirectory + +test cmdah-15.1 {Tcl_FileCmd: isdirectory} { + list [catch {file isdirectory a b} msg] $msg +} {1 {wrong # args: should be "file isdirectory name"}} +test cmdah-15.2 {Tcl_FileCmd: isdirectory} {file isdirectory gorp.file} 0 +test cmdah-15.3 {Tcl_FileCmd: isdirectory} {unixExecs} {file isd dir.file} 1 + +# isfile + +test cmdah-15.4 {Tcl_FileCmd: isfile} { + list [catch {file isfile a b} msg] $msg +} {1 {wrong # args: should be "file isfile name"}} +test cmdah-15.5 {Tcl_FileCmd: isfile} {file isfile gorp.file} 1 +test cmdah-15.6 {Tcl_FileCmd: isfile} {file isfile dir.file} 0 + +# lstat and readlink: don't run these tests everywhere, since not all +# sites will have symbolic links + +catch {exec ln -s gorp.file link.file} +test cmdah-16.1 {Tcl_FileCmd: lstat} {unixExecs} { + list [catch {file lstat a} msg] $msg +} {1 {wrong # args: should be "file lstat name varName"}} +test cmdah-16.2 {Tcl_FileCmd: lstat} {unixExecs} { + list [catch {file lstat a b c} msg] $msg +} {1 {wrong # args: should be "file lstat name varName"}} +test cmdah-16.3 {Tcl_FileCmd: lstat} {unixOnly nonPortable} { + catch {unset stat} + file lstat link.file stat + lsort [array names stat] +} {atime ctime dev gid ino mode mtime nlink size type uid} +test cmdah-16.4 {Tcl_FileCmd: lstat} {unixOnly nonPortable} { + catch {unset stat} + file lstat link.file stat + list $stat(nlink) [expr $stat(mode)&0777] $stat(type) +} {1 511 link} +test cmdah-16.5 {Tcl_FileCmd: lstat errors} {nonPortable} { + 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 cmdah-16.6 {Tcl_FileCmd: lstat errors} {unixExecs nonPortable} { + 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} + +# mtime + +test cmdah-17.1 {Tcl_FileCmd: mtime} { + list [catch {file mtime a b} msg] $msg +} {1 {wrong # args: should be "file mtime name"}} +test cmdah-17.2 {Tcl_FileCmd: mtime} {unixExecs} { + set old [file mtime gorp.file] + after 2000 + 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 cmdah-17.3 {Tcl_FileCmd: mtime} {unixExecs} { + catch {unset stat} + file stat gorp.file stat + list [expr {[file mtime gorp.file] == $stat(mtime)}] \ + [expr {[file atime gorp.file] == $stat(atime)}] +} {1 1} +test cmdah-17.4 {Tcl_FileCmd: mtime} {unixExecs} { + 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}}} + +# owned + +test cmdah-18.1 {Tcl_FileCmd: owned} { + list [catch {file owned a b} msg] $msg +} {1 {wrong # args: should be "file owned name"}} +test cmdah-18.2 {Tcl_FileCmd: owned} {unixExecs} {file owned gorp.file} 1 +if {$user != "root"} { + test cmdah-18.3 {Tcl_FileCmd: owned} {unixOnly} {file owned /} 0 +} + +# readlink + +test cmdah-19.1 {Tcl_FileCmd: readlink} { + list [catch {file readlink a b} msg] $msg +} {1 {wrong # args: should be "file readlink name"}} +test cmdah-19.2 {Tcl_FileCmd: readlink} {unixOnly nonPortable} { + file readlink link.file +} gorp.file +test cmdah-19.3 {Tcl_FileCmd: readlink errors} {unixOnly nonPortable} { + list [catch {file readlink _bogus_} msg] [string tolower $msg] \ + [string tolower $errorCode] +} {1 {couldn't readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} +test cmdah-19.4 {Tcl_FileCmd: readlink errors} {macOnly nonPortable} { + list [catch {file readlink _bogus_} msg] [string tolower $msg] \ + [string tolower $errorCode] +} {1 {couldn't readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} +test cmdah-19.5 {Tcl_FileCmd: readlink errors} {pcOnly nonPortable} { + list [catch {file readlink _bogus_} msg] [string tolower $msg] \ + [string tolower $errorCode] +} {1 {couldn't readlink "_bogus_": invalid argument} {posix einval {invalid argument}}} + +# size + +test cmdah-20.1 {Tcl_FileCmd: size} { + list [catch {file size a b} msg] $msg +} {1 {wrong # args: should be "file size name"}} +test cmdah-20.2 {Tcl_FileCmd: size} { + set oldsize [file size gorp.file] + set f [open gorp.file a] + fconfigure $f -translation lf -eofchar {} + puts $f "More text" + close $f + expr {[file size gorp.file] - $oldsize} +} {10} +test cmdah-20.3 {Tcl_FileCmd: size} { + 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}}} + +# stat + +testsetplatform $platform +makeFile "Test string" gorp.file +catch {exec chmod 765 gorp.file} + +test cmdah-21.1 {Tcl_FileCmd: stat} { + list [catch {file stat _bogus_} msg] $msg $errorCode +} {1 {wrong # args: should be "file stat name varName"} NONE} +test cmdah-21.2 {Tcl_FileCmd: stat} { + list [catch {file stat _bogus_ a b} msg] $msg $errorCode +} {1 {wrong # args: should be "file stat name varName"} NONE} +test cmdah-21.3 {Tcl_FileCmd: stat} { + catch {unset stat} + file stat gorp.file stat + lsort [array names stat] +} {atime ctime dev gid ino mode mtime nlink size type uid} +test cmdah-21.4 {Tcl_FileCmd: stat} {unixOnly} { + catch {unset stat} + file stat gorp.file stat + list $stat(nlink) $stat(size) [expr $stat(mode)&0777] $stat(type) +} {1 12 501 file} +test cmdah-21.5 {Tcl_FileCmd: stat} { + 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 cmdah-21.6 {Tcl_FileCmd: stat} { + 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} + +# type + +file delete link.file + +test cmdah-22.1 {Tcl_FileCmd: type} { + list [catch {file size a b} msg] $msg +} {1 {wrong # args: should be "file size name"}} +test cmdah-22.2 {Tcl_FileCmd: type} {unixExecs} { + file type dir.file +} directory +test cmdah-22.3 {Tcl_FileCmd: type} { + file type gorp.file +} file +test cmdah-22.4 {Tcl_FileCmd: type} {unixOnly nonPortable} { + exec ln -s a/b/c link.file + set result [file type link.file] + file delete link.file + set result +} link +test cmdah-22.5 {Tcl_FileCmd: type} { + 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}}} + +# Error conditions + +test cmdah-23.1 {error conditions} { + list [catch {file gorp x} msg] $msg +} {1 {bad option "gorp": should be atime, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, owned, pathtype, readable, readlink, rename, root, size, split, stat, tail, type, or writable}} +test cmdah-23.2 {error conditions} { + list [catch {file ex x} msg] $msg +} {1 {bad option "ex": should be atime, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, owned, pathtype, readable, readlink, rename, root, size, split, stat, tail, type, or writable}} +test cmdah-23.3 {error conditions} { + list [catch {file is x} msg] $msg +} {1 {bad option "is": should be atime, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, owned, pathtype, readable, readlink, rename, root, size, split, stat, tail, type, or writable}} +test cmdah-23.4 {error conditions} { + list [catch {file n x} msg] $msg +} {1 {bad option "n": should be atime, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, owned, pathtype, readable, readlink, rename, root, size, split, stat, tail, type, or writable}} +test cmdah-23.5 {error conditions} { + list [catch {file read x} msg] $msg +} {1 {bad option "read": should be atime, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, owned, pathtype, readable, readlink, rename, root, size, split, stat, tail, type, or writable}} +test cmdah-23.6 {error conditions} { + list [catch {file s x} msg] $msg +} {1 {bad option "s": should be atime, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, owned, pathtype, readable, readlink, rename, root, size, split, stat, tail, type, or writable}} +test cmdah-23.7 {error conditions} { + list [catch {file t x} msg] $msg +} {1 {bad option "t": should be atime, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, owned, pathtype, readable, readlink, rename, root, size, split, stat, tail, type, or writable}} +test cmdah-23.8 {error conditions} { + list [catch {file dirname ~woohgy} msg] $msg +} {1 {user "woohgy" doesn't exist}} + +testsetplatform $platform +catch {unset platform} + +catch {exec chmod 777 dir.file} +file delete -force dir.file +file delete gorp.file +file delete link.file + +concat "" diff --git a/tcl7.3/tests/cmdinfo.test b/tcl7.6/tests/cmdInfo.test similarity index 56% rename from tcl7.3/tests/cmdinfo.test rename to tcl7.6/tests/cmdInfo.test index 8998363..aa050ef 100644 --- a/tcl7.3/tests/cmdinfo.test +++ b/tcl7.6/tests/cmdInfo.test @@ -1,31 +1,18 @@ # 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. +# Tcl_SetCommandInfo, Tcl_CreateCommand, Tcl_DeleteCommand, and +# Tcl_NameOfCommand. 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. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) cmdInfo.test 1.5 96/04/05 15:28:12 if {[info commands testcmdinfo] == {}} { puts "This application hasn't been compiled with the \"testcmdinfo\"" @@ -75,5 +62,13 @@ test cmdinfo-3.3 {Tcl_Get/SetCommandInfo return values} { testcmdinfo modify non_existent } 0 +test cmdinfo-4.1 {Tcl_GetCommandName procedure} { + set x [testcmdtoken create x1] + rename x1 newName + set y [testcmdtoken name $x] + rename newName x1 + lappend y [testcmdtoken name $x] +} {newName x1} + catch {rename x1 ""} concat {} diff --git a/tcl7.6/tests/concat.test b/tcl7.6/tests/concat.test new file mode 100644 index 0000000..b86aeed --- /dev/null +++ b/tcl7.6/tests/concat.test @@ -0,0 +1,39 @@ +# 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. +# Copyright (c) 1994 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) concat.test 1.8 96/02/16 08:55:43 + +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/tcl7.6/tests/dcall.test b/tcl7.6/tests/dcall.test new file mode 100644 index 0000000..c7ad1c6 --- /dev/null +++ b/tcl7.6/tests/dcall.test @@ -0,0 +1,40 @@ +# 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. +# Copyright (c) 1994 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) dcall.test 1.6 96/02/16 08:55:44 + +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} { + lsort -increasing [testdcall 1 2 3] +} {1 2 3} +test dcall-1.2 {deletion callbacks} { + testdcall +} {} +test dcall-1.3 {deletion callbacks} { + lsort -increasing [testdcall 20 21 22 -22] +} {20 21} +test dcall-1.4 {deletion callbacks} { + lsort -increasing [testdcall 20 21 22 -20] +} {21 22} +test dcall-1.5 {deletion callbacks} { + lsort -increasing [testdcall 20 21 22 -21] +} {20 22} +test dcall-1.6 {deletion callbacks} { + lsort -increasing [testdcall 20 21 22 -21 -22 -20] +} {} diff --git a/tcl7.6/tests/defs b/tcl7.6/tests/defs new file mode 100644 index 0000000..4be66bc --- /dev/null +++ b/tcl7.6/tests/defs @@ -0,0 +1,343 @@ +# 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. +# +# Copyright (c) 1990-1994 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) defs 1.44 96/10/08 17:26:58 + +if ![info exists VERBOSE] { + set VERBOSE 0 +} +if ![info exists TESTS] { + set TESTS {} +} + +# 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 {} +if {$tcl_platform(platform) == "unix"} { + catch {set user [exec whoami]} + if {$user == ""} { + catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user} + } + if {$user == ""} {set user root} + 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 +# differences in word length, file system configuration, etc. In order +# to prevent false alarms, these tests are generally only run in the +# master development directory for Tcl. The presence of a file +# "doAllTests" in this directory is used to indicate that the non-portable +# tests should be run. + +set doNonPortableTests [file exists doAllTests] + +# If there is no "memory" command (because memory debugging isn't +# enabled), generate a dummy command that does nothing. + +if {[info commands memory] == ""} { + proc memory args {} +} + +# Check configuration information that will determine which tests +# to run. To do this, create an array testConfig. Each element +# has a 0 or 1 value, and the following elements are defined: +# unixOnly - 1 means this is a UNIX platform, so it's OK +# to run tests that only work under UNIX. +# macOnly - 1 means this is a Mac platform, so it's OK +# to run tests that only work on Macs. +# pcOnly - 1 means this is a PC platform, so it's OK to +# run tests that only work on PCs. +# unixOrPc - 1 means this is a UNIX or PC platform. +# macOrPc - 1 means this is a Mac or PC platform. +# macOrUnix - 1 means this is a Mac or UNIX platform. +# nonPortable - 1 means this the tests are being running in +# the master Tcl/Tk development environment; +# Some tests are inherently non-portable because +# they depend on things like word length, file system +# configuration, window manager, etc. These tests +# are only run in the main Tcl development directory +# where the configuration is well known. The presence +# of the file "doAllTests" in this directory indicates +# that it is safe to run non-portable tests. +# tempNotPc - The inverse of pcOnly. This flag is used to +# temporarily disable a test. +# nonBlockFiles - 1 means this platform supports setting files into +# nonblocking mode. +# asyncPipeClose- 1 means this platform supports async flush and +# async close on a pipe. +# unixExecs - 1 means this machine has commands such as 'cat', +# 'echo' etc available. + +catch {unset testConfig} +if {$tcl_platform(platform) == "unix"} { + set testConfig(unixOnly) 1 + set testConfig(tempNotPc) 1 +} else { + set testConfig(unixOnly) 0 +} +if {$tcl_platform(platform) == "macintosh"} { + set testConfig(tempNotPc) 1 + set testConfig(macOnly) 1 +} else { + set testConfig(macOnly) 0 +} +if {$tcl_platform(platform) == "windows"} { + set testConfig(pcOnly) 1 +} else { + set testConfig(pcOnly) 0 +} +set testConfig(unixOrPc) [expr $testConfig(unixOnly) || $testConfig(pcOnly)] +set testConfig(macOrPc) [expr $testConfig(macOnly) || $testConfig(pcOnly)] +set testConfig(macOrUnix) [expr $testConfig(macOnly) || $testConfig(unixOnly)] +set testConfig(nonPortable) [file exists doAllTests] + +set f [open defs r] +if {[expr [catch {fconfigure $f -blocking off}]] == 0} { + set testConfig(nonBlockFiles) 1 +} else { + set testConfig(nonBlockFiles) 0 +} +close $f + +# Test for SCO Unix - cannot run async flushing tests because a potential +# problem with select is apparently interfering. (Mark Diekhans). + +if {$tcl_platform(platform) == "unix"} { + if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} { + set testConfig(asyncPipeClose) 0 + } else { + set testConfig(asyncPipeClose) 1 + } +} else { + set testConfig(asyncPipeClose) 1 +} + +# Test to see if execed commands such as cat, echo, rm and so forth are +# present on this machine. + +set testConfig(unixExecs) 1 +if {$tcl_platform(platform) == "macintosh"} { + set testConfig(unixExecs) 0 +} +if {($testConfig(unixExecs) == 1) && ($tcl_platform(platform) == "windows")} { + if {[catch {exec cat defs}] == 1} { + set testConfig(unixExecs) 0 + } + if {($testConfig(unixExecs) == 1) && ([catch {exec echo hello}] == 1)} { + set testConfig(unixExecs) 0 + } + if {($testConfig(unixExecs) == 1) && \ + ([catch {exec sh -c echo hello}] == 1)} { + set testConfig(unixExecs) 0 + } + if {($testConfig(unixExecs) == 1) && ([catch {exec wc defs}] == 1)} { + set testConfig(unixExecs) 0 + } + if {$testConfig(unixExecs) == 1} { + exec echo hello > removeMe + if {[catch {exec rm removeMe}] == 1} { + set testConfig(unixExecs) 0 + } + } + if {($testConfig(unixExecs) == 1) && ([catch {exec sleep 1}] == 1)} { + set testConfig(unixExecs) 0 + } + if {($testConfig(unixExecs) == 1) && \ + ([catch {exec fgrep unixExecs defs}] == 1)} { + set testConfig(unixExecs) 0 + } + if {($testConfig(unixExecs) == 1) && ([catch {exec ps}] == 1)} { + set testConfig(unixExecs) 0 + } + if {($testConfig(unixExecs) == 1) && \ + ([catch {exec echo abc > removeMe}] == 0) && \ + ([catch {exec chmod 644 removeMe}] == 1) && \ + ([catch {exec rm removeMe}] == 0)} { + set testConfig(unixExecs) 0 + } else { + catch {exec rm -f removeMe} + } + if {($testConfig(unixExecs) == 1) && \ + ([catch {exec mkdir removeMe}] == 1)} { + set testConfig(unixExecs) 0 + } else { + catch {exec rm -r removeMe} + } + if {$testConfig(unixExecs) == 0} { + puts stdout "Warning: Unix-style executables are not available, so" + puts stdout "some tests will be skipped." + } +} + +proc print_verbose {name description script code answer} { + puts stdout "\n" + puts stdout "==== $name $description" + puts stdout "==== Contents of test case:" + puts stdout "$script" + 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" + } +} + +# test -- +# This procedure runs a test and prints an error message if the +# test fails. If VERBOSE has been set, it also prints a message +# even if the test succeeds. The test will be skipped if it +# doesn't match the TESTS variable, or if one of the elements +# of "constraints" turns out not to be true. +# +# Arguments: +# name - Name of test, in the form foo-1.2. +# description - Short textual description of the test, to +# help humans understand what it does. +# constraints - A list of one or more keywords, each of +# which must be the name of an element in +# the array "testConfig". If any of these +# elements is zero, the test is skipped. +# This argument may be omitted. +# script - Script to run to carry out the test. It must +# return a result that can be checked for +# correctness. +# answer - Expected result from script. + +proc test {name description script answer args} { + global VERBOSE TESTS testConfig + if {[string compare $TESTS ""] != 0} then { + set ok 0 + foreach test $TESTS { + if [string match $test $name] then { + set ok 1 + break + } + } + if !$ok then return + } + set i [llength $args] + if {$i == 0} { + # Empty body + } elseif {$i == 1} { + # "constraints" argument exists; shuffle arguments down, then + # make sure that the constraints are satisfied. + + set constraints $script + set script $answer + set answer [lindex $args 0] + foreach constraint $constraints { + if {![info exists testConfig($constraint)] + || !$testConfig($constraint)} { + return + } + } + } else { + error "wrong # args: must be \"test name description ?constraints? script answer\"" + } + memory tag $name + set code [catch {uplevel $script} result] + if {$code != 0} { + print_verbose $name $description $script \ + $code $result + } elseif {[string compare $result $answer] == 0} then { + if $VERBOSE then { + if {$VERBOSE > 0} { + print_verbose $name $description $script \ + $code $result + } + puts stdout "++++ $name PASSED" + } + } else { + print_verbose $name $description $script \ + $code $result + puts stdout "---- Result should have been:" + puts stdout "$answer" + puts stdout "---- $name FAILED" + } +} + +proc dotests {file args} { + global TESTS + set savedTests $TESTS + set TESTS $args + source $file + set TESTS $savedTests +} + +proc normalizeMsg {msg} { + regsub "\n$" [string tolower $msg] "" msg + regsub -all "\n\n" $msg "\n" msg + regsub -all "\n\}" $msg "\}" msg + return $msg +} + +proc makeFile {contents name} { + set fd [open $name w] + fconfigure $fd -translation lf + if {[string index $contents [expr [string length $contents] - 1]] == "\n"} { + puts -nonewline $fd $contents + } else { + puts $fd $contents + } + close $fd +} + +proc removeFile {name} { + file delete $name +} + +proc makeDirectory {name} { + file mkdir $name +} + +proc removeDirectory {name} { + file delete -force $name +} + +proc viewFile {name} { + global tcl_platform testConfig + if {($tcl_platform(platform) == "macintosh") || \ + ($testConfig(unixExecs) == 0)} { + set f [open $name] + set data [read -nonewline $f] + close $f + return $data + } else { + exec cat $name + } +} + +# Locate tcltest executable + +set tcltest [list [info nameofexecutable]] +if {$tcltest == "{}"} { + set tcltest {} + puts "Unable to find tcltest executable, multiple process tests will fail." +} + + diff --git a/tcl7.3/tests/dstring.test b/tcl7.6/tests/dstring.test similarity index 64% rename from tcl7.3/tests/dstring.test rename to tcl7.6/tests/dstring.test index 563dc89..93a84d4 100644 --- a/tcl7.3/tests/dstring.test +++ b/tcl7.6/tests/dstring.test @@ -5,26 +5,12 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1993 The Regents of the University of California. -# All rights reserved. +# Copyright (c) 1994 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) dstring.test 1.10 96/10/08 17:40:02 if {[info commands testdstring] == {}} { puts "This application hasn't been compiled with the \"testdstring\"" @@ -90,6 +76,38 @@ test dstring-2.3 {appending list elements} { } testdstring get } {aaaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbb ccccccccccccccccccccc ddddddddddddddddddddd eeeeeeeeeeeeeeeeeeeee fffffffffffffffffffff ggggggggggggggggggggg hhhhhhhhhhhhhhhhhhhhh iiiiiiiiiiiiiiiiiiiii jjjjjjjjjjjjjjjjjjjjj kkkkkkkkkkkkkkkkkkkkk lllllllllllllllllllll mmmmmmmmmmmmmmmmmmmmm nnnnnnnnnnnnnnnnnnnnn ooooooooooooooooooooo ppppppppppppppppppppp} +test dstring-2.4 {appending list elements} { + testdstring free + testdstring append "a\{" -1 + testdstring element abc + testdstring append " \{" -1 + testdstring element xyzzy + testdstring get +} "a{ abc {xyzzy" +test dstring-2.5 {appending list elements} { + testdstring free + testdstring append " \{" -1 + testdstring element abc + testdstring get +} " {abc" +test dstring-2.6 {appending list elements} { + testdstring free + testdstring append " " -1 + testdstring element abc + testdstring get +} { abc} +test dstring-2.7 {appending list elements} { + testdstring free + testdstring append "\\ " -1 + testdstring element abc + testdstring get +} "\\ abc" +test dstring-2.8 {appending list elements} { + testdstring free + testdstring append "x " -1 + testdstring element abc + testdstring get +} {x abc} test dstring-3.1 {nested sublists} { testdstring free @@ -135,7 +153,7 @@ test dstring-3.4 {nested sublists} { testdstring element last testdstring get } {before {during more} last} -test dstring-3.4 {nested sublists} { +test dstring-3.5 {nested sublists} { testdstring free testdstring element "\{" testdstring start @@ -165,6 +183,7 @@ test dstring-5.1 {copying to result} { } xyz test dstring-5.2 {copying to result} { testdstring free + catch {unset a} 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 } @@ -189,4 +208,41 @@ ooooooooooooooooooooo ppppppppppppppppppppp } abc} +test dstring-6.1 {Tcl_DStringGetResult} { + testdstring free + list [testdstring gresult staticsmall] [testdstring get] +} {{} short} +test dstring-6.2 {Tcl_DStringGetResult} { + 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 gresult staticsmall] [testdstring get] +} {{} short} +test dstring-6.3 {Tcl_DStringGetResult} { + set result {} + lappend result [testdstring gresult staticlarge] + testdstring append x 1 + lappend result [testdstring get] +} {{} {first0 first1 first2 first3 first4 first5 first6 first7 first8 first9 +second0 second1 second2 second3 second4 second5 second6 second7 second8 second9 +third0 third1 third2 third3 third4 third5 third6 third7 third8 third9 +fourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9 +fifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9 +sixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9 +seventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9 +x}} +test dstring-6.4 {Tcl_DStringGetResult} { + set result {} + lappend result [testdstring gresult free] + testdstring append y 1 + lappend result [testdstring get] +} {{} {This is a malloc-ed stringy}} +test dstring-6.5 {Tcl_DStringGetResult} { + set result {} + lappend result [testdstring gresult special] + testdstring append z 1 + lappend result [testdstring get] +} {{} {This is a specially-allocated stringz}} + testdstring free diff --git a/tcl7.3/tests/env.test b/tcl7.6/tests/env.test similarity index 70% rename from tcl7.3/tests/env.test rename to tcl7.6/tests/env.test index 43e9249..22f1284 100644 --- a/tcl7.3/tests/env.test +++ b/tcl7.6/tests/env.test @@ -5,26 +5,12 @@ # 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. +# Copyright (c) 1994 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) env.test 1.9 96/02/16 08:55:47 if {[string compare test [info procs test]] == 1} then {source defs} diff --git a/tcl7.3/tests/error.test b/tcl7.6/tests/error.test similarity index 79% rename from tcl7.3/tests/error.test rename to tcl7.6/tests/error.test index e2410aa..1ef6cd1 100644 --- a/tcl7.3/tests/error.test +++ b/tcl7.6/tests/error.test @@ -5,26 +5,12 @@ # 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. +# Copyright (c) 1994 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) error.test 1.15 96/10/08 17:40:23 if {[string compare test [info procs test]] == 1} then {source defs} @@ -85,16 +71,16 @@ test error-2.1 {simple errors from commands} { # 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} { +test error-2.2 {errors in nested procedures} { catch foo b } 1 -test error-2.2 {errors in nested procedures} { +test error-2.3 {errors in nested procedures} { catch foo b set b } {Human-generated} -test error-2.3 {errors in nested procedures} { +test error-2.4 {errors in nested procedures} { catch foo b set errorInfo } {Human-generated @@ -104,16 +90,16 @@ test error-2.3 {errors in nested procedures} { invoked from within "foo"} -test error-2.4 {errors in nested procedures} { +test error-2.5 {errors in nested procedures} { catch foo2 b } 1 -test error-2.5 {errors in nested procedures} { +test error-2.6 {errors in nested procedures} { catch foo2 b set b } {Human-generated} -test error-2.6 {errors in nested procedures} { +test error-2.7 {errors in nested procedures} { catch foo2 b set errorInfo } {glorp2 diff --git a/tcl7.3/tests/eval.test b/tcl7.6/tests/eval.test similarity index 54% rename from tcl7.3/tests/eval.test rename to tcl7.6/tests/eval.test index b75460f..dcd2ea8 100644 --- a/tcl7.3/tests/eval.test +++ b/tcl7.6/tests/eval.test @@ -5,26 +5,12 @@ # 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. +# Copyright (c) 1994 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) eval.test 1.7 96/02/16 08:55:49 if {[string compare test [info procs test]] == 1} then {source defs} diff --git a/tcl7.6/tests/event.test b/tcl7.6/tests/event.test new file mode 100644 index 0000000..6f4bbed --- /dev/null +++ b/tcl7.6/tests/event.test @@ -0,0 +1,932 @@ +# This file contains a collection of tests for the procedures in the file +# tclEvent.c, which includes the "after", "update", and "vwait" Tcl +# commands. Sourcing this file into Tcl runs the tests and generates +# output for errors. No output means no errors were found. +# +# Copyright (c) 1995-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# "@(#) event.test 1.21 96/08/19 12:53:40" + +if {[string compare test [info procs test]] == 1} then {source defs} + +if {[catch {testfilehandler create 0 off off}] == 0 } { + test event-1.1 {Tcl_CreateFileHandler, reading} { + testfilehandler close + testfilehandler create 0 readable off + testfilehandler clear 0 + testfilehandler oneevent + set result "" + lappend result [testfilehandler counts 0] + testfilehandler fillpartial 0 + testfilehandler oneevent + lappend result [testfilehandler counts 0] + testfilehandler oneevent + lappend result [testfilehandler counts 0] + testfilehandler close + set result + } {{0 0} {1 0} {2 0}} + test event-1.2 {Tcl_CreateFileHandler, writing} {nonPortable} { + # This test is non-portable because on some systems (e.g. + # SunOS 4.1.3) pipes seem to be writable always. + testfilehandler close + testfilehandler create 0 off writable + testfilehandler clear 0 + testfilehandler oneevent + set result "" + lappend result [testfilehandler counts 0] + testfilehandler fillpartial 0 + testfilehandler oneevent + lappend result [testfilehandler counts 0] + testfilehandler fill 0 + testfilehandler oneevent + lappend result [testfilehandler counts 0] + testfilehandler close + set result + } {{0 1} {0 2} {0 2}} + test event-1.3 {Tcl_DeleteFileHandler} { + testfilehandler close + testfilehandler create 2 disabled disabled + testfilehandler create 1 readable writable + testfilehandler create 0 disabled disabled + testfilehandler fillpartial 1 + set result "" + testfilehandler oneevent + lappend result [testfilehandler counts 1] + testfilehandler oneevent + lappend result [testfilehandler counts 1] + testfilehandler oneevent + lappend result [testfilehandler counts 1] + testfilehandler create 1 off off + testfilehandler oneevent + lappend result [testfilehandler counts 1] + testfilehandler close + set result + } {{0 1} {1 1} {1 2} {0 0}} + + test event-2.1 {Tcl_DeleteFileHandler} { + testfilehandler close + testfilehandler create 2 disabled disabled + testfilehandler create 1 readable writable + testfilehandler fillpartial 1 + set result "" + testfilehandler oneevent + lappend result [testfilehandler counts 1] + testfilehandler oneevent + lappend result [testfilehandler counts 1] + testfilehandler oneevent + lappend result [testfilehandler counts 1] + testfilehandler create 1 off off + testfilehandler oneevent + lappend result [testfilehandler counts 1] + testfilehandler close + set result + } {{0 1} {1 1} {1 2} {0 0}} + test event-2.2 {Tcl_DeleteFileHandler, fd reused & events still pending} { + testfilehandler close + testfilehandler create 0 readable writable + testfilehandler fillpartial 0 + set result "" + testfilehandler oneevent + lappend result [testfilehandler counts 0] + testfilehandler close + testfilehandler create 0 readable writable + testfilehandler oneevent + lappend result [testfilehandler counts 0] + testfilehandler close + set result + } {{0 1} {0 0}} + + test event-3.1 {FileHandlerCheckProc, TCL_FILE_EVENTS off } { + testfilehandler close + testfilehandler create 1 readable writable + testfilehandler fillpartial 1 + testfilehandler windowevent + set result [testfilehandler counts 1] + testfilehandler close + set result + } {0 0} + + test event-4.1 {FileHandlerEventProc, race between event and disabling } { + testfilehandler close + testfilehandler create 2 disabled disabled + testfilehandler create 1 readable writable + testfilehandler fillpartial 1 + set result "" + testfilehandler oneevent + lappend result [testfilehandler counts 1] + testfilehandler oneevent + lappend result [testfilehandler counts 1] + testfilehandler oneevent + lappend result [testfilehandler counts 1] + testfilehandler create 1 disabled disabled + testfilehandler oneevent + lappend result [testfilehandler counts 1] + testfilehandler close + set result + } {{0 1} {1 1} {1 2} {0 0}} + test event-4.2 {FileHandlerEventProc, TCL_FILE_EVENTS off } { + testfilehandler close + testfilehandler create 1 readable writable + testfilehandler create 2 readable writable + testfilehandler fillpartial 1 + testfilehandler fillpartial 2 + testfilehandler oneevent + set result "" + lappend result [testfilehandler counts 1] [testfilehandler counts 2] + testfilehandler windowevent + lappend result [testfilehandler counts 1] [testfilehandler counts 2] + testfilehandler close + set result + } {{0 0} {0 1} {0 0} {0 1}} + testfilehandler close + update +} + +test event-5.1 {Tcl_CreateTimerHandler procedure} { + foreach i [after info] { + after cancel $i + } + set x "" + foreach i {100 200 1000 50 150} { + after $i lappend x $i + } + after 200 + update + set x +} {50 100 150 200} + +test event-6.1 {Tcl_DeleteTimerHandler procedure} { + foreach i [after info] { + after cancel $i + } + set x "" + foreach i {100 200 300 50 150} { + after $i lappend x $i + } + after cancel lappend x 150 + after cancel lappend x 50 + after 200 + update + set x +} {100 200} + +if {[info commands testmodal] != ""} { + test event-7.1 {Tcl_CreateModalTimeout and Tcl_DeleteModalTimeout procedures} { + update + set x {} + set result {} + testmodal create 50 first + testmodal create 200 second + after 100 + testmodal eventnotimers + lappend result $x + after 150 + testmodal eventnotimers + lappend result $x + testmodal delete + testmodal eventnotimers + lappend result $x + testmodal eventnotimers + lappend result $x + testmodal delete + testmodal eventnotimers + lappend result $x + } {{} second {second first} {second first first} {second first first}} + + test event-8.1 {TimerHandlerSetupProc procedure, choosing correct timer} { + update + set x {} + after 100 {lappend x normal} + testmodal create 200 modal + vwait x + testmodal delete + set x + } {normal} + test event-8.2 {TimerHandlerSetupProc procedure, choosing correct timer} { + update + set x {} + after 200 {lappend x normal} + testmodal create 100 modal + vwait x + testmodal delete + set x + } {modal} +} + +# No tests for TimerHandlerCheckProc: it's already tested by other tests +# above and below. + +test event-9.1 {TimerHandlerEventProc procedure} { + foreach i [after info] { + after cancel $i + } + foreach i {100 200 300} { + after $i lappend x $i + } + after 100 + set result "" + set x "" + update + lappend result $x + after 100 + update + lappend result $x + after 100 + update + lappend result $x +} {100 {100 200} {100 200 300}} + +# No tests for Tcl_DoWhenIdle: it's already tested by other tests +# below. + +test event-10.1 {Tk_CancelIdleCall procedure} { + foreach i [after info] { + after cancel $i + } + set x before + set y before + set z before + after idle set x after1 + after idle set y after2 + after idle set z after3 + after cancel set y after2 + update idletasks + concat $x $y $z +} {after1 before after3} +test event-10.2 {Tk_CancelIdleCall procedure} { + foreach i [after info] { + after cancel $i + } + set x before + set y before + set z before + after idle set x after1 + after idle set y after2 + after idle set z after3 + after cancel set x after1 + update idletasks + concat $x $y $z +} {before after2 after3} + +test event-11.1 {Tcl_ServiceIdle, self-rescheduling handlers} { + foreach i [after info] { + after cancel $i + } + set x 1 + set y 23 + after idle {incr x; after idle {incr x; after idle {incr x}}} + after idle {incr y} + vwait x + set result "$x $y" + update idletasks + lappend result $x +} {2 24 4} + +test event-12.1 {Tcl_BackgroundError, HandleBgErrors procedures} { + catch {rename bgerror {}} + proc bgerror msg { + global errorInfo errorCode x + lappend x [list $msg $errorInfo $errorCode] + } + after idle {error "a simple error"} + after idle {open non_existent} + after idle {set errorInfo foobar; set errorCode xyzzy} + set x {} + update idletasks + rename bgerror {} + set x +} {{{a simple error} {a simple error + while executing +"error "a simple error"" + ("after" script)} NONE} {{couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory + while executing +"open non_existent" + ("after" script)} {POSIX ENOENT {no such file or directory}}}} +test event-12.2 {Tcl_BackgroundError, HandleBgErrors procedures} { + catch {rename bgerror {}} + proc bgerror msg { + global x + lappend x $msg + return -code break + } + after idle {error "a simple error"} + after idle {open non_existent} + set x {} + update idletasks + rename bgerror {} + set x +} {{a simple error}} + +test event-13.1 {BgErrorDeleteProc procedure} { + catch {interp delete foo} + interp create foo + foo eval { + proc bgerror args { + global errorInfo + set f [open err.out r+] + seek $f 0 end + puts $f "$args $errorInfo" + close $f + } + after 100 {error "first error"} + after 100 {error "second error"} + } + makeFile Unmodified err.out + after 100 {interp delete foo} + after 200 + update + set f [open err.out r] + set result [read $f] + close $f + removeFile err.out + set result +} {Unmodified +} + +test event-14.1 {tkerror/bgerror backwards compabitility} { + catch {rename bgerror {}} + proc tkerror {x y} { + return [expr $x + $y] + } + list [tkerror 4 7] [bgerror 8 -3] +} {11 5} +test event-14.2 {tkerror/bgerror backwards compabitility} { + proc bgerror {x y} { + return [expr 1 + $x + $y] + } + list [tkerror 6 -2] [bgerror 7 2] +} {5 10} +test event-14.3 {tkerror/bgerror backwards compabitility} { + proc bgerror {x y} { + return [expr 1 + $x + $y] + } + set result [list [info commands bgerror] [info commands tkerror]] + rename tkerror {} + lappend result [info commands bgerror] [info commands tkerror] +} {bgerror tkerror {} {}} +test event-14.4 {tkerror/bgerror backwards compabitility} { + proc tkerror {x y} { + return [expr 1 + $x + $y] + } + set result [list [info commands bgerror] [info commands tkerror]] + rename bgerror {} + lappend result [info commands bgerror] [info commands tkerror] +} {bgerror tkerror {} {}} +test event-14.5 {tkerror/bgerror backwards compabitility} { + proc tkerror {x y} { + return [expr 1 + $x + $y] + } + rename tkerror foo + list [info commands bgerror] [info commands tkerror] [foo 4 3] +} {{} {} 8} +test event-14.6 {tkerror/bgerror backwards compabitility} { + proc bgerror {x y} { + return [expr 1 + $x + $y] + } + catch {rename foo {}} + rename bgerror foo + list [info commands bgerror] [info commands tkerror] [foo 4 3] +} {{} {} 8} +test event-14.7 {tkerror/bgerror backwards compabitility} { + proc foo args {return $args} + catch {rename tkerror {}} + rename foo tkerror + list [info commands bgerror] [info commands tkerror] [info commands foo] [tkerror a b c d] +} {bgerror tkerror {} {a b c d}} +test event-14.8 {tkerror/bgerror backwards compabitility} { + proc foo args {return $args} + catch {rename bgerror {}} + rename foo bgerror + list [info commands bgerror] [info commands tkerror] [info commands foo] [tkerror a b c d] +} {bgerror tkerror {} {a b c d}} +test event-14.9 {tkerror/bgerror backwards compabitility} { + proc bgerror args {return $args} + list [catch {rename bgerror tkerror} msg] $msg +} {1 {can't rename to "tkerror": command already exists}} +rename bgerror {} + +if {[info commands testexithandler] != ""} { + test event-15.1 {Tcl_CreateExitHandler procedure} {unixOrPc} { + set child [open |[list [info nameofexecutable]] r+] + puts $child "testexithandler create 41; testexithandler create 4" + puts $child "testexithandler create 6; exit" + flush $child + set result [read $child] + close $child + set result + } {even 6 +even 4 +odd 41 +} + + test event-16.1 {Tcl_DeleteExitHandler procedure} {unixOrPc} { + set child [open |[list [info nameofexecutable]] r+] + puts $child "testexithandler create 41; testexithandler create 4" + puts $child "testexithandler create 6; testexithandler delete 41" + puts $child "testexithandler create 16; exit" + flush $child + set result [read $child] + close $child + set result + } {even 16 +even 6 +even 4 +} + test event-16.2 {Tcl_DeleteExitHandler procedure} {unixOrPc} { + set child [open |[list [info nameofexecutable]] r+] + puts $child "testexithandler create 41; testexithandler create 4" + puts $child "testexithandler create 6; testexithandler delete 4" + puts $child "testexithandler create 16; exit" + flush $child + set result [read $child] + close $child + set result + } {even 16 +even 6 +odd 41 +} + test event-16.3 {Tcl_DeleteExitHandler procedure} {unixOrPc} { + set child [open |[list [info nameofexecutable]] r+] + puts $child "testexithandler create 41; testexithandler create 4" + puts $child "testexithandler create 6; testexithandler delete 6" + puts $child "testexithandler create 16; exit" + flush $child + set result [read $child] + close $child + set result + } {even 16 +even 4 +odd 41 +} + test event-16.4 {Tcl_DeleteExitHandler procedure} {unixOrPc} { + set child [open |[list [info nameofexecutable]] r+] + puts $child "testexithandler create 41; testexithandler delete 41" + puts $child "testexithandler create 16; exit" + flush $child + set result [read $child] + close $child + set result + } {even 16 +} +} + +test event-17.1 {Tcl_Exit procedure} {unixOrPc} { + set child [open |[list [info nameofexecutable]] r+] + puts $child "exit 3" + list [catch {close $child} msg] $msg [lindex $errorCode 0] \ + [lindex $errorCode 2] +} {1 {child process exited abnormally} CHILDSTATUS 3} + +test event-18.1 {Tcl_AfterCmd procedure, basics} { + list [catch {after} msg] $msg +} {1 {wrong # args: should be "after option ?arg arg ...?"}} +test event-18.2 {Tcl_AfterCmd procedure, basics} { + list [catch {after 2x} msg] $msg +} {1 {expected integer but got "2x"}} +test event-18.3 {Tcl_AfterCmd procedure, basics} { + list [catch {after gorp} msg] $msg +} {1 {bad argument "gorp": must be cancel, idle, info, or a number}} +test event-18.4 {Tcl_AfterCmd procedure, ms argument} { + set x before + after 400 {set x after} + after 200 + update + set y $x + after 400 + update + list $y $x +} {before after} +test event-18.5 {Tcl_AfterCmd procedure, ms argument} { + set x before + after 300 set x after + after 200 + update + set y $x + after 200 + update + list $y $x +} {before after} +test event-18.6 {Tcl_AfterCmd procedure, cancel option} { + list [catch {after cancel} msg] $msg +} {1 {wrong # args: should be "after cancel id|command"}} +test event-18.7 {Tcl_AfterCmd procedure, cancel option} { + after cancel after#1 +} {} +test event-18.8 {Tcl_AfterCmd procedure, cancel option} { + after cancel {foo bar} +} {} +test event-18.9 {Tcl_AfterCmd procedure, cancel option} { + foreach i [after info] { + after cancel $i + } + set x before + set y [after 100 set x after] + after cancel $y + after 200 + update + set x +} {before} +test event-18.10 {Tcl_AfterCmd procedure, cancel option} { + foreach i [after info] { + after cancel $i + } + set x before + after 100 set x after + after cancel {set x after} + after 200 + update + set x +} {before} +test event-18.11 {Tcl_AfterCmd procedure, cancel option} { + foreach i [after info] { + after cancel $i + } + set x before + after 100 set x after + set id [after 300 set x after] + after cancel $id + after 200 + update + set y $x + set x cleared + after 200 + update + list $y $x +} {after cleared} +test event-18.12 {Tcl_AfterCmd procedure, cancel option} { + foreach i [after info] { + after cancel $i + } + set x first + after idle lappend x second + after idle lappend x third + set i [after idle lappend x fourth] + after cancel {lappend x second} + after cancel $i + update idletasks + set x +} {first third} +test event-18.13 {Tcl_AfterCmd procedure, cancel option, multiple arguments for command} { + foreach i [after info] { + after cancel $i + } + set x first + after idle lappend x second + after idle lappend x third + set i [after idle lappend x fourth] + after cancel lappend x second + after cancel $i + update idletasks + set x +} {first third} +test event-18.14 {Tcl_AfterCmd procedure, cancel option, cancel during handler, used to dump core} { + foreach i [after info] { + after cancel $i + } + set id [ + after 100 { + set x done + after cancel $id + } + ] + vwait x +} {} +test event-18.15 {Tcl_AfterCmd procedure, cancel option, multiple interps} { + foreach i [after info] { + after cancel $i + } + interp create x + x eval {set a before; set b before; after idle {set a a-after}; + after idle {set b b-after}} + set result [llength [x eval after info]] + lappend result [llength [after info]] + after cancel {set b b-after} + set a aaa + set b bbb + x eval {after cancel set a a-after} + update idletasks + lappend result $a $b [x eval {list $a $b}] + interp delete x + set result +} {2 0 aaa bbb {before b-after}} +test event-18.16 {Tcl_AfterCmd procedure, idle option} { + list [catch {after idle} msg] $msg +} {1 {wrong # args: should be "after idle script script ..."}} +test event-18.17 {Tcl_AfterCmd procedure, idle option} { + set x before + after idle {set x after} + set y $x + update idletasks + list $y $x +} {before after} +test event-18.18 {Tcl_AfterCmd procedure, idle option} { + set x before + after idle set x after + set y $x + update idletasks + list $y $x +} {before after} +set event1 [after idle event 1] +set event2 [after 1000 event 2] +interp create x +set childEvent [x eval {after idle event in child}] +test event-18.19 {Tcl_AfterCmd, info option} { + lsort [after info] +} "$event1 $event2" +test event-18.20 {Tcl_AfterCmd, info option} { + list [catch {after info a b} msg] $msg +} {1 {wrong # args: should be "after info ?id?"}} +test event-18.21 {Tcl_AfterCmd, info option} { + list [catch {after info $childEvent} msg] $msg +} "1 {event \"$childEvent\" doesn't exist}" +test event-18.22 {Tcl_AfterCmd, info option} { + list [after info $event1] [after info $event2] +} {{{event 1} idle} {{event 2} timer}} +after cancel $event1 +after cancel $event2 +interp delete x + +set event [after idle foo bar] +scan $event after#%d id +test event-19.1 {GetAfterEvent procedure} { + list [catch {after info xfter#$id} msg] $msg +} "1 {event \"xfter#$id\" doesn't exist}" +test event-19.2 {GetAfterEvent procedure} { + list [catch {after info afterx$id} msg] $msg +} "1 {event \"afterx$id\" doesn't exist}" +test event-19.3 {GetAfterEvent procedure} { + list [catch {after info after#ab} msg] $msg +} {1 {event "after#ab" doesn't exist}} +test event-19.4 {GetAfterEvent procedure} { + list [catch {after info after#} msg] $msg +} {1 {event "after#" doesn't exist}} +test event-19.5 {GetAfterEvent procedure} { + list [catch {after info after#${id}x} msg] $msg +} "1 {event \"after#${id}x\" doesn't exist}" +test event-19.6 {GetAfterEvent procedure} { + list [catch {after info afterx[expr $id+1]} msg] $msg +} "1 {event \"afterx[expr $id+1]\" doesn't exist}" +after cancel $event + +test event-20.1 {AfterProc procedure} { + set x before + proc foo {} { + set x untouched + after 100 {set x after} + after 200 + update + return $x + } + list [foo] $x +} {untouched after} +test event-20.2 {AfterProc procedure} { + catch {rename bgerror {}} + proc bgerror msg { + global x errorInfo + set x [list $msg $errorInfo] + } + set x empty + after 100 {error "After error"} + after 200 + set y $x + update + catch {rename bgerror {}} + list $y $x +} {empty {{After error} {After error + while executing +"error "After error"" + ("after" script)}}} +test event-20.3 {AfterProc procedure, deleting handler from itself} { + foreach i [after info] { + after cancel $i + } + proc foo {} { + global x + set x {} + foreach i [after info] { + lappend x [after info $i] + } + after cancel foo + } + after idle foo + after 1000 {error "I shouldn't ever have executed"} + update idletasks + set x +} {{{error "I shouldn't ever have executed"} timer}} +test event-20.4 {AfterProc procedure, deleting handler from itself} { + foreach i [after info] { + after cancel $i + } + proc foo {} { + global x + set x {} + foreach i [after info] { + lappend x [after info $i] + } + after cancel foo + } + after 1000 {error "I shouldn't ever have executed"} + after idle foo + update idletasks + set x +} {{{error "I shouldn't ever have executed"} timer}} + foreach i [after info] { + after cancel $i + } + +test event-21.1 {AfterCleanupProc procedure} { + catch {interp delete x} + interp create x + x eval {after 200 { + lappend x after + puts "part 1: this message should not appear" + }} + after 200 {lappend x after2} + x eval {after 200 { + lappend x after3 + puts "part 2: this message should not appear" + }} + after 200 {lappend x after4} + x eval {after 200 { + lappend x after5 + puts "part 3: this message should not appear" + }} + interp delete x + set x before + after 300 + update + set x +} {before after2 after4} + +test event-22.1 {Tcl_VwaitCmd procedure} { + list [catch {vwait} msg] $msg +} {1 {wrong # args: should be "vwait name"}} +test event-22.2 {Tcl_VwaitCmd procedure} { + list [catch {vwait a b} msg] $msg +} {1 {wrong # args: should be "vwait name"}} +test event-22.3 {Tcl_VwaitCmd procedure} { + catch {unset x} + set x 1 + list [catch {vwait x(1)} msg] $msg +} {1 {can't trace "x(1)": variable isn't array}} +test event-22.4 {Tcl_VwaitCmd procedure} { + foreach i [after info] { + after cancel $i + } + after 100 {set x x-done} + after 200 {set y y-done} + after 300 {set z z-done} + after idle {set q q-done} + set x before + set y before + set z before + set q before + list [vwait y] $x $y $z $q +} {{} x-done y-done before q-done} + +test event-23.1 {Tcl_UpdateCmd procedure} { + list [catch {update a b} msg] $msg +} {1 {wrong # args: should be "update ?idletasks?"}} +test event-23.2 {Tcl_UpdateCmd procedure} { + list [catch {update bogus} msg] $msg +} {1 {bad option "bogus": must be idletasks}} +test event-23.3 {Tcl_UpdateCmd procedure} { + foreach i [after info] { + after cancel $i + } + after 500 {set x after} + after idle {set y after} + after idle {set z "after, y = $y"} + set x before + set y before + set z before + update idletasks + list $x $y $z +} {before after {after, y = after}} +test event-23.4 {Tcl_UpdateCmd procedure} { + foreach i [after info] { + after cancel $i + } + after 200 {set x x-done} + after 500 {set y y-done} + after idle {set z z-done} + set x before + set y before + set z before + after 300 + update + list $x $y $z +} {x-done before z-done} + +if {[info commands testfilehandler] != ""} { + test event-24.1 {Tcl_WaitForFile procedure, readable} unixOnly { + foreach i [after info] { + after cancel $i + } + after 100 set x timeout + testfilehandler close + testfilehandler create 1 off off + set x "no timeout" + set result [testfilehandler wait 1 readable 0] + update + testfilehandler close + list $result $x + } {{} {no timeout}} + test event-24.2 {Tcl_WaitForFile procedure, readable} unixOnly { + foreach i [after info] { + after cancel $i + } + after 100 set x timeout + testfilehandler close + testfilehandler create 1 off off + set x "no timeout" + set result [testfilehandler wait 1 readable 100] + update + testfilehandler close + list $result $x + } {{} timeout} + test event-24.3 {Tcl_WaitForFile procedure, readable} unixOnly { + foreach i [after info] { + after cancel $i + } + after 100 set x timeout + testfilehandler close + testfilehandler create 1 off off + testfilehandler fillpartial 1 + set x "no timeout" + set result [testfilehandler wait 1 readable 100] + update + testfilehandler close + list $result $x + } {readable {no timeout}} + test event-24.4 {Tcl_WaitForFile procedure, writable} {unixOnly nonPortable} { + foreach i [after info] { + after cancel $i + } + after 100 set x timeout + testfilehandler close + testfilehandler create 1 off off + testfilehandler fill 1 + set x "no timeout" + set result [testfilehandler wait 1 writable 0] + update + testfilehandler close + list $result $x + } {{} {no timeout}} + test event-24.5 {Tcl_WaitForFile procedure, writable} {unixOnly nonPortable} { + foreach i [after info] { + after cancel $i + } + after 100 set x timeout + testfilehandler close + testfilehandler create 1 off off + testfilehandler fill 1 + set x "no timeout" + set result [testfilehandler wait 1 writable 100] + update + testfilehandler close + list $result $x + } {{} timeout} + test event-24.6 {Tcl_WaitForFile procedure, writable} unixOnly { + foreach i [after info] { + after cancel $i + } + after 100 set x timeout + testfilehandler close + testfilehandler create 1 off off + set x "no timeout" + set result [testfilehandler wait 1 writable 100] + update + testfilehandler close + list $result $x + } {writable {no timeout}} + test event-24.7 {Tcl_WaitForFile procedure, don't call other event handlers} unixOnly { + foreach i [after info] { + after cancel $i + } + after 100 lappend x timeout + after idle lappend x idle + testfilehandler close + testfilehandler create 1 off off + set x "" + set result [list [testfilehandler wait 1 readable 200] $x] + update + testfilehandler close + lappend result $x + } {{} {} {timeout idle}} + test event-24.8 {Tcl_WaitForFile procedure, waiting indefinitely} unixOnly { + set f [open "|sleep 2" r] + set result "" + lappend result [testfilewait $f readable 100] + lappend result [testfilewait $f readable -1] + close $f + set result + } {{} readable} +} + +foreach i [after info] { + after cancel $i +} diff --git a/tcl7.3/tests/exec.test b/tcl7.6/tests/exec.test similarity index 52% rename from tcl7.3/tests/exec.test rename to tcl7.6/tests/exec.test index 3528b52..2131f39 100644 --- a/tcl7.3/tests/exec.test +++ b/tcl7.6/tests/exec.test @@ -4,91 +4,90 @@ # 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. +# Copyright (c) 1991-1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) exec.test 1.54 96/08/27 14:40:01 if {[string compare test [info procs test]] == 1} then {source defs} +# If exec is not defined just return with no error +# Some platforms like the Macintosh do not have the exec command +if {[info commands exec] == ""} { + puts "exec not implemented for this machine" + return +} + # Basic operations. -test exec-1.1 {basic exec operation} { +test exec-1.1 {basic exec operation} {unixExecs} { exec echo a b c } "a b c" -test exec-1.2 {pipelining} { +test exec-1.2 {pipelining} {unixExecs} { exec echo a b c d | cat | cat } "a b c d" -test exec-1.3 {pipelining} { +test exec-1.3 {pipelining} {unixExecs} { 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} + list [scan $a "%d %d %d" b c d] $b $c +} {3 1 4} +set arg {12345678901234567890123456789012345678901234567890} +set arg "$arg$arg$arg$arg$arg$arg" +test exec-1.4 {long command lines} {unixExecs} { + exec echo $arg +} $arg +set arg {} # I/O redirection: input from Tcl command. -test exec-2.1 {redirecting input from immediate source} { +test exec-2.1 {redirecting input from immediate source} {unixExecs} { exec cat << "Sample text" } {Sample text} -test exec-2.2 {redirecting input from immediate source} { +test exec-2.2 {redirecting input from immediate source} {unixExecs} { exec << "Sample text" cat | cat } {Sample text} -test exec-2.3 {redirecting input from immediate source} { +test exec-2.3 {redirecting input from immediate source} {unixExecs} { exec cat << "Sample text" | cat } {Sample text} -test exec-2.4 {redirecting input from immediate source} { +test exec-2.4 {redirecting input from immediate source} {unixExecs} { exec cat | cat << "Sample text" } {Sample text} -test exec-2.5 {redirecting input from immediate source} { +test exec-2.5 {redirecting input from immediate source} {unixExecs} { exec cat "< gorp.file exec cat gorp.file } "Some simple words" -test exec-3.2 {redirecting output to file} { +test exec-3.2 {redirecting output to file} {unixExecs} { exec echo "More simple words" | >gorp.file cat | cat exec cat gorp.file } "More simple words" -test exec-3.3 {redirecting output to file} { +test exec-3.3 {redirecting output to file} {unixExecs} { exec > gorp.file echo "Different simple words" | cat | cat exec cat gorp.file } "Different simple words" -test exec-3.4 {redirecting output to file} { +test exec-3.4 {redirecting output to file} {unixExecs} { exec echo "Some simple words" >gorp.file exec cat gorp.file } "Some simple words" -test exec-3.5 {redirecting output to file} { +test exec-3.5 {redirecting output to file} {unixExecs} { 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} { +test exec-3.6 {redirecting output to file} {unixExecs} { 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} { +test exec-3.7 {redirecting output to file} {unixExecs} { set f [open gorp.file w] puts $f "Line 1" flush $f @@ -102,20 +101,20 @@ test exec-3.7 {redirecting output to file} { # I/O redirection: output and stderr to file. catch {exec rm -f gorp.file} -test exec-4.1 {redirecting output and stderr to file} { +test exec-4.1 {redirecting output and stderr to file} {unixExecs} { exec echo "test output" >& gorp.file exec cat gorp.file } "test output" -test exec-4.2 {redirecting output and stderr to file} { +test exec-4.2 {redirecting output and stderr to file} {unixExecs} { 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} { +test exec-4.3 {redirecting output and stderr to file} {unixExecs} { 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} { +test exec-4.4 {redirecting output and stderr to file} {unixExecs} { set f [open gorp.file w] puts $f "Line 1" flush $f @@ -125,7 +124,7 @@ test exec-4.4 {redirecting output and stderr to file} { close $f exec cat gorp.file } "Line 1\nMore text\nEven more\nLine 3" -test exec-4.5 {redirecting output and stderr to file} { +test exec-4.5 {redirecting output and stderr to file} {unixExecs} { set f [open gorp.file w] puts $f "Line 1" flush $f @@ -138,29 +137,29 @@ test exec-4.5 {redirecting output and stderr to file} { # I/O redirection: input from file. -exec echo "Just a few thoughts" > gorp.file -test exec-5.1 {redirecting input from file} { +catch {exec echo "Just a few thoughts" > gorp.file} +test exec-5.1 {redirecting input from file} {unixExecs} { exec cat < gorp.file } {Just a few thoughts} -test exec-5.2 {redirecting input from file} { +test exec-5.2 {redirecting input from file} {unixExecs} { exec cat | cat < gorp.file } {Just a few thoughts} -test exec-5.3 {redirecting input from file} { +test exec-5.3 {redirecting input from file} {unixExecs} { exec cat < gorp.file | cat } {Just a few thoughts} -test exec-5.4 {redirecting input from file} { +test exec-5.4 {redirecting input from file} {unixExecs} { exec < gorp.file cat | cat } {Just a few thoughts} -test exec-5.5 {redirecting input from file} { +test exec-5.5 {redirecting input from file} {unixExecs} { exec cat &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 +test exec-6.3 {redirecting stderr through a pipeline} {unixExecs} { + 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} { +test exec-7.1 {multiple I/O redirections} {unixExecs} { exec << "command input" > gorp.file2 cat < gorp.file exec cat gorp.file2 } {Just a few thoughts} -test exec-7.2 {multiple I/O redirections} { +test exec-7.2 {multiple I/O redirections} {unixExecs} { exec < gorp.file << "command input" cat } {command input} @@ -197,7 +197,7 @@ 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} { +test exec-8.1 {long input and output} {unixExecs} { exec cat << $a } $a @@ -205,29 +205,27 @@ test exec-8.1 {long input and output} { 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 $x [string tolower $msg] [string tolower $errorCode] +} {1 {couldn't execute "gorp456": no such file or directory} {posix enoent {no such file or directory}}} +test exec-9.2 {commands returning errors} {unixExecs} { + string tolower [list [catch {exec echo foo | foo123} msg] $msg $errorCode] +} {1 {couldn't execute "foo123": no such file or directory} {posix enoent {no such file or directory}}} +test exec-9.3 {commands returning errors} {unixExecs} { 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} { +test exec-9.4 {commands returning errors} {unixExecs} { + list [catch {exec sh -c "exit 43" | echo "foo bar"} msg] $msg +} {1 {foo bar +child process exited abnormally}} +test exec-9.5 {commands returning errors} {unixExecs} { + list [catch {exec gorp456 | echo a b c} msg] [string tolower $msg] +} {1 {couldn't execute "gorp456": no such file or directory}} +test exec-9.6 {commands returning errors} {unixExecs} { 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 +test exec-9.7 {commands returning errors} {unixExecs} { + list [catch {exec sh -c "echo error msg 1>&2" \ + | sh -c "echo error msg 1>&2"} msg] $msg } {1 {error msg error msg}} @@ -276,101 +274,112 @@ test exec-10.13 {errors in exec invocation} { 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} { +test exec-10.15 {errors in exec invocation} {unixExecs} { 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} { +test exec-10.16 {errors in exec invocation} {unixExecs} { 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} { +test exec-10.17 {errors in exec invocation} {unixExecs} { 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}" +} "1 {channel \"$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}" +} "1 {channel \"$f\" wasn't opened for writing}" close $f +test exec-10.20 {errors in exec invocation} { + list [catch {exec ~non_existent_user/foo/bar} msg] $msg +} {1 {user "non_existent_user" doesn't exist}} +test exec-10.21 {errors in exec invocation} {unixExecs} { + list [catch {exec true | ~xyzzy_bad_user/x | false} msg] $msg +} {1 {user "xyzzy_bad_user" doesn't exist}} # Commands in background. -test exec-11.1 {commands in background} { +test exec-11.1 {commands in background} {unixExecs} { set x [lindex [time {exec sleep 2 &}] 0] expr $x<1000000 } 1 -test exec-11.2 {commands in background} { +test exec-11.2 {commands in background} {unixExecs} { list [catch {exec echo a &b} msg] $msg } {0 {a &b}} -test exec-11.3 {commands in background} { +test exec-11.3 {commands in background} {unixExecs} { llength [exec sleep 1 &] } 1 -test exec-11.4 {commands in background} { +test exec-11.4 {commands in background} {unixExecs} { llength [exec sleep 1 | sleep 1 | sleep 1 &] } 3 +test exec-11.5 {commands in background} {unixExecs} { + set f [open gorp.file w] + puts $f { catch { exec echo foo & } } + close $f + string compare "foo" [exec [info nameofexecutable] gorp.file] +} 0 # 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} -} +catch {exec sleep 3} +test exec-12.1 {reaping background processes} {unixOnly nonPortable} { + 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} {unixExecs nonPortable} { + exec sleep 2 | sleep 2 | sleep 2 & + catch {exec ps | fgrep -i "sleep" | fgrep -i -v fgrep | wc} msg + set x [lindex $msg 0] + exec sleep 3 + catch {exec ps | fgrep -i "sleep" | fgrep -i -v fgrep | wc} msg + list $x [lindex $msg 0] +} {3 0} +test exec-12.3 {reaping background processes} {unixOnly nonPortable} { + exec sleep 1000 & + exec sleep 1000 & + set x [exec ps | fgrep "sleep" | 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" | fgrep -v fgrep | wc} msg + set x [lindex $msg 0] + + foreach i $pids { + catch {exec kill -KILL $i} + } + catch {exec ps | fgrep "sleep" | 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} { +test exec-13.1 {setting errorCode variable} {unixExecs} { 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} { +test exec-13.2 {setting errorCode variable} {unixExecs} { 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} + set x [catch {exec _weird_cmd_} msg] + list $x [string tolower $msg] [lindex $errorCode 0] \ + [string tolower [lrange $errorCode 2 end]] +} {1 {couldn't execute "_weird_cmd_": no such file or directory} POSIX {{no such file or directory}}} # Switches before the first argument -test exec-14.1 {-keepnewline switch} { +test exec-14.1 {-keepnewline switch} {unixExecs} { exec -keepnewline echo foo } "foo\n" test exec-14.2 {-keepnewline switch} { @@ -380,27 +389,27 @@ 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}} + list [catch {exec -- -gorp} msg] [string tolower $msg] +} {1 {couldn't execute "-gorp": no such file or directory}} # Redirecting standard error separately from standard output -test exec-15.1 {standard error redirection} { +test exec-15.1 {standard error redirection} {unixExecs} { 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} { +test exec-15.2 {standard error redirection} {unixExecs} { 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} { +test exec-15.3 {standard error redirection} {unixExecs} { 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} { +test exec-15.4 {standard error redirection} {unixExecs} { set f [open gorp.file w] puts $f "Line 1" flush $f @@ -411,25 +420,58 @@ test exec-15.4 {standard error redirection} { } {Line 1 foo bar Line 3} -test exec-15.5 {standard error redirection} { +test exec-15.5 {standard error redirection} {unixExecs} { 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} { +test exec-15.6 {standard error redirection} {unixExecs} { 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}} -} +test exec-16.1 {flush output before exec} {unixExecs} { + set f [open gorp.file w] + puts $f "First line" + exec echo "Second line" >@ $f + puts $f "Third line" + close $f + exec cat gorp.file +} {First line +Second line +Third line} +test exec-16.2 {flush output before exec} {unixExecs} { + set f [open gorp.file w] + puts $f "First line" + exec sh -c "echo Second line 1>&2" >&@ $f > gorp.file2 + puts $f "Third line" + close $f + exec cat gorp.file +} {First line +Second line +Third line} + +test exec-17.1 { inheriting standard I/O } {unixOrPc unixExecs} { + set f [open script w] + puts $f {close stdout + set f [open gorp.file w] + catch {exec echo foobar &} + exec sleep 2 + close $f + } + close $f + catch {eval exec $tcltest script} result + set f [open gorp.file r] + lappend result [read $f] + close $f + set result +} {{foobar +}} + +removeFile script +removeFile gorp.file +removeFile gorp.file2 -catch {exec rm -f gorp.file} -catch {exec rm -f gorp.file2} return {} diff --git a/tcl7.3/tests/expr.test b/tcl7.6/tests/expr.test similarity index 80% rename from tcl7.3/tests/expr.test rename to tcl7.6/tests/expr.test index 199134f..9ad8942 100644 --- a/tcl7.3/tests/expr.test +++ b/tcl7.6/tests/expr.test @@ -4,27 +4,13 @@ # 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. +# Copyright (c) 1991-1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) expr.test 1.49 96/09/06 13:23:15 if {[string compare test [info procs test]] == 1} then {source defs} @@ -87,46 +73,51 @@ 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 +test expr-1.50 {integer operators} {expr +36} 36 +test expr-1.51 {integer operators} {expr +--++36} 36 +test expr-1.52 {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} { +test expr-2.3 {floating-point operators} {expr +5.7} 5.7 +test expr-2.4 {floating-point operators} {expr +--+-62.0} -62.0 +test expr-2.5 {floating-point operators} {expr !2.1} 0 +test expr-2.6 {floating-point operators} {expr !0.0} 1 +test expr-2.7 {floating-point operators} {expr 4.2*6.3} 26.46 +test expr-2.8 {floating-point operators} {expr 36.0/12.0} 3.0 +test expr-2.9 {floating-point operators} {expr 27/4.0} 6.75 +test expr-2.10 {floating-point operators} {expr 2.3+2.1} 4.4 +test expr-2.11 {floating-point operators} {expr 2.3-6.5} -4.2 +test expr-2.12 {floating-point operators} {expr 3.1>2.1} 1 +test expr-2.13 {floating-point operators} {expr {2.1 > 2.1}} 0 +test expr-2.14 {floating-point operators} {expr 1.23>2.34e+1} 0 +test expr-2.15 {floating-point operators} {expr 3.45<2.34} 0 +test expr-2.16 {floating-point operators} {expr 0.002e3<--200e-2} 0 +test expr-2.17 {floating-point operators} {expr 1.1<2.1} 1 +test expr-2.18 {floating-point operators} {expr 3.1>=2.2} 1 +test expr-2.19 {floating-point operators} {expr 2.345>=2.345} 1 +test expr-2.20 {floating-point operators} {expr 1.1>=2.2} 0 +test expr-2.21 {floating-point operators} {expr 3.0<=2.0} 0 +test expr-2.22 {floating-point operators} {expr 2.2<=2.2} 1 +test expr-2.23 {floating-point operators} {expr 2.2<=2.2001} 1 +test expr-2.24 {floating-point operators} {expr 3.2==2.2} 0 +test expr-2.25 {floating-point operators} {expr 2.2==2.2} 1 +test expr-2.26 {floating-point operators} {expr 3.2!=2.2} 1 +test expr-2.27 {floating-point operators} {expr 2.2!=2.2} 0 +test expr-2.28 {floating-point operators} {expr 0.0&&0.0} 0 +test expr-2.29 {floating-point operators} {expr 0.0&&1.3} 0 +test expr-2.30 {floating-point operators} {expr 1.3&&0.0} 0 +test expr-2.31 {floating-point operators} {expr 1.3&&3.3} 1 +test expr-2.32 {floating-point operators} {expr 0.0||0.0} 0 +test expr-2.33 {floating-point operators} {expr 0.0||1.3} 1 +test expr-2.34 {floating-point operators} {expr 1.3||0.0} 1 +test expr-2.35 {floating-point operators} {expr 3.3||0.0} 1 +test expr-2.36 {floating-point operators} {expr 3.3>2.3?44.3:66.3} 44.3 +test expr-2.37 {floating-point operators} {expr 2.3>3.3?44.3:66.3} 66.3 +test expr-2.38 {floating-point operators} { list [catch {expr 028.1 + 09.2} msg] $msg } {0 37.3} @@ -183,8 +174,12 @@ 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 + +# The following tests are non-portable because on some systems "+" +# and "-" can be parsed as numbers. + +test expr-4.19 {string operators} {nonPortable} {expr {"0" == "+"}} 0 +test expr-4.20 {string operators} {nonPortable} {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 @@ -194,48 +189,51 @@ 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.3 {illegal string operations} { +test expr-5.4 {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} { +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.5 {illegal string operations} { +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.6 {illegal string operations} { +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.7 {illegal string operations} { +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.8 {illegal string operations} { +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.9 {illegal string operations} { +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.10 {illegal string operations} { +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.11 {illegal string operations} { +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.12 {illegal string operations} { +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.13 {illegal string operations} { +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.14 {illegal string operations} { +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.15 {illegal string operations} { +test expr-5.16 {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} { +test expr-5.17 {illegal string operations} { list [catch {expr {"a"?4:2}} msg] $msg } {1 {can't use non-numeric string as operand of "?"}} @@ -251,6 +249,7 @@ 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-8.3 {precedence checks} {expr +2-4} -2 test expr-9.1 {precedence checks} {expr 2*3+4} 10 test expr-9.2 {precedence checks} {expr 8/2+4} 8 @@ -284,7 +283,7 @@ 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-13.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 @@ -316,11 +315,16 @@ 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 +test expr-20.3 {precedence checks} {expr 1?2:0?3:4} 2 +test expr-20.4 {precedence checks} {expr 0?2:0?3:4} 4 +test expr-20.5 {precedence checks} {expr 1?2?3:4:0} 3 +test expr-20.6 {precedence checks} {expr 0?2?3:4:0} 0 # Parentheses. test expr-21.1 {parenthesization} {expr (2+4)*6} 36 test expr-21.2 {parenthesization} {expr (1?0:4)||1} 1 +test expr-21.3 {parenthesization} {expr +(3-4)} -1 # Embedded commands and variable names. @@ -339,28 +343,31 @@ test expr-22.3 {embedded variables} { 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"}} +} {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} { +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} { +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} { +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} { +test expr-23.7 {double quotes} { list [catch {expr {"a[error Testing]bc"}} msg] $msg } {1 Testing} +test expr-23.8 {double quotes} { + list [catch {expr {"12398712938788234-1298379" != ""}} msg] $msg +} {0 1} # Numbers in various bases. @@ -484,6 +491,26 @@ test expr-27.5 {cancelled evaluation} { test expr-27.6 {cancelled evaluation} { list [catch {expr {0 && [concat $x]}} msg] $msg } {0 0} +test expr-27.7 {cancelled evaluation} { + set one 1 + list [catch {expr {1 || 1/$one}} msg] $msg +} {0 1} +test expr-27.8 {cancelled evaluation} { + list [catch {expr {1 || -"string"}} msg] $msg +} {0 1} +test expr-27.9 {cancelled evaluation} { + list [catch {expr {1 || ("string" * ("x" && "y"))}} msg] $msg +} {0 1} +test expr-27.10 {cancelled evaluation} { + set x -1.0 + list [catch {expr {($x > 0) ? round(log($x)) : 0}} msg] $msg +} {0 0} +test expr-27.11 {cancelled evaluation} { + list [catch {expr {0 && foo}} msg] $msg +} {1 {syntax error in expression "0 && foo"}} +test expr-27.12 {cancelled evaluation} { + list [catch {expr {0 ? 1 : foo}} msg] $msg +} {1 {syntax error in expression "0 ? 1 : foo"}} # Tcl_ExprBool as used in "if" statements @@ -545,6 +572,12 @@ test expr-28.11 {Tcl_ExprBoolean usage} { test expr-28.12 {Tcl_ExprBool usage} { list [catch {if {"abc"} {}} msg] $msg } {1 {expected boolean value but got "abc"}} +test expr-28.13 {Tcl_ExprBool usage} { + list [catch {if {"ogle"} {}} msg] $msg +} {1 {expected boolean value but got "ogle"}} +test expr-28.14 {Tcl_ExprBool usage} { + list [catch {if {"o"} {}} msg] $msg +} {1 {expected boolean value but got "o"}} # Operands enclosed in braces @@ -659,11 +692,9 @@ test expr-32.23 {math functions in expressions} { 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.25 {math functions in expressions} {nonPortable} { + 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} @@ -764,11 +795,9 @@ test expr-34.8 {errors in math functions} { 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.10 {errors in math functions} {nonPortable} { + 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}}} @@ -820,3 +849,48 @@ catch {unset tcl_precision} test expr-35.8 {tcl_precision variable} { expr 2.0/3 } 0.666667 + +test expr-36.1 {ExprLooksLikeInt procedure} { + list [catch {expr 0289} msg] $msg +} {1 {syntax error in expression "0289"}} +test expr-36.2 {ExprLooksLikeInt procedure} { + set x 0289 + list [catch {expr {$x+1}} msg] $msg +} {1 {can't use non-numeric string as operand of "+"}} +test expr-36.3 {ExprLooksLikeInt procedure} { + list [catch {expr 0289.1} msg] $msg +} {0 289.1} +test expr-36.4 {ExprLooksLikeInt procedure} { + set x 0289.1 + list [catch {expr {$x+1}} msg] $msg +} {0 290.1} +test expr-36.5 {ExprLooksLikeInt procedure} { + set x { +22} + list [catch {expr {$x+1}} msg] $msg +} {0 23} +test expr-36.6 {ExprLooksLikeInt procedure} { + set x { -22} + list [catch {expr {$x+1}} msg] $msg +} {0 -21} +test expr-36.7 {ExprLooksLikeInt procedure} {nonPortable unixOnly} { + list [catch {expr nan} msg] $msg +} {1 {domain error: argument not in valid range}} +test expr-36.8 {ExprLooksLikeInt procedure} { + list [catch {expr 78e1} msg] $msg +} {0 780.0} +test expr-36.9 {ExprLooksLikeInt procedure} { + list [catch {expr 24E1} msg] $msg +} {0 240.0} +test expr-36.10 {ExprLooksLikeInt procedure} {nonPortable unixOnly} { + list [catch {expr 78e} msg] $msg +} {1 {syntax error in expression "78e"}} + + +# Special test for Pentium arithmetic bug of 1994: + +if {(4195835.0 - (4195835.0/3145727.0)*3145727.0) == 256.0} { + puts "Warning: this machine contains a defective Pentium processor" + puts "that performs arithmetic incorrectly. I recommend that you" + puts "call Intel customer service immediately at 1-800-628-8686" + puts "to request a replacement processor." +} diff --git a/tcl7.6/tests/fCmd.test b/tcl7.6/tests/fCmd.test new file mode 100644 index 0000000..f5c0a5b --- /dev/null +++ b/tcl7.6/tests/fCmd.test @@ -0,0 +1,1982 @@ +# This file tests the tclFCmd.c 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) 1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) fCmd.test 1.18 96/10/14 14:38:39 +# + +if {[string compare test [info procs test]] == 1} then {source defs} + +if {$user == "root"} { + puts "Skipping fCmd tests. They depend on not being able to write to" + puts "certain directories. It would be too dangerous to run them as root." + return +} + +proc createfile {file {string a}} { + set f [open $file w] + puts -nonewline $f $string + close $f + return $string +} + +# +# checkcontent -- +# +# Ensures that file "file" contains only the string "matchString" +# returns 0 if the file does not exist, or has a different content +# +proc checkcontent {file matchString} { + if {[catch { + set f [open $file] + set fileString [read $f] + close $f + }]} { + return 0 + } + return [string match $matchString $fileString] +} + +proc cleanup {args} { + foreach p ". $args" { + set x "" + catch { + set x [glob [file join $p tf*] [file join $p td*]] + } + if {$x != ""} { + eval file delete -force $x + } + } +} + +proc contents {file} { + set f [open $file r] + set r [read $f] + close $f + set r +} + +set testConfig(NT) 0 +set testConfig(95) 0 + +switch $tcl_platform(os) { + "Windows NT" {set testConfig(NT) 1} + "Windows 95" {set testConfig(95) 1} +} + +set root [lindex [file split [pwd]] 0] + +# A really long file name +# length of long is 1216 chars, which should be greater than any static +# buffer or allowable filename. + +set long "abcdefghihjllmnopqrstuvwxyz01234567890" +append long $long +append long $long +append long $long +append long $long +append long $long + +test fcmd-1.1 {TclFileRenameCmd} { + cleanup + createfile tf1 + file rename tf1 tf2 + glob tf* +} {tf2} + +test fcmd-2.1 {TclFileCopyCmd} { + cleanup + createfile tf1 + file copy tf1 tf2 + lsort [glob tf*] +} {tf1 tf2} + +test fcmd-3.1 {FileCopyRename: FileForceOption fails} { + list [catch {file rename -xyz} msg] $msg +} {1 {bad option "-xyz": should be -force or --}} +test fcmd-3.2 {FileCopyRename: not enough args} { + list [catch {file rename xyz} msg] $msg +} {1 {wrong # args: should be "file rename ?options? source ?source ...? target"}} +test fcmd-3.3 {FileCopyRename: Tcl_TranslateFileName fails} { + list [catch {file rename xyz ~nonexistantuser} msg] $msg +} {1 {user "nonexistantuser" doesn't exist}} +test fcmd-3.4 {FileCopyRename: Tcl_TranslateFileName passes} { + cleanup + list [catch {file copy tf1 ~} msg] $msg +} {1 {error copying "tf1": no such file or directory}} +test fcmd-3.5 {FileCopyRename: target doesn't exist: stat(target) != 0} { + cleanup + list [catch {file rename tf1 tf2 tf3} msg] $msg +} {1 {error renaming: target "tf3" is not a directory}} +test fcmd-3.6 {FileCopyRename: target tf3 is not a directory: !S_ISDIR(target)} { + cleanup + createfile tf3 + list [catch {file rename tf1 tf2 tf3} msg] $msg +} {1 {error renaming: target "tf3" is not a directory}} +test fcmd-3.7 {FileCopyRename: target exists & is directory} { + cleanup + file mkdir td1 + createfile tf1 tf1 + file rename tf1 td1 + contents [file join td1 tf1] +} {tf1} +test fcmd-3.8 {FileCopyRename: too many arguments: argc - i > 2} { + cleanup + list [catch {file rename tf1 tf2 tf3} msg] $msg +} {1 {error renaming: target "tf3" is not a directory}} +test fcmd-3.9 {FileCopyRename: too many arguments: argc - i > 2} { + cleanup + list [catch {file copy -force -- tf1 tf2 tf3} msg] $msg +} {1 {error copying: target "tf3" is not a directory}} +test fcmd-3.10 {FileCopyRename: just 2 arguments} { + cleanup + createfile tf1 tf1 + file rename tf1 tf2 + contents tf2 +} {tf1} +test fcmd-3.11 {FileCopyRename: just 2 arguments} { + cleanup + createfile tf1 tf1 + file rename -force -force -- tf1 tf2 + contents tf2 +} {tf1} +test fcmd-3.12 {FileCopyRename: move each source: 1 source} { + cleanup + createfile tf1 tf1 + file mkdir td1 + file rename tf1 td1 + contents [file join td1 tf1] +} {tf1} +test fcmd-3.13 {FileCopyRename: move each source: multiple sources} { + cleanup + createfile tf1 tf1 + createfile tf2 tf2 + createfile tf3 tf3 + createfile tf4 tf4 + file mkdir td1 + file rename tf1 tf2 tf3 tf4 td1 + list [contents [file join td1 tf1]] [contents [file join td1 tf2]] \ + [contents [file join td1 tf3]] [contents [file join td1 tf4]] +} {tf1 tf2 tf3 tf4} +test fcmd-3.14 {FileCopyRename: FileBasename fails} { + cleanup + file mkdir td1 + list [catch {file rename ~nonexistantuser td1} msg] $msg +} {1 {user "nonexistantuser" doesn't exist}} +test fcmd-3.15 {FileCopyRename: source[0] == '\0'} {unixOrPc} { + cleanup + file mkdir td1 + list [catch {file rename / td1} msg] $msg +} {1 {error renaming "/" to "td1": file already exists}} +test fcmd-3.16 {FileCopyRename: break on first error} { + cleanup + createfile tf1 + createfile tf2 + createfile tf3 + createfile tf4 + file mkdir td1 + createfile [file join td1 tf3] + list [catch {file rename tf1 tf2 tf3 tf4 td1} msg] $msg +} [subst {1 {error renaming "tf3" to "[file join td1 tf3]": file already exists}}] + +test fcmd-4.1 {TclFileMakeDirsCmd: make each dir: 1 dir} { + cleanup + file mkdir td1 + glob td* +} {td1} +test fcmd-4.2 {TclFileMakeDirsCmd: make each dir: multiple dirs} { + cleanup + file mkdir td1 td2 td3 + lsort [glob td*] +} {td1 td2 td3} +test fcmd-4.3 {TclFileMakeDirsCmd: stops on first error} { + cleanup + createfile tf1 + catch {file mkdir td1 td2 tf1 td3 td4} + glob td1 td2 tf1 td3 td4 +} {td1 td2 tf1} +test fcmd-4.4 {TclFileMakeDirsCmd: Tcl_TranslateFileName fails} { + cleanup + list [catch {file mkdir ~nonexistantuser} msg] $msg +} {1 {user "nonexistantuser" doesn't exist}} +test fcmd-4.5 {TclFileMakeDirsCmd: Tcl_SplitPath returns 0: *name == '\0'} { + cleanup + list [catch {file mkdir ""} msg] $msg +} {1 {can't create directory "": no such file or directory}} +test fcmd-4.6 {TclFileMakeDirsCmd: one level deep} { + cleanup + file mkdir td1 + glob td1 +} {td1} +test fcmd-4.7 {TclFileMakeDirsCmd: multi levels deep} { + cleanup + file mkdir [file join td1 td2 td3 td4] + glob td1 [file join td1 td2] +} "td1 [file join td1 td2]" +test fcmd-4.8 {TclFileMakeDirsCmd: already exist: lstat(target) == 0} { + cleanup + file mkdir td1 + set x [file exist td1] + file mkdir td1 + list $x [file exist td1] +} {1 1} +test fcmd-4.9 {TclFileMakeDirsCmd: exists, not dir} { + cleanup + createfile tf1 + list [catch {file mkdir tf1} msg] $msg +} [subst {1 {can't create directory "[file join tf1]": file already exists}}] +test fcmd-4.10 {TclFileMakeDirsCmd: exists, is dir} { + cleanup + file mkdir td1 + set x [file exist td1] + file mkdir td1 + list $x [file exist td1] +} {1 1} +test fcmd-4.11 {TclFileMakeDirsCmd: doesn't exist: errno != ENOENT} {unixOnly} { + cleanup + file mkdir td1/td2/td3 + testchmod 000 td1/td2 + set msg [list [catch {file mkdir td1/td2/td3/td4} msg] $msg] + testchmod 755 td1/td2 + set msg +} {1 {can't create directory "td1/td2/td3": permission denied}} +test fcmd-4.12 {TclFileMakeDirsCmd: doesn't exist: errno != ENOENT} {macOnly} { + cleanup + list [catch {file mkdir nonexistantvolume:} msg] $msg +} {1 {can't create directory "nonexistantvolume:": invalid argument}} +test fcmd-4.13 {TclFileMakeDirsCmd: doesn't exist: errno == ENOENT} { + cleanup + set x [file exist td1] + file mkdir td1 + list $x [file exist td1] +} {0 1} +test fcmd-4.14 {TclFileMakeDirsCmd: TclpCreateDirectory fails} {unixOnly nonPortable} { + cleanup + list [catch {file mkdir /tf1} msg] $msg +} {1 {can't create directory "/tf1": permission denied}} +test fcmd-4.15 {TclFileMakeDirsCmd: TclpCreateDirectory fails} {pcOnly} { + # error message is either "permission denied" or "file already exists" + catch {file mkdir c:.} msg + string range $msg 0 26 +} {can't create directory "c:"} +test fcmd-4.16 {TclFileMakeDirsCmd: TclpCreateDirectory fails} {macOnly} { + list [catch {file mkdir ${root}:} msg] $msg +} [subst {1 {can't create directory "${root}:": no such file or directory}}] +test fcmd-4.17 {TclFileMakeDirsCmd: TclpCreateDirectory succeeds} { + cleanup + file mkdir tf1 + file exists tf1 +} {1} + +test fcmd-5.1 {TclFileDeleteCmd: FileForceOption fails} { + list [catch {file delete -xyz} msg] $msg +} {1 {bad option "-xyz": should be -force or --}} +test fcmd-5.2 {TclFileDeleteCmd: not enough args} { + list [catch {file delete -force -force} msg] $msg +} {1 {wrong # args: should be "file delete ?options? file ?file ...?"}} +test fcmd-5.3 {TclFileDeleteCmd: 1 file} { + cleanup + createfile tf1 + createfile tf2 + file mkdir td1 + file delete tf2 + glob tf* td* +} {tf1 td1} +test fcmd-5.4 {TclFileDeleteCmd: multiple files} { + cleanup + createfile tf1 + createfile tf2 + file mkdir td1 + set x [list [file exist tf1] [file exist tf2] [file exist td1]] + file delete tf1 td1 tf2 + lappend x [file exist tf1] [file exist tf2] [file exist tf3] +} {1 1 1 0 0 0} +test fcmd-5.5 {TclFileDeleteCmd: stop at first error} {unixOrPc} { + cleanup + createfile tf1 + createfile tf2 + file mkdir td1 + catch {file delete tf1 td1 $root tf2} + list [file exist tf1] [file exist tf2] [file exist td1] +} {0 1 0} +test fcmd-5.6 {TclFileDeleteCmd: Tcl_TranslateFileName fails} { + list [catch {file delete ~nonexistantuser} msg] $msg +} {1 {user "nonexistantuser" doesn't exist}} +test fcmd-5.7 {TclFileDeleteCmd: Tcl_TranslateFileName succeeds} { + file delete ~/tf1 + createfile ~/tf1 + file delete ~/tf1 +} {} +test fcmd-5.8 {TclFileDeleteCmd: file doesn't exist: lstat(name) != 0} { + cleanup + set x [file exist tf1] + file delete tf1 + list $x [file exist tf1] +} {0 0} +test fcmd-5.9 {TclFileDeleteCmd: is directory} { + cleanup + file mkdir td1 + file delete td1 + file exist td1 +} {0} +test fcmd-5.10 {TclFileDeleteCmd: TclpRemoveDirectory fails} { + cleanup + file mkdir td1/td2 + list [catch {file delete td1} msg] $msg +} {1 {error deleting "td1": directory not empty}} + +test fcmd-6.1 {CopyRenameOneFile: bad source} { + # can't test this, because it's caught by FileCopyRename +} {} +test fcmd-6.2 {CopyRenameOneFile: bad target} { + # can't test this, because it's caught by FileCopyRename +} {} +test fcmd-6.3 {CopyRenameOneFile: lstat(source) != 0} { + cleanup + list [catch {file rename tf1 tf2} msg] $msg +} {1 {error renaming "tf1": no such file or directory}} +test fcmd-6.4 {CopyRenameOneFile: lstat(source) == 0} { + cleanup + createfile tf1 + file rename tf1 tf2 + glob tf* +} {tf2} +test fcmd-6.5 {CopyRenameOneFile: lstat(target) != 0} { + cleanup + createfile tf1 + file rename tf1 tf2 + glob tf* +} {tf2} +test fcmd-6.6 {CopyRenameOneFile: errno != ENOENT} {unixOnly} { + cleanup + file mkdir td1 + testchmod 000 td1 + createfile tf1 + set msg [list [catch {file rename tf1 td1} msg] $msg] + testchmod 755 td1 + set msg +} {1 {error renaming "tf1" to "td1/tf1": permission denied}} +test fcmd-6.7 {CopyRenameOneFile: errno != ENOENT} {95} { + cleanup + createfile tf1 + list [catch {file rename tf1 $long} msg] $msg +} [subst {1 {error renaming "tf1" to "$long": file name too long}}] +test fcmd-6.8 {CopyRenameOneFile: errno != ENOENT} {macOnly} { + cleanup + createfile tf1 + list [catch {file rename tf1 $long} msg] $msg +} [subst {1 {error renaming "tf1" to "$long": file name too long}}] +test fcmd-6.9 {CopyRenameOneFile: errno == ENOENT} {unixOnly} { + cleanup + createfile tf1 + file rename tf1 tf2 + glob tf* +} {tf2} +test fcmd-6.10 {CopyRenameOneFile: lstat(target) == 0} { + cleanup + createfile tf1 + createfile tf2 + list [catch {file rename tf1 tf2} msg] $msg +} {1 {error renaming "tf1" to "tf2": file already exists}} +test fcmd-6.11 {CopyRenameOneFile: force == 0} { + cleanup + createfile tf1 + createfile tf2 + list [catch {file rename tf1 tf2} msg] $msg +} {1 {error renaming "tf1" to "tf2": file already exists}} +test fcmd-6.12 {CopyRenameOneFile: force != 0} { + cleanup + createfile tf1 + createfile tf2 + file rename -force tf1 tf2 + glob tf* +} {tf2} +test fcmd-6.13 {CopyRenameOneFile: source is dir, target is file} { + cleanup + file mkdir td1 + file mkdir td2 + createfile [file join td2 td1] + list [catch {file rename -force td1 td2} msg] $msg +} [subst {1 {can't overwrite file "[file join td2 td1]" with directory "td1"}}] +test fcmd-6.14 {CopyRenameOneFile: source is file, target is dir} { + cleanup + createfile tf1 + file mkdir [file join td1 tf1] + list [catch {file rename -force tf1 td1} msg] $msg +} [subst {1 {can't overwrite directory "[file join td1 tf1]" with file "tf1"}}] +test fcmd-6.15 {CopyRenameOneFile: TclpRenameFile succeeds} { + cleanup + file mkdir [file join td1 td2] + file mkdir td2 + createfile [file join td2 tf1] + file rename -force td2 td1 + file exists [file join td1 td2 tf1] +} {1} +test fcmd-6.16 {CopyRenameOneFile: TclpCopyRenameOneFile fails} { + cleanup + file mkdir [file join td1 td2] + createfile [file join td1 td2 tf1] + file mkdir td2 + list [catch {file rename -force td2 td1} msg] $msg +} [subst {1 {error renaming "td2" to "[file join td1 td2]": file already exists}}] +test fcmd-6.17 {CopyRenameOneFile: errno == EINVAL} { + cleanup + list [catch {file rename -force $root tf1} msg] $msg +} [subst {1 {error renaming "$root" to "tf1": trying to rename a volume or move a directory into itself}}] +test fcmd-6.18 {CopyRenameOneFile: errno != EXDEV} { + cleanup + file mkdir [file join td1 td2] + createfile [file join td1 td2 tf1] + file mkdir td2 + list [catch {file rename -force td2 td1} msg] $msg +} [subst {1 {error renaming "td2" to "[file join td1 td2]": file already exists}}] +test fcmd-6.19 {CopyRenameOneFile: errno == EXDEV} {unixOnly} { + cleanup /tmp + createfile tf1 + file rename tf1 /tmp + glob tf* /tmp/tf1 +} {/tmp/tf1} +test fcmd-6.20 {CopyRenameOneFile: errno == EXDEV} {pcOnly} { + file delete -force c:/tcl8975@ d:/tcl8975@ + file mkdir c:/tcl8975@ + if [catch {file rename c:/tcl8975@ d:/}] { + list d:/tcl8975@ + } else { + set msg [glob c:/tcl8975@ d:/tcl8975@] + file delete -force d:/tcl8975@ + set msg + } +} {d:/tcl8975@} +test fcmd-6.21 {CopyRenameOneFile: copy/rename: S_ISDIR(source)} {unixOnly} { + cleanup /tmp + file mkdir td1 + file rename td1 /tmp + glob td* /tmp/td* +} {/tmp/td1} +test fcmd-6.22 {CopyRenameOneFile: copy/rename: !S_ISDIR(source)} {unixOnly} { + cleanup /tmp + createfile tf1 + file rename tf1 /tmp + glob tf* /tmp/tf* +} {/tmp/tf1} +test fcmd-6.23 {CopyRenameOneFile: TclpCopyDirectory failed} {unixOnly} { + cleanup /tmp + file mkdir td1/td2/td3 + exec chmod 000 td1 + set msg [list [catch {file rename td1 /tmp} msg] $msg] + exec chmod 755 td1 + set msg +} {1 {error renaming "td1": permission denied}} +test fcmd-6.24 {CopyRenameOneFile: error uses original name} {unixOnly} { + cleanup + file mkdir ~/td1/td2 + exec chmod 000 [file join [file dirname ~] [file tail ~] td1] + set msg [list [catch {file copy ~/td1 td1} msg] $msg] + exec chmod 755 [file join [file dirname ~] [file tail ~] td1] + file delete -force ~/td1 + set msg +} {1 {error copying "~/td1": permission denied}} +test fcmd-6.25 {CopyRenameOneFile: error uses original name} {unixOnly} { + cleanup + file mkdir td2 + file mkdir ~/td1 + exec chmod 000 [file join [file dirname ~] [file tail ~] td1] + set msg [list [catch {file copy td2 ~/td1} msg] $msg] + exec chmod 755 [file join [file dirname ~] [file tail ~] td1] + file delete -force ~/td1 + set msg +} {1 {error copying "td2" to "~/td1/td2": permission denied}} +test fcmd-6.26 {CopyRenameOneFile: doesn't use original name} {unixOnly} { + cleanup + file mkdir ~/td1/td2 + exec chmod 000 [file join [file dirname ~] [file tail ~] td1 td2] + set msg [list [catch {file copy ~/td1 td1} msg] $msg] + exec chmod 755 [file join [file dirname ~] [file tail ~] td1 td2] + file delete -force ~/td1 + set msg +} "1 {error copying \"~/td1\" to \"td1\": \"[file join [file dirname ~] [file tail ~] td1 td2]\": permission denied}" +test fcmd-6.27 {CopyRenameOneFile: TclpCopyDirectory failed} {unixOnly} { + cleanup /tmp + file mkdir td1/td2/td3 + file mkdir /tmp/td1 + createfile /tmp/td1/tf1 + list [catch {file rename -force td1 /tmp} msg] $msg +} {1 {error renaming "td1" to "/tmp/td1": file already exists}} +test fcmd-6.28 {CopyRenameOneFile: TclpCopyDirectory failed} {unixOnly} { + cleanup /tmp + file mkdir td1/td2/td3 + exec chmod 000 td1/td2/td3 + set msg [list [catch {file rename td1 /tmp} msg] $msg] + exec chmod 755 td1/td2/td3 + set msg +} {1 {error renaming "td1" to "/tmp/td1": "td1/td2/td3": permission denied}} +test fcmd-6.29 {CopyRenameOneFile: TclpCopyDirectory passed} {unixOnly} { + cleanup /tmp + file mkdir td1/td2/td3 + file rename td1 /tmp + glob td* /tmp/td1/t* +} {/tmp/td1/td2} +test fcmd-6.30 {CopyRenameOneFile: TclpRemoveDirectory failed} {unixOnly nonPortable} { + cleanup + if [file exists /kernel] { + set msg [list [catch {file rename /kernel td1} msg] $msg] + set a1 {1 {can't unlink "/kernel": permission denied}} + expr {$msg == $a1} + } else { + list 1 + } +} {1} +test fcmd-6.31 {CopyRenameOneFile: TclpDeleteFile passed} {unixOnly} { + cleanup /tmp + file mkdir /tmp/td1 + createfile /tmp/td1/tf1 + file rename /tmp/td1/tf1 tf1 + list [file exists /tmp/td1/tf1] [file exists tf1] +} {0 1} +test fcmd-6.32 {CopyRenameOneFile: copy} { + cleanup + list [catch {file copy tf1 tf2} msg] $msg +} {1 {error copying "tf1": no such file or directory}} +cleanup /tmp + +test fcmd-7.1 {FileForceOption: none} { + cleanup + file mkdir [file join tf1 tf2] + list [catch {file delete tf1} msg] $msg +} {1 {error deleting "tf1": directory not empty}} +test fcmd-7.2 {FileForceOption: -force} { + cleanup + file mkdir [file join tf1 tf2] + file delete -force tf1 +} {} +test fcmd-7.3 {FileForceOption: --} { + createfile -tf1 + file delete -- -tf1 +} {} +test fcmd-7.4 {FileForceOption: bad option} { + createfile -tf1 + set msg [list [catch {file delete -tf1} msg] $msg] + file delete -- -tf1 + set msg +} {1 {bad option "-tf1": should be -force or --}} +test fcmd-7.5 {FileForceOption: multiple times through loop} { + createfile -- + createfile -force + file delete -force -force -- -- -force + list [catch {glob -- -- -force} msg] $msg +} {1 {no files matched glob patterns "-- -force"}} + +test fcmd-8.1 {FileBasename: basename of ~user: argc == 1 && *path == ~} {unixOnly} { + list [catch {file rename ~$user /} msg] $msg +} "1 {error renaming \"~$user\" to \"/$user\": permission denied}" + +test fcmd-9.1 {file rename: comprehensive: EACCES} {unixOnly} { + cleanup + file mkdir td1 + list [catch {file rename td1 /} msg] $msg +} {1 {error renaming "td1" to "/td1": permission denied}} +test fcmd-9.2 {file rename: comprehensive: source doesn't exist} { + cleanup + list [catch {file rename tf1 tf2} msg] $msg +} {1 {error renaming "tf1": no such file or directory}} +test fcmd-9.3 {file rename: comprehensive: file to new name} { + cleanup + createfile tf1 + createfile tf2 + testchmod 444 tf2 + file rename tf1 tf3 + file rename tf2 tf4 + list [lsort [glob tf*]] [file writable tf3] [file writable tf4] +} {{tf3 tf4} 1 0} +test fcmd-9.4 {file rename: comprehensive: dir to new name} { + cleanup + file mkdir td1 td2 + testchmod 555 td2 + file rename td1 td3 + file rename td2 td4 + list [lsort [glob td*]] [file writable td3] [file writable td4] +} {{td3 td4} 1 0} +test fcmd-9.5 {file rename: comprehensive: file to self} { + cleanup + createfile tf1 tf1 + createfile tf2 tf2 + testchmod 444 tf2 + file rename -force tf1 tf1 + file rename -force tf2 tf2 + list [contents tf1] [contents tf2] [file writable tf1] [file writable tf2] +} {tf1 tf2 1 0} +test fcmd-9.6 {file rename: comprehensive: dir to self} { + cleanup + file mkdir td1 + file mkdir td2 + testchmod 555 td2 + file rename -force td1 . + file rename -force td2 . + list [lsort [glob td*]] [file writable td1] [file writable td2] +} {{td1 td2} 1 0} +test fcmd-9.7 {file rename: comprehensive: file to existing file} { + cleanup + createfile tf1 + createfile tf2 + createfile tfs1 + createfile tfs2 + createfile tfs3 + createfile tfs4 + createfile tfd1 + createfile tfd2 + createfile tfd3 + createfile tfd4 + testchmod 444 tfs3 + testchmod 444 tfs4 + testchmod 444 tfd2 + testchmod 444 tfd4 + set msg [list [catch {file rename tf1 tf2} msg] $msg] + file rename -force tfs1 tfd1 + file rename -force tfs2 tfd2 + file rename -force tfs3 tfd3 + file rename -force tfs4 tfd4 + list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4] +} {{tf1 tf2 tfd1 tfd2 tfd3 tfd4} {1 {error renaming "tf1" to "tf2": file already exists}} 1 1 0 0} +test fcmd-9.8 {file rename: comprehensive: dir to empty dir} { + # Under unix, you can rename a read-only directory, but you can't + # move it into another directory. + + cleanup + file mkdir td1 + file mkdir td2/td1 + file mkdir tds1 + file mkdir tds2 + file mkdir tds3 + file mkdir tds4 + file mkdir tdd1/tds1 + file mkdir tdd2/tds2 + file mkdir tdd3/tds3 + file mkdir tdd4/tds4 + if {$tcl_platform(platform) != "unix"} { + testchmod 555 tds3 + testchmod 555 tds4 + } + testchmod 555 tdd2/tds2 + testchmod 555 tdd4/tds4 + set msg [list [catch {file rename td1 td2} msg] $msg] + file rename -force tds1 tdd1 + file rename -force tds2 tdd2 + file rename -force tds3 tdd3 + file rename -force tds4 tdd4 + if {$tcl_platform(platform) != "unix"} { + set w3 [file writable tdd3/tds3] + set w4 [file writable tdd4/tds4] + } else { + set w3 0 + set w4 0 + } + list [lsort [glob td*]] $msg [file writable tdd1/tds1] [file writable tdd2/tds2] $w3 $w4 +} [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4} {1 {error renaming "td1" to "[file join td2 td1]": file already exists}} 1 1 0 0}] +test fcmd-9.9 {file rename: comprehensive: dir to non-empty dir} { + cleanup + file mkdir tds1 + file mkdir tds2 + file mkdir tdd1/tds1/xxx + file mkdir tdd2/tds2/xxx + if {$tcl_platform(platform) != "unix"} { + testchmod 555 tds2 + } + set a1 [list [catch {file rename -force tds1 tdd1} msg] $msg] + set a2 [list [catch {file rename -force tds2 tdd2} msg] $msg] + if {$tcl_platform(platform) != "unix"} { + set w2 [file writable tds2] + } else { + set w2 0 + } + list [lsort [glob td*]] $a1 $a2 [file writable tds1] $w2 +} [subst {{tdd1 tdd2 tds1 tds2} {1 {error renaming "tds1" to "[file join tdd1 tds1]": file already exists}} {1 {error renaming "tds2" to "[file join tdd2 tds2]": file already exists}} 1 0}] +test fcmd-9.10 {file rename: comprehensive: file to new name and dir} { + cleanup + createfile tf1 + createfile tf2 + file mkdir td1 + testchmod 444 tf2 + file rename tf1 td1/tf3 + file rename tf2 td1/tf4 + list [catch {glob tf*}] [lsort [glob td1/t*]] [file writable td1/tf3] [file writable td1/tf4] +} [subst {1 {[file join td1 tf3] [file join td1 tf4]} 1 0}] +test fcmd-9.11 {file rename: comprehensive: dir to new name and dir} { + cleanup + file mkdir td1 + file mkdir td2 + file mkdir td3 + if {$tcl_platform(platform) != "unix"} { + testchmod 555 td2 + } + file rename td1 td3/td3 + file rename td2 td3/td4 + if {$tcl_platform(platform) != "unix"} { + set w4 [file writable td3/td4] + } else { + set w4 0 + } + list [lsort [glob td*]] [lsort [glob td3/t*]] [file writable td3/td3] $w4 +} [subst {td3 {[file join td3 td3] [file join td3 td4]} 1 0}] +test fcmd-9.12 {file rename: comprehensive: target exists} { + cleanup + file mkdir td1/td2 td2/td1 + testchmod 555 td2/td1 + file mkdir td3/td4 td4/td3 + file rename -force td3 td4 + set msg [list [file exists td3] [file exists td4/td3/td4] [catch {file rename td1 td2} msg] $msg] + testchmod 755 td2/td1 + set msg +} [subst {0 1 1 {error renaming "td1" to "[file join td2 td1]": file already exists}}] +test fcmd-9.13 {file rename: comprehensive: can't overwrite target} { + cleanup + file mkdir td1/td2 td2/td1/td4 + list [catch {file rename -force td1 td2} msg] $msg +} [subst {1 {error renaming "td1" to "[file join td2 td1]": file already exists}}] +test fcmd-9.14 {file rename: comprehensive: dir into self} { + cleanup + file mkdir td1 + list [glob td*] [list [catch {file rename td1 td1} msg] $msg] +} [subst {td1 {1 {error renaming "td1" to "[file join td1 td1]": trying to rename a volume or move a directory into itself}}}] +test fcmd-9.15 {file rename: comprehensive: source and target incompatible} { + cleanup + file mkdir td1 + createfile tf1 + list [catch {file rename -force td1 tf1} msg] $msg +} {1 {can't overwrite file "tf1" with directory "td1"}} +test fcmd-9.16 {file rename: comprehensive: source and target incompatible} { + cleanup + file mkdir td1/tf1 + createfile tf1 + list [catch {file rename -force tf1 td1} msg] $msg +} [subst {1 {can't overwrite directory "[file join td1 tf1]" with file "tf1"}}] + +test fcmd-10.1 {file copy: comprehensive: source doesn't exist} { + cleanup + list [catch {file copy tf1 tf2} msg] $msg +} {1 {error copying "tf1": no such file or directory}} +test fcmd-10.2 {file copy: comprehensive: file to new name} { + cleanup + createfile tf1 tf1 + createfile tf2 tf2 + testchmod 444 tf2 + file copy tf1 tf3 + file copy tf2 tf4 + list [lsort [glob tf*]] [contents tf3] [contents tf4] [file writable tf3] [file writable tf4] +} {{tf1 tf2 tf3 tf4} tf1 tf2 1 0} +test fcmd-10.3 {file copy: comprehensive: dir to new name} { + cleanup + file mkdir td1/tdx + file mkdir td2/tdy + testchmod 555 td2 + file copy td1 td3 + file copy td2 td4 + set msg [list [lsort [glob td*]] [glob td3/t*] [glob td4/t*] [file writable td3] [file writable td4]] + testchmod 755 td2 + testchmod 755 td4 + set msg +} [subst {{td1 td2 td3 td4} [file join td3 tdx] [file join td4 tdy] 1 0}] +test fcmd-10.4 {file copy: comprehensive: file to existing file} { + cleanup + createfile tf1 + createfile tf2 + createfile tfs1 + createfile tfs2 + createfile tfs3 + createfile tfs4 + createfile tfd1 + createfile tfd2 + createfile tfd3 + createfile tfd4 + testchmod 444 tfs3 + testchmod 444 tfs4 + testchmod 444 tfd2 + testchmod 444 tfd4 + set msg [list [catch {file copy tf1 tf2} msg] $msg] + file copy -force tfs1 tfd1 + file copy -force tfs2 tfd2 + file copy -force tfs3 tfd3 + file copy -force tfs4 tfd4 + list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4] +} {{tf1 tf2 tfd1 tfd2 tfd3 tfd4 tfs1 tfs2 tfs3 tfs4} {1 {error copying "tf1" to "tf2": file already exists}} 1 1 0 0} +test fcmd-10.5 {file copy: comprehensive: dir to empty dir} { + cleanup + file mkdir td1 + file mkdir td2/td1 + file mkdir tds1 + file mkdir tds2 + file mkdir tds3 + file mkdir tds4 + file mkdir tdd1/tds1 + file mkdir tdd2/tds2 + file mkdir tdd3/tds3 + file mkdir tdd4/tds4 + testchmod 555 tds3 + testchmod 555 tds4 + testchmod 555 tdd2/tds2 + testchmod 555 tdd4/tds4 + set a1 [list [catch {file copy td1 td2} msg] $msg] + set a2 [list [catch {file copy -force tds1 tdd1} msg] $msg] + set a3 [catch {file copy -force tds2 tdd2}] + set a4 [catch {file copy -force tds3 tdd3}] + set a5 [catch {file copy -force tds4 tdd4}] + list [lsort [glob td*]] $a1 $a2 $a3 $a4 $a5 +} [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4 tds1 tds2 tds3 tds4} {1 {error copying "td1" to "[file join td2 td1]": file already exists}} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} 1 1 1}] +test fcmd-10.6 {file copy: comprehensive: dir to non-empty dir} { + cleanup + file mkdir tds1 + file mkdir tds2 + file mkdir tdd1/tds1/xxx + file mkdir tdd2/tds2/xxx + testchmod 555 tds2 + set a1 [list [catch {file copy -force tds1 tdd1} msg] $msg] + set a2 [list [catch {file copy -force tds2 tdd2} msg] $msg] + list [lsort [glob td*]] $a1 $a2 [file writable tds1] [file writable tds2] +} [subst {{tdd1 tdd2 tds1 tds2} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} {1 {error copying "tds2" to "[file join tdd2 tds2]": file already exists}} 1 0}] +test fcmd-10.7 {file rename: comprehensive: file to new name and dir} { + cleanup + createfile tf1 + createfile tf2 + file mkdir td1 + testchmod 444 tf2 + file copy tf1 td1/tf3 + file copy tf2 td1/tf4 + list [lsort [glob tf*]] [lsort [glob td1/t*]] [file writable td1/tf3] [file writable td1/tf4] +} [subst {{tf1 tf2} {[file join td1 tf3] [file join td1 tf4]} 1 0}] +test fcmd-10.8 {file rename: comprehensive: dir to new name and dir} { + cleanup + file mkdir td1 + file mkdir td2 + file mkdir td3 + testchmod 555 td2 + file copy td1 td3/td3 + file copy td2 td3/td4 + list [lsort [glob td*]] [lsort [glob td3/t*]] [file writable td3/td3] [file writable td3/td4] +} [subst {{td1 td2 td3} {[file join td3 td3] [file join td3 td4]} 1 0}] +test fcmd-10.9 {file copy: comprehensive: source and target incompatible} { + cleanup + file mkdir td1 + createfile tf1 + list [catch {file copy -force td1 tf1} msg] $msg +} {1 {can't overwrite file "tf1" with directory "td1"}} +test fcmd-10.10 {file copy: comprehensive: source and target incompatible} { + cleanup + file mkdir td1/tf1 + createfile tf1 + list [catch {file copy -force tf1 td1} msg] $msg +} [subst {1 {can't overwrite directory "[file join td1 tf1]" with file "tf1"}}] +cleanup + +# old tests + +test fcmd-11.1 {TclFileRenameCmd: -- option } { + file delete -force -- -tfa1 + set s [createfile -tfa1] + file rename -- -tfa1 tfa2 + set result [expr [checkcontent tfa2 $s] && ![file exists -tfa1]] + file delete tfa2 + set result +} {1} + +test fcmd-11.2 {TclFileRenameCmd: bad option } { + file delete -force -- tfa1 + set s [createfile tfa1] + set r1 [catch {file rename -x tfa1 tfa2}] + set result [expr $r1 && [checkcontent tfa1 $s] && ![file exists tfa2]] + file delete tfa1 + set result +} {1} + +test fcmd-11.3 {TclFileRenameCmd: bad \# args} { + catch {file rename -- } +} {1} + +test fcmd-11.4 {TclFileRenameCmd: target filename translation failing} { + global env + set temp $env(HOME) + unset env(HOME) + set result [catch {file rename tfa ~/foobar }] + set env(HOME) $temp + set result + } {1} + +test fcmd-11.5 {TclFileRenameCmd: more than one source and target is not a directory} { + file delete -force -- tfa1 tfa2 tfa3 + createfile tfa1 + createfile tfa2 + createfile tfa3 + set result [catch {file rename tfa1 tfa2 tfa3}] + file delete tfa1 tfa2 tfa3 + set result +} {1} + +test fcmd-11.6 {TclFileRenameCmd: : single file into directory } { + file delete -force -- tfa1 tfad + set s [createfile tfa1] + file mkdir tfad + file rename tfa1 tfad + set result [expr [checkcontent tfad/tfa1 $s] && ![file exists tfa1]] + file delete -force tfad + set result +} {1} + +test fcmd-11.7 {TclFileRenameCmd: : multiple files into directory } { + file delete -force -- tfa1 tfa2 tfad + set s1 [createfile tfa1 ] + set s2 [createfile tfa2 ] + file mkdir tfad + file rename tfa1 tfa2 tfad + set r1 [checkcontent tfad/tfa1 $s1] + set r2 [checkcontent tfad/tfa2 $s2] + + set result [expr $r1 && $r2 && ![file exists tfa1] && ![file exists tfa2]] + + file delete -force tfad + set result +} {1} + +test fcmd-11.8 {TclFileRenameCmd: error renaming file to directory } { + file delete -force -- tfa tfad + set s [createfile tfa ] + file mkdir tfad + file mkdir tfad/tfa + set r1 [catch {file rename tfa tfad}] + set r2 [checkcontent tfa $s] + set r3 [file isdir tfad] + set result [expr $r1 && $r2 && $r3 ] + file delete -force tfa tfad + set result +} {1} + +# +# Coverage tests for renamefile() ; +# +test fcmd-12.1 {renamefile: source filename translation failing} { + global env + set temp $env(HOME) + unset env(HOME) + set result [catch {file rename ~/tfa1 tfa2}] + set env(HOME) $temp + set result +} {1} + +test fcmd-12.2 {renamefile: src filename translation failing} { + global env + set temp $env(HOME) + unset env(HOME) + set s [createfile tfa1] + file mkdir tfad + set result [catch {file rename tfa1 ~/tfa2 tfad}] + set env(HOME) $temp + file delete -force tfad + set result +} {1} + +test fcmd-12.3 {renamefile: stat failing on source} { + file delete -force -- tfa1 tfa2 + set r1 [catch {file rename tfa1 tfa2}] + expr {$r1 && ![file exists tfa1] && ![file exists tfa2]} +} {1} + +test fcmd-12.4 {renamefile: error renaming file to directory } { + file delete -force -- tfa tfad + set s1 [createfile tfa ] + file mkdir tfad + file mkdir tfad/tfa + set r1 [catch {file rename tfa tfad}] + set r2 [checkcontent tfa $s1] + set r3 [file isdir tfad/tfa] + set result [expr $r1 && $r2 && $r3] + file delete -force tfa tfad + set result +} {1} + +test fcmd-12.5 {renamefile: error renaming directory to file } { + file delete -force -- tfa tfad + file mkdir tfa + file mkdir tfad + set s [createfile tfad/tfa] + set r1 [catch {file rename tfa tfad}] + set r2 [checkcontent tfad/tfa $s] + set r3 [file isdir tfad] + set r4 [file isdir tfa] + set result [expr $r1 && $r2 && $r3 && $r4 ] + file delete -force tfa tfad + set result +} {1} + +test fcmd-12.6 {renamefile: TclRenameFile succeeding } { + file delete -force -- tfa1 tfa2 + set s [createfile tfa1] + file rename tfa1 tfa2 + set result [expr [checkcontent tfa2 $s] && ![file exists tfa1]] + file delete tfa2 + set result +} {1} + +test fcmd-12.7 {renamefile: renaming directory into offspring} { + file delete -force -- tfad + file mkdir tfad + file mkdir tfad/dir + set result [catch {file rename tfad tfad/dir}] + file delete -force tfad + set result +} {1} + +test fcmd-12.8 {renamefile: generic error } {unixOnly} { + file delete -force -- tfa + file mkdir tfa + file mkdir tfa/dir + exec chmod 555 tfa + set result [catch {file rename tfa/dir tfa2}] + exec chmod 777 tfa + file delete -force tfa + set result +} {1} + + +test fcmd-12.9 {renamefile: moving a file across volumes } {unixOnly} { + file delete -force -- tfa /tmp/tfa + set s [createfile tfa ] + file rename tfa /tmp + set result [expr [checkcontent /tmp/tfa $s] && ![file exists tfa]] + file delete /tmp/tfa + set result +} {1} + +test fcmd-12.10 {renamefile: moving a directory across volumes } {unixOnly} { + file delete -force -- tfad /tmp/tfad + file mkdir tfad + set s [createfile tfad/a ] + file rename tfad /tmp + set restul [expr [checkcontent /tmp/tfad/a $s] && ![file exists tfad]] + file delete -force /tmp/tfad + set result +} {1} + +# +# Coverage tests for TclCopyFilesCmd() +# +test fcmd-13.1 {TclCopyFilesCmd: -force option } { + file delete -force -- tfa1 + set s [createfile tfa1] + file copy -force tfa1 tfa2 + set result [expr [checkcontent tfa2 $s] && [checkcontent tfa1 $s]] + file delete tfa1 tfa2 + set result +} {1} + +test fcmd-13.2 {TclCopyFilesCmd: -- option } { + file delete -force -- tfa1 + set s [createfile -tfa1] + file copy -- -tfa1 tfa2 + set result [expr [checkcontent tfa2 $s] && [checkcontent -tfa1 $s]] + file delete -- -tfa1 tfa2 + set result +} {1} + +test fcmd-13.3 {TclCopyFilesCmd: bad option } { + file delete -force -- tfa1 + set s [createfile tfa1] + set r1 [catch {file copy -x tfa1 tfa2}] + set result [expr $r1 && [checkcontent tfa1 $s] && ![file exists tfa2]] + file delete tfa1 + set result +} {1} + +test fcmd-13.4 {TclCopyFilesCmd: bad \# args} { + catch {file copy -- } +} {1} + +test fcmd-13.5 {TclCopyFilesCmd: target filename translation failing} { + global env + set temp $env(HOME) + unset env(HOME) + set result [catch {file copy tfa ~/foobar }] + set env(HOME) $temp + set result + } {1} + +test fcmd-13.6 {TclCopyFilesCmd: more than one source and target is not a directory} { + file delete -force -- tfa1 tfa2 tfa3 + createfile tfa1 + createfile tfa2 + createfile tfa3 + set result [catch {file copy tfa1 tfa2 tfa3}] + file delete tfa1 tfa2 tfa3 + set result +} {1} + +test fcmd-13.7 {TclCopyFilesCmd: : single file into directory } { + file delete -force -- tfa1 tfad + set s [createfile tfa1] + file mkdir tfad + file copy tfa1 tfad + set result [expr [checkcontent tfad/tfa1 $s] && [checkcontent tfa1 $s]] + file delete -force tfad tfa1 + set result +} {1} + +test fcmd-13.8 {TclCopyFilesCmd: : multiple files into directory } { + file delete -force -- tfa1 tfa2 tfad + set s1 [createfile tfa1 ] + set s2 [createfile tfa2 ] + file mkdir tfad + file copy tfa1 tfa2 tfad + set r1 [checkcontent tfad/tfa1 $s1] + set r2 [checkcontent tfad/tfa2 $s2] + set r3 [checkcontent tfa1 $s1] + set r4 [checkcontent tfa2 $s2] + set result [expr $r1 && $r2 && $r3 && $r4 ] + + file delete -force tfad tfa1 tfa2 + set result +} {1} + +test fcmd-13.9 {TclCopyFilesCmd: error copying file to directory } { + file delete -force -- tfa tfad + set s [createfile tfa ] + file mkdir tfad + file mkdir tfad/tfa + set r1 [catch {file copy tfa tfad}] + set r2 [expr [checkcontent tfa $s] && [file isdir tfad/tfa]] + set r3 [file isdir tfad] + set result [expr $r1 && $r2 && $r3 ] + file delete -force tfa tfad + set result +} {1} + +# +# Coverage tests for copyfile() +# +test fcmd-14.1 {copyfile: source filename translation failing} { + global env + set temp $env(HOME) + unset env(HOME) + set result [catch {file copy ~/tfa1 tfa2}] + set env(HOME) $temp + set result +} {1} + +test fcmd-14.2 {copyfile: dst filename translation failing} { + global env + set temp $env(HOME) + unset env(HOME) + set s [createfile tfa1] + file mkdir tfad + set r1 [catch {file copy tfa1 ~/tfa2 tfad}] + set result [expr $r1 && [checkcontent tfad/tfa1 $s]] + set env(HOME) $temp + file delete -force tfa1 tfad + set result +} {1} + +test fcmd-14.3 {copyfile: stat failing on source} { + file delete -force -- tfa1 tfa2 + set r1 [catch {file copy tfa1 tfa2}] + expr $r1 && ![file exists tfa1] && ![file exists tfa2] +} {1} + +test fcmd-14.4 {copyfile: error copying file to directory } { + file delete -force -- tfa tfad + set s1 [createfile tfa ] + file mkdir tfad + file mkdir tfad/tfa + set r1 [catch {file copy tfa tfad}] + set r2 [checkcontent tfa $s1] + set r3 [file isdir tfad] + set r4 [file isdir tfad/tfa] + set result [expr $r1 && $r2 && $r3 && $r4 ] + file delete -force tfa tfad + set result +} {1} + + test fcmd-14.5 {copyfile: error copying directory to file } { + file delete -force -- tfa tfad + file mkdir tfa + file mkdir tfad + set s [createfile tfad/tfa] + set r1 [catch {file copy tfa tfad}] + set r2 [checkcontent tfad/tfa $s] + set r3 [file isdir tfad] + set r4 [file isdir tfa] + set result [expr $r1 && $r2 && $r3 && $r4 ] + file delete -force tfa tfad + set result +} {1} + +test fcmd-14.6 {copyfile: copy file succeeding } { + file delete -force -- tfa tfa2 + set s [createfile tfa] + file copy tfa tfa2 + set result [expr [checkcontent tfa $s] && [checkcontent tfa2 $s]] + file delete tfa tfa2 + set result +} {1} + +test fcmd-14.7 {copyfile: copy directory succeeding } { + file delete -force -- tfa tfa2 + file mkdir tfa + set s [createfile tfa/file] + file copy tfa tfa2 + set result [expr [checkcontent tfa/file $s] && [checkcontent tfa2/file $s]] + file delete -force tfa tfa2 + set result +} {1} + +test fcmd-14.8 {copyfile: copy directory failing } {unixOnly} { + file delete -force -- tfa + file mkdir tfa/dir/a/b/c + exec chmod 000 tfa/dir + set r1 [catch {file copy tfa tfa2}] + exec chmod 777 tfa/dir + set result $r1 + file delete -force tfa tfa2 + set result +} {1} + +# +# Coverage tests for TclMkdirCmd() +# +test fcmd-15.1 {TclMakeDirsCmd: target filename translation failing} { + global env + set temp $env(HOME) + unset env(HOME) + set result [catch {file mkdir ~/tfa}] + set env(HOME) $temp + set result +} {1} +# +# Can Tcl_SplitPath return argc == 0? If so them we need a +# test for that code. +# +test fcmd-15.2 {TclMakeDirsCmd - one directory } { + file delete -force -- tfa + file mkdir tfa + set result [file isdirectory tfa] + file delete tfa + set result +} {1} + +test fcmd-15.3 {TclMakeDirsCmd: - two directories } { + file delete -force -- tfa1 tfa2 + file mkdir tfa1 tfa2 + set result [expr [file isdirectory tfa1] && [file isdirectory tfa2]] + file delete tfa1 tfa2 + set result +} {1} + +test fcmd-15.4 {TclMakeDirsCmd - stat failing } {unixOnly} { + file delete -force -- tfa + file mkdir tfa + createfile tfa/file + exec chmod 000 tfa + set result [catch {file mkdir tfa/file}] + exec chmod 777 tfa + file delete -force tfa + set result +} {1} + +test fcmd-15.5 {TclMakeDirsCmd: - making a directory several levels deep } { + file delete -force -- tfa + file mkdir tfa/a/b/c + set result [file isdir tfa/a/b/c] + file delete -force tfa + set result +} {1} + + +test fcmd-15.6 {TclMakeDirsCmd: - trying to overwrite a file } { + file delete -force -- tfa + set s [createfile tfa] + set r1 [catch {file mkdir tfa}] + set r2 [file isdir tfa] + set r3 [file exists tfa] + set result [expr $r1 && !$r2 && $r3 && [checkcontent tfa $s]] + file delete tfa + set result +} {1} + +test fcmd-15.7 {TclMakeDirsCmd - making several directories } { + file delete -force -- tfa1 tfa2 + file mkdir tfa1 tfa2/a/b/c + set result [expr [file isdir tfa1] && [file isdir tfa2/a/b/c]] + file delete -force tfa1 tfa2 + set result +} {1} + +test fcmd-15.8 {TclFileMakeDirsCmd: trying to create an existing dir} { + file mkdir tfa + file mkdir tfa + set result [file isdir tfa] + file delete tfa + set result +} {1} + + +# Coverage tests for TclDeleteFilesCommand() +test fcmd-16.1 { test the -- argument } { + file delete -force -- tfa + createfile tfa + file delete -- tfa + file exists tfa +} {0} + +test fcmd-16.2 { test the -force and -- arguments } { + file delete -force -- tfa + createfile tfa + file delete -force -- tfa + file exists tfa +} {0} + +test fcmd-16.3 { test bad option } { + file delete -force -- tfa + createfile tfa + set result [catch {file delete -dog tfa}] + file delete tfa + set result +} {1} + +test fcmd-16.4 { test not enough args } { + catch {file delete} +} {1} + +test fcmd-16.5 { test not enough args with options } { + catch {file delete --} +} {1} + +test fcmd-16.6 {delete: source filename translation failing} { + global env + set temp $env(HOME) + unset env(HOME) + set result [catch {file delete ~/tfa}] + set env(HOME) $temp + set result +} {1} + +test fcmd-16.7 {remove a non-empty directory without -force } { + file delete -force -- tfa + file mkdir tfa + createfile tfa/a + set result [catch {file delete tfa }] + file delete -force tfa + set result +} {1} + +test fcmd-16.8 {remove a normal file } { + file delete -force -- tfa + file mkdir tfa + createfile tfa/a + set result [catch {file delete tfa }] + file delete -force tfa + set result +} {1} + +test fcmd-16.9 {error while deleting file } {unixOnly} { + file delete -force -- tfa + file mkdir tfa + createfile tfa/a + exec chmod 555 tfa + set result [catch {file delete tfa/a }] + ####### + ####### If any directory in a tree that is being removed does not + ####### have write permission, the process will fail! + ####### This is also the case with "rm -rf" + ####### + exec chmod 777 tfa + file delete -force tfa + set result +} {1} + +test fcmd-16.10 {deleting multiple files } { + file delete -force -- tfa1 tfa2 + createfile tfa1 + createfile tfa2 + file delete tfa1 tfa2 + expr ![file exists tfa1] && ![file exists tfa2] +} {1} + +test fcmd-16.11 { TclFileDeleteCmd: removing a nonexistant file} { + file delete -force -- tfa + file delete tfa + set result 1 +} {1} + +# More coverage tests for mkpath() + test fcmd-17.1 {mkdir stat failing on target but not ENOENT } {unixOnly} { + file delete -force -- tfa1 + file mkdir tfa1 + exec chmod 555 tfa1 + set result [catch {file mkdir tfa1/tfa2}] + exec chmod 777 tfa1 + file delete -force tfa1 + set result +} {1} + +test fcmd-17.2 {mkdir several levels deep - relative } { + file delete -force -- tfa + file mkdir tfa/a/b + set result [file isdir tfa/a/b ] + file delete tfa/a/b tfa/a tfa + set result +} {1} + +test fcmd-17.3 {mkdir several levels deep - absolute } { + file delete -force -- tfa + set f [file join [pwd] tfa a ] + file mkdir $f + set result [file isdir $f ] + file delete $f [file join [pwd] tfa] + set result +} {1} + +# +# Functionality tests for TclFileRenameCmd() +# + +test fcmd-18.1 {TclFileRenameCmd: rename (first form) in the same directory} { + file delete -force -- tfad + file mkdir tfad/dir + cd tfad/dir + set s [createfile foo ] + file rename foo bar + file rename bar ./foo + file rename ./foo bar + file rename ./bar ./foo + file rename foo ../dir/bar + file rename ../dir/bar ./foo + file rename ../../tfad/dir/foo ../../tfad/dir/bar + file rename [file join [pwd] bar] foo + file rename foo [file join [pwd] bar] + set result [expr [checkcontent bar $s] && ![file exists foo]] + cd ../.. + file delete -force tfad + set result +} {1} + +test fcmd-18.2 {TclFileRenameCmd: single dir to nonexistant } { + file delete -force -- tfa1 tfa2 + file mkdir tfa1 + file rename tfa1 tfa2 + set result [expr [file exists tfa2] && ![file exists tfa1]] + file delete tfa2 + set result +} {1} + +test fcmd-18.3 {TclFileRenameCmd: mixed dirs and files into directory } { + file delete -force -- tfa1 tfad1 tfad2 + set s [createfile tfa1 ] + file mkdir tfad1 tfad2 + file rename tfa1 tfad1 tfad2 + set r1 [checkcontent tfad2/tfa1 $s] + set r2 [file isdir tfad2/tfad1] + set result [expr $r1 && $r2 && ![file exists tfa1] && ![file exists tfad1]] + file delete tfad2/tfa1 + file delete -force tfad2 + set result +} {1} + +test fcmd-18.4 {TclFileRenameCmd: attempt to replace non-dir with dir } { + file delete -force -- tfa tfad + set s [createfile tfa ] + file mkdir tfad + set r1 [catch {file rename tfad tfa}] + set r2 [checkcontent tfa $s] + set r3 [file isdir tfad] + set result [expr $r1 && $r2 && $r3 ] + file delete tfa tfad + set result +} {1} + +test fcmd-18.5 {TclFileRenameCmd: attempt to replace dir with non-dir } { + file delete -force -- tfa tfad + set s [createfile tfa ] + file mkdir tfad/tfa + set r1 [catch {file rename tfa tfad}] + set r2 [checkcontent tfa $s] + set r3 [file isdir tfad/tfa] + set result [expr $r1 && $r2 && $r3 ] + file delete -force tfa tfad + set result +} {1} + +# +# On Windows there is no easy way to determine if two files are the same +# +test fcmd-18.6 {TclFileRenameCmd: rename a file to itself} {macOrUnix} { + file delete -force -- tfa + set s [createfile tfa] + set r1 [catch {file rename tfa tfa}] + set result [expr $r1 && [checkcontent tfa $s]] + file delete tfa + set result +} {1} + +test fcmd-18.7 {TclFileRenameCmd: rename dir on top of another empty dir w/o -force} { + file delete -force -- tfa tfad + file mkdir tfa tfad/tfa + set r1 [catch {file rename tfa tfad}] + set result [expr $r1 && [file isdir tfa]] + file delete -force tfa tfad + set result +} {1} + +test fcmd-18.8 {TclFileRenameCmd: rename dir on top of another empty dir w/ -force} { + file delete -force -- tfa tfad + file mkdir tfa tfad/tfa + file rename -force tfa tfad + set result [expr ![file isdir tfa]] + file delete -force tfad + set result +} {1} + +test fcmd-18.9 {TclFileRenameCmd: rename dir on top of a non-empty dir w/o -force} { + file delete -force -- tfa tfad + file mkdir tfa tfad/tfa/file + set r1 [catch {file rename tfa tfad}] + set result [expr $r1 && [file isdir tfa] && [file isdir tfad/tfa/file]] + file delete -force tfa tfad + set result +} {1} + +test fcmd-18.10 {TclFileRenameCmd: rename dir on top of a non-empty dir w/ -force} { + file delete -force -- tfa tfad + file mkdir tfa tfad/tfa/file + set r1 [catch {file rename -force tfa tfad}] + set result [expr $r1 && [file isdir tfa] && [file isdir tfad/tfa/file]] + file delete -force tfa tfad + set result +} {1} + +test fcmd-18.11 {TclFileRenameCmd: rename a non-existant file} { + file delete -force -- tfa1 + set r1 [catch {file rename tfa1 tfa2}] + set result [expr $r1 && ![file exists tfa1] && ![file exists tfa2]] +} {1} + +test fcmd-18.12 {TclFileRenameCmd : rename a symbolic link to file} {unixOnly} { + file delete -force -- tfa1 tfa2 tfa3 + + set s [createfile tfa1] + exec ln -s tfa1 tfa2 + file rename tfa2 tfa3 + set t [file type tfa3] + set result [expr { $t == "link" }] + file delete tfa1 tfa3 + set result +} {1} + +test fcmd-18.13 {TclFileRenameCmd : rename a symbolic link to dir} {unixOnly} { + file delete -force -- tfa1 tfa2 tfa3 + + file mkdir tfa1 + exec ln -s tfa1 tfa2 + file rename tfa2 tfa3 + set t [file type tfa3] + set result [expr { $t == "link" }] + file delete tfa1 tfa3 + set result +} {1} + +test fcmd-18.14 {TclFileRenameCmd : rename a path with sym link} {unixOnly} { + file delete -force -- tfa1 tfa2 tfa3 + + file mkdir tfa1/a/b/c/d + file mkdir tfa2 + set f [file join [pwd] tfa1/a/b] + set f2 [file join [pwd] {tfa2/b alias}] + exec ln -s $f $f2 + file rename {tfa2/b alias/c} tfa3 + set r1 [file isdir tfa3] + set r2 [file exists tfa1/a/b/c] + set result [expr $r1 && !$r2] + file delete -force tfa1 tfa2 tfa3 + set result +} {1} + +test fcmd-18.15 {TclFileRenameCmd : rename a file to a symlink dir} {unixOnly} { + file delete -force -- tfa1 tfa2 tfalink + + file mkdir tfa1 + set s [createfile tfa2] + exec ln -s tfa1 tfalink + + file rename tfa2 tfalink + set result [checkcontent tfa1/tfa2 $s ] + file delete -force tfa1 tfalink + set result +} {1} + +test fcmd-18.16 {TclFileRenameCmd : rename a dangling symlink} {unixOnly} { + file delete -force -- tfa1 tfalink + + file mkdir tfa1 + exec ln -s tfa1 tfalink + file delete tfa1 + file rename tfalink tfa2 + set result [expr [string compare [file type tfa2] "link"] == 0] + file delete tfa2 + set result +} {1} + + +# +# Coverage tests for TclUnixRmdir +# +test fcmd-19.1 { remove empty directory } { + file delete -force -- tfa + file mkdir tfa + file delete tfa + file exists tfa +} {0} + +test fcmd-19.2 { rmdir error besides EEXIST} {unixOnly} { + file delete -force -- tfa + file mkdir tfa + file mkdir tfa/a + exec chmod 555 tfa + set result [catch {file delete tfa/a}] + exec chmod 777 tfa + file delete -force tfa + set result +} {1} + +test fcmd-19.3 { recursive remove } { + file delete -force -- tfa + file mkdir tfa + file mkdir tfa/a + file delete -force tfa + file exists tfa +} {0} + +# +# TclUnixDeleteFile and TraversalDelete are covered by tests from the +# TclDeleteFilesCmd suite +# +# + +# +# Coverage tests for TraverseUnixTree(), called from TclDeleteFilesCmd +# + +test fcmd-20.1 {TraverseUnixTree : failure opening a subdirectory directory } {unixOnly} { + file delete -force -- tfa + file mkdir tfa + file mkdir tfa/a + exec chmod 000 tfa/a + set result [catch {file delete -force tfa}] + exec chmod 777 tfa/a + file delete -force tfa + set result +} {1} + + +# +# Feature testing for TclCopyFilesCmd +# +test fcmd-21.1 {copy : single file to nonexistant } { + file delete -force -- tfa1 tfa2 + set s [createfile tfa1] + file copy tfa1 tfa2 + set result [expr [checkcontent tfa2 $s] && [checkcontent tfa1 $s]] + file delete tfa1 tfa2 + set result +} {1} + +test fcmd-21.2 {copy : single dir to nonexistant } { + file delete -force -- tfa1 tfa2 + file mkdir tfa1 + file copy tfa1 tfa2 + set result [expr [file isdir tfa2] && [file isdir tfa1]] + file delete tfa1 tfa2 + set result +} {1} + +test fcmd-21.3 {copy : single file into directory } { + file delete -force -- tfa1 tfad + set s [createfile tfa1] + file mkdir tfad + file copy tfa1 tfad + set result [expr [checkcontent tfad/tfa1 $s] && [checkcontent tfa1 $s]] + file delete -force tfa1 tfad + set result +} {1} + +test fcmd-21.4 {copy : more than one source and target is not a directory} { + file delete -force -- tfa1 tfa2 tfa3 + createfile tfa1 + createfile tfa2 + createfile tfa3 + set result [catch {file copy tfa1 tfa2 tfa3}] + file delete tfa1 tfa2 tfa3 + set result +} {1} + +test fcmd-21.5 {copy : multiple files into directory } { + file delete -force -- tfa1 tfa2 tfad + set s1 [createfile tfa1 ] + set s2 [createfile tfa2 ] + file mkdir tfad + file copy tfa1 tfa2 tfad + set r1 [checkcontent tfad/tfa1 $s1] + set r2 [checkcontent tfad/tfa2 $s2] + set r3 [checkcontent tfa1 $s1] + set r4 [checkcontent tfa2 $s2] + set result [expr $r1 && $r2 && $r3 && $r4] + file delete -force tfa1 tfa2 tfad + set result +} {1} + +test fcmd-21.6 {copy : mixed dirs and files into directory } { + file delete -force -- tfa1 tfad1 tfad2 + set s [createfile tfa1 ] + file mkdir tfad1 tfad2 + file copy tfa1 tfad1 tfad2 + set r1 [checkcontent tfad2/tfa1 $s] + set r2 [file isdir tfad2/tfad1] + set r3 [checkcontent tfa1 $s] + set result [expr $r1 && $r2 && $r3 && [file isdir tfad1]] + file delete -force tfa1 tfad1 tfad2 + set result +} {1} + +test fcmd-21.7 {TclCopyFilesCmd : copy a dangling link } {unixOnly} { + file mkdir tfad1 + exec ln -s tfad1 tfalink + file delete tfad1 + file copy tfalink tfalink2 + set result [string match [file type tfalink2] link] + file delete tfalink tfalink2 + set result +} {1} + +test fcmd-21.8 {TclCopyFilesCmd : copy a link } {unixOnly} { + file mkdir tfad1 + exec ln -s tfad1 tfalink + file copy tfalink tfalink2 + set r1 [file type tfalink] + set r2 [file type tfalink2] + set r3 [file isdir tfad1] + set result [expr {("$r1" == "link" ) && ("$r2" == "link" ) && $r3}] + file delete tfad1 tfalink tfalink2 + set result +} {1} + +test fcmd-21.9 {TclCopyFilesCmd : copy dir with a link in it } {unixOnly} { + file mkdir tfad1 + exec ln -s "[pwd]/tfad1" tfad1/tfalink + file copy tfad1 tfad2 + set result [string match [file type tfad2/tfalink] link] + file delete -force tfad1 tfad2 + set result +} {1} + +test fcmd-21.10 {TclFileCopyCmd: copy dir on top of another empty dir w/o -force} { + file delete -force -- tfa tfad + file mkdir tfa tfad/tfa + set r1 [catch {file copy tfa tfad}] + set result [expr $r1 && [file isdir tfa]] + file delete -force tfa tfad + set result +} {1} + +test fcmd-21.11 {TclFileCopyCmd: copy dir on top of a dir w/o -force} { + file delete -force -- tfa tfad + file mkdir tfa tfad/tfa/file + set r1 [catch {file copy tfa tfad}] + set result [expr $r1 && [file isdir tfa] && [file isdir tfad/tfa/file]] + file delete -force tfa tfad + set result +} {1} + +test fcmd-21.12 {TclFileCopyCmd: copy dir on top of a non-empty dir w/ -force} { + file delete -force -- tfa tfad + file mkdir tfa tfad/tfa/file + set r1 [catch {file copy -force tfa tfad}] + set result [expr $r1 && [file isdir tfa] && [file isdir tfad/tfa/file]] + file delete -force tfa tfad + set result +} {1} + +# +# Coverage testing for TclMacRenameFile +# +test fcmd-22.1 { TclMacRenameFile : rename and overwrite in a single dir } { + file delete -force -- tfa1 tfa2 + set s [createfile tfa1] + set s2 [createfile tfa2 q] + + set r1 [catch {rename tfa1 tfa2}] + file rename -force tfa1 tfa2 + set result [expr $r1 && [checkcontent tfa2 $s]] + file delete [glob tfa1 tfa2] + set result +} {1} + +test fcmd-22.2 { TclMacRenameFile : attempt to overwrite itself } {macOrUnix} { + file delete -force -- tfa1 + set s [createfile tfa1] + file rename -force tfa1 tfa1 + set result [checkcontent tfa1 $s] + file delete tfa1 + set result +} {1} + +test fcmd-22.3 { TclMacRenameFile : rename dir to existing dir } { + file delete -force -- d1 tfad + file mkdir d1 tfad/d1 + set r1 [catch {file rename d1 tfad}] + set result [expr $r1 && [file isdir d1] && [file isdir tfad/d1]] + file delete -force d1 tfad + set result +} {1} + +test fcmd-22.4 { TclMacRenameFile : rename dir to dir several levels deep } { + file delete -force -- d1 tfad + file mkdir d1 tfad/a/b/c + file rename d1 tfad/a/b/c + set result [expr ![file isdir d1] && [file isdir tfad/a/b/c/d1]] + file delete -force [glob d1 tfad] + set result +} {1} + + +# +# TclMacCopyFile needs to be redone. +# +test fcmd-22.5 { TclMacCopyFile : copy and overwrite in a single dir } { + file delete -force -- tfa1 tfa2 + set s [createfile tfa1] + set s2 [createfile tfa2 q] + + set r1 [catch {file copy tfa1 tfa2}] + file copy -force tfa1 tfa2 + set result [expr $r1 && [checkcontent tfa2 $s] && [checkcontent tfa1 $s]] + file delete tfa1 tfa2 + set result +} {1} + +# +# TclMacMkdir - basic cases are covered elsewhere. +# Error cases are not covered. +# + +# +# TclMacRmdir +# Error cases are not covered. +# + +test fcmd-23.1 { TclMacRmdir : trying to remove a nonempty directory } { + file delete -force -- tfad + + file mkdir tfad/dir + + set result [catch {file delete tfad}] + file delete -force tfad + set result +} {1} + +# +# TclMacDeleteFile +# Error cases are not covered. +# +test fcmd-24.1 { TclMacDeleteFile : deleting a normal file } { + file delete -force -- tfa1 + + createfile tfa1 + file delete tfa1 + file exists tfa1 +} {0} + +# +# TclMacCopyDirectory +# Error cases are not covered. +# +test fcmd-25.1 { TclMacCopyDirectory : copying a normal directory} { + file delete -force -- tfad1 tfad2 + + file mkdir tfad1/a/b/c + file copy tfad1 tfad2 + set result [expr [file isdir tfad1/a/b/c] && [file isdir tfad2/a/b/c]] + file delete -force tfad1 tfad2 + set result +} {1} + +test fcmd-25.2 { TclMacCopyDirectory : copying a short path normal directory} { + file delete -force -- tfad1 tfad2 + + file mkdir tfad1 + file copy tfad1 tfad2 + set result [expr [file isdir tfad1] && [file isdir tfad2]] + file delete tfad1 tfad2 + set result +} {1} + +test fcmd-25.3 { TclMacCopyDirectory : copying dirs between different dirs} { + file delete -force -- tfad1 tfad2 + + file mkdir tfad1/x/y/z + file mkdir tfad2/dir + file copy tfad1 tfad2/dir + set result [expr [file isdir tfad1/x/y/z] && [file isdir tfad2/dir/tfad1/x/y/z]] + file delete -force tfad1 tfad2 + set result +} {1} + +# +# Functionality tests for TclDeleteFilesCmd +# + +test fcmd-26.1 { TclDeleteFilesCmd : delete symlink} {unixOnly} { + file delete -force -- tfad1 tfad2 + + file mkdir tfad1 + exec ln -s tfad1 tfalink + file delete tfalink + + set r1 [file isdir tfad1] + set r2 [file exists tfalink] + + set result [expr $r1 && !$r2] + file delete tfad1 + set result +} {1} + +test fcmd-26.2 { TclDeleteFilesCmd : delete dir with symlink} {unixOnly} { + file delete -force -- tfad1 tfad2 + + file mkdir tfad1 + file mkdir tfad2 + exec ln -s tfad1 tfad2/link + file delete -force tfad2 + + set r1 [file isdir tfad1] + set r2 [file exists tfad2] + + set result [expr $r1 && !$r2] + file delete tfad1 + set result +} {1} + +test fcmd-26.3 { TclDeleteFilesCmd : delete dangling symlink} {unixOnly} { + file delete -force -- tfad1 tfad2 + + file mkdir tfad1 + exec ln -s tfad1 tfad2 + file delete tfad1 + file delete tfad2 + + set r1 [file exists tfad1] + set r2 [file exists tfad2] + + set result [expr !$r1 && !$r2] + set result +} {1} + +cleanup diff --git a/tcl7.6/tests/fhandle.test b/tcl7.6/tests/fhandle.test new file mode 100644 index 0000000..18fdb90 --- /dev/null +++ b/tcl7.6/tests/fhandle.test @@ -0,0 +1,63 @@ +# This file tests the functions in tclFHandle.c 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) 1995-1996 by Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) fhandle.test 1.3 96/03/26 11:49:04 + +if {[string compare test [info procs test]] == 1} then {source defs} + +if {[info commands testfhandle] == {}} { + puts "This application hasn't been compiled with the \"testfhandle\"" + puts "command, so I can't test the procedures in tclFHandle.c." + return +} + +test fhandle-1.1 {file handle creation/retrieval} { + testfhandle get 0 2 3 + testfhandle get 1 2 3 + set result [testfhandle compare 0 1] + testfhandle free 0 + set result +} {equal} +test fhandle-1.2 {file handle creation/retrieval} { + testfhandle get 0 2 3 + testfhandle get 1 2 4 + set result [testfhandle compare 0 1] + testfhandle free 0 + set result +} {notequal} +test fhandle-1.3 {file handle creation/retrieval} { + testfhandle get 0 2 3 + testfhandle get 1 2 4 + set result [testfhandle compare 0 1] + testfhandle free 0 + testfhandle free 1 + set result +} {notequal} +test fhandle-1.4 {file handle creation/retrieval} { + testfhandle get 0 2 3 + testfhandle get 1 5 3 + set result [testfhandle compare 0 1] + testfhandle free 0 + testfhandle free 1 + set result +} {notequal} +test fhandle-1.5 {file handle creation/retrieval} { + testfhandle get 0 5 6 + set result [testfhandle info2 0] + testfhandle free 0 + set result +} {5 6} +test fhandle-1.6 {file handle creation/retrieval} { + testfhandle get 0 5 6 + set result [testfhandle info1 0] + testfhandle free 0 + set result +} {5} diff --git a/tcl7.6/tests/fileName.test b/tcl7.6/tests/fileName.test new file mode 100644 index 0000000..8522cb0 --- /dev/null +++ b/tcl7.6/tests/fileName.test @@ -0,0 +1,1398 @@ +# This file tests the filename manipulation routines. +# +# 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) 1995-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) fileName.test 1.27 96/10/08 17:39:46 + +if {[string compare test [info procs test]] == 1} then {source defs} + +if {[info commands testsetplatform] == {}} { + puts "This application hasn't been compiled with the \"testsetplatform\"" + puts "command, so I can't test the filename conversion procedures." + return +} + +global env +set platform [testgetplatform] + +test filename-1.1 {Tcl_GetPathType: unix} { + testsetplatform unix + file pathtype / +} absolute +test filename-1.2 {Tcl_GetPathType: unix} { + testsetplatform unix + file pathtype /foo +} absolute +test filename-1.3 {Tcl_GetPathType: unix} { + testsetplatform unix + file pathtype foo +} relative +test filename-1.4 {Tcl_GetPathType: unix} { + testsetplatform unix + file pathtype c:/foo +} relative +test filename-1.5 {Tcl_GetPathType: unix} { + testsetplatform unix + file pathtype ~ +} absolute +test filename-1.6 {Tcl_GetPathType: unix} { + testsetplatform unix + file pathtype ~/foo +} absolute +test filename-1.7 {Tcl_GetPathType: unix} { + testsetplatform unix + file pathtype ~foo +} absolute +test filename-1.8 {Tcl_GetPathType: unix} { + testsetplatform unix + file pathtype ./~foo +} relative + +test filename-2.1 {Tcl_GetPathType: mac, denerate names} { + testsetplatform mac + file pathtype / +} relative +test filename-2.2 {Tcl_GetPathType: mac, denerate names} { + testsetplatform mac + file pathtype /. +} relative +test filename-2.3 {Tcl_GetPathType: mac, denerate names} { + testsetplatform mac + file pathtype /.. +} relative +test filename-2.4 {Tcl_GetPathType: mac, denerate names} { + testsetplatform mac + file pathtype //.// +} relative +test filename-2.5 {Tcl_GetPathType: mac, denerate names} { + testsetplatform mac + file pathtype //.//../. +} relative +test filename-2.6 {Tcl_GetPathType: mac, tilde names} { + testsetplatform mac + file pathtype ~ +} absolute +test filename-2.7 {Tcl_GetPathType: mac, tilde names} { + testsetplatform mac + file pathtype ~: +} absolute +test filename-2.8 {Tcl_GetPathType: mac, tilde names} { + testsetplatform mac + file pathtype ~:foo +} absolute +test filename-2.9 {Tcl_GetPathType: mac, tilde names} { + testsetplatform mac + file pathtype ~/ +} absolute +test filename-2.10 {Tcl_GetPathType: mac, tilde names} { + testsetplatform mac + file pathtype ~/foo +} absolute +test filename-2.11 {Tcl_GetPathType: mac, unix-style names} { + testsetplatform mac + file pathtype /foo +} absolute +test filename-2.12 {Tcl_GetPathType: mac, unix-style names} { + testsetplatform mac + file pathtype /./foo +} absolute +test filename-2.13 {Tcl_GetPathType: mac, unix-style names} { + testsetplatform mac + file pathtype /..//./foo +} absolute +test filename-2.14 {Tcl_GetPathType: mac, unix-style names} { + testsetplatform mac + file pathtype /foo/bar +} absolute +test filename-2.15 {Tcl_GetPathType: mac, unix-style names} { + testsetplatform mac + file pathtype foo/bar +} relative +test filename-2.16 {Tcl_GetPathType: mac, mac-style names} { + testsetplatform mac + file pathtype : +} relative +test filename-2.17 {Tcl_GetPathType: mac, mac-style names} { + testsetplatform mac + file pathtype :foo +} relative +test filename-2.18 {Tcl_GetPathType: mac, mac-style names} { + testsetplatform mac + file pathtype foo: +} absolute +test filename-2.19 {Tcl_GetPathType: mac, mac-style names} { + testsetplatform mac + file pathtype foo:bar +} absolute +test filename-2.20 {Tcl_GetPathType: mac, mac-style names} { + testsetplatform mac + file pathtype :foo:bar +} relative +test filename-2.21 {Tcl_GetPathType: mac, mac-style names} { + testsetplatform mac + file pathtype ::foo:bar +} relative +test filename-2.22 {Tcl_GetPathType: mac, mac-style names} { + testsetplatform mac + file pathtype ~foo +} absolute +test filename-2.23 {Tcl_GetPathType: mac, mac-style names} { + testsetplatform mac + file pathtype :~foo +} relative +test filename-2.24 {Tcl_GetPathType: mac, mac-style names} { + testsetplatform mac + file pathtype ~foo: +} absolute +test filename-2.25 {Tcl_GetPathType: mac, mac-style names} { + testsetplatform mac + file pathtype foo/bar: +} absolute +test filename-2.26 {Tcl_GetPathType: mac, mac-style names} { + testsetplatform mac + file pathtype /foo: +} absolute +test filename-2.27 {Tcl_GetPathType: mac, mac-style names} { + testsetplatform mac + file pathtype foo +} relative + +test filename-3.1 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype / +} volumerelative +test filename-3.2 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype \\ +} volumerelative +test filename-3.3 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype /foo +} volumerelative +test filename-3.4 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype \\foo +} volumerelative +test filename-3.5 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype c:/ +} absolute +test filename-3.6 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype c:\\ +} absolute +test filename-3.7 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype c:/foo +} absolute +test filename-3.8 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype c:\\foo +} absolute +test filename-3.9 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype c: +} volumerelative +test filename-3.10 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype c:foo +} volumerelative +test filename-3.11 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype foo +} relative +test filename-3.12 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype //foo/bar +} absolute +test filename-3.13 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype ~foo +} absolute +test filename-3.14 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype ~ +} absolute +test filename-3.15 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype ~/foo +} absolute +test filename-3.16 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype ./~foo +} relative + +test filename-4.1 {Tcl_SplitPath: unix} { + testsetplatform unix + file split / +} {/} +test filename-4.2 {Tcl_SplitPath: unix} { + testsetplatform unix + file split /foo +} {/ foo} +test filename-4.3 {Tcl_SplitPath: unix} { + testsetplatform unix + file split /foo/bar +} {/ foo bar} +test filename-4.4 {Tcl_SplitPath: unix} { + testsetplatform unix + file split /foo/bar/baz +} {/ foo bar baz} +test filename-4.5 {Tcl_SplitPath: unix} { + testsetplatform unix + file split foo/bar +} {foo bar} +test filename-4.6 {Tcl_SplitPath: unix} { + testsetplatform unix + file split ./foo/bar +} {. foo bar} +test filename-4.7 {Tcl_SplitPath: unix} { + testsetplatform unix + file split /foo/../././foo/bar +} {/ foo .. . . foo bar} +test filename-4.8 {Tcl_SplitPath: unix} { + testsetplatform unix + file split ../foo/bar +} {.. foo bar} +test filename-4.9 {Tcl_SplitPath: unix} { + testsetplatform unix + file split {} +} {} +test filename-4.10 {Tcl_SplitPath: unix} { + testsetplatform unix + file split . +} {.} +test filename-4.11 {Tcl_SplitPath: unix} { + testsetplatform unix + file split ../ +} {..} +test filename-4.12 {Tcl_SplitPath: unix} { + testsetplatform unix + file split ../.. +} {.. ..} +test filename-4.13 {Tcl_SplitPath: unix} { + testsetplatform unix + file split //foo +} {/ foo} +test filename-4.14 {Tcl_SplitPath: unix} { + testsetplatform unix + file split foo//bar +} {foo bar} +test filename-4.15 {Tcl_SplitPath: unix} { + testsetplatform unix + file split ~foo +} {~foo} +test filename-4.16 {Tcl_SplitPath: unix} { + testsetplatform unix + file split ~foo/~bar +} {~foo ./~bar} +test filename-4.17 {Tcl_SplitPath: unix} { + testsetplatform unix + file split ~foo/~bar/~baz +} {~foo ./~bar ./~baz} +test filename-4.18 {Tcl_SplitPath: unix} { + testsetplatform unix + file split foo/bar~/baz +} {foo bar~ baz} + +test filename-5.1 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a:b +} {a: b} +test filename-5.2 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a:b:c +} {a: b c} +test filename-5.3 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a:b:c: +} {a: b c} +test filename-5.4 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a: +} {a:} +test filename-5.5 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a:: +} {a: ::} +test filename-5.6 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a::: +} {a: :: ::} +test filename-5.7 {Tcl_SplitPath: mac} { + testsetplatform mac + file split :a +} {a} +test filename-5.8 {Tcl_SplitPath: mac} { + testsetplatform mac + file split :a:: +} {a ::} +test filename-5.9 {Tcl_SplitPath: mac} { + testsetplatform mac + file split : +} {:} +test filename-5.10 {Tcl_SplitPath: mac} { + testsetplatform mac + file split :: +} {::} +test filename-5.11 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ::: +} {:: ::} +test filename-5.12 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a:::b +} {a: :: :: b} +test filename-5.13 {Tcl_SplitPath: mac} { + testsetplatform mac + file split /a:b +} {/a: b} +test filename-5.14 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ~: +} {~:} +test filename-5.15 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ~/: +} {~/:} +test filename-5.16 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ~:foo +} {~: foo} +test filename-5.17 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ~/foo +} {~: foo} +test filename-5.18 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ~foo: +} {~foo:} +test filename-5.19 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a:~foo +} {a: :~foo} +test filename-5.20 {Tcl_SplitPath: mac} { + testsetplatform mac + file split / +} {:/} +test filename-5.21 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a:b/c +} {a: :b/c} +test filename-5.22 {Tcl_SplitPath: mac} { + testsetplatform mac + file split /foo +} {foo:} +test filename-5.23 {Tcl_SplitPath: mac} { + testsetplatform mac + file split /a/b +} {a: b} +test filename-5.24 {Tcl_SplitPath: mac} { + testsetplatform mac + file split /a/b/foo +} {a: b foo} +test filename-5.25 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a/b +} {a b} +test filename-5.26 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ./foo/bar +} {: foo bar} +test filename-5.27 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ../foo/bar +} {:: foo bar} +test filename-5.28 {Tcl_SplitPath: mac} { + testsetplatform mac + file split {} +} {} +test filename-5.29 {Tcl_SplitPath: mac} { + testsetplatform mac + file split . +} {:} +test filename-5.30 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ././ +} {: :} +test filename-5.31 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ././. +} {: : :} +test filename-5.32 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ../ +} {::} +test filename-5.33 {Tcl_SplitPath: mac} { + testsetplatform mac + file split .. +} {::} +test filename-5.34 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ../.. +} {:: ::} +test filename-5.35 {Tcl_SplitPath: mac} { + testsetplatform mac + file split //foo +} {foo:} +test filename-5.36 {Tcl_SplitPath: mac} { + testsetplatform mac + file split foo//bar +} {foo bar} +test filename-5.37 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ~foo +} {~foo:} +test filename-5.38 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ~ +} {~:} +test filename-5.39 {Tcl_SplitPath: mac} { + testsetplatform mac + file split foo +} {foo} +test filename-5.40 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ~/ +} {~:} +test filename-5.41 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ~foo/~bar +} {~foo: :~bar} +test filename-5.42 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ~foo/~bar/~baz +} {~foo: :~bar :~baz} +test filename-5.43 {Tcl_SplitPath: mac} { + testsetplatform mac + file split foo/bar~/baz +} {foo bar~ baz} +test filename-5.44 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a/../b +} {a :: b} +test filename-5.45 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a/../../b +} {a :: :: b} +test filename-5.46 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a/.././../b +} {a :: : :: b} +test filename-5.47 {Tcl_SplitPath: mac} { + testsetplatform mac + file split /../bar +} {bar:} +test filename-5.48 {Tcl_SplitPath: mac} { + testsetplatform mac + file split /./bar +} {bar:} +test filename-5.49 {Tcl_SplitPath: mac} { + testsetplatform mac + file split //.//.././bar +} {bar:} +test filename-5.50 {Tcl_SplitPath: mac} { + testsetplatform mac + file split /.. +} {:/..} +test filename-5.51 {Tcl_SplitPath: mac} { + testsetplatform mac + file split //.//.././ +} {://.//.././} + +test filename-6.1 {Tcl_SplitPath: win} { + testsetplatform win + file split / +} {/} +test filename-6.2 {Tcl_SplitPath: win} { + testsetplatform win + file split /foo +} {/ foo} +test filename-6.3 {Tcl_SplitPath: win} { + testsetplatform win + file split /foo/bar +} {/ foo bar} +test filename-6.4 {Tcl_SplitPath: win} { + testsetplatform win + file split /foo/bar/baz +} {/ foo bar baz} +test filename-6.5 {Tcl_SplitPath: win} { + testsetplatform win + file split foo/bar +} {foo bar} +test filename-6.6 {Tcl_SplitPath: win} { + testsetplatform win + file split ./foo/bar +} {. foo bar} +test filename-6.7 {Tcl_SplitPath: win} { + testsetplatform win + file split /foo/../././foo/bar +} {/ foo .. . . foo bar} +test filename-6.8 {Tcl_SplitPath: win} { + testsetplatform win + file split ../foo/bar +} {.. foo bar} +test filename-6.9 {Tcl_SplitPath: win} { + testsetplatform win + file split {} +} {} +test filename-6.10 {Tcl_SplitPath: win} { + testsetplatform win + file split . +} {.} +test filename-6.11 {Tcl_SplitPath: win} { + testsetplatform win + file split ../ +} {..} +test filename-6.12 {Tcl_SplitPath: win} { + testsetplatform win + file split ../.. +} {.. ..} +test filename-6.13 {Tcl_SplitPath: win} { + testsetplatform win + file split //foo +} {/ foo} +test filename-6.14 {Tcl_SplitPath: win} { + testsetplatform win + file split foo//bar +} {foo bar} +test filename-6.15 {Tcl_SplitPath: win} { + testsetplatform win + file split /\\/foo//bar +} {//foo/bar} +test filename-6.16 {Tcl_SplitPath: win} { + testsetplatform win + file split /\\/foo//bar +} {//foo/bar} +test filename-6.17 {Tcl_SplitPath: win} { + testsetplatform win + file split /\\/foo//bar +} {//foo/bar} +test filename-6.18 {Tcl_SplitPath: win} { + testsetplatform win + file split \\\\foo\\bar +} {//foo/bar} +test filename-6.19 {Tcl_SplitPath: win} { + testsetplatform win + file split \\\\foo\\bar/baz +} {//foo/bar baz} +test filename-6.20 {Tcl_SplitPath: win} { + testsetplatform win + file split c:/foo +} {c:/ foo} +test filename-6.21 {Tcl_SplitPath: win} { + testsetplatform win + file split c:foo +} {c: foo} +test filename-6.22 {Tcl_SplitPath: win} { + testsetplatform win + file split c: +} {c:} +test filename-6.23 {Tcl_SplitPath: win} { + testsetplatform win + file split c:\\ +} {c:/} +test filename-6.24 {Tcl_SplitPath: win} { + testsetplatform win + file split c:/ +} {c:/} +test filename-6.25 {Tcl_SplitPath: win} { + testsetplatform win + file split c:/./.. +} {c:/ . ..} +test filename-6.26 {Tcl_SplitPath: win} { + testsetplatform win + file split ~foo +} {~foo} +test filename-6.27 {Tcl_SplitPath: win} { + testsetplatform win + file split ~foo/~bar +} {~foo ./~bar} +test filename-6.28 {Tcl_SplitPath: win} { + testsetplatform win + file split ~foo/~bar/~baz +} {~foo ./~bar ./~baz} +test filename-6.29 {Tcl_SplitPath: win} { + testsetplatform win + file split foo/bar~/baz +} {foo bar~ baz} +test filename-6.30 {Tcl_SplitPath: win} { + testsetplatform win + file split c:~foo +} {c: ./~foo} + +test filename-7.1 {Tcl_JoinPath: unix} { + testsetplatform unix + file join / a +} {/a} +test filename-7.2 {Tcl_JoinPath: unix} { + testsetplatform unix + file join a b +} {a/b} +test filename-7.3 {Tcl_JoinPath: unix} { + testsetplatform unix + file join /a c /b d +} {/b/d} +test filename-7.4 {Tcl_JoinPath: unix} { + testsetplatform unix + file join / +} {/} +test filename-7.5 {Tcl_JoinPath: unix} { + testsetplatform unix + file join a +} {a} +test filename-7.6 {Tcl_JoinPath: unix} { + testsetplatform unix + file join {} +} {} +test filename-7.7 {Tcl_JoinPath: unix} { + testsetplatform unix + file join /a/ b +} {/a/b} +test filename-7.8 {Tcl_JoinPath: unix} { + testsetplatform unix + file join /a// b +} {/a/b} +test filename-7.9 {Tcl_JoinPath: unix} { + testsetplatform unix + file join /a/./../. b +} {/a/./.././b} +test filename-7.10 {Tcl_JoinPath: unix} { + testsetplatform unix + file join ~ a +} {~/a} +test filename-7.11 {Tcl_JoinPath: unix} { + testsetplatform unix + file join ~a ~b +} {~b} +test filename-7.12 {Tcl_JoinPath: unix} { + testsetplatform unix + file join ./~a b +} {./~a/b} +test filename-7.13 {Tcl_JoinPath: unix} { + testsetplatform unix + file join ./~a ~b +} {~b} +test filename-7.14 {Tcl_JoinPath: unix} { + testsetplatform unix + file join ./~a ./~b +} {./~a/~b} +test filename-7.15 {Tcl_JoinPath: unix} { + testsetplatform unix + file join a . b +} {a/./b} +test filename-7.16 {Tcl_JoinPath: unix} { + testsetplatform unix + file join a . ./~b +} {a/./~b} +test filename-7.17 {Tcl_JoinPath: unix} { + testsetplatform unix + file join //a b +} {/a/b} +test filename-7.18 {Tcl_JoinPath: unix} { + testsetplatform unix + file join /// a b +} {/a/b} + +test filename-8.1 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a b +} {:a:b} +test filename-8.2 {Tcl_JoinPath: mac} { + testsetplatform mac + file join :a b +} {:a:b} +test filename-8.3 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a b: +} {b:} +test filename-8.4 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a: :b +} {a:b} +test filename-8.5 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a: :b: +} {a:b} +test filename-8.6 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a :: b +} {:a::b} +test filename-8.7 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a :: :: b +} {:a:::b} +test filename-8.8 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a ::: b +} {:a:::b} +test filename-8.9 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a: b: +} {b:} +test filename-8.10 {Tcl_JoinPath: mac} { + testsetplatform mac + file join /a/b +} {a:b} +test filename-8.11 {Tcl_JoinPath: mac} { + testsetplatform mac + file join /a/b c/d +} {a:b:c:d} +test filename-8.12 {Tcl_JoinPath: mac} { + testsetplatform mac + file join /a/b :c:d +} {a:b:c:d} +test filename-8.13 {Tcl_JoinPath: mac} { + testsetplatform mac + file join ~ foo +} {~:foo} +test filename-8.14 {Tcl_JoinPath: mac} { + testsetplatform mac + file join :: :: +} {:::} +test filename-8.15 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a: :: +} {a::} +test filename-8.16 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a {} b +} {:a:b} +test filename-8.17 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a::: b +} {a:::b} +test filename-8.18 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a : : : +} {:a} +test filename-8.19 {Tcl_JoinPath: mac} { + testsetplatform mac + file join : +} {:} +test filename-8.20 {Tcl_JoinPath: mac} { + testsetplatform mac + file join : a +} {:a} +test filename-8.21 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a: :b/c +} {a:b/c} +test filename-8.22 {Tcl_JoinPath: mac} { + testsetplatform mac + file join :a :b/c +} {:a:b/c} + +test filename-9.1 {Tcl_JoinPath: win} { + testsetplatform win + file join a b +} {a/b} +test filename-9.2 {Tcl_JoinPath: win} { + testsetplatform win + file join /a b +} {/a/b} +test filename-9.3 {Tcl_JoinPath: win} { + testsetplatform win + file join /a /b +} {/b} +test filename-9.4 {Tcl_JoinPath: win} { + testsetplatform win + file join c: foo +} {c:foo} +test filename-9.5 {Tcl_JoinPath: win} { + testsetplatform win + file join c:/ foo +} {c:/foo} +test filename-9.6 {Tcl_JoinPath: win} { + testsetplatform win + file join c:\\bar foo +} {c:/bar/foo} +test filename-9.7 {Tcl_JoinPath: win} { + testsetplatform win + file join /foo c:bar +} {c:bar} +test filename-9.8 {Tcl_JoinPath: win} { + testsetplatform win + file join ///host//share dir +} {//host/share/dir} +test filename-9.9 {Tcl_JoinPath: win} { + testsetplatform win + file join ~ foo +} {~/foo} +test filename-9.10 {Tcl_JoinPath: win} { + testsetplatform win + file join ~/~foo +} {~/~foo} +test filename-9.11 {Tcl_JoinPath: win} { + testsetplatform win + file join ~ ./~foo +} {~/~foo} +test filename-9.12 {Tcl_JoinPath: win} { + testsetplatform win + file join / ~foo +} {~foo} +test filename-9.13 {Tcl_JoinPath: win} { + testsetplatform win + file join ./a/ b c +} {./a/b/c} +test filename-9.14 {Tcl_JoinPath: win} { + testsetplatform win + file join ./~a/ b c +} {./~a/b/c} +test filename-9.15 {Tcl_JoinPath: win} { + testsetplatform win + file join // host share path +} {/host/share/path} +test filename-9.16 {Tcl_JoinPath: win} { + testsetplatform win + file join foo . bar +} {foo/./bar} +test filename-9.17 {Tcl_JoinPath: win} { + testsetplatform win + file join foo .. bar +} {foo/../bar} +test filename-9.18 {Tcl_JoinPath: win} { + testsetplatform win + file join foo/./bar +} {foo/./bar} + +test filename-10.1 {Tcl_TranslateFileName} { + testsetplatform unix + list [catch {testtranslatefilename foo} msg] $msg +} {0 foo} +test filename-10.2 {Tcl_TranslateFileName} { + testsetplatform windows + list [catch {testtranslatefilename {c:/foo}} msg] $msg +} {0 {c:\foo}} +test filename-10.3 {Tcl_TranslateFileName} { + testsetplatform windows + list [catch {testtranslatefilename {c:/\\foo/}} msg] $msg +} {0 {c:\foo}} +test filename-10.4 {Tcl_TranslateFileName} { + testsetplatform mac + list [catch {testtranslatefilename foo} msg] $msg +} {0 :foo} +test filename-10.5 {Tcl_TranslateFileName} { + testsetplatform mac + list [catch {testtranslatefilename :~foo} msg] $msg +} {0 :~foo} +test filename-10.6 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "/home/test" + testsetplatform unix + set result [list [catch {testtranslatefilename ~/foo} msg] $msg] + set env(HOME) $temp + set result +} {0 /home/test/foo} +test filename-10.7 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + unset env(HOME) + testsetplatform unix + set result [list [catch {testtranslatefilename ~/foo} msg] $msg] + set env(HOME) $temp + set result +} {1 {couldn't find HOME environment variable to expand path}} +test filename-10.8 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "/home/test" + testsetplatform unix + set result [list [catch {testtranslatefilename ~} msg] $msg] + set env(HOME) $temp + set result +} {0 /home/test} +test filename-10.9 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "/home/test/" + testsetplatform unix + set result [list [catch {testtranslatefilename ~} msg] $msg] + set env(HOME) $temp + set result +} {0 /home/test} +test filename-10.10 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "/home/test/" + testsetplatform unix + set result [list [catch {testtranslatefilename ~/foo} msg] $msg] + set env(HOME) $temp + set result +} {0 /home/test/foo} +test filename-10.11 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "Root:" + testsetplatform mac + set result [list [catch {testtranslatefilename ~/foo} msg] $msg] + set env(HOME) $temp + set result +} {0 Root:foo} +test filename-10.12 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "Root:home" + testsetplatform mac + set result [list [catch {testtranslatefilename ~/foo} msg] $msg] + set env(HOME) $temp + set result +} {0 Root:home:foo} +test filename-10.13 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "Root:home" + testsetplatform mac + set result [list [catch {testtranslatefilename ~::foo} msg] $msg] + set env(HOME) $temp + set result +} {0 Root:home::foo} +test filename-10.14 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "Root:home" + testsetplatform mac + set result [list [catch {testtranslatefilename ~} msg] $msg] + set env(HOME) $temp + set result +} {0 Root:home} +test filename-10.15 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "Root:home:" + testsetplatform mac + set result [list [catch {testtranslatefilename ~::foo} msg] $msg] + set env(HOME) $temp + set result +} {0 Root:home::foo} +test filename-10.16 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "Root:home::" + testsetplatform mac + set result [list [catch {testtranslatefilename ~::foo} msg] $msg] + set env(HOME) $temp + set result +} {0 Root:home:::foo} +test filename-10.17 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "\\home\\" + testsetplatform windows + set result [list [catch {testtranslatefilename ~/foo} msg] $msg] + set env(HOME) $temp + set result +} {0 {\home\foo}} +test filename-10.18 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "\\home\\" + testsetplatform windows + set result [list [catch {testtranslatefilename ~/foo\\bar} msg] $msg] + set env(HOME) $temp + set result +} {0 {\home\foo\bar}} +test filename-10.19 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "c:" + testsetplatform windows + set result [list [catch {testtranslatefilename ~/foo} msg] $msg] + set env(HOME) $temp + set result +} {0 c:foo} +test filename-10.20 {Tcl_TranslateFileName} { + list [catch {testtranslatefilename ~blorp/foo} msg] $msg +} {1 {user "blorp" doesn't exist}} +test filename-10.21 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "c:\\" + testsetplatform windows + set result [list [catch {testtranslatefilename ~/foo} msg] $msg] + set env(HOME) $temp + set result +} {0 {c:\foo}} +test filename-10.22 {Tcl_TranslateFileName} { + testsetplatform windows + list [catch {testtranslatefilename foo//bar} msg] $msg +} {0 {foo\bar}} + +testsetplatform $platform + +test filename-10.23 {Tcl_TranslateFileName} {nonPortable unixOnly} { + # this test fails if ~ouster is not /home/ouster + list [catch {testtranslatefilename ~ouster} msg] $msg +} {0 /home/ouster} +test filename-10.24 {Tcl_TranslateFileName} {nonPortable unixOnly} { + # this test fails if ~ouster is not /home/ouster + list [catch {testtranslatefilename ~ouster/foo} msg] $msg +} {0 /home/ouster/foo} + + +test filename-11.1 {Tcl_GlobCmd} { + list [catch {glob} msg] $msg +} {1 {wrong # args: should be "glob ?switches? name ?name ...?"}} +test filename-11.2 {Tcl_GlobCmd} { + list [catch {glob -gorp} msg] $msg +} {1 {bad switch "-gorp": must be -nocomplain or --}} +test filename-11.3 {Tcl_GlobCmd} { + list [catch {glob -nocomplai} msg] $msg +} {1 {bad switch "-nocomplai": must be -nocomplain or --}} +test filename-11.4 {Tcl_GlobCmd} { + list [catch {glob -nocomplain} msg] $msg +} {1 {wrong # args: should be "glob ?switches? name ?name ...?"}} +test filename-11.5 {Tcl_GlobCmd} { + list [catch {glob -nocomplain ~xyqrszzz} msg] $msg +} {0 {}} +test filename-11.6 {Tcl_GlobCmd} { + list [catch {glob ~xyqrszzz} msg] $msg +} {1 {user "xyqrszzz" doesn't exist}} +test filename-11.7 {Tcl_GlobCmd} { + list [catch {glob -- -nocomplain} msg] $msg +} {1 {no files matched glob patterns "-nocomplain"}} +test filename-11.8 {Tcl_GlobCmd} { + list [catch {glob -nocomplain -- -nocomplain} msg] $msg +} {0 {}} +test filename-11.9 {Tcl_GlobCmd} { + testsetplatform unix + list [catch {glob ~\\xyqrszzz/bar} msg] $msg +} {1 {globbing characters not supported in user names}} +test filename-11.10 {Tcl_GlobCmd} { + testsetplatform unix + list [catch {glob -nocomplain ~\\xyqrszzz/bar} msg] $msg +} {0 {}} +test filename-11.11 {Tcl_GlobCmd} { + testsetplatform unix + list [catch {glob ~xyqrszzz\\/\\bar} msg] $msg +} {1 {user "xyqrszzz" doesn't exist}} +test filename-11.12 {Tcl_GlobCmd} { + testsetplatform unix + 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 path}} + +testsetplatform $platform + +test filename-11.13 {Tcl_GlobCmd} { + list [catch {file join [lindex [glob ~] 0]} msg] $msg +} [list 0 [file join $env(HOME)]] + +# The following tests will work on Windows platforms only if MKS +# toolkit is installed. + +catch { + set oldhome $env(HOME) + set env(HOME) [pwd] + file delete -force globTest + file mkdir globTest/a1/b1 + file mkdir globTest/a1/b2 + file mkdir globTest/a2/b3 + file mkdir globTest/a3 + close [open globTest/x1.c w] + close [open globTest/y1.c w] + close [open globTest/z1.c w] + close [open globTest/x,z1.c w] + close [open "globTest/weird name.c" w] + close [open globTest/.1 w] + close [open globTest/a1/b1/x2.c w] + close [open globTest/a1/b2/y2.c w] +} + +test filename-11.14 {Tcl_GlobCmd} {unixExecs} { + list [catch {glob ~/globTest} msg] $msg +} [list 0 [list [file join $env(HOME) globTest]]] +test filename-11.15 {Tcl_GlobCmd} {unixExecs} { + list [catch {glob ~\\/globTest} msg] $msg +} [list 0 [list [file join $env(HOME) globTest]]] +test filename-11.16 {Tcl_GlobCmd} {unixExecs} { + list [catch {glob globTest} msg] $msg +} {0 globTest} + +test filename-12.1 {simple globbing} {unixOrPc} { + list [catch {glob {}} msg] $msg +} {0 .} +test filename-12.2 {simple globbing} {macOnly} { + list [catch {glob {}} msg] $msg +} {0 :} +test filename-12.3 {simple globbing} { + list [catch {glob -nocomplain \{a1,a2\}} msg] $msg +} {0 {}} + +if {$tcl_platform(platform) == "macintosh"} { + set globPreResult :globTest: +} else { + set globPreResult globTest/ +} +set x1 x1.c +set y1 y1.c +test filename-12.4 {simple globbing} {unixOrPC} { + lsort [glob globTest/x1.c globTest/y1.c globTest/foo] +} "$globPreResult$x1 $globPreResult$y1" +test filename-12.5 {simple globbing} {unixExecs} { + list [catch {glob globTest\\/x1.c} msg] $msg +} "0 $globPreResult$x1" +test filename-12.6 {simple globbing} {unixExecs} { + list [catch {glob globTest\\/\\x1.c} msg] $msg +} "0 $globPreResult$x1" + +test filename-13.1 {globbing with brace substitution} {unixExecs} { + list [catch {glob globTest/\{\}} msg] $msg +} "0 $globPreResult" +test filename-13.2 {globbing with brace substitution} { + list [catch {glob globTest/\{} msg] $msg +} {1 {unmatched open-brace in file name}} +test filename-13.3 {globbing with brace substitution} { + list [catch {glob globTest/\{\\\}} msg] $msg +} {1 {unmatched open-brace in file name}} +test filename-13.4 {globbing with brace substitution} { + list [catch {glob globTest/\{\\} msg] $msg +} {1 {unmatched open-brace in file name}} +test filename-13.5 {globbing with brace substitution} { + list [catch {glob globTest/\}} msg] $msg +} {1 {unmatched close-brace in file name}} +test filename-13.6 {globbing with brace substitution} {unixExecs} { + list [catch {glob globTest/\{\}x1.c} msg] $msg +} "0 $globPreResult$x1" +test filename-13.7 {globbing with brace substitution} {unixExecs} { + list [catch {glob globTest/\{x\}1.c} msg] $msg +} "0 $globPreResult$x1" +test filename-13.8 {globbing with brace substitution} {unixExecs} { + list [catch {glob globTest/\{x\{\}\}1.c} msg] $msg +} "0 $globPreResult$x1" +test filename-13.9 {globbing with brace substitution} {unixExecs} { + list [lsort [catch {glob globTest/\{x,y\}1.c} msg]] $msg +} [list 0 [list $globPreResult$x1 $globPreResult$y1]] +test filename-13.10 {globbing with brace substitution} {unixExecs} { + list [lsort [catch {glob globTest/\{x,,y\}1.c} msg]] $msg +} [list 0 [list $globPreResult$x1 $globPreResult$y1]] +test filename-13.11 {globbing with brace substitution} {unixOrPc unixExecs} { + list [lsort [catch {glob globTest/\{x,x\\,z,z\}1.c} msg]] $msg +} {0 {globTest/x1.c globTest/x,z1.c globTest/z1.c}} +test filename-13.12 {globbing with brace substitution} {macOnly} { + list [lsort [catch {glob globTest/\{x,x\\,z,z\}1.c} msg]] $msg +} {0 {:globTest:x1.c :globTest:x,z1.c :globTest:z1.c}} +test filename-13.13 {globbing with brace substitution} {unixExecs} { + lsort [glob globTest/{a,b,x,y}1.c] +} [list $globPreResult$x1 $globPreResult$y1] +test filename-13.14 {globbing with brace substitution} {unixOrPc unixExecs} { + lsort [glob {globTest/{x1,y2,weird name}.c}] +} {{globTest/weird name.c} globTest/x1.c} +test filename-13.15 {globbing with brace substitution} {macOnly} { + lsort [glob {globTest/{x1,y2,weird name}.c}] +} {{:globTest:weird name.c} :globTest:x1.c} +test filename-13.16 {globbing with brace substitution} {unixOrPc unixExecs} { + lsort [glob globTest/{x1.c,a1/*}] +} {globTest/a1/b1 globTest/a1/b2 globTest/x1.c} +test filename-13.17 {globbing with brace substitution} {macOnly} { + lsort [glob globTest/{x1.c,a1/*}] +} {:globTest:a1:b1 :globTest:a1:b2 :globTest:x1.c} +test filename-13.18 {globbing with brace substitution} {unixOrPc unixExecs} { + lsort [glob globTest/{x1.c,{a},a1/*}] +} {globTest/a1/b1 globTest/a1/b2 globTest/x1.c} +test filename-13.19 {globbing with brace substitution} {macOnly} { + lsort [glob globTest/{x1.c,{a},a1/*}] +} {:globTest:a1:b1 :globTest:a1:b2 :globTest:x1.c} +test filename-13.20 {globbing with brace substitution} {unixOrPc unixExecs} { + lsort [glob globTest/{a,x}1/*/{x,y}*] +} {globTest/a1/b1/x2.c globTest/a1/b2/y2.c} +test filename-13.21 {globbing with brace substitution} {macOnly} { + lsort [glob globTest/{a,x}1/*/{x,y}*] +} {:globTest:a1:b1:x2.c :globTest:a1:b2:y2.c} +test filename-13.22 {globbing with brace substitution} {unixExecs} { + list [catch {glob globTest/\{a,x\}1/*/\{} msg] $msg +} {1 {unmatched open-brace in file name}} + +test filename-14.1 {asterisks, question marks, and brackets} {unixExecs unixOrPc} { + lsort [glob g*/*.c] +} {{globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c} +test filename-14.2 {asterisks, question marks, and brackets} {macOnly} { + lsort [glob g*/*.c] +} {{:globTest:weird name.c} :globTest:x,z1.c :globTest:x1.c :globTest:y1.c :globTest:z1.c} +test filename-14.3 {asterisks, question marks, and brackets} {unixExecs unixOrPc} { + lsort [glob globTest/?1.c] +} {globTest/x1.c globTest/y1.c globTest/z1.c} +test filename-14.4 {asterisks, question marks, and brackets} {macOnly} { + lsort [glob globTest/?1.c] +} {:globTest:x1.c :globTest:y1.c :globTest:z1.c} +test filename-14.5 {asterisks, question marks, and brackets} {unixExecs unixOrPc} { + lsort [glob */*/*/*.c] +} {globTest/a1/b1/x2.c globTest/a1/b2/y2.c} +test filename-14.6 {asterisks, question marks, and brackets} {macOnly} { + lsort [glob */*/*/*.c] +} {:globTest:a1:b1:x2.c :globTest:a1:b2:y2.c} +test filename-14.7 {asterisks, question marks, and brackets} {unixExecs unixOrPc} { + lsort [glob globTest/*] +} {globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c} +test filename-14.8 {asterisks, question marks, and brackets} {macOnly} { + lsort [glob globTest/*] +} {:globTest:.1 :globTest:a1 :globTest:a2 :globTest:a3 {:globTest:weird name.c} :globTest:x,z1.c :globTest:x1.c :globTest:y1.c :globTest:z1.c} +test filename-14.9 {asterisks, question marks, and brackets} {unixExecs unixOrPc} { + lsort [glob globTest/.*] +} {globTest/. globTest/.. globTest/.1} +test filename-14.10 {asterisks, question marks, and brackets} {macOnly} { + lsort [glob globTest/.*] +} {:globTest:.1} +test filename-14.11 {asterisks, question marks, and brackets} {unixExecs unixOrPc} { + lsort [glob globTest/*/*] +} {globTest/a1/b1 globTest/a1/b2 globTest/a2/b3} +test filename-14.12 {asterisks, question marks, and brackets} {macOnly} { + lsort [glob globTest/*/*] +} {:globTest:a1:b1 :globTest:a1:b2 :globTest:a2:b3} +test filename-14.13 {asterisks, question marks, and brackets} {unixExecs unixOrPc} { + lsort [glob {globTest/[xyab]1.*}] +} {globTest/x1.c globTest/y1.c} +test filename-14.14 {asterisks, question marks, and brackets} {macOnly} { + lsort [glob {globTest/[xyab]1.*}] +} {:globTest:x1.c :globTest:y1.c} +test filename-14.15 {asterisks, question marks, and brackets} {unixExecs unixOrPc} { + lsort [glob globTest/*/] +} {globTest/a1/ globTest/a2/ globTest/a3/} +test filename-14.16 {asterisks, question marks, and brackets} {macOnly} { + lsort [glob globTest/*/] +} {:globTest:a1: :globTest:a2: :globTest:a3:} +test filename-14.17 {asterisks, question marks, and brackets} {unixExecs} { + global env + set temp $env(HOME) + set env(HOME) [file join $env(HOME) globTest] + set result [list [catch {glob ~/z*} msg] $msg] + set env(HOME) $temp + set result +} [list 0 [list [file join $env(HOME) globTest z1.c]]] +test filename-14.18 {asterisks, question marks, and brackets} {unixExecs unixOrPc} { + list [catch {lsort [glob globTest/*.c goo/*]} msg] $msg +} {0 {{globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}} +test filename-14.19 {asterisks, question marks, and brackets} {macOnly} { + list [catch {lsort [glob globTest/*.c goo/*]} msg] $msg +} {0 {{:globTest:weird name.c} :globTest:x,z1.c :globTest:x1.c :globTest:y1.c :globTest:z1.c}} +test filename-14.20 {asterisks, question marks, and brackets} { + list [catch {glob -nocomplain goo/*} msg] $msg +} {0 {}} +test filename-14.21 {asterisks, question marks, and brackets} { + list [catch {glob globTest/*/gorp} msg] $msg +} {1 {no files matched glob pattern "globTest/*/gorp"}} +test filename-14.22 {asterisks, question marks, and brackets} { + list [catch {glob goo/* x*z foo?q} msg] $msg +} {1 {no files matched glob patterns "goo/* x*z foo?q"}} +test filename-14.23 {slash globbing} {unixOrPc} { + glob / +} / +test filename-14.24 {slash globbing} {pcOnly} { + glob {\\} +} / + +# The following tests are only valid for Unix systems. + +if {$tcl_platform(platform) == "unix"} { + # On some systems, like AFS, "000" protection doesn't prevent + # access by owner, so the following test is not portable. + + exec chmod 000 globTest + test filename-15.1 {unix specific globbing} {nonPortable} { + 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 filename-15.2 {unix specific globbing} {nonPortable} { + glob ~ouster/.csh* + } "/home/ouster/.cshrc" + close [open globTest/odd\\\[\]*?\{\}name w] + test filename-15.3 {unix specific globbing} { + global env + set temp $env(HOME) + set env(HOME) $env(HOME)/globTest/odd\\\[\]*?\{\}name + set result [list [catch {glob ~} msg] $msg] + set env(HOME) $temp + set result + } [list 0 [list [glob ~]/globTest/odd\\\[\]*?\{\}name]] + exec rm -f globTest/odd\\\[\]*?\{\}name +} + +# The following tests are only valid for Windows systems. + +if {$tcl_platform(platform) == "windows"} { + set temp [pwd] + cd c:/ + catch { + removeDirectory globTest + makeDirectory globTest + close [open globTest/x1.BAT w] + close [open globTest/y1.Bat w] + close [open globTest/z1.bat w] + } + + test filename-16.1 {windows specific globbing} {unixExecs} { + lsort [glob globTest/*.bat] + } {globTest/x1.BAT globTest/y1.Bat globTest/z1.bat} + test filename-16.2 {windows specific globbing} { + glob c: + } c: + test filename-16.3 {windows specific globbing} {unixExecs} { + glob c:\\\\ + } c:/ + test filename-16.4 {windows specific globbing} { + glob c:/ + } c:/ + test filename-16.5 {windows specific globbing} {unixExecs} { + glob c:*Test + } c:globTest + test filename-16.6 {windows specific globbing} {unixExecs} { + glob c:\\\\*Test + } c:/globTest + test filename-16.7 {windows specific globbing} {unixExecs} { + glob c:/*Test + } c:/globTest + test filename-16.8 {windows specific globbing} {unixExecs} { + lsort [glob c:globTest/*.bat] + } {c:globTest/x1.BAT c:globTest/y1.Bat c:globTest/z1.bat} + test filename-16.9 {windows specific globbing} {unixExecs} { + lsort [glob c:/globTest/*.bat] + } {c:/globTest/x1.BAT c:/globTest/y1.Bat c:/globTest/z1.bat} + test filename-16.10 {windows specific globbing} {unixExecs} { + lsort [glob c:globTest\\\\*.bat] + } {c:globTest/x1.BAT c:globTest/y1.Bat c:globTest/z1.bat} + test filename-16.11 {windows specific globbing} {unixExecs} { + lsort [glob c:\\\\globTest\\\\*.bat] + } {c:/globTest/x1.BAT c:/globTest/y1.Bat c:/globTest/z1.bat} + + removeDirectory globTest + + if $testConfig(nonPortable) { + cd //gaspode/d + removeDirectory globTest + makeDirectory globTest + + close [open globTest/x1.BAT w] + close [open globTest/y1.Bat w] + close [open globTest/z1.bat w] + + test filename-16.12 {windows specific globbing} { + glob //gaspode/d/*Test + } //gaspode/d/globTest + test filename-16.13 {windows specific globbing} { + glob {\\\\gaspode\\d\\*Test} + } //gaspode/d/globTest + + removeDirectory globTest + } + + cd $temp +} + +removeDirectory globTest +set env(HOME) $oldhome + +testsetplatform $platform +catch {unset oldhome platform temp result} +concat "" diff --git a/tcl7.3/tests/for.test b/tcl7.6/tests/for.test similarity index 64% rename from tcl7.3/tests/for.test rename to tcl7.6/tests/for.test index 2fafcc5..be2dcc9 100644 --- a/tcl7.3/tests/for.test +++ b/tcl7.6/tests/for.test @@ -5,26 +5,12 @@ # 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. +# Copyright (c) 1994 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) for.test 1.12 96/10/08 17:40:43 if {[string compare test [info procs test]] == 1} then {source defs} @@ -48,22 +34,22 @@ 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"} +} {wrong # args: should be "foreach varList list ?varList 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"} +} {wrong # args: should be "foreach varList list ?varList 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"} +} {wrong # args: should be "foreach varList list ?varList 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"} +} {wrong # args: should be "foreach varList list ?varList list ...? command"} test for-1.11 {basic foreach tests} { set a {} foreach i {} { @@ -71,12 +57,68 @@ test for-1.11 {basic foreach tests} { } set a } {} -test for-1.11 {foreach errors} { +test for-1.12 {foreach errors} { + list [catch {foreach {{a}{b}} {1 2 3} {}} msg] $msg +} {1 {list element in braces followed by "{b}" instead of space}} +test for-1.13 {foreach errors} { + list [catch {foreach a {{1 2}3} {}} msg] $msg +} {1 {list element in braces followed by "3" instead of space}} +catch {unset a} +test for-1.14 {foreach errors} { catch {unset a} set a(0) 44 list [catch {foreach a {1 2 3} {}} msg] $msg -} {1 {couldn't set loop variable}} +} {1 {couldn't set loop variable: "a"}} catch {unset a} +test for-1.15 {parallel foreach tests} { + set x {} + foreach {a b} {1 2 3 4} { + append x $b $a + } + set x +} {2143} +test for-1.16 {parallel foreach tests} { + set x {} + foreach {a b} {1 2 3 4 5} { + append x $b $a + } + set x +} {21435} +test for-1.17 {parallel foreach tests} { + set x {} + foreach a {1 2 3} b {4 5 6} { + append x $b $a + } + set x +} {415263} +test for-1.18 {parallel foreach tests} { + set x {} + foreach a {1 2 3} b {4 5 6 7 8} { + append x $b $a + } + set x +} {41526378} +test for-1.19 {parallel foreach tests} { + set x {} + foreach {a b} {a b A B aa bb} c {c C cc CC} { + append x $a $b $c + } + set x +} {abcABCaabbccCC} +test for-1.20 {parallel foreach tests} { + set x {} + foreach a {1 2 3} b {1 2 3} c {1 2 3} d {1 2 3} e {1 2 3} { + append x $a $b $c $d $e + } + set x +} {111112222233333} +test for-1.21 {parallel foreach tests} { + set x {} + foreach a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} { + append x $a $b $c $d $e + } + set x +} {1111 2222334} # Check "continue". diff --git a/tcl7.3/tests/format.test b/tcl7.6/tests/format.test similarity index 80% rename from tcl7.3/tests/format.test rename to tcl7.6/tests/format.test index e31ba50..219327b 100644 --- a/tcl7.3/tests/format.test +++ b/tcl7.6/tests/format.test @@ -4,27 +4,13 @@ # 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. +# Copyright (c) 1991-1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) format.test 1.24 96/10/08 17:40:55 if {[string compare test [info procs test]] == 1} then {source defs} @@ -42,20 +28,15 @@ if {"[format %7.1e 68.514]" == "6.8e+01"} { 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} -} +test format-1.2 {integer formatting} {nonPortable} { + format "%4d %4d %4d %4d %d %#x %#X" 6 34 16923 -12 -1 14 12 +} { 6 34 16923 -12 -1 0xe 0XC} -# %u output depends on word length, so don't run these tests except -# at Berkeley, where word length is known. +# %u output depends on word length, so this test is not portable. -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.3 {integer formatting} {nonPortable} { + 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 } @@ -67,25 +48,23 @@ test format-1.6 {integer formatting} { } {000034} # Printing negative numbers in hex or octal format depends on word -# length; only run at Berkeley where word length is known. +# length, so these tests are not portable. -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-1.7 {integer formatting} {nonPortable} { + format "%4x %4x %4x %4x" 6 34 16923 -12 -1 +} { 6 22 421b fffffff4} +test format-1.8 {integer formatting} {nonPortable} { + format "%#x %#X %#X %#x" 6 34 16923 -12 -1 +} {0x6 0X22 0X421B 0xfffffff4} +test format-1.9 {integer formatting} {nonPortable} { + format "%#20x %#20x %#20x %#20x" 6 34 16923 -12 -1 +} { 0x6 0x22 0x421b 0xfffffff4} +test format-1.10 {integer formatting} {nonPortable} { + format "%-#20x %-#20x %-#20x %-#20x" 6 34 16923 -12 -1 +} {0x6 0x22 0x421b 0xfffffff4 } +test format-1.11 {integer formatting} {nonPortable} { + 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 @@ -120,7 +99,7 @@ if {!$roundOffBug} { 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} { +test format-3.7 {e and f formats} {nonPortable} { 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} { @@ -202,13 +181,13 @@ test format-4.16 {g-format} { test format-4.17 {g-format} { format "%.3g" .001 } {0.001} -test format-4.19 {g-format} { +test format-4.18 {g-format} { format "%.3g" .00001 } {1e-05} -test format-4.20 {g-format} { +test format-4.19 {g-format} { format "%#.3g" 1234.0 } {1.23e+03} -test format-4.21 {g-format} { +test format-4.20 {g-format} { format "%#.3G" 9999.5 } {1.00E+04} @@ -329,17 +308,15 @@ test format-8.1 {long result} { 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-9.1 {"h" format specifier} {nonPortable} { + format %hd 0xffff +} -1 +test format-9.2 {"h" format specifier} {nonPortable} { + format %hx 0x10fff +} fff +test format-9.3 {"h" format specifier} {nonPortable} { + format %hd 0x10000 +} 0 test format-10.1 {XPG3 %$n specifiers} { format {%2$d %1$d} 4 5 @@ -377,3 +354,7 @@ test format-10.11 {XPG3 %$n specifiers} { test format-10.12 {XPG3 %$n specifiers} { list [catch {format {%2$*d} 4 5 6} msg] $msg } {0 { 6}} + +test format-11.1 {negative width specifiers} { + format "%*d" -47 25 +} {25} diff --git a/tcl7.6/tests/get.test b/tcl7.6/tests/get.test new file mode 100644 index 0000000..50e68bb --- /dev/null +++ b/tcl7.6/tests/get.test @@ -0,0 +1,72 @@ +# Commands covered: none +# +# This file contains a collection of tests for the procedures in the +# file tclGet.c. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1995-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) get.test 1.6 96/10/08 17:39:21 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test get-1.1 {Tcl_GetInt procedure} { + set x 44 + incr x { 22} +} {66} +test get-1.2 {Tcl_GetInt procedure} { + set x 44 + incr x -3 +} {41} +test get-1.3 {Tcl_GetInt procedure} { + set x 44 + incr x +8 +} {52} +test get-1.4 {Tcl_GetInt procedure} { + set x 44 + list [catch {incr x foo} msg] $msg +} {1 {expected integer but got "foo"}} +test get-1.5 {Tcl_GetInt procedure} { + set x 44 + list [catch {incr x {16 }} msg] $msg +} {0 60} +test get-1.6 {Tcl_GetInt procedure} { + set x 44 + list [catch {incr x {16 x}} msg] $msg +} {1 {expected integer but got "16 x"}} + +# The following tests are non-portable because they depend on +# word size. + +test get-1.7 {Tcl_GetInt procedure} {nonPortable unixOnly} { + set x 44 + list [catch {incr x 4294967296} msg] $msg $errorCode +} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} +test get-1.8 {Tcl_GetInt procedure} {nonPortable} { + set x 0 + list [catch {incr x 4294967294} msg] $msg +} {0 -2} +test get-1.9 {Tcl_GetInt procedure} {nonPortable} { + set x 0 + list [catch {incr x +4294967294} msg] $msg +} {0 -2} +test get-1.10 {Tcl_GetInt procedure} {nonPortable} { + set x 0 + list [catch {incr x -4294967294} msg] $msg +} {0 2} + +test get-2.1 {Tcl_GetInt procedure} { + format %g 1.23 +} {1.23} +test get-2.2 {Tcl_GetInt procedure} { + format %g { 1.23 } +} {1.23} +test get-2.3 {Tcl_GetInt procedure} { + list [catch {format %g clip} msg] $msg +} {1 {expected floating-point number but got "clip"}} +test get-2.4 {Tcl_GetInt procedure} {nonPortable} { + list [catch {format %g .000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001} msg] $msg $errorCode +} {1 {floating-point value too small to represent} {ARITH UNDERFLOW {floating-point value too small to represent}}} diff --git a/tcl7.3/tests/history.test b/tcl7.6/tests/history.test similarity index 91% rename from tcl7.3/tests/history.test rename to tcl7.6/tests/history.test index 56e337b..d5921b6 100644 --- a/tcl7.3/tests/history.test +++ b/tcl7.6/tests/history.test @@ -5,26 +5,12 @@ # 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. +# Copyright (c) 1994 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) history.test 1.11 96/02/16 08:55:57 if {[info commands history] == ""} { puts stdout "This version of Tcl was built without the history command;\n" @@ -261,7 +247,7 @@ 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} +} {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 diff --git a/tcl7.3/tests/if.test b/tcl7.6/tests/if.test similarity index 75% rename from tcl7.3/tests/if.test rename to tcl7.6/tests/if.test index 1ab205e..2279117 100644 --- a/tcl7.3/tests/if.test +++ b/tcl7.6/tests/if.test @@ -5,26 +5,12 @@ # 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. +# Copyright (c) 1994 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) if.test 1.9 96/10/08 17:41:14 if {[string compare test [info procs test]] == 1} then {source defs} @@ -53,17 +39,17 @@ test if-1.5 {taking proper branch} { if 0 {set a 1} else {} set a } {} -test if-1.5 {taking proper branch} { +test if-1.6 {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} { +test if-1.7 {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} { +test if-1.8 {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 @@ -141,7 +127,7 @@ test if-4.4 {error conditions} { } {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"}} +} {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}} @@ -150,13 +136,13 @@ test if-4.7 {error conditions} { } {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"}} +} {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"}} +} {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/tcl7.3/tests/incr.test b/tcl7.6/tests/incr.test similarity index 63% rename from tcl7.3/tests/incr.test rename to tcl7.6/tests/incr.test index d04fe7f..edbda9b 100644 --- a/tcl7.3/tests/incr.test +++ b/tcl7.6/tests/incr.test @@ -5,26 +5,12 @@ # 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. +# Copyright (c) 1994 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) incr.test 1.9 96/10/08 17:41:28 if {[string compare test [info procs test]] == 1} then {source defs} @@ -42,7 +28,7 @@ test incr-1.3 {basic incr operation} { set x " -106" list [incr x 1] $x } {-105 -105} -test incr-1.3 {basic incr operation} { +test incr-1.4 {basic incr operation} { set x " +106" list [incr x 1] $x } {107 107} @@ -81,6 +67,22 @@ test incr-2.6 {incr errors} { } {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} +test incr-2.7 {incr errors} { + set x - + list [catch {incr x 1} msg] $msg +} {1 {expected integer but got "-"}} +test incr-2.8 {incr errors} { + set x { - } + list [catch {incr x 1} msg] $msg +} {1 {expected integer but got " - "}} +test incr-2.9 {incr errors} { + set x + + list [catch {incr x 1} msg] $msg +} {1 {expected integer but got "+"}} +test incr-2.10 {incr errors} { + set x {20 x} + list [catch {incr x 1} msg] $msg +} {1 {expected integer but got "20 x"}} + concat {} diff --git a/tcl7.3/tests/info.test b/tcl7.6/tests/info.test similarity index 72% rename from tcl7.3/tests/info.test rename to tcl7.6/tests/info.test index ecc7d94..7c580c4 100644 --- a/tcl7.3/tests/info.test +++ b/tcl7.6/tests/info.test @@ -4,27 +4,13 @@ # 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. +# Copyright (c) 1991-1994 The Regents of the University of California. +# Copyright (c) 1994-1995 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) info.test 1.34 96/08/21 15:22:52 if {[string compare test [info procs test]] == 1} then {source defs} @@ -96,7 +82,7 @@ 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]"}} +} {1 {wrong # args: should be "info commands ?pattern?"}} test info-5.1 {info complete option} { info complete "" @@ -221,6 +207,24 @@ test info-5.40 {info complete option} { test info-5.41 {info complete option} { info complete "a\nb\n# \{\n# \{\nc\n" } 1 +test info-5.42 {info complete option} { + info complete "#Incomplete comment\\\n" +} 0 +test info-5.43 {info complete option} { + info complete "#Incomplete comment\\\nBut now it's complete.\n" +} 1 +test info-5.44 {info complete option} { + info complete "# Complete comment\\\\\n" +} 1 +test info-5.45 {info complete option} { + info complete "abc\\\n def" +} 1 +test info-5.46 {info complete option} { + info complete "abc\\\n " +} 1 +test info-5.47 {info complete option} { + info complete "abc\\\n" +} 0 test info-6.1 {info default option} { proc t1 {a b {c d} {e "long default value"}} {} @@ -330,7 +334,7 @@ test info-8.2 {info globals option} { } {_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]"}} +} {1 {wrong # args: should be "info globals ?pattern?"}} test info-9.1 {info level option} { info level @@ -379,25 +383,28 @@ test info-9.9 {info level option} { list [catch {t1 -3} msg] $msg } {1 {bad level "-3"}} +set savedLibrary $tcl_library 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. +test info-10.2 {info library option} { + set tcl_library 12345 + info library +} {12345} +test info-10.3 {info library option} { + unset tcl_library + list [catch {info library} msg] $msg +} {1 {no library has been specified for Tcl}} +set tcl_library $savedLibrary -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 loaded option} { + list [catch {info loaded a b} msg] $msg +} {1 {wrong # args: should be "info loaded ?interp?"}} +test info-11.2 {info loaded option} { + list [catch {info loaded {}}] [catch {info loaded gorp} msg] $msg +} {0 1 {couldn't find slave interpreter named "gorp"}} -test info-11.1 {info locals option} { +test info-12.1 {info locals option} { set a 22 proc t1 {x y} { set b 13 @@ -407,83 +414,104 @@ test info-11.1 {info locals option} { } lsort [t1 23 24] } {b c x y} -test info-11.2 {info locals option} { +test info-12.2 {info locals option} { proc t1 {x y} { set xx1 2 set xx2 3 set y 4 - return [info lo x*] + return [info loc x*] } lsort [t1 2 3] } {x xx1 xx2} -test info-11.3 {info locals option} { +test info-12.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} { +} {1 {wrong # args: should be "info locals ?pattern?"}} +test info-12.4 {info locals option} { info locals } {} -test info-11.5 {info locals option} { +test info-12.5 {info locals option} { proc t1 {} {return [info locals]} t1 } {} -test info-12.1 {info patchlevel option} { +test info-13.1 {info nameofexecutable option} { + list [catch {info nameofexecutable foo} msg] $msg +} {1 {wrong # args: should be "info nameofexecutable"}} + +test info-14.1 {info patchlevel option} { set a [info patchlevel] - incr a 2 - expr $a-[info patchlevel] -} 2 -test info-12.2 {info patchlevel option} { + regexp {[0-9]+\.[0-9]+([p[0-9]+)?} $a +} 1 +test info-14.2 {info patchlevel option} { list [catch {info patchlevel a} msg] $msg } {1 {wrong # args: should be "info patchlevel"}} +test info-14.3 {info patchlevel option} { + set t $tcl_patchLevel + unset tcl_patchLevel + set result [list [catch {info patchlevel} msg] $msg] + set tcl_patchLevel $t + set result +} {1 {can't read "tcl_patchLevel": no such variable}} -test info-13.1 {info procs option} { +test info-15.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} { +test info-15.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} { +test info-15.3 {info procs option} { list [catch {info procs 2 3} msg] $msg -} {1 {wrong # args: should be "info procs [pattern]"}} +} {1 {wrong # args: should be "info procs ?pattern?"}} -test info-14.1 {info script option} { +test info-16.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] +test info-16.2 {info script option} { + file tail [info sc] } info.test -catch {exec rm -f gorp.info} -exec cat > gorp.info << "info script\n" -test info-14.3 {info script option} { +removeFile gorp.info +makeFile "info script\n" gorp.info +test info-16.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} { +test info-16.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} { +test info-16.5 {resetting "info script" after errors} { catch {source _nonexistent_} file tail [info script] } {info.test} -exec rm -f gorp.info +removeFile gorp.info -test info-15.1 {info tclversion option} { +test info-17.1 {info sharedlibextension option} { + list [catch {info sharedlibextension foo} msg] $msg +} {1 {wrong # args: should be "info sharedlibextension"}} + +test info-18.1 {info tclversion option} { set x [info tclversion] scan $x "%d.%d%c" a b c } 2 -test info-15.2 {info tclversion option} { +test info-18.2 {info tclversion option} { list [catch {info t 2} msg] $msg } {1 {wrong # args: should be "info tclversion"}} +test info-18.3 {info tclversion option} { + set t $tcl_version + unset tcl_version + set result [list [catch {info tclversion} msg] $msg] + set tcl_version $t + set result +} {1 {can't read "tcl_version": no such variable}} -test info-16.1 {info vars option} { +test info-19.1 {info vars option} { set a 1 set b 2 proc t1 {x y} { @@ -493,7 +521,7 @@ test info-16.1 {info vars option} { } lsort [t1 18 19] } {a b c x y} -test info-16.2 {info vars option} { +test info-19.2 {info vars option} { set xxx1 1 set xxx2 2 proc t1 {xxa y} { @@ -503,22 +531,25 @@ test info-16.2 {info vars option} { } lsort [t1 18 19] } {xxa xxx1 xxx2} -test info-16.3 {info vars option} { +test info-19.3 {info vars option} { lsort [info vars] } [lsort [info globals]] -test info-16.4 {info vars option} { +test info-19.4 {info vars option} { list [catch {info vars a b} msg] $msg -} {1 {wrong # args: should be "info vars [pattern]"}} +} {1 {wrong # args: should be "info vars ?pattern?"}} -test info-17.1 {miscellaneous error conditions} { +test info-20.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} { +test info-20.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} { +} {1 {bad option "gorp": should be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} +test info-20.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} { +} {1 {bad option "c": should be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} +test info-20.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}} +} {1 {bad option "l": should be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} +test info-20.5 {miscellaneous error conditions} { + list [catch {info s} msg] $msg +} {1 {bad option "s": should be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} diff --git a/tcl7.6/tests/interp.test b/tcl7.6/tests/interp.test new file mode 100644 index 0000000..262d8a2 --- /dev/null +++ b/tcl7.6/tests/interp.test @@ -0,0 +1,638 @@ +# This file tests the multiple interpreter facility of Tcl +# +# 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) 1995-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) interp.test 1.31 96/10/08 18:01:16 + +if {[string compare test [info procs test]] == 1} then {source defs} + +foreach i [interp slaves] { + interp delete $i +} + +proc equiv {x} {return $x} + +# Part 0: Check out options for interp command +test interp-1.1 {options for interp command} { + list [catch {interp} msg] $msg +} {1 {wrong # args: should be "interp cmd ?arg ...?"}} +test interp-1.2 {options for interp command} { + list [catch {interp frobox} msg] $msg +} {1 {bad option "frobox": should be alias, aliases, create, delete, exists, eval, issafe, share, slaves, target or transfer}} +test interp-1.3 {options for interp command} { + interp delete +} "" +test interp-1.4 {options for interp command} { + list [catch {interp delete foo bar} msg] $msg +} {1 {interpreter named "foo" not found}} +test interp-1.5 {options for interp command} { + list [catch {interp exists foo bar} msg] $msg +} {1 {wrong # args: should be "interp exists ?path?"}} +# +# test interp-0.6 was removed +# +test interp-1.6 {options for interp command} { + list [catch {interp slaves foo bar zop} msg] $msg +} {1 {wrong # args: should be "interp slaves ?path?"}} +test interp-1.7 {options for interp command} { + list [catch {interp hello} msg] $msg +} {1 {bad option "hello": should be alias, aliases, create, delete, exists, eval, issafe, share, slaves, target or transfer}} +test interp-1.8 {options for interp command} { + list [catch {interp -froboz} msg] $msg +} {1 {bad option "-froboz": should be alias, aliases, create, delete, exists, eval, issafe, share, slaves, target or transfer}} +test interp-1.9 {options for interp command} { + list [catch {interp -froboz -safe} msg] $msg +} {1 {bad option "-froboz": should be alias, aliases, create, delete, exists, eval, issafe, share, slaves, target or transfer}} +test interp-1.10 {options for interp command} { + list [catch {interp target} msg] $msg +} {1 {wrong # args: should be "interp target path alias"}} + +# Part 1: Basic interpreter creation tests: +test interp-2.1 {basic interpreter creation} { + interp create a +} a +test interp-2.2 {basic interpreter creation} { + catch {interp create} +} 0 +test interp-2.3 {basic interpreter creation} { + catch {interp create -safe} +} 0 +test interp-2.4 {basic interpreter creation} { + list [catch {interp create a} msg] $msg +} {1 {interpreter named "a" already exists, cannot create}} +test interp-2.5 {basic interpreter creation} { + interp create b -safe +} b +test interp-2.6 {basic interpreter creation} { + interp create d -safe +} d +test interp-2.7 {basic interpreter creation} { + list [catch {interp create -froboz} msg] $msg +} {1 {bad option "-froboz": should be -safe}} +test interp-2.8 {basic interpreter creation} { + interp create -- -froboz +} -froboz +test interp-2.9 {basic interpreter creation} { + interp create -safe -- -froboz1 +} -froboz1 +test interp-2.10 {basic interpreter creation} { + interp create {a x1} + interp create {a x2} + interp create {a x3} -safe +} {a x3} + +foreach i [interp slaves] { + interp delete $i +} + +# Part 2: Testing "interp slaves" and "interp exists" +test interp-3.1 {testing interp exists and interp slaves} { + interp slaves +} "" +test interp-3.2 {testing interp exists and interp slaves} { + interp create a + interp exists a +} 1 +test interp-3.3 {testing interp exists and interp slaves} { + interp exists nonexistent +} 0 +test interp-3.4 {testing interp exists and interp slaves} { + list [catch {interp slaves a b c} msg] $msg +} {1 {wrong # args: should be "interp slaves ?path?"}} +test interp-3.5 {testing interp exists and interp slaves} { + list [catch {interp exists a b c} msg] $msg +} {1 {wrong # args: should be "interp exists ?path?"}} +test interp-3.6 {testing interp exists and interp slaves} { + interp exists +} 1 +test interp-3.7 {testing interp exists and interp slaves} { + interp slaves +} a +test interp-3.8 {testing interp exists and interp slaves} { + list [catch {interp slaves a b c} msg] $msg +} {1 {wrong # args: should be "interp slaves ?path?"}} +test interp-3.9 {testing interp exists and interp slaves} { + interp create {a a2} -safe + interp slaves a +} {a2} +test interp-3.10 {testing interp exists and interp slaves} { + interp exists {a a2} +} 1 + +# Part 3: Testing "interp delete" +test interp-3.11 {testing interp delete} { + interp delete +} "" +test interp-4.1 {testing interp delete} { + interp delete a +} "" +test interp-4.2 {testing interp delete} { + list [catch {interp delete nonexistent} msg] $msg +} {1 {interpreter named "nonexistent" not found}} +test interp-4.3 {testing interp delete} { + list [catch {interp delete x y z} msg] $msg +} {1 {interpreter named "x" not found}} +test interp-4.4 {testing interp delete} { + interp delete +} "" +test interp-4.5 {testing interp delete} { + interp create a + interp create {a x1} + interp delete {a x1} + interp slaves a +} "" +test interp-4.6 {testing interp delete} { + interp create c1 + interp create c2 + interp create c3 + interp delete c1 c2 c3 +} "" +test interp-4.7 {testing interp delete} { + interp create c1 + interp create c2 + list [catch {interp delete c1 c2 c3} msg] $msg +} {1 {interpreter named "c3" not found}} + +foreach i [interp slaves] { + interp delete $i +} + +# Part 4: Consistency checking - all nondeleted interpreters should be +# there: +test interp-5.1 {testing consistency} { + interp slaves +} "" +test interp-5.2 {testing consistency} { + interp exists a +} 0 +test interp-5.3 {testing consistency} { + interp exists nonexistent +} 0 + +# Recreate interpreter "a" +interp create a + +# Part 5: Testing eval in interpreter object command and with interp command +test interp-6.1 {testing eval} { + a eval expr 3 + 5 +} 8 +test interp-6.2 {testing eval} { + list [catch {a eval foo} msg] $msg +} {1 {invalid command name "foo"}} +test interp-6.3 {testing eval} { + a eval {proc foo {} {expr 3 + 5}} + a eval foo +} 8 +test interp-6.4 {testing eval} { + interp eval a foo +} 8 + +test interp-6.5 {testing eval} { + interp create {a x2} + interp eval {a x2} {proc frob {} {expr 4 * 9}} + interp eval {a x2} frob +} 36 +test interp-6.6 {testing eval} { + list [catch {interp eval {a x2} foo} msg] $msg +} {1 {invalid command name "foo"}} + +# UTILITY PROCEDURE RUNNING IN MASTER INTERPRETER: +proc in_master {args} { + return [list seen in master: $args] +} + +# Part 6: Testing basic alias creation +test interp-7.1 {testing basic alias creation} { + a alias foo in_master +} foo +test interp-7.2 {testing basic alias creation} { + a alias bar in_master a1 a2 a3 +} bar +# Test 6.3 has been deleted. +test interp-7.3 {testing basic alias creation} { + a alias foo +} in_master +test interp-7.4 {testing basic alias creation} { + a alias bar +} {in_master a1 a2 a3} +test interp-7.5 {testing basic alias creation} { + a aliases +} {foo bar} + +# Part 7: testing basic alias invocation +test interp-8.1 {testing basic alias invocation} { + a eval foo s1 s2 s3 +} {seen in master: {s1 s2 s3}} +test interp-8.2 {testing basic alias invocation} { + a eval bar s1 s2 s3 +} {seen in master: {a1 a2 a3 s1 s2 s3}} + +# Part 8: Testing aliases for non-existent targets +test interp-9.1 {testing aliases for non-existent targets} { + a alias zop nonexistent-command-in-master + list [catch {a eval zop} msg] $msg +} {1 {aliased target "nonexistent-command-in-master" for "zop" not found}} +test interp-9.2 {testing aliases for non-existent targets} { + proc nonexistent-command-in-master {} {return i_exist!} + a eval zop +} i_exist! + +if {[info command nonexistent-command-in-master] != ""} { + rename nonexistent-command-in-master {} +} + +# Recreate interpreter b.. +if {![interp exists b]} { + interp create b +} + +# Part 9: Aliasing between interpreters +test interp-10.1 {testing aliasing between interpreters} { + interp alias a a_alias b b_alias 1 2 3 +} a_alias +test interp-10.2 {testing aliasing between interpreters} { + b eval {proc b_alias {args} {return [list got $args]}} + a eval a_alias a b c +} {got {1 2 3 a b c}} +test interp-10.3 {testing aliasing between interpreters} { + b eval {rename b_alias {}} + list [catch {a eval a_alias a b c} msg] $msg +} {1 {aliased target "b_alias" for "a_alias" not found}} +test interp-10.4 {testing aliasing between interpreters} { + a aliases +} {foo zop bar a_alias} +test interp-10.5 {testing aliasing between interpreters} { + interp delete b + a aliases +} {foo zop bar} + +# Recreate interpreter b.. +if {![interp exists b]} { + interp create b +} + +test interp-10.6 {testing aliasing between interpreters} { + interp alias a a_command b b_command a1 a2 a3 + b alias b_command in_master b1 b2 b3 + a eval a_command m1 m2 m3 +} {seen in master: {b1 b2 b3 a1 a2 a3 m1 m2 m3}} +test interp-10.7 {testing aliases between interpreters} { + interp alias "" foo a zoppo + a eval {proc zoppo {x} {list $x $x $x}} + set x [foo 33] + a eval {rename zoppo {}} + interp alias "" foo a {} + equiv $x +} {33 33 33} + +# Part 10: Testing "interp target" +test interp-11.1 {testing interp target} { + list [catch {interp target} msg] $msg +} {1 {wrong # args: should be "interp target path alias"}} +test interp-11.2 {testing interp target} { + list [catch {interp target nosuchinterpreter foo} msg] $msg +} {1 {could not find interpreter "nosuchinterpreter"}} +test interp-11.3 {testing interp target} { + a alias boo no_command + interp target a boo +} "" +test interp-11.4 {testing interp target} { + interp create x1 + x1 eval interp create x2 + x1 eval x2 eval interp create x3 + interp create y1 + y1 eval interp create y2 + y1 eval y2 eval interp create y3 + interp alias {x1 x2 x3} xcommand {y1 y2 y3} ycommand + interp target {x1 x2 x3} xcommand +} {y1 y2 y3} +test interp-11.5 {testing interp target} { + list [catch {x1 eval {interp target {x2 x3} xcommand}} msg] $msg +} {1 {target interpreter for alias "xcommand" in path "x2 x3" is not my descendant}} + +# Part 11: testing "interp issafe" +test interp-12.1 {testing interp issafe} { + interp issafe +} 0 +test interp-12.2 {testing interp issafe} { + interp issafe a +} 0 +test interp-12.3 {testing interp issafe} { + interp create {a x3} -safe + interp issafe {a x3} +} 1 +test interp-12.4 {testing interp issafe} { + interp create {a x3 foo} + interp issafe {a x3 foo} +} 1 + +# Part 12: testing interpreter object command "issafe" sub-command +test interp-13.1 {testing foo issafe} { + a issafe +} 0 +test interp-13.2 {testing foo issafe} { + a eval x3 issafe +} 1 +test interp-13.3 {testing foo issafe} { + a eval x3 eval foo issafe +} 1 + +# part 14: testing interp aliases +test interp-14.1 {testing interp aliases} { + interp aliases +} "" +test interp-14.2 {testing interp aliases} { + interp aliases a +} {boo foo zop bar a_command} +test interp-14.3 {testing interp aliases} { + interp alias {a x3} froboz "" puts + interp aliases {a x3} +} froboz + +# part 15: testing file sharing +test interp-15.1 {testing file sharing} { + interp create z + z eval close stdout + list [catch {z eval puts hello} msg] $msg +} {1 {can not find channel named "stdout"}} +catch {removeFile file-15.2} +test interp-15.2 {testing file sharing} { + set f [open file-15.2 w] + interp share "" $f z + z eval puts $f hello + z eval close $f + close $f +} "" +catch {removeFile file-15.2} +test interp-15.3 {testing file sharing} { + interp create xsafe -safe + list [catch {xsafe eval puts hello} msg] $msg +} {1 {can not find channel named "stdout"}} +catch {removeFile file-15.4} +test interp-15.4 {testing file sharing} { + set f [open file-15.4 w] + interp share "" $f xsafe + xsafe eval puts $f hello + xsafe eval close $f + close $f +} "" +catch {removeFile file-15.4} +test interp-15.5 {testing file sharing} { + interp share "" stdout xsafe + list [catch {xsafe eval gets stdout} msg] $msg +} {1 {channel "stdout" wasn't opened for reading}} +catch {removeFile file-15.6} +test interp-15.6 {testing file sharing} { + set f [open file-15.6 w] + interp share "" $f xsafe + set x [list [catch [list xsafe eval gets $f] msg] $msg] + xsafe eval close $f + close $f + string compare [string tolower $x] \ + [list 1 [format "channel \"%s\" wasn't opened for reading" $f]] +} 0 +catch {removeFile file-15.6} +catch {removeFile file-15.7} +test interp-15.7 {testing file transferring} { + set f [open file-15.7 w] + interp transfer "" $f xsafe + xsafe eval puts $f hello + xsafe eval close $f +} "" +catch {removeFile file-15.7} +catch {removeFile file-15.8} +test interp-15.8 {testing file transferring} { + set f [open file-15.8 w] + interp transfer "" $f xsafe + xsafe eval close $f + set x [list [catch {close $f} msg] $msg] + string compare [string tolower $x] \ + [list 1 [format "can not find channel named \"%s\"" $f]] +} 0 +catch {removeFile file-15.8} + +# +# Torture tests for interpreter deletion order +# +proc kill {} {interp delete xxx} + +test interp-15.9 {testing deletion order} { + interp create xxx + xxx alias kill kill + list [catch {xxx eval kill} msg] $msg +} {0 {}} +test interp-16.1 {testing deletion order} { + interp create xxx + interp create {xxx yyy} + interp alias {xxx yyy} kill "" kill + list [catch {interp eval {xxx yyy} kill} msg] $msg +} {0 {}} +test interp-16.2 {testing deletion order} { + interp create xxx + interp create {xxx yyy} + interp alias {xxx yyy} kill "" kill + list [catch {xxx eval yyy eval kill} msg] $msg +} {0 {}} +test interp-16.3 {testing deletion order} { + interp create xxx + interp create ddd + xxx alias kill kill + interp alias ddd kill xxx kill + set x [ddd eval kill] + interp delete ddd + set x +} "" +test interp-16.4 {testing deletion order} { + interp create xxx + interp create {xxx yyy} + interp alias {xxx yyy} kill "" kill + interp create ddd + interp alias ddd kill {xxx yyy} kill + set x [ddd eval kill] + interp delete ddd + set x +} "" + +# +# Alias loop prevention testing. +# + +test interp-16.5 {alias loop prevention} { + list [catch {interp alias {} a {} a} msg] $msg +} {1 {cannot define or rename alias "a": would create a loop}} +test interp-17.1 {alias loop prevention} { + catch {interp delete x} + interp create x + x alias a loop + list [catch {interp alias {} loop x a} msg] $msg +} {1 {cannot define or rename alias "loop": would create a loop}} +test interp-17.2 {alias loop prevention} { + catch {interp delete x} + interp create x + interp alias x a x b + list [catch {interp alias x b x a} msg] $msg +} {1 {cannot define or rename alias "b": would create a loop}} +test interp-17.3 {alias loop prevention} { + catch {interp delete x} + interp create x + interp alias x b x a + list [catch {x eval rename b a} msg] $msg +} {1 {cannot define or rename alias "b": would create a loop}} +test interp-17.4 {alias loop prevention} { + catch {interp delete x} + interp create x + x alias z l1 + interp alias {} l2 x z + list [catch {rename l2 l1} msg] $msg +} {1 {cannot define or rename alias "l2": would create a loop}} + +# +# Test robustness of Tcl_DeleteInterp when applied to a slave interpreter. +# If there are bugs in the implementation these tests are likely to expose +# the bugs as a core dump. +# + +if {[info commands testinterpdelete] != ""} { + test interp-18.1 {testing Tcl_DeleteInterp vs slaves} { + list [catch {testinterpdelete} msg] $msg + } {1 {wrong # args: should be "testinterpdelete path"}} + test interp-18.2 {testing Tcl_DeleteInterp vs slaves} { + catch {interp delete a} + interp create a + testinterpdelete a + } "" + test interp-18.3 {testing Tcl_DeleteInterp vs slaves} { + catch {interp delete a} + interp create a + interp create {a b} + testinterpdelete {a b} + } "" + test interp-18.4 {testing Tcl_DeleteInterp vs slaves} { + catch {interp delete a} + interp create a + interp create {a b} + testinterpdelete a + } "" + test interp-18.5 {testing Tcl_DeleteInterp vs slaves} { + catch {interp delete a} + interp create a + interp create {a b} + interp alias {a b} dodel {} dodel + proc dodel {x} {testinterpdelete $x} + list [catch {interp eval {a b} {dodel {a b}}} msg] $msg + } {0 {}} + test interp-18.6 {testing Tcl_DeleteInterp vs slaves} { + catch {interp delete a} + interp create a + interp create {a b} + interp alias {a b} dodel {} dodel + proc dodel {x} {testinterpdelete $x} + list [catch {interp eval {a b} {dodel a}} msg] $msg + } {0 {}} + test interp-18.7 {eval in deleted interp} { + catch {interp delete a} + interp create a + a eval { + proc dodel {} { + delme + dosomething else + } + proc dosomething args { + puts "I should not have been called!!" + } + } + a alias delme dela + proc dela {} {interp delete a} + list [catch {a eval dodel} msg] $msg + } {1 {attempt to call eval in deleted interpreter}} + test interp-18.8 {eval in deleted interp} { + catch {interp delete a} + interp create a + a eval { + interp create b + b eval { + proc dodel {} { + dela + } + } + proc foo {} { + b eval dela + dosomething else + } + proc dosomething args { + puts "I should not have been called!!" + } + } + interp alias {a b} dela {} dela + proc dela {} {interp delete a} + list [catch {a eval foo} msg] $msg + } {1 {attempt to call eval in deleted interpreter}} +} + +# Test alias deletion + +test interp-19.1 {alias deletion} { + catch {interp delete a} + interp create a + interp alias a foo a bar + set s [interp alias a foo {}] + interp delete a + set s +} {} +test interp-19.2 {alias deletion} { + catch {interp delete a} + interp create a + catch {interp alias a foo {}} msg + interp delete a + set msg +} {alias "foo" not found} +test interp-19.3 {alias deletion} { + catch {interp delete a} + interp create a + interp alias a foo a bar + interp eval a {rename foo zop} + interp alias a foo a zop + catch {interp eval a foo} msg + interp delete a + set msg +} {aliased target "zop" for "foo" not found} +test interp-19.4 {alias deletion} { + catch {interp delete a} + interp create a + interp alias a foo a bar + interp eval a {rename foo zop} + catch {interp eval a foo} msg + interp delete a + set msg +} {invalid command name "foo"} +test interp-19.5 {alias deletion} { + catch {interp delete a} + interp create a + interp eval a {proc bar {} {return 1}} + interp alias a foo a bar + interp eval a {rename foo zop} + catch {interp eval a zop} msg + interp delete a + set msg +} 1 +test interp-19.6 {alias deletion} { + catch {interp delete a} + interp create a + interp alias a foo a bar + interp eval a {rename foo zop} + interp alias a foo a zop + set s [interp aliases a] + interp delete a + set s +} foo + +foreach i [interp slaves] { + interp delete $i +} diff --git a/tcl7.6/tests/io.test b/tcl7.6/tests/io.test new file mode 100644 index 0000000..17ff802 --- /dev/null +++ b/tcl7.6/tests/io.test @@ -0,0 +1,4501 @@ +# Functionality covered: operation of all IO commands, and all procedures +# defined in generic/tclIO.c. +# +# 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-1994 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# "@(#) io.test 1.95 96/10/08 15:12:28" + +if {[string compare test [info procs test]] == 1} then {source defs} + +removeFile test1 +removeFile pipe + +# set up a long data file for some of the following tests + +set f [open longfile w] +fconfigure $f -eofchar {} -translation lf +for { set i 0 } { $i < 100 } { incr i} { + puts $f "#123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef +\#123456789abcdef01 +\#" + } +close $f + +# These tests are disabled until we decide what to do with "unsupported0". +# +#test io-1.7 {unsupported0 command} { +# removeFile test1 +# set f1 [open iocmd.test] +# set f2 [open test1 w] +# unsupported0 $f1 $f2 +# close $f1 +# catch {close $f2} +# set s1 [file size io.test] +# set s2 [file size test1] +# set x ok +# if {"$s1" != "$s2"} { +# set x broken +# } +# set x +#} ok +#test io-1.8 {unsupported0 command} { +# removeFile test1 +# set f1 [open io.test] +# set f2 [open test1 w] +# unsupported0 $f1 $f2 40 +# close $f1 +# close $f2 +# file size test1 +#} 40 +#test io-1.9 {unsupported0 command} { +# removeFile test1 +# set f1 [open io.test] +# set f2 [open test1 w] +# unsupported0 $f1 $f2 -1 +# close $f1 +# close $f2 +# set x ok +# set s1 [file size io.test] +# set s2 [file size test1] +# if {$s1 != $s2} { +# set x broken +# } +# set x +#} ok +#test io-1.10 {unsupported0 command} {unixOrPc} { +# removeFile pipe +# removeFile test1 +# set f1 [open pipe w] +# puts $f1 {puts ready} +# puts $f1 {gets stdin} +# puts $f1 {set f1 [open io.test r]} +# puts $f1 {puts [read $f1 100]} +# puts $f1 {close $f1} +# close $f1 +# set f1 [open "|$tcltest pipe" r+] +# gets $f1 +# puts $f1 ready +# flush $f1 +# set f2 [open test1 w] +# set c [unsupported0 $f1 $f2 40] +# catch {close $f1} +# close $f2 +# set s1 [file size test1] +# set x ok +# if {$s1 != "40"} { +# set x broken +# } +# list $c $x +#} {40 ok} + +# Test standard handle management. The functions tested are +# Tcl_SetStdChannel and Tcl_GetStdChannel. Incidentally we are +# also testing channel table management. + +if {$tcl_platform(platform) == "macintosh"} { + set consoleFileNames [list console0 console1 console2] +} else { + set consoleFileNames [lsort [testchannel open]] +} +test io-1.1 {Tcl_SetStdChannel and Tcl_GetStdChannel} { + set l "" + lappend l [fconfigure stdin -buffering] + lappend l [fconfigure stdout -buffering] + lappend l [fconfigure stderr -buffering] + lappend l [lsort [testchannel open]] + set l +} [list line line none $consoleFileNames] +test io-1.2 {Tcl_SetStdChannel and Tcl_GetStdChannel} { + interp create x + set l "" + lappend l [x eval {fconfigure stdin -buffering}] + lappend l [x eval {fconfigure stdout -buffering}] + lappend l [x eval {fconfigure stderr -buffering}] + interp delete x + set l +} {line line none} +test io-1.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} {unixOrPc} { + set f [open test1 w] + puts $f { + close stdin + close stdout + close stderr + set f [open test1 r] + set f2 [open test2 w] + set f3 [open test3 w] + puts stdout [gets stdin] + puts stdout out + puts stderr err + close $f + close $f2 + close $f3 + } + close $f + set result [eval exec $tcltest test1] + set f [open test2 r] + set f2 [open test3 r] + lappend result [read $f] [read $f2] + close $f + close $f2 + set result +} {{ +out +} {err +}} +# This test relies on the fact that the smallest available fd is used first. +test io-1.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} {unixOnly} { + set f [open test1 w] + puts $f { close stdin + close stdout + close stderr + set f [open test1 r] + set f2 [open test2 w] + set f3 [open test3 w] + puts stdout [gets stdin] + puts stdout $f2 + puts stderr $f3 + close $f + close $f2 + close $f3 + } + close $f + set result [eval exec $tcltest test1] + set f [open test2 r] + set f2 [open test3 r] + lappend result [read $f] [read $f2] + close $f + close $f2 + set result +} {{ close stdin +file1 +} {file2 +}} +catch {interp delete z} +test io-1.5 {Tcl_GetChannel: stdio name translation} { + interp create z + eof stdin + catch {z eval flush stdin} msg1 + catch {z eval close stdin} msg2 + catch {z eval flush stdin} msg3 + set result [list $msg1 $msg2 $msg3] + interp delete z + set result +} {{channel "stdin" wasn't opened for writing} {} {can not find channel named "stdin"}} +test io-1.6 {Tcl_GetChannel: stdio name translation} { + interp create z + eof stdout + catch {z eval flush stdout} msg1 + catch {z eval close stdout} msg2 + catch {z eval flush stdout} msg3 + set result [list $msg1 $msg2 $msg3] + interp delete z + set result +} {{} {} {can not find channel named "stdout"}} +test io-1.7 {Tcl_GetChannel: stdio name translation} { + interp create z + eof stderr + catch {z eval flush stderr} msg1 + catch {z eval close stderr} msg2 + catch {z eval flush stderr} msg3 + set result [list $msg1 $msg2 $msg3] + interp delete z + set result +} {{} {} {can not find channel named "stderr"}} +test io-1.8 {reuse of stdio special channels} {unixOnly} { + removeFile script + removeFile test1 + set f [open script w] + puts $f { + close stderr + set f [open test1 w] + puts stderr hello + close $f + set f [open test1 r] + puts [gets $f] + } + close $f + set f [open "|$tcltest script" r] + set c [gets $f] + close $f + set c +} hello +test io-1.9 {reuse of stdio special channels} {unixOnly} { + removeFile script + removeFile test1 + set f [open script w] + puts $f { + set f [open test1 w] + puts $f hello + close $f + close stderr + set f [open "|cat test1" r] + puts [gets $f] + } + close $f + set f [open "|$tcltest script" r] + set c [gets $f] + close $f + set c +} hello + +# Must add test function for testing Tcl_CreateCloseHandler and +# Tcl_DeleteCloseHandler. + +# Test channel table management. The functions tested are +# GetChannelTable, DeleteChannelTable, Tcl_RegisterChannel, +# Tcl_UnregisterChannel, Tcl_GetChannel and Tcl_CreateChannel. +# +# These functions use "eof stdin" to ensure that the standard +# channels are added to the channel table of the interpreter. + +test io-3.1 {GetChannelTable, DeleteChannelTable on std handles} { + set l1 [testchannel refcount stdin] + eof stdin + interp create x + set l "" + lappend l [expr [testchannel refcount stdin] - $l1] + x eval {eof stdin} + lappend l [expr [testchannel refcount stdin] - $l1] + interp delete x + lappend l [expr [testchannel refcount stdin] - $l1] + set l +} {0 1 0} +test io-3.2 {GetChannelTable, DeleteChannelTable on std handles} { + set l1 [testchannel refcount stdout] + eof stdin + interp create x + set l "" + lappend l [expr [testchannel refcount stdout] - $l1] + x eval {eof stdout} + lappend l [expr [testchannel refcount stdout] - $l1] + interp delete x + lappend l [expr [testchannel refcount stdout] - $l1] + set l +} {0 1 0} +test io-3.3 {GetChannelTable, DeleteChannelTable on std handles} { + set l1 [testchannel refcount stderr] + eof stdin + interp create x + set l "" + lappend l [expr [testchannel refcount stderr] - $l1] + x eval {eof stderr} + lappend l [expr [testchannel refcount stderr] - $l1] + interp delete x + lappend l [expr [testchannel refcount stderr] - $l1] + set l +} {0 1 0} +test io-3.4 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { + removeFile test1 + set l "" + set f [open test1 w] + lappend l [lindex [testchannel info $f] 15] + close $f + if {[catch {lindex [testchannel info $f] 15} msg]} { + lappend l $msg + } else { + lappend l "very broken: $f found after being closed" + } + string compare [string tolower $l] \ + [list 1 [format "can not find channel named \"%s\"" $f]] +} 0 +test io-3.5 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { + removeFile test1 + set l "" + set f [open test1 w] + lappend l [lindex [testchannel info $f] 15] + interp create x + interp share "" $f x + lappend l [lindex [testchannel info $f] 15] + x eval close $f + lappend l [lindex [testchannel info $f] 15] + interp delete x + lappend l [lindex [testchannel info $f] 15] + close $f + if {[catch {lindex [testchannel info $f] 15} msg]} { + lappend l $msg + } else { + lappend l "very broken: $f found after being closed" + } + string compare [string tolower $l] \ + [list 1 2 1 1 [format "can not find channel named \"%s\"" $f]] +} 0 +test io-3.6 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { + removeFile test1 + set l "" + set f [open test1 w] + lappend l [lindex [testchannel info $f] 15] + interp create x + interp share "" $f x + lappend l [lindex [testchannel info $f] 15] + interp delete x + lappend l [lindex [testchannel info $f] 15] + close $f + if {[catch {lindex [testchannel info $f] 15} msg]} { + lappend l $msg + } else { + lappend l "very broken: $f found after being closed" + } + string compare [string tolower $l] \ + [list 1 2 1 [format "can not find channel named \"%s\"" $f]] +} 0 +test io-3.7 {Tcl_GetChannel->Tcl_GetStdChannel, standard handles} { + eof stdin +} 0 +test io-3.6 {testing Tcl_GetChannel, user opened handle} { + removeFile test1 + set f [open test1 w] + set x [eof $f] + close $f + set x +} 0 +test io-3.8 {Tcl_GetChannel, channel not found} { + list [catch {eof file34} msg] $msg +} {1 {can not find channel named "file34"}} +test io-3.9 {Tcl_CreateChannel, insertion into channel table} { + removeFile test1 + set f [open test1 w] + set l "" + lappend l [eof $f] + close $f + if {[catch {lindex [testchannel info $f] 15} msg]} { + lappend l $msg + } else { + lappend l "very broken: $f found after being closed" + } + string compare [string tolower $l] \ + [list 0 [format "can not find channel named \"%s\"" $f]] +} 0 + +# Test management of attributes associated with a channel, such as +# its default translation, its name and type, etc. The functions +# tested in this group are Tcl_GetChannelName, +# Tcl_GetChannelType and Tcl_GetChannelFile. Tcl_GetChannelInstanceData +# not tested because files do not use the instance data. + +test io-4.1 {Tcl_GetChannelName} { + removeFile test1 + set f [open test1 w] + set n [testchannel name $f] + close $f + string compare $n $f +} 0 +test io-4.2 {Tcl_GetChannelType} { + removeFile test1 + set f [open test1 w] + set t [testchannel type $f] + close $f + string compare $t file +} 0 +test io-4.3 {Tcl_GetChannelFile, input} { + set f [open test1 w] + fconfigure $f -translation lf -eofchar {} + puts $f "1234567890\n098765432" + close $f + set f [open test1 r] + gets $f + set l "" + lappend l [testchannel inputbuffered $f] + lappend l [tell $f] + close $f + set l +} {10 11} +test io-4.4 {Tcl_GetChannelFile, output} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts $f hello + set l "" + lappend l [testchannel outputbuffered $f] + lappend l [tell $f] + flush $f + lappend l [testchannel outputbuffered $f] + lappend l [tell $f] + close $f + removeFile test1 + set l +} {6 6 0 6} + +# Test flushing. The functions tested here are FlushChannel. + +test io-5.1 {FlushChannel, no output buffered} { + removeFile test1 + set f [open test1 w] + flush $f + set s [file size test1] + close $f + set s +} 0 +test io-5.2 {FlushChannel, some output buffered} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -eofchar {} + set l "" + puts $f hello + lappend l [file size test1] + flush $f + lappend l [file size test1] + close $f + lappend l [file size test1] + set l +} {0 6 6} +test io-5.3 {FlushChannel, implicit flush on close} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -eofchar {} + set l "" + puts $f hello + lappend l [file size test1] + close $f + lappend l [file size test1] + set l +} {0 6} +test io-5.4 {FlushChannel, implicit flush when buffer fills} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -eofchar {} + fconfigure $f -buffersize 60 + set l "" + lappend l [file size test1] + for {set i 0} {$i < 12} {incr i} { + puts $f hello + } + lappend l [file size test1] + flush $f + lappend l [file size test1] + close $f + set l +} {0 60 72} +test io-5.5 {FlushChannel, implicit flush when buffer fills and on close} {unixOrPc} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -buffersize 60 -eofchar {} + set l "" + lappend l [file size test1] + for {set i 0} {$i < 12} {incr i} { + puts $f hello + } + lappend l [file size test1] + close $f + lappend l [file size test1] + set l +} {0 60 72} +test io-5.6 {FlushChannel, async flushing, async close} {unixOrPc asyncPipeClose} { + removeFile pipe + removeFile output + set f [open pipe w] + puts $f { + set f [open output w] + fconfigure $f -translation lf -buffering none -eofchar {} + while {![eof stdin]} { + after 20 + puts -nonewline $f [read stdin 1024] + } + close $f + } + close $f + set x 01234567890123456789012345678901 + for {set i 0} {$i < 11} {incr i} { + set x "$x$x" + } + set f [open output w] + close $f + set f [open "|$tcltest pipe" w] + fconfigure $f -blocking off + puts -nonewline $f $x + close $f + set counter 0 + while {([file size output] < 65536) && ($counter < 1000)} { + incr counter + after 20 + update + } + if {$counter == 1000} { + set result probably_broken + } else { + set result ok + } +} ok + +# Tests closing a channel. The functions tested are CloseChannel and Tcl_Close. + +test io-6.1 {CloseChannel called when all references are dropped} { + removeFile test1 + set f [open test1 w] + interp create x + interp share "" $f x + set l "" + lappend l [testchannel refcount $f] + x eval close $f + interp delete x + lappend l [testchannel refcount $f] + close $f + set l +} {2 1} +test io-6.2 {CloseChannel called when all references are dropped} { + removeFile test1 + set f [open test1 w] + interp create x + interp share "" $f x + puts -nonewline $f abc + close $f + x eval puts $f def + x eval close $f + interp delete x + set f [open test1 r] + set l [gets $f] + close $f + set l +} abcdef +test io-6.3 {CloseChannel, not called before output queue is empty} {unixOrPc asyncPipeClose tempNotPc nonPortable} { + removeFile pipe + removeFile output + set f [open pipe w] + puts $f { + + # Need to not have eof char appended on close, because the other + # side of the pipe already closed, so that writing would cause an + # error "invalid file". + + fconfigure stdout -eofchar {} + fconfigure stderr -eofchar {} + + set f [open output w] + fconfigure $f -translation lf -buffering none + for {set x 0} {$x < 20} {incr x} { + after 20 + puts -nonewline $f [read stdin 1024] + } + close $f + } + close $f + set x 01234567890123456789012345678901 + for {set i 0} {$i < 11} {incr i} { + set x "$x$x" + } + set f [open output w] + close $f + set f [open "|$tcltest pipe" r+] + fconfigure $f -blocking off -eofchar {} + puts -nonewline $f $x + close $f + set counter 0 + while {([file size output] < 20480) && ($counter < 1000)} { + incr counter + after 20 + update + } + if {$counter == 1000} { + set result probably_broken + } else { + set result ok + } + # + # Wait for the flush to finish + # + catch {vwait x} + set result +} ok +test io-6.4 {Tcl_Close} { + removeFile test1 + set l "" + lappend l [lsort [testchannel open]] + set f [open test1 w] + lappend l [lsort [testchannel open]] + close $f + lappend l [lsort [testchannel open]] + set x [list $consoleFileNames \ + [lsort [eval list $consoleFileNames $f]] \ + $consoleFileNames] + string compare $l $x +} 0 +test io-6.5 {Tcl_Close vs standard handles} {unixOnly} { + removeFile script + set f [open script w] + puts $f { + close stdin + puts [testchannel open] + } + close $f + set f [open "|$tcltest script" r] + set l [gets $f] + close $f + set l +} {file1 file2} + +# Test output on channels. The functions tested are Tcl_Write +# and Tcl_Flush. + +test io-7.1 {Tcl_Write, channel not writable} { + list [catch {puts stdin hello} msg] $msg +} {1 {channel "stdin" wasn't opened for writing}} +test io-7.2 {Tcl_Write, empty string} { + removeFile test1 + set f [open test1 w] + fconfigure $f -eofchar {} + puts -nonewline $f "" + close $f + file size test1 +} 0 +test io-7.3 {Tcl_Write, nonempty string} { + removeFile test1 + set f [open test1 w] + fconfigure $f -eofchar {} + puts -nonewline $f hello + close $f + file size test1 +} 5 +test io-7.4 {Tcl_Write, buffering in full buffering mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -buffering full -eofchar {} + puts $f hello + set l "" + lappend l [testchannel outputbuffered $f] + lappend l [file size test1] + flush $f + lappend l [testchannel outputbuffered $f] + lappend l [file size test1] + close $f + set l +} {6 0 0 6} +test io-7.5 {Tcl_Write, buffering in line buffering mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -buffering line -eofchar {} + puts -nonewline $f hello + set l "" + lappend l [testchannel outputbuffered $f] + lappend l [file size test1] + puts $f hello + lappend l [testchannel outputbuffered $f] + lappend l [file size test1] + close $f + set l +} {5 0 0 11} +test io-7.6 {Tcl_Write, buffering in no buffering mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -buffering none -eofchar {} + puts -nonewline $f hello + set l "" + lappend l [testchannel outputbuffered $f] + lappend l [file size test1] + puts $f hello + lappend l [testchannel outputbuffered $f] + lappend l [file size test1] + close $f + set l +} {0 5 0 11} +test io-7.7 {Tcl_Flush, full buffering} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -buffering full -eofchar {} + puts -nonewline $f hello + set l "" + lappend l [testchannel outputbuffered $f] + lappend l [file size test1] + puts $f hello + lappend l [testchannel outputbuffered $f] + lappend l [file size test1] + flush $f + lappend l [testchannel outputbuffered $f] + lappend l [file size test1] + close $f + set l +} {5 0 11 0 0 11} +test io-7.8 {Tcl_Flush, full buffering} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -buffering line + puts -nonewline $f hello + set l "" + lappend l [testchannel outputbuffered $f] + lappend l [file size test1] + flush $f + lappend l [testchannel outputbuffered $f] + lappend l [file size test1] + puts $f hello + lappend l [testchannel outputbuffered $f] + lappend l [file size test1] + flush $f + lappend l [testchannel outputbuffered $f] + lappend l [file size test1] + close $f + set l +} {5 0 0 5 0 11 0 11} +test io-7.9 {Tcl_Flush, channel not writable} { + list [catch {flush stdin} msg] $msg +} {1 {channel "stdin" wasn't opened for writing}} +test io-7.10 {Tcl_Write, looping and buffering} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -eofchar {} + set f2 [open longfile r] + for {set x 0} {$x < 10} {incr x} { + puts $f1 [gets $f2] + } + close $f2 + close $f1 + file size test1 +} 387 +test io-7.11 {Tcl_Write, no newline, implicit flush} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -eofchar {} + set f2 [open longfile r] + for {set x 0} {$x < 10} {incr x} { + puts -nonewline $f1 [gets $f2] + } + close $f1 + close $f2 + file size test1 +} 377 +test io-7.12 {Tcl_Write on a pipe} {unixOrPc} { + removeFile test1 + removeFile pipe + set f1 [open pipe w] + puts $f1 { + set f1 [open longfile r] + for {set x 0} {$x < 10} {incr x} { + puts [gets $f1] + } + } + close $f1 + set f1 [open "|$tcltest pipe" r] + set f2 [open longfile r] + set y ok + for {set x 0} {$x < 10} {incr x} { + set l1 [gets $f1] + set l2 [gets $f2] + if {"$l1" != "$l2"} { + set y broken + } + } + close $f1 + close $f2 + set y +} ok +test io-7.13 {Tcl_Write to a pipe, line buffered} {unixOrPc} { + removeFile test1 + removeFile pipe + set f1 [open pipe w] + puts $f1 { + puts [gets stdin] + puts [gets stdin] + } + close $f1 + set y ok + set f1 [open "|$tcltest pipe" r+] + fconfigure $f1 -buffering line + set f2 [open longfile r] + set line [gets $f2] + puts $f1 $line + set backline [gets $f1] + if {"$line" != "$backline"} { + set y broken + } + set line [gets $f2] + puts $f1 $line + set backline [gets $f1] + if {"$line" != "$backline"} { + set y broken + } + close $f1 + close $f2 + set y +} ok +test io-7.14 {Tcl_Write, buffering and implicit flush at close} { + removeFile test3 + set f [open test3 w] + puts -nonewline $f "Text1" + puts -nonewline $f " Text 2" + puts $f " Text 3" + close $f + set f [open test3 r] + set x [gets $f] + close $f + set x +} {Text1 Text 2 Text 3} +test io-7.15 {Tcl_Flush, channel not open for writing} { + removeFile test1 + set fd [open test1 w] + close $fd + set fd [open test1 r] + set x [list [catch {flush $fd} msg] $msg] + close $fd + string compare $x \ + [list 1 "channel \"$fd\" wasn't opened for writing"] +} 0 +test io-7.16 {Tcl_Flush on pipe opened only for reading} {unixOrPc unixExecs} { + set fd [open "|cat longfile" r] + set x [list [catch {flush $fd} msg] $msg] + catch {close $fd} + string compare $x \ + [list 1 "channel \"$fd\" wasn't opened for writing"] +} 0 +test io-7.17 {Tcl_Write buffers, then Tcl_Flush flushes} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf + puts $f1 hello + puts $f1 hello + puts $f1 hello + flush $f1 + set x [file size test1] + close $f1 + set x +} 18 +test io-7.18 {Tcl_Write and Tcl_Flush intermixed} { + removeFile test1 + set x "" + set f1 [open test1 w] + fconfigure $f1 -translation lf + puts $f1 hello + puts $f1 hello + puts $f1 hello + flush $f1 + lappend x [file size test1] + puts $f1 hello + flush $f1 + lappend x [file size test1] + puts $f1 hello + flush $f1 + lappend x [file size test1] + close $f1 + set x +} {18 24 30} +test io-7.19 {Explicit and implicit flushes} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -eofchar {} + set x "" + puts $f1 hello + puts $f1 hello + puts $f1 hello + flush $f1 + lappend x [file size test1] + puts $f1 hello + flush $f1 + lappend x [file size test1] + puts $f1 hello + close $f1 + lappend x [file size test1] + set x +} {18 24 30} +test io-7.20 {Implicit flush when buffer is full} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -eofchar {} + set line "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" + for {set x 0} {$x < 100} {incr x} { + puts $f1 $line + } + set z "" + lappend z [file size test1] + for {set x 0} {$x < 100} {incr x} { + puts $f1 $line + } + lappend z [file size test1] + close $f1 + lappend z [file size test1] + set z +} {4096 12288 12600} +test io-7.21 {Tcl_Flush to pipe} {unixOrPc} { + removeFile pipe + set f1 [open pipe w] + puts $f1 {set x [read stdin 6]} + puts $f1 {set cnt [string length $x]} + puts $f1 {puts "read $cnt characters"} + close $f1 + set f1 [open "|$tcltest pipe" r+] + puts $f1 hello + flush $f1 + set x [gets $f1] + catch {close $f1} + set x +} "read 6 characters" +test io-7.22 {Tcl_Flush called at other end of pipe} {unixOrPc} { + removeFile pipe + set f1 [open pipe w] + puts $f1 { + fconfigure stdout -buffering full + puts hello + puts hello + flush stdout + gets stdin + puts bye + flush stdout + } + close $f1 + set f1 [open "|$tcltest pipe" r+] + set x "" + lappend x [gets $f1] + lappend x [gets $f1] + puts $f1 hello + flush $f1 + lappend x [gets $f1] + close $f1 + set x +} {hello hello bye} +test io-7.23 {Tcl_Flush and line buffering at end of pipe} {unixOrPc} { + removeFile pipe + set f1 [open pipe w] + puts $f1 { + puts hello + puts hello + gets stdin + puts bye + } + close $f1 + set f1 [open "|$tcltest pipe" r+] + set x "" + lappend x [gets $f1] + lappend x [gets $f1] + puts $f1 hello + flush $f1 + lappend x [gets $f1] + close $f1 + set x +} {hello hello bye} +test io-7.24 {Tcl_Write and Tcl_Flush move end of file} { + 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 io-7.25 {Implicit flush with Tcl_Flush to command pipelines} {unixOrPc unixExecs} { + removeFile test3 + set f [open "| cat | cat > test3" w] + puts $f "Line 1" + puts $f "Line 2" + close $f + after 100 + set f [open test3 r] + set x [read $f] + close $f + set x +} {Line 1 +Line 2 +} +test io-7.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {unixOrPc unixExecs} { + set f [open "| cat -u" r+] + puts $f "Line1" + flush $f + set x [gets $f] + close $f + set x +} {Line1} +test io-7.27 {Tcl_Flush on closed pipeline} {unixOrPc tempNotPc} { + removeFile pipe + set f [open pipe w] + puts $f {exit} + close $f + set f [open "|$tcltest pipe" r+] + gets $f + puts $f output + after 50 + # + # The flush below will get a SIGPIPE. This is an expected part of + # test and indicates that the test operates correctly. If you run + # this test under a debugger, the signal will by intercepted unless + # you disable the debugger's signal interception. + # + if {[catch {flush $f} msg]} { + set x [list 1 $msg $errorCode] + catch {close $f} + } else { + if {[catch {close $f} msg]} { + set x [list 1 $msg $errorCode] + } else { + set x {this was supposed to fail and did not} + } + } + regsub {".*":} $x {"":} x + string tolower $x +} {1 {error flushing "": broken pipe} {posix epipe {broken pipe}}} +test io-7.28 {Tcl_Write, lf mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -eofchar {} + puts $f hello\nthere\nand\nhere + flush $f + set s [file size test1] + close $f + set s +} 21 +test io-7.29 {Tcl_Write, cr mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr -eofchar {} + puts $f hello\nthere\nand\nhere + close $f + file size test1 +} 21 +test io-7.30 {Tcl_Write, crlf mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf -eofchar {} + puts $f hello\nthere\nand\nhere + close $f + file size test1 +} 25 +test io-7.31 {Tcl_Write, background flush} {unixOrPc} { + removeFile pipe + removeFile output + set f [open pipe w] + puts $f {set f [open output w]} + puts $f {fconfigure $f -translation lf} + set x [list while {![eof stdin]}] + set x "$x {" + puts $f $x + puts $f { puts -nonewline $f [read stdin 4096]} + puts $f { flush $f} + puts $f "}" + puts $f {close $f} + close $f + set x 01234567890123456789012345678901 + for {set i 0} {$i < 11} {incr i} { + set x "$x$x" + } + set f [open output w] + close $f + set f [open "|$tcltest pipe" r+] + fconfigure $f -blocking off + puts -nonewline $f $x + close $f + set counter 0 + while {([file size output] < 65536) && ($counter < 1000)} { + incr counter + after 5 + update + } + if {$counter == 1000} { + set result probably_broken + } else { + set result ok + } +} ok +test io-7.32 {Tcl_Write, background flush to slow reader} {unixOrPc asyncPipeClose} { + removeFile pipe + removeFile output + set f [open pipe w] + puts $f {set f [open output w]} + puts $f {fconfigure $f -translation lf} + set x [list while {![eof stdin]}] + set x "$x {" + puts $f $x + puts $f { after 20} + puts $f { puts -nonewline $f [read stdin 1024]} + puts $f { flush $f} + puts $f "}" + puts $f {close $f} + close $f + set x 01234567890123456789012345678901 + for {set i 0} {$i < 11} {incr i} { + set x "$x$x" + } + set f [open output w] + close $f + set f [open "|$tcltest pipe" r+] + fconfigure $f -blocking off + puts -nonewline $f $x + close $f + set counter 0 + while {([file size output] < 65536) && ($counter < 1000)} { + incr counter + after 20 + update + } + if {$counter == 1000} { + set result probably_broken + } else { + set result ok + } +} ok +test io-7.33 {Tcl_Flush, implicit flush on exit} {unixOrPc} { + set f [open script w] + puts $f { + set f [open test1 w] + fconfigure $f -translation lf + puts $f hello + puts $f bye + puts $f strange + } + close $f + eval exec $tcltest script + set f [open test1 r] + set r [read $f] + close $f + set r +} {hello +bye +strange +} +test io-7.34 {Tcl_Close, async flush on close, using sockets} { + set c 0 + set x running + set l abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz + proc writelots {s l} { + for {set i 0} {$i < 2000} {incr i} { + puts $s $l + } + } + proc accept {s a p} { + global x + fileevent $s readable [list readit $s] + fconfigure $s -blocking off + set x accepted + } + proc readit {s} { + global c x + set l [gets $s] + + if {[eof $s]} { + close $s + set x done + } elseif {([string length $l] > 0) || ![fblocked $s]} { + incr c + } + } + set ss [socket -server accept 2828] + set cs [socket [info hostname] 2828] + vwait x + fconfigure $cs -blocking off + writelots $cs $l + close $cs + close $ss + vwait x + set c +} 2000 +test io-7.35 {Tcl_Close vs fileevent vs multiple interpreters} { + catch {interp delete x} + catch {interp delete y} + interp create x + interp create y + set s [socket -server accept 2828] + proc accept {s a p} { + puts $s hello + close $s + } + set c [socket [info hostname] 2828] + interp share {} $c x + interp share {} $c y + close $c + x eval { + proc readit {s} { + gets $s + if {[eof $s]} { + close $s + } + } + } + y eval { + proc readit {s} { + gets $s + if {[eof $s]} { + close $s + } + } + } + x eval "fileevent $c readable \{readit $c\}" + y eval "fileevent $c readable \{readit $c\}" + y eval [list close $c] + update + close $s + interp delete x + interp delete y +} "" + +# Test end of line translations. Procedures tested are Tcl_Write, Tcl_Read. + +test io-8.1 {Tcl_Write lf, Tcl_Read lf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation lf + set x [read $f] + close $f + set x +} "hello\nthere\nand\nhere\n" +test io-8.2 {Tcl_Write lf, Tcl_Read cr} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation cr + set x [read $f] + close $f + set x +} "hello\nthere\nand\nhere\n" +test io-8.3 {Tcl_Write lf, Tcl_Read crlf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation crlf + set x [read $f] + close $f + set x +} "hello\nthere\nand\nhere\n" +test io-8.4 {Tcl_Write cr, Tcl_Read cr} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation cr + set x [read $f] + close $f + set x +} "hello\nthere\nand\nhere\n" +test io-8.5 {Tcl_Write cr, Tcl_Read lf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation lf + set x [read $f] + close $f + set x +} "hello\rthere\rand\rhere\r" +test io-8.6 {Tcl_Write cr, Tcl_Read crlf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation crlf + set x [read $f] + close $f + set x +} "hello\rthere\rand\rhere\r" +test io-8.7 {Tcl_Write crlf, Tcl_Read crlf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation crlf + set x [read $f] + close $f + set x +} "hello\nthere\nand\nhere\n" +test io-8.8 {Tcl_Write crlf, Tcl_Read lf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation lf + set x [read $f] + close $f + set x +} "hello\r\nthere\r\nand\r\nhere\r\n" +test io-8.9 {Tcl_Write crlf, Tcl_Read cr} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation cr + set x [read $f] + close $f + set x +} "hello\n\nthere\n\nand\n\nhere\n\n" +test io-8.10 {Tcl_Write lf, Tcl_Read auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + set c [read $f] + set x [fconfigure $f -translation] + close $f + list $c $x +} {{hello +there +and +here +} auto} +test io-8.11 {Tcl_Write cr, Tcl_Read auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + set c [read $f] + set x [fconfigure $f -translation] + close $f + list $c $x +} {{hello +there +and +here +} auto} +test io-8.12 {Tcl_Write crlf, Tcl_Read auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + set c [read $f] + set x [fconfigure $f -translation] + close $f + list $c $x +} {{hello +there +and +here +} auto} + +test io-8.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + set line "123456789ABCDE" ;# 14 char plus crlf + puts -nonewline $f x ;# shift crlf across block boundary + for {set i 0} {$i < 700} {incr i} { + puts $f $line + } + close $f + set f [open test1 r] + fconfigure $f -translation auto + set c [read $f] + close $f + string length $c +} [expr 700*15+1] + +test io-8.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + set line "123456789ABCDE" ;# 14 char plus crlf + puts -nonewline $f x ;# shift crlf across block boundary + for {set i 0} {$i < 700} {incr i} { + puts $f $line + } + close $f + set f [open test1 r] + fconfigure $f -translation crlf + set c [read $f] + close $f + string length $c +} [expr 700*15+1] + +test io-8.15 {Tcl_Write mixed, Tcl_Read auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts $f hello\nthere\nand\rhere + close $f + set f [open test1 r] + fconfigure $f -translation auto + set c [read $f] + close $f + set c +} {hello +there +and +here +} +test io-8.16 {Tcl_Write ^Z at end, Tcl_Read auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f hello\nthere\nand\rhere\n\x1a + close $f + set f [open test1 r] + fconfigure $f -eofchar \x1a -translation auto + set c [read $f] + close $f + set c +} {hello +there +and +here +} +test io-8.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} {pcOnly} { + removeFile test1 + set f [open test1 w] + fconfigure $f -eofchar \x1a -translation lf + puts $f hello\nthere\nand\rhere + close $f + set f [open test1 r] + fconfigure $f -eofchar \x1a -translation auto + set c [read $f] + close $f + set c +} {hello +there +and +here +} +test io-8.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + set s [format "abc\ndef\n%cghi\nqrs" 26] + puts $f $s + close $f + set f [open test1 r] + fconfigure $f -eofchar \x1a -translation auto + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {abc def 0 {} 1 {} 1} +test io-8.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + set s [format "abc\ndef\n%cghi\nqrs" 26] + puts $f $s + close $f + set f [open test1 r] + fconfigure $f -eofchar \x1a -translation auto + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {abc def 0 {} 1 {} 1} +test io-8.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -eofchar {} + set s [format "abc\ndef\n%cghi\nqrs" 26] + puts $f $s + close $f + set f [open test1 r] + fconfigure $f -translation lf -eofchar {} + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} "abc def 0 \x1aghi 0 qrs 0 {} 1" +test io-8.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -eofchar {} + set s [format "abc\ndef\n%cghi\nqrs" 26] + puts $f $s + close $f + set f [open test1 r] + fconfigure $f -translation cr -eofchar {} + set l "" + set x [gets $f] + lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs"] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {0 1 {} 1} +test io-8.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -eofchar {} + set s [format "abc\ndef\n%cghi\nqrs" 26] + puts $f $s + close $f + set f [open test1 r] + fconfigure $f -translation crlf -eofchar {} + set l "" + set x [gets $f] + lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs"] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {0 1 {} 1} +test io-8.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + set c [format abc\ndef\n%cqrs\ntuv 26] + puts $f $c + close $f + set f [open test1 r] + fconfigure $f -translation auto -eofchar \x1a + set c [string length [read $f]] + set e [eof $f] + close $f + list $c $e +} {8 1} +test io-8.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + set c [format abc\ndef\n%cqrs\ntuv 26] + puts $f $c + close $f + set f [open test1 r] + fconfigure $f -translation lf -eofchar \x1a + set c [string length [read $f]] + set e [eof $f] + close $f + list $c $e +} {8 1} +test io-8.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr + set c [format abc\ndef\n%cqrs\ntuv 26] + puts $f $c + close $f + set f [open test1 r] + fconfigure $f -translation auto -eofchar \x1a + set c [string length [read $f]] + set e [eof $f] + close $f + list $c $e +} {8 1} +test io-8.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr + set c [format abc\ndef\n%cqrs\ntuv 26] + puts $f $c + close $f + set f [open test1 r] + fconfigure $f -translation cr -eofchar \x1a + set c [string length [read $f]] + set e [eof $f] + close $f + list $c $e +} {8 1} +test io-8.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + set c [format abc\ndef\n%cqrs\ntuv 26] + puts $f $c + close $f + set f [open test1 r] + fconfigure $f -translation auto -eofchar \x1a + set c [string length [read $f]] + set e [eof $f] + close $f + list $c $e +} {8 1} +test io-8.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + set c [format abc\ndef\n%cqrs\ntuv 26] + puts $f $c + close $f + set f [open test1 r] + fconfigure $f -translation crlf -eofchar \x1a + set c [string length [read $f]] + set e [eof $f] + close $f + list $c $e +} {8 1} + +# Test end of line translations. Functions tested are Tcl_Write and Tcl_Gets. + +test io-9.1 {Tcl_Write lf, Tcl_Gets auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + set l "" + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + close $f + set l +} {hello 6 auto there 12 auto} +test io-9.2 {Tcl_Write cr, Tcl_Gets auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + set l "" + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + close $f + set l +} {hello 6 auto there 12 auto} +test io-9.3 {Tcl_Write crlf, Tcl_Gets auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + set l "" + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + close $f + set l +} {hello 7 auto there 14 auto} +test io-9.4 {Tcl_Write lf, Tcl_Gets lf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation lf + set l "" + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + close $f + set l +} {hello 6 lf there 12 lf} +test io-9.5 {Tcl_Write lf, Tcl_Gets cr} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation cr + set l "" + lappend l [string length [gets $f]] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + close $f + set l +} {20 21 cr 1 {} 21 cr 1} +test io-9.6 {Tcl_Write lf, Tcl_Gets crlf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation crlf + set l "" + lappend l [string length [gets $f]] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + close $f + set l +} {20 21 crlf 1 {} 21 crlf 1} +test io-9.7 {Tcl_Write cr, Tcl_Gets cr} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation cr + set l "" + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + close $f + set l +} {hello 6 cr 0 there 12 cr 0} +test io-9.8 {Tcl_Write cr, Tcl_Gets lf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation lf + set l "" + lappend l [string length [gets $f]] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + close $f + set l +} {21 21 lf 1 {} 21 lf 1} +test io-9.9 {Tcl_Write cr, Tcl_Gets crlf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation crlf + set l "" + lappend l [string length [gets $f]] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + close $f + set l +} {21 21 crlf 1 {} 21 crlf 1} +test io-9.10 {Tcl_Write crlf, Tcl_Gets crlf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation crlf + set l "" + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + close $f + set l +} {hello 7 crlf 0 there 14 crlf 0} +test io-9.11 {Tcl_Write crlf, Tcl_Gets cr} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation cr + set l "" + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + lappend l [string length [gets $f]] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + close $f + set l +} {hello 6 cr 0 6 13 cr 0} +test io-9.12 {Tcl_Write crlf, Tcl_Gets lf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation lf + set l "" + lappend l [string length [gets $f]] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + lappend l [string length [gets $f]] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + close $f + set l +} {6 7 lf 0 6 14 lf 0} +test io-9.13 {binary mode is synonym of lf mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation binary + set x [fconfigure $f -translation] + close $f + set x +} lf +# +# Test io-9.14 has been removed because "auto" output translation mode is +# not supoprted. +# +test io-9.15 {Tcl_Write mixed, Tcl_Gets auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts $f hello\nthere\rand\r\nhere + close $f + set f [open test1 r] + fconfigure $f -translation auto + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {hello there and here 0 {} 1} +test io-9.16 {Tcl_Write mixed, Tcl_Gets auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f hello\nthere\rand\r\nhere\r + close $f + set f [open test1 r] + fconfigure $f -translation auto + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {hello there and here 0 {} 1} +test io-9.17 {Tcl_Write mixed, Tcl_Gets auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f hello\nthere\rand\r\nhere\n + close $f + set f [open test1 r] + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {hello there and here 0 {} 1} +test io-9.18 {Tcl_Write mixed, Tcl_Gets auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f hello\nthere\rand\r\nhere\r\n + close $f + set f [open test1 r] + fconfigure $f -translation auto + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {hello there and here 0 {} 1} +test io-9.19 {Tcl_Write ^Z at end, Tcl_Gets auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + set s [format "hello\nthere\nand\rhere\n\%c" 26] + puts $f $s + close $f + set f [open test1 r] + fconfigure $f -eofchar \x1a -translation auto + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {hello there and here 0 {} 1} +test io-9.20 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -eofchar \x1a -translation lf + puts $f hello\nthere\nand\rhere + close $f + set f [open test1 r] + fconfigure $f -eofchar \x1a -translation auto + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {hello there and here 0 {} 1} +test io-9.21 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + set s [format "abc\ndef\n%cqrs\ntuv" 26] + puts $f $s + close $f + set f [open test1 r] + fconfigure $f -eofchar \x1a + fconfigure $f -translation auto + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {abc def 0 {} 1} +test io-9.22 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + set s [format "abc\ndef\n%cqrs\ntuv" 26] + puts $f $s + close $f + set f [open test1 r] + fconfigure $f -eofchar \x1a -translation auto + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {abc def 0 {} 1} +test io-9.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -eofchar {} + set s [format "abc\ndef\n%cqrs\ntuv" 26] + puts $f $s + close $f + set f [open test1 r] + fconfigure $f -translation lf -eofchar {} + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} "abc def 0 \x1aqrs 0 tuv 0 {} 1" +test io-9.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr -eofchar {} + set s [format "abc\ndef\n%cqrs\ntuv" 26] + puts $f $s + close $f + set f [open test1 r] + fconfigure $f -translation cr -eofchar {} + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} "abc def 0 \x1aqrs 0 tuv 0 {} 1" +test io-9.25 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf -eofchar {} + set s [format "abc\ndef\n%cqrs\ntuv" 26] + puts $f $s + close $f + set f [open test1 r] + fconfigure $f -translation crlf -eofchar {} + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} "abc def 0 \x1aqrs 0 tuv 0 {} 1" +test io-9.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + set s [format "abc\ndef\n%cqrs\ntuv" 26] + puts $f $s + close $f + set f [open test1 r] + fconfigure $f -translation auto -eofchar \x1a + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {abc def 0 {} 1} +test io-9.27 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + set s [format "abc\ndef\n%cqrs\ntuv" 26] + puts $f $s + close $f + set f [open test1 r] + fconfigure $f -translation lf -eofchar \x1a + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {abc def 0 {} 1} +test io-9.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr -eofchar {} + set s [format "abc\ndef\n%cqrs\ntuv" 26] + puts $f $s + close $f + set f [open test1 r] + fconfigure $f -translation auto -eofchar \x1a + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {abc def 0 {} 1} +test io-9.29 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr -eofchar {} + set s [format "abc\ndef\n%cqrs\ntuv" 26] + puts $f $s + close $f + set f [open test1 r] + fconfigure $f -translation cr -eofchar \x1a + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {abc def 0 {} 1} +test io-9.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf -eofchar {} + set s [format "abc\ndef\n%cqrs\ntuv" 26] + puts $f $s + close $f + set f [open test1 r] + fconfigure $f -translation auto -eofchar \x1a + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {abc def 0 {} 1} +test io-9.31 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf -eofchar {} + set s [format "abc\ndef\n%cqrs\ntuv" 26] + puts $f $s + close $f + set f [open test1 r] + fconfigure $f -translation crlf -eofchar \x1a + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {abc def 0 {} 1} +test io-9.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + set line "123456789ABCDE" ;# 14 char plus crlf + puts -nonewline $f x ;# shift crlf across block boundary + for {set i 0} {$i < 700} {incr i} { + puts $f $line + } + close $f + set f [open test1 r] + fconfigure $f -translation auto + set c "" + while {[gets $f line] >= 0} { + append c $line\n + } + close $f + string length $c +} [expr 700*15+1] +test io-9.33 {Tcl_Write crlf on block boundary, Tcl_Gets auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + set line "123456789ABCDE" ;# 14 char plus crlf + puts -nonewline $f x ;# shift crlf across block boundary + for {set i 0} {$i < 256} {incr i} { + puts $f $line + } + close $f + set f [open test1 r] + fconfigure $f -translation auto + set c "" + while {[gets $f line] >= 0} { + append c $line\n + } + close $f + string length $c +} [expr 256*15+1] + + +# Test Tcl_Read and buffering. + +test io-10.1 {Tcl_Read, channel not readable} { + list [catch {read stdout} msg] $msg +} {1 {channel "stdout" wasn't opened for reading}} +test io-10.2 {Tcl_Read, zero byte count} { + read stdin 0 +} "" +test io-10.3 {Tcl_Read, negative byte count} { + set f [open longfile r] + set l [list [catch {read $f -1} msg] $msg] + close $f + set l +} {1 {bad argument "-1": should be "nonewline"}} +test io-10.4 {Tcl_Read, positive byte count} { + set f [open longfile r] + set x [read $f 1024] + set s [string length $x] + unset x + close $f + set s +} 1024 +test io-10.5 {Tcl_Read, multiple buffers} { + set f [open longfile r] + fconfigure $f -buffersize 100 + set x [read $f 1024] + set s [string length $x] + unset x + close $f + set s +} 1024 +test io-10.6 {Tcl_Read, very large read} { + set f1 [open longfile r] + set z [read $f1 1000000] + close $f1 + set l [string length $z] + set x ok + set z [file size longfile] + if {$z != $l} { + set x broken + } + set x +} ok +test io-10.7 {Tcl_Read, nonblocking, file} {nonBlockFiles} { + set f1 [open longfile r] + fconfigure $f1 -blocking off + set z [read $f1 20] + close $f1 + set l [string length $z] + set x ok + if {$l != 20} { + set x broken + } + set x +} ok +test io-10.8 {Tcl_Read, nonblocking, file} {nonBlockFiles} { + set f1 [open longfile r] + fconfigure $f1 -blocking off + set z [read $f1 1000000] + close $f1 + set x ok + set l [string length $z]] + set z [file size longfile]] + if {$z != $l} { + set x broken + } + set x +} ok +test io-10.9 {Tcl_Read, read to end of file} { + set f1 [open longfile r] + set z [read $f1] + close $f1 + set l [string length $z] + set x ok + set z [file size longfile] + if {$z != $l} { + set x broken + } + set x +} ok +test io-10.10 {Tcl_Read from a pipe} {unixOrPc} { + removeFile pipe + set f1 [open pipe w] + puts $f1 {puts [gets stdin]} + close $f1 + set f1 [open "|$tcltest pipe" r+] + puts $f1 hello + flush $f1 + set x [read $f1] + close $f1 + set x +} "hello\n" +test io-10.11 {Tcl_Read from a pipe} {unixOrPc} { + removeFile pipe + set f1 [open pipe w] + puts $f1 {puts [gets stdin]} + puts $f1 {puts [gets stdin]} + close $f1 + set f1 [open "|$tcltest pipe" r+] + puts $f1 hello + flush $f1 + set x "" + lappend x [read $f1 6] + puts $f1 hello + flush $f1 + lappend x [read $f1] + close $f1 + set x +} {{hello +} {hello +}} +test io-10.12 {Tcl_Read, -nonewline} { + removeFile test1 + set f1 [open test1 w] + puts $f1 hello + puts $f1 bye + close $f1 + set f1 [open test1 r] + set c [read -nonewline $f1] + close $f1 + set c +} {hello +bye} +test io-10.13 {Tcl_Read, -nonewline} { + removeFile test1 + set f1 [open test1 w] + puts $f1 hello + puts $f1 bye + close $f1 + set f1 [open test1 r] + set c [read -nonewline $f1] + close $f1 + list [string length $c] $c +} {9 {hello +bye}} +test io-10.14 {Tcl_Read, reading in small chunks} { + removeFile test1 + set f [open test1 w] + puts $f "Two lines: this one" + puts $f "and this one" + close $f + 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 io-10.15 {Tcl_Read, asking for more input than available} { + removeFile test1 + set f [open test1 w] + puts $f "Two lines: this one" + puts $f "and this one" + close $f + set f [open test1] + set x [read $f 100] + close $f + set x +} {Two lines: this one +and this one +} +test io-10.16 {Tcl_Read, read to end of file with -nonewline} { + removeFile test1 + set f [open test1 w] + puts $f "Two lines: this one" + puts $f "and this one" + close $f + set f [open test1] + set x [read -nonewline $f] + close $f + set x +} {Two lines: this one +and this one} + +# Test Tcl_Gets. + +test io-11.1 {Tcl_Gets, reading what was written} { + removeFile test1 + set f1 [open test1 w] + set y "first line" + puts $f1 $y + close $f1 + set f1 [open test1 r] + set x [gets $f1] + set z ok + if {"$x" != "$y"} { + set z broken + } + close $f1 + set z +} ok +test io-11.2 {Tcl_Gets into variable} { + set f1 [open longfile r] + set c [gets $f1 x] + set l [string length x] + set z ok + if {$l != $l} { + set z broken + } + close $f1 + set z +} ok +test io-11.3 {Tcl_Gets from pipe} {unixOrPc} { + removeFile pipe + set f1 [open pipe w] + puts $f1 {puts [gets stdin]} + close $f1 + set f1 [open "|$tcltest pipe" r+] + puts $f1 hello + flush $f1 + set x [gets $f1] + close $f1 + set z ok + if {"$x" != "hello"} { + set z broken + } + set z +} ok +test io-11.4 {Tcl_Gets with long line} { + removeFile test3 + 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 + set f [open test3] + set x [gets $f] + close $f + set x +} {abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ} +test io-11.5 {Tcl_Gets with long line} { + set f [open test3] + set x [gets $f y] + close $f + list $x $y +} {260 abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ} +test io-11.6 {Tcl_Gets and end of file} { + removeFile test3 + 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 {}} +test io-11.7 {Tcl_Gets and bad variable} { + set f [open test3 w] + puts $f "Line 1" + puts $f "Line 2" + close $f + 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 io-11.8 {Tcl_Gets, exercising double buffering} { + set f [open test3 w] + fconfigure $f -translation lf -eofchar {} + set x "" + for {set y 0} {$y < 99} {incr y} {set x "a$x"} + for {set y 0} {$y < 100} {incr y} {puts $f $x} + close $f + set f [open test3 r] + fconfigure $f -translation lf + for {set y 0} {$y < 100} {incr y} {gets $f} + close $f + set y +} 100 +test io-11.9 {Tcl_Gets, exercising double buffering} { + set f [open test3 w] + fconfigure $f -translation lf -eofchar {} + set x "" + for {set y 0} {$y < 99} {incr y} {set x "a$x"} + for {set y 0} {$y < 200} {incr y} {puts $f $x} + close $f + set f [open test3 r] + fconfigure $f -translation lf + for {set y 0} {$y < 200} {incr y} {gets $f} + close $f + set y +} 200 +test io-11.10 {Tcl_Gets, exercising double buffering} { + set f [open test3 w] + fconfigure $f -translation lf -eofchar {} + set x "" + for {set y 0} {$y < 99} {incr y} {set x "a$x"} + for {set y 0} {$y < 300} {incr y} {puts $f $x} + close $f + set f [open test3 r] + fconfigure $f -translation lf + for {set y 0} {$y < 300} {incr y} {gets $f} + close $f + set y +} 300 + +# Test Tcl_Seek and Tcl_Tell. + +test io-12.1 {Tcl_Seek to current position at start of file} { + set f1 [open longfile r] + seek $f1 0 current + set c [tell $f1] + close $f1 + set c +} 0 +test io-12.2 {Tcl_Seek to offset from start} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -eofchar {} + puts $f1 "abcdefghijklmnopqrstuvwxyz" + puts $f1 "abcdefghijklmnopqrstuvwxyz" + close $f1 + set f1 [open test1 r] + seek $f1 10 start + set c [tell $f1] + close $f1 + set c +} 10 +test io-12.3 {Tcl_Seek to end of file} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -eofchar {} + puts $f1 "abcdefghijklmnopqrstuvwxyz" + puts $f1 "abcdefghijklmnopqrstuvwxyz" + close $f1 + set f1 [open test1 r] + seek $f1 0 end + set c [tell $f1] + close $f1 + set c +} 54 +test io-12.4 {Tcl_Seek to offset from end of file} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -eofchar {} + puts $f1 "abcdefghijklmnopqrstuvwxyz" + puts $f1 "abcdefghijklmnopqrstuvwxyz" + close $f1 + set f1 [open test1 r] + seek $f1 -10 end + set c [tell $f1] + close $f1 + set c +} 44 +test io-12.5 {Tcl_Seek to offset from current position} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -eofchar {} + puts $f1 "abcdefghijklmnopqrstuvwxyz" + puts $f1 "abcdefghijklmnopqrstuvwxyz" + close $f1 + set f1 [open test1 r] + seek $f1 10 current + seek $f1 10 current + set c [tell $f1] + close $f1 + set c +} 20 +test io-12.6 {Tcl_Seek to offset from end of file} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -eofchar {} + puts $f1 "abcdefghijklmnopqrstuvwxyz" + puts $f1 "abcdefghijklmnopqrstuvwxyz" + close $f1 + set f1 [open test1 r] + seek $f1 -10 end + set c [tell $f1] + set r [read $f1] + close $f1 + list $c $r +} {44 {rstuvwxyz +}} +test io-12.7 {Tcl_Seek to offset from end of file, then to current position} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -eofchar {} + puts $f1 "abcdefghijklmnopqrstuvwxyz" + puts $f1 "abcdefghijklmnopqrstuvwxyz" + close $f1 + set f1 [open test1 r] + seek $f1 -10 end + set c1 [tell $f1] + set r1 [read $f1 5] + seek $f1 0 current + set c2 [tell $f1] + close $f1 + list $c1 $r1 $c2 +} {44 rstuv 49} +test io-12.8 {Tcl_Seek on pipes: not supported} {unixOrPc} { + set f1 [open "|$tcltest" r+] + set x [list [catch {seek $f1 0 current} msg] $msg] + close $f1 + regsub {".*":} $x {"":} x + string tolower $x +} {1 {error during seek on "": invalid argument}} +test io-12.9 {Tcl_Seek, testing buffered input flushing} { + removeFile test3 + set f [open test3 w] + fconfigure $f -eofchar {} + puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + close $f + set f [open test3 RDWR] + 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 io-12.10 {Tcl_Seek testing flushing of buffered input} { + set f [open test3 w] + fconfigure $f -translation lf + puts $f xyz\n123 + close $f + set f [open test3 r+] + fconfigure $f -translation lf + set x [gets $f] + seek $f 0 current + puts $f 456 + close $f + list $x [viewFile test3] +} "xyz {xyz +456}" +test io-12.11 {Tcl_Seek testing flushing of buffered output} { + 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 [viewFile test3] +} "zzy xyzzy" +test io-12.12 {Tcl_Seek testing combination of write, seek back and read} { + set f [open test3 w] + fconfigure $f -translation lf -eofchar {} + puts $f xyz\n123 + close $f + set f [open test3 a+] + fconfigure $f -translation lf -eofchar {} + puts $f xyzzy + flush $f + set x [tell $f] + seek $f -4 cur + set y [gets $f] + close $f + list $x [viewFile test3] $y +} {14 {xyz +123 +xyzzy} zzy} +test io-12.13 {Tcl_Tell at start of file} { + removeFile test1 + set f1 [open test1 w] + set p [tell $f1] + close $f1 + set p +} 0 +test io-12.14 {Tcl_Tell after seek to end of file} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -eofchar {} + puts $f1 "abcdefghijklmnopqrstuvwxyz" + puts $f1 "abcdefghijklmnopqrstuvwxyz" + close $f1 + set f1 [open test1 r] + seek $f1 0 end + set c1 [tell $f1] + close $f1 + set c1 +} 54 +test io-12.15 {Tcl_Tell combined with seeking} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -eofchar {} + puts $f1 "abcdefghijklmnopqrstuvwxyz" + puts $f1 "abcdefghijklmnopqrstuvwxyz" + close $f1 + set f1 [open test1 r] + seek $f1 10 start + set c1 [tell $f1] + seek $f1 10 current + set c2 [tell $f1] + close $f1 + list $c1 $c2 +} {10 20} +test io-12.16 {Tcl_tell on pipe: always -1} {unixOrPc} { + set f1 [open "|$tcltest" r+] + set c [tell $f1] + close $f1 + set c +} -1 +test io-12.17 {Tcl_Tell on pipe: always -1} {unixOrPc} { + set f1 [open "|$tcltest" r+] + puts $f1 {puts hello} + flush $f1 + set c [tell $f1] + gets $f1 + close $f1 + set c +} -1 +test io-12.18 {Tcl_Tell combined with seeking and reading} { + removeFile test2 + set f [open test2 w] + fconfigure $f -translation lf -eofchar {} + puts -nonewline $f "line1\nline2\nline3\nline4\nline5\n" + close $f + set f [open test2] + fconfigure $f -translation lf + 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 io-12.19 {Tcl_Tell combined with opening in append mode} { + set f [open test3 w] + fconfigure $f -translation lf -eofchar {} + puts $f "abcdefghijklmnopqrstuvwxyz" + puts $f "abcdefghijklmnopqrstuvwxyz" + close $f + set f [open test3 a] + set c [tell $f] + close $f + set c +} 54 +test io-12.20 {Tcl_Tell combined with writing} { + set f [open test3 w] + set l "" + seek $f 29 start + lappend l [tell $f] + puts -nonewline $f a + seek $f 39 start + lappend l [tell $f] + puts -nonewline $f a + lappend l [tell $f] + seek $f 407 end + lappend l [tell $f] + close $f + set l +} {29 39 40 447} + +# Test Tcl_Eof + +test io-13.1 {Tcl_Eof} { + removeFile test1 + set f [open test1 w] + puts $f hello + puts $f hello + close $f + 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 io-13.2 {Tcl_Eof with pipe} {unixOrPc} { + removeFile pipe + set f1 [open pipe w] + puts $f1 {gets stdin} + puts $f1 {puts hello} + close $f1 + set f1 [open "|$tcltest pipe" r+] + puts $f1 hello + set x [eof $f1] + flush $f1 + lappend x [eof $f1] + gets $f1 + lappend x [eof $f1] + gets $f1 + lappend x [eof $f1] + close $f1 + set x +} {0 0 0 1} +test io-13.3 {Tcl_Eof with pipe} {unixOrPc} { + removeFile pipe + set f1 [open pipe w] + puts $f1 {gets stdin} + puts $f1 {puts hello} + close $f1 + set f1 [open "|$tcltest pipe" r+] + puts $f1 hello + set x [eof $f1] + flush $f1 + lappend x [eof $f1] + gets $f1 + lappend x [eof $f1] + gets $f1 + lappend x [eof $f1] + gets $f1 + lappend x [eof $f1] + gets $f1 + lappend x [eof $f1] + close $f1 + set x +} {0 0 0 1 1 1} +test io-13.4 {Tcl_Eof, eof detection on nonblocking file} {nonBlockFiles} { + removeFile test1 + set f [open test1 w] + close $f + set f [open test1 r] + fconfigure $f -blocking off + set l "" + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {{} 1} +test io-13.5 {Tcl_Eof, eof detection on nonblocking pipe} {unixOrPc} { + removeFile pipe + set f [open pipe w] + puts $f { + exit + } + close $f + set f [open "|$tcltest pipe" r] + set l "" + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {{} 1} +test io-13.6 {Tcl_Eof, eof char, lf write, auto read} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -eofchar \x1a + puts $f abc\ndef + close $f + set s [file size test1] + set f [open test1 r] + fconfigure $f -translation auto -eofchar \x1a + set l [string length [read $f]] + set e [eof $f] + close $f + list $s $l $e +} {9 8 1} +test io-13.7 {Tcl_Eof, eof char, lf write, lf read} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -eofchar \x1a + puts $f abc\ndef + close $f + set s [file size test1] + set f [open test1 r] + fconfigure $f -translation lf -eofchar \x1a + set l [string length [read $f]] + set e [eof $f] + close $f + list $s $l $e +} {9 8 1} +test io-13.8 {Tcl_Eof, eof char, cr write, auto read} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr -eofchar \x1a + puts $f abc\ndef + close $f + set s [file size test1] + set f [open test1 r] + fconfigure $f -translation auto -eofchar \x1a + set l [string length [read $f]] + set e [eof $f] + close $f + list $s $l $e +} {9 8 1} +test io-13.9 {Tcl_Eof, eof char, cr write, cr read} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr -eofchar \x1a + puts $f abc\ndef + close $f + set s [file size test1] + set f [open test1 r] + fconfigure $f -translation cr -eofchar \x1a + set l [string length [read $f]] + set e [eof $f] + close $f + list $s $l $e +} {9 8 1} +test io-13.10 {Tcl_Eof, eof char, crlf write, auto read} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf -eofchar \x1a + puts $f abc\ndef + close $f + set s [file size test1] + set f [open test1 r] + fconfigure $f -translation auto -eofchar \x1a + set l [string length [read $f]] + set e [eof $f] + close $f + list $s $l $e +} {11 8 1} +test io-13.11 {Tcl_Eof, eof char, crlf write, crlf read} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf -eofchar \x1a + puts $f abc\ndef + close $f + set s [file size test1] + set f [open test1 r] + fconfigure $f -translation crlf -eofchar \x1a + set l [string length [read $f]] + set e [eof $f] + close $f + list $s $l $e +} {11 8 1} +test io-13.12 {Tcl_Eof, eof char in middle, lf write, auto read} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -eofchar {} + set i [format abc\ndef\n%cqrs\nuvw 26] + puts $f $i + close $f + set c [file size test1] + set f [open test1 r] + fconfigure $f -translation auto -eofchar \x1a + set l [string length [read $f]] + set e [eof $f] + close $f + list $c $l $e +} {17 8 1} +test io-13.13 {Tcl_Eof, eof char in middle, lf write, lf read} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -eofchar {} + set i [format abc\ndef\n%cqrs\nuvw 26] + puts $f $i + close $f + set c [file size test1] + set f [open test1 r] + fconfigure $f -translation lf -eofchar \x1a + set l [string length [read $f]] + set e [eof $f] + close $f + list $c $l $e +} {17 8 1} +test io-13.14 {Tcl_Eof, eof char in middle, cr write, auto read} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr -eofchar {} + set i [format abc\ndef\n%cqrs\nuvw 26] + puts $f $i + close $f + set c [file size test1] + set f [open test1 r] + fconfigure $f -translation auto -eofchar \x1a + set l [string length [read $f]] + set e [eof $f] + close $f + list $c $l $e +} {17 8 1} +test io-13.15 {Tcl_Eof, eof char in middle, cr write, cr read} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr -eofchar {} + set i [format abc\ndef\n%cqrs\nuvw 26] + puts $f $i + close $f + set c [file size test1] + set f [open test1 r] + fconfigure $f -translation cr -eofchar \x1a + set l [string length [read $f]] + set e [eof $f] + close $f + list $c $l $e +} {17 8 1} +test io-13.16 {Tcl_Eof, eof char in middle, crlf write, auto read} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf -eofchar {} + set i [format abc\ndef\n%cqrs\nuvw 26] + puts $f $i + close $f + set c [file size test1] + set f [open test1 r] + fconfigure $f -translation auto -eofchar \x1a + set l [string length [read $f]] + set e [eof $f] + close $f + list $c $l $e +} {21 8 1} +test io-13.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf -eofchar {} + set i [format abc\ndef\n%cqrs\nuvw 26] + puts $f $i + close $f + set c [file size test1] + set f [open test1 r] + fconfigure $f -translation crlf -eofchar \x1a + set l [string length [read $f]] + set e [eof $f] + close $f + list $c $l $e +} {21 8 1} + +# Test Tcl_InputBlocked + +test io-14.1 {Tcl_InputBlocked on nonblocking pipe} {unixOrPc tempNotPc} { + set f1 [open "|$tcltest" r+] + puts $f1 {puts hello_from_pipe} + flush $f1 + gets $f1 + fconfigure $f1 -blocking off -buffering full + puts $f1 {puts hello} + set x "" + lappend x [gets $f1] + lappend x [fblocked $f1] + flush $f1 + after 200 + lappend x [gets $f1] + lappend x [fblocked $f1] + lappend x [gets $f1] + lappend x [fblocked $f1] + close $f1 + set x +} {{} 1 hello 0 {} 1} +test io-14.2 {Tcl_InputBlocked on blocking pipe} {unixOrPc tempNotPc} { + set f1 [open "|$tcltest" r+] + fconfigure $f1 -buffering line + puts $f1 {puts hello_from_pipe} + set x "" + lappend x [gets $f1] + lappend x [fblocked $f1] + puts $f1 {exit} + lappend x [gets $f1] + lappend x [fblocked $f1] + lappend x [eof $f1] + close $f1 + set x +} {hello_from_pipe 0 {} 0 1} +test io-14.3 {Tcl_InputBlocked vs files, short read} { + removeFile test1 + set f [open test1 w] + puts $f abcdefghijklmnop + close $f + set f [open test1 r] + set l "" + lappend l [fblocked $f] + lappend l [read $f 3] + lappend l [fblocked $f] + lappend l [read -nonewline $f] + lappend l [fblocked $f] + lappend l [eof $f] + close $f + set l +} {0 abc 0 defghijklmnop 0 1} +test io-14.4 {Tcl_InputBlocked vs files, event driven read} { + proc in {f} { + global l + lappend l [read $f 3] + if {[eof $f]} {lappend l eof; close $f} + } + removeFile test1 + set f [open test1 w] + puts $f abcdefghijklmnop + close $f + set f [open test1 r] + set l "" + fileevent $f readable [list in $f] + update + set l +} {abc def ghi jkl mno {p +} eof} +test io-14.5 {Tcl_InputBlocked vs files, short read, nonblocking} {nonBlockFiles} { + removeFile test1 + set f [open test1 w] + puts $f abcdefghijklmnop + close $f + set f [open test1 r] + fconfigure $f -blocking off + set l "" + lappend l [fblocked $f] + lappend l [read $f 3] + lappend l [fblocked $f] + lappend l [read -nonewline $f] + lappend l [fblocked $f] + lappend l [eof $f] + close $f + set l +} {0 abc 0 defghijklmnop 0 1} +test io-14.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles} { + proc in {f} { + global l + lappend l [read $f 3] + if {[eof $f]} {lappend l eof; close $f} + } + removeFile test1 + set f [open test1 w] + puts $f abcdefghijklmnop + close $f + set f [open test1 r] + fconfigure $f -blocking off + set l "" + fileevent $f readable [list in $f] + update + set l +} {abc def ghi jkl mno {p +} eof} + +# Test Tcl_InputBuffered + +test io-15.1 {Tcl_InputBuffered} { + set f [open longfile r] + fconfigure $f -buffersize 4096 + read $f 3 + set l "" + lappend l [testchannel inputbuffered $f] + lappend l [tell $f] + close $f + set l +} {4093 3} +test io-15.2 {Tcl_InputBuffered, test input flushing on seek} { + set f [open longfile r] + fconfigure $f -buffersize 4096 + read $f 3 + set l "" + lappend l [testchannel inputbuffered $f] + lappend l [tell $f] + seek $f 0 current + lappend l [testchannel inputbuffered $f] + lappend l [tell $f] + close $f + set l +} {4093 3 0 3} + +# Test Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize + +test io-16.1 {Tcl_GetChannelBufferSize, default buffer size} { + set f [open longfile r] + set s [fconfigure $f -buffersize] + close $f + set s +} 4096 +test io-16.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} { + set f [open longfile r] + set l "" + lappend l [fconfigure $f -buffersize] + fconfigure $f -buffersize 10000 + lappend l [fconfigure $f -buffersize] + fconfigure $f -buffersize 1 + lappend l [fconfigure $f -buffersize] + fconfigure $f -buffersize -1 + lappend l [fconfigure $f -buffersize] + fconfigure $f -buffersize 0 + lappend l [fconfigure $f -buffersize] + fconfigure $f -buffersize 100000 + lappend l [fconfigure $f -buffersize] + fconfigure $f -buffersize 10000000 + lappend l [fconfigure $f -buffersize] + close $f + set l +} {4096 10000 4096 4096 4096 100000 4096} + +# Test Tcl_SetChannelOption, Tcl_GetChannelOption + +test io-17.1 {Tcl_GetChannelOption} { + removeFile test1 + set f1 [open test1 w] + set x [fconfigure $f1 -blocking] + close $f1 + set x +} 1 +# +# Test 17.2 was removed. +# +test io-17.3 {Tcl_GetChannelOption} { + removeFile test1 + set f1 [open test1 w] + set x [fconfigure $f1 -buffering] + close $f1 + set x +} full +test io-17.4 {Tcl_GetChannelOption} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -buffering line + set x [fconfigure $f1 -buffering] + close $f1 + set x +} line +test io-17.5 {Tcl_GetChannelOption, Tcl_SetChannelOption} { + removeFile test1 + set f1 [open test1 w] + set l "" + lappend l [fconfigure $f1 -buffering] + fconfigure $f1 -buffering line + lappend l [fconfigure $f1 -buffering] + fconfigure $f1 -buffering none + lappend l [fconfigure $f1 -buffering] + fconfigure $f1 -buffering line + lappend l [fconfigure $f1 -buffering] + fconfigure $f1 -buffering full + lappend l [fconfigure $f1 -buffering] + close $f1 + set l +} {full line none line full} +test io-17.6 {Tcl_GetChannelOption, invariance} { + removeFile test1 + set f1 [open test1 w] + set l "" + lappend l [fconfigure $f1 -buffering] + lappend l [list [catch {fconfigure $f1 -buffering green} msg] $msg] + lappend l [fconfigure $f1 -buffering] + close $f1 + set l +} {full {1 {bad value for -buffering: must be one of full, line, or none}} full} +test io-17.7 {Tcl_SetChannelOption, multiple options} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -buffering line + puts $f1 hello + puts $f1 bye + set x [file size test1] + close $f1 + set x +} 10 +test io-17.8 {Tcl_SetChannelOption, buffering, translation} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf + puts $f1 hello + puts $f1 bye + set x "" + fconfigure $f1 -buffering line + lappend x [file size test1] + puts $f1 really_bye + lappend x [file size test1] + close $f1 + set x +} {0 21} +test io-17.9 {Tcl_SetChannelOption, different buffering options} { + removeFile test1 + set f1 [open test1 w] + set l "" + fconfigure $f1 -translation lf -buffering none -eofchar {} + puts -nonewline $f1 hello + lappend l [file size test1] + puts -nonewline $f1 hello + lappend l [file size test1] + fconfigure $f1 -buffering full + puts -nonewline $f1 hello + lappend l [file size test1] + fconfigure $f1 -buffering none + lappend l [file size test1] + puts -nonewline $f1 hello + lappend l [file size test1] + close $f1 + lappend l [file size test1] + set l +} {5 10 10 10 20 20} +test io-17.10 {Tcl_SetChannelOption, blocking mode} {nonBlockFiles} { + removeFile test1 + set f1 [open test1 w] + close $f1 + set f1 [open test1 r] + set x "" + lappend x [fconfigure $f1 -blocking] + fconfigure $f1 -blocking off + lappend x [fconfigure $f1 -blocking] + lappend x [gets $f1] + lappend x [read $f1 1000] + lappend x [fblocked $f1] + lappend x [eof $f1] + close $f1 + set x +} {1 0 {} {} 0 1} +test io-17.11 {Tcl_SetChannelOption, blocking mode} {unixOrPc tempNotPc} { + removeFile pipe + set f1 [open pipe w] + puts $f1 {gets stdin} + puts $f1 {after 100} + puts $f1 {puts hi} + puts $f1 {gets stdin} + close $f1 + set x "" + set f1 [open "|$tcltest pipe" r+] + fconfigure $f1 -blocking off -buffering line + lappend x [fconfigure $f1 -blocking] + lappend x [gets $f1] + lappend x [fblocked $f1] + puts $f1 hello + lappend x [gets $f1] + lappend x [fblocked $f1] + puts $f1 bye + lappend x [gets $f1] + lappend x [fblocked $f1] + fconfigure $f1 -blocking on + lappend x [fconfigure $f1 -blocking] + lappend x [gets $f1] + lappend x [fblocked $f1] + lappend x [eof $f1] + lappend x [gets $f1] + lappend x [eof $f1] + close $f1 + set x +} {0 {} 1 {} 1 {} 1 1 hi 0 0 {} 1} +test io-17.12 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} { + removeFile test1 + set f [open test1 w] + fconfigure $f -buffersize -10 + set x [fconfigure $f -buffersize] + close $f + set x +} 4096 +test io-17.13 {Tcl_SetChannelOption, Tcl_GetChannelOption buffer size} { + removeFile test1 + set f [open test1 w] + fconfigure $f -buffersize 10000000 + set x [fconfigure $f -buffersize] + close $f + set x +} 4096 +test io-17.14 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} { + removeFile test1 + set f [open test1 w] + fconfigure $f -buffersize 40000 + set x [fconfigure $f -buffersize] + close $f + set x +} 40000 + +test io-18.1 {POSIX open access modes: RDWR} { + removeFile test3 + set f [open test3 w] + puts $f xyzzy + close $f + set f [open test3 RDWR] + puts -nonewline $f "ab" + seek $f 0 current + set x [gets $f] + close $f + set f [open test3 r] + lappend x [gets $f] + close $f + set x +} {zzy abzzy} +test io-18.2 {POSIX open access modes: CREAT} {unixOnly} { + removeFile 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 + set f [open test3 r] + lappend x [gets $f] + close $f + set x +} {0600 {line 1}} +test io-18.3 {POSIX open access modes: CREAT} {unixOnly nonPortable} { + # This test only works if your umask is 2, like ouster's. + removeFile test3 + set f [open test3 {WRONLY CREAT}] + close $f + file stat test3 stats + format "0%o" [expr $stats(mode)&0777] +} 0664 +test io-18.4 {POSIX open access modes: CREAT} { + removeFile test3 + set f [open test3 w] + fconfigure $f -eofchar {} + puts $f xyzzy + close $f + set f [open test3 {WRONLY CREAT}] + fconfigure $f -eofchar {} + puts -nonewline $f "ab" + close $f + set f [open test3 r] + set x [gets $f] + close $f + set x +} abzzy +test io-18.5 {POSIX open access modes: APPEND} { + removeFile test3 + set f [open test3 w] + fconfigure $f -translation lf -eofchar {} + puts $f xyzzy + close $f + set f [open test3 {WRONLY APPEND}] + fconfigure $f -translation lf + puts $f "new line" + seek $f 0 + puts $f "abc" + close $f + set f [open test3 r] + fconfigure $f -translation lf + set x "" + seek $f 6 current + lappend x [gets $f] + lappend x [gets $f] + close $f + set x +} {{new line} abc} +test io-18.6 {POSIX open access modes: EXCL} { + removeFile test3 + set f [open test3 w] + puts $f xyzzy + close $f + 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 io-18.7 {POSIX open access modes: EXCL} {unixExecs} { + removeFile test3 + set f [open test3 {WRONLY CREAT EXCL}] + fconfigure $f -eofchar {} + puts $f "A test line" + close $f + viewFile test3 +} {A test line} +test io-18.8 {POSIX open access modes: TRUNC} { + removeFile test3 + set f [open test3 w] + puts $f xyzzy + close $f + set f [open test3 {WRONLY TRUNC}] + puts $f abc + close $f + set f [open test3 r] + set x [gets $f] + close $f + set x +} abc +test io-18.9 {POSIX open access modes: NONBLOCK} {nonPortable macOrUnix} { + removeFile test3 + set f [open test3 {WRONLY NONBLOCK CREAT}] + puts $f "NONBLOCK test" + close $f + set f [open test3 r] + set x [gets $f] + close $f + set x +} {NONBLOCK test} +test io-18.10 {POSIX open access modes: RDONLY} { + set f [open test1 w] + puts $f "two lines: this one" + puts $f "and this" + close $f + set f [open test1 RDONLY] + set x [list [gets $f] [catch {puts $f Test} msg] $msg] + close $f + string compare [string tolower $x] \ + [list {two lines: this one} 1 \ + [format "channel \"%s\" wasn't opened for writing" $f]] +} 0 +test io-18.11 {POSIX open access modes: RDONLY} {unixExecs} { + removeFile test3 + string tolower [list [catch {open test3 RDONLY} msg] $msg] +} {1 {couldn't open "test3": no such file or directory}} +test io-18.12 {POSIX open access modes: WRONLY} {unixExecs} { + removeFile test3 + string tolower [list [catch {open test3 WRONLY} msg] $msg] +} {1 {couldn't open "test3": no such file or directory}} +test io-18.13 {POSIX open access modes: WRONLY} {unixExecs} { + makeFile xyzzy test3 + set f [open test3 WRONLY] + fconfigure $f -eofchar {} + puts -nonewline $f "ab" + seek $f 0 current + set x [list [catch {gets $f} msg] $msg] + close $f + lappend x [viewFile test3] + string compare [string tolower $x] \ + [list 1 "channel \"$f\" wasn't opened for reading" abzzy] +} 0 +test io-18.14 {POSIX open access modes: RDWR} {unixExecs} { + removeFile test3 + string tolower [list [catch {open test3 RDWR} msg] $msg] +} {1 {couldn't open "test3": no such file or directory}} +test io-18.15 {POSIX open access modes: RDWR} { + makeFile xyzzy test3 + set f [open test3 RDWR] + puts -nonewline $f "ab" + seek $f 0 current + set x [gets $f] + close $f + lappend x [viewFile test3] +} {zzy abzzy} +if {![file exists ~/_test_] && [file writable ~]} { + test io-18.16 {tilde substitution in open} { + set f [open ~/_test_ w] + puts $f "Some text" + close $f + set x [file exists [file join $env(HOME) _test_]] + removeFile [file join $env(HOME) _test_] + set x + } 1 +} +test io-18.17 {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 path}} + +test io-19.1 {Tcl_FileeventCmd: errors} { + list [catch {fileevent foo} msg] $msg +} {1 {wrong # args: must be "fileevent channelId event ?script?}} +test io-19.2 {Tcl_FileeventCmd: errors} { + list [catch {fileevent foo bar baz q} msg] $msg +} {1 {wrong # args: must be "fileevent channelId event ?script?}} +test io-19.3 {Tcl_FileeventCmd: errors} { + list [catch {fileevent gorp readable} msg] $msg +} {1 {can not find channel named "gorp"}} +test io-19.4 {Tcl_FileeventCmd: errors} { + list [catch {fileevent gorp writable} msg] $msg +} {1 {can not find channel named "gorp"}} +test io-19.5 {Tcl_FileeventCmd: errors} { + list [catch {fileevent gorp who-knows} msg] $msg +} {1 {bad event name "who-knows": must be readable or writable}} + +# +# Test fileevent on a file +# + +set f [open foo w+] + +test io-20.1 {Tcl_FileeventCmd: creating, deleting, querying} { + list [fileevent $f readable] [fileevent $f writable] +} {{} {}} +test io-20.2 {Tcl_FileeventCmd: replacing} { + set result {} + fileevent $f r "first script" + lappend result [fileevent $f readable] + fileevent $f r "new script" + lappend result [fileevent $f readable] + fileevent $f r "yet another" + lappend result [fileevent $f readable] + fileevent $f r "" + lappend result [fileevent $f readable] +} {{first script} {new script} {yet another} {}} + +# +# Test fileevent on a pipe +# + +if {($tcl_platform(platform) != "macintosh") && \ + ($testConfig(unixExecs) == 1)} { + +catch {set f2 [open {|cat -u} r+]} +catch {set f3 [open {|cat -u} r+]} + +test io-21.1 {Tcl_FileeventCmd: creating, deleting, querying} { + set result {} + fileevent $f readable "script 1" + lappend result [fileevent $f readable] [fileevent $f writable] + fileevent $f writable "write script" + lappend result [fileevent $f readable] [fileevent $f writable] + fileevent $f readable {} + lappend result [fileevent $f readable] [fileevent $f writable] + fileevent $f writable {} + lappend result [fileevent $f readable] [fileevent $f writable] +} {{script 1} {} {script 1} {write script} {} {write script} {} {}} +test io-21.2 {Tcl_FileeventCmd: deleting when many present} { + set result {} + lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r] + fileevent $f r "read f" + fileevent $f2 r "read f2" + fileevent $f3 r "read f3" + lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r] + fileevent $f2 r {} + lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r] + fileevent $f3 r {} + lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r] + fileevent $f r {} + lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r] +} {{} {} {} {read f} {read f2} {read f3} {read f} {} {read f3} {read f} {} {} {} {} {}} + +test io-22.1 {FileEventProc procedure: normal read event} { + fileevent $f2 readable { + set x [gets $f2]; fileevent $f2 readable {} + } + puts $f2 text; flush $f2 + set x initial + vwait x + set x +} {text} +test io-22.2 {FileEventProc procedure: error in read event} { + proc bgerror args { + global x + set x $args + } + fileevent $f2 readable {error bogus} + puts $f2 text; flush $f2 + set x initial + vwait x + rename bgerror {} + list $x [fileevent $f2 readable] +} {bogus {}} +test io-22.3 {FileEventProc procedure: normal write event} { + fileevent $f2 writable { + lappend x "triggered" + incr count -1 + if {$count <= 0} { + fileevent $f2 writable {} + } + } + set x initial + set count 3 + vwait x + vwait x + vwait x + set x +} {initial triggered triggered triggered} +test io-22.4 {FileEventProc procedure: eror in write event} { + proc bgerror args { + global x + set x $args + } + fileevent $f2 writable {error bad-write} + set x initial + vwait x + rename bgerror {} + list $x [fileevent $f2 writable] +} {bad-write {}} +test io-22.5 {FileEventProc procedure: end of file} {unixOrPc unixExecs} { + set f4 [open {|cat << foo} r] + fileevent $f4 readable { + if {[gets $f4 line] < 0} { + lappend x eof + fileevent $f4 readable {} + } else { + lappend x $line + } + } + set x initial + vwait x + vwait x + close $f4 + set x +} {initial foo eof} + +catch {close $f2} +catch {close $f3} + +} + # Closes if {($platform(platform) != "macintosh") && \ + # ($testConfig(unixExecs) == 1)} clause + +close $f +makeFile "foo bar" foo +test io-23.1 {DeleteFileEvent, cleanup on close} { + set f [open foo r] + fileevent $f readable { + lappend x "binding triggered: \"[gets $f]\"" + fileevent $f readable {} + } + close $f + set x initial + update + set x +} {initial} +test io-23.2 {DeleteFileEvent, cleanup on close} { + set f [open foo r] + set f2 [open foo r] + fileevent $f readable { + lappend x "f triggered: \"[gets $f]\"" + fileevent $f readable {} + } + fileevent $f2 readable { + lappend x "f2 triggered: \"[gets $f2]\"" + fileevent $f2 readable {} + } + close $f + set x initial + vwait x + close $f2 + set x +} {initial {f2 triggered: "foo bar"}} +test io-23.3 {DeleteFileEvent, cleanup on close} { + set f [open foo r] + set f2 [open foo r] + set f3 [open foo r] + fileevent $f readable {f script} + fileevent $f2 readable {f2 script} + fileevent $f3 readable {f3 script} + set x {} + close $f2 + lappend x [catch {fileevent $f readable} msg] $msg \ + [catch {fileevent $f2 readable}] \ + [catch {fileevent $f3 readable} msg] $msg + close $f3 + lappend x [catch {fileevent $f readable} msg] $msg \ + [catch {fileevent $f2 readable}] \ + [catch {fileevent $f3 readable}] + close $f + lappend x [catch {fileevent $f readable}] \ + [catch {fileevent $f2 readable}] \ + [catch {fileevent $f3 readable}] +} {0 {f script} 1 0 {f3 script} 0 {f script} 1 1 1 1 1} + +# Execute these tests only if the "testfevent" command is present. + +if {[info commands testfevent] == "testfevent"} { + +test io-24.1 {Tcl event loop vs multiple interpreters} { + testfevent create + testfevent cmd { + set f [open foo r] + set x "no event" + fileevent $f readable { + set x "f triggered: [gets $f]" + fileevent $f readable {} + } + } + update + testfevent cmd {close $f} + list [testfevent cmd {set x}] [testfevent cmd {info commands after}] +} {{f triggered: foo bar} after} +test io-24.2 {Tcl event loop vs multiple interpreters} { + testfevent create + testfevent cmd { + set x 0 + after 100 {set x triggered} + vwait x + set x + } +} {triggered} +test io-24.3 {Tcl event loop vs multiple interpreters} { + testfevent create + testfevent cmd { + set x 0 + after 10 {lappend x timer} + after 30 + set result $x + update idletasks + lappend result $x + update + lappend result $x + } +} {0 0 {0 timer}} + +test io-25.1 {fileevent vs multiple interpreters} { + set f [open foo r] + set f2 [open foo r] + set f3 [open foo r] + fileevent $f readable {script 1} + testfevent create + testfevent share $f2 + testfevent cmd "fileevent $f2 readable {script 2}" + fileevent $f3 readable {sript 3} + set x {} + lappend x [fileevent $f2 readable] + testfevent delete + lappend x [fileevent $f readable] [fileevent $f2 readable] \ + [fileevent $f3 readable] + close $f + close $f2 + close $f3 + set x +} {{} {script 1} {} {sript 3}} +test io-25.2 {deleting fileevent on interpreter delete} { + set f [open foo r] + set f2 [open foo r] + set f3 [open foo r] + set f4 [open foo r] + fileevent $f readable {script 1} + testfevent create + testfevent share $f2 + testfevent share $f3 + testfevent cmd "fileevent $f2 readable {script 2} + fileevent $f3 readable {script 3}" + fileevent $f4 readable {script 4} + testfevent delete + set x [list [fileevent $f readable] [fileevent $f2 readable] \ + [fileevent $f3 readable] [fileevent $f4 readable]] + close $f + close $f2 + close $f3 + close $f4 + set x +} {{script 1} {} {} {script 4}} +test io-25.3 {deleting fileevent on interpreter delete} { + set f [open foo r] + set f2 [open foo r] + set f3 [open foo r] + set f4 [open foo r] + testfevent create + testfevent share $f3 + testfevent share $f4 + fileevent $f readable {script 1} + fileevent $f2 readable {script 2} + testfevent cmd "fileevent $f3 readable {script 3} + fileevent $f4 readable {script 4}" + testfevent delete + set x [list [fileevent $f readable] [fileevent $f2 readable] \ + [fileevent $f3 readable] [fileevent $f4 readable]] + close $f + close $f2 + close $f3 + close $f4 + set x +} {{script 1} {script 2} {} {}} +test io-25.4 {file events on shared files and multiple interpreters} { + set f [open foo r] + set f2 [open foo r] + testfevent create + testfevent share $f + testfevent cmd "fileevent $f readable {script 1}" + fileevent $f readable {script 2} + fileevent $f2 readable {script 3} + set x [list [fileevent $f2 readable] \ + [testfevent cmd "fileevent $f readable"] \ + [fileevent $f readable]] + testfevent delete + close $f + close $f2 + set x +} {{script 3} {script 1} {script 2}} +test io-25.5 {file events on shared files, deleting file events} { + set f [open foo r] + testfevent create + testfevent share $f + testfevent cmd "fileevent $f readable {script 1}" + fileevent $f readable {script 2} + testfevent cmd "fileevent $f readable {}" + set x [list [testfevent cmd "fileevent $f readable"] \ + [fileevent $f readable]] + testfevent delete + close $f + set x +} {{} {script 2}} +test io-25.6 {file events on shared files, deleting file events} { + set f [open foo r] + testfevent create + testfevent share $f + testfevent cmd "fileevent $f readable {script 1}" + fileevent $f readable {script 2} + fileevent $f readable {} + set x [list [testfevent cmd "fileevent $f readable"] \ + [fileevent $f readable]] + testfevent delete + close $f + set x +} {{script 1} {}} + +} + +# The above curly closes the test for presence of the "testfevent" command. + +test io-26.1 {testing readability conditions} { + set f [open bar w] + puts $f abcdefg + puts $f abcdefg + puts $f abcdefg + puts $f abcdefg + puts $f abcdefg + close $f + set f [open bar r] + fileevent $f readable [list consume $f] + proc consume {f} { + global x l + lappend l called + if {[eof $f]} { + close $f + set x done + } else { + gets $f + } + } + set l "" + set x not_done + vwait x + list $x $l +} {done {called called called called called called called}} +test io-26.2 {testing readability conditions} {nonBlockFiles} { + set f [open bar w] + puts $f abcdefg + puts $f abcdefg + puts $f abcdefg + puts $f abcdefg + puts $f abcdefg + close $f + set f [open bar r] + fileevent $f readable [list consume $f] + fconfigure $f -blocking off + proc consume {f} { + global x l + lappend l called + if {[eof $f]} { + close $f + set x done + } else { + gets $f + } + } + set l "" + set x not_done + vwait x + list $x $l +} {done {called called called called called called called}} +test io-26.3 {testing readability conditions} {unixOnly nonBlockFiles} { + set f [open bar w] + puts $f abcdefg + puts $f abcdefg + puts $f abcdefg + puts $f abcdefg + puts $f abcdefg + close $f + set f [open my_script w] + puts $f { + proc copy_slowly {f} { + while {![eof $f]} { + puts [gets $f] + after 200 + } + close $f + } + } + close $f + set f [open |$tcltest r+] + fileevent $f readable [list consume $f] + fconfigure $f -buffering line + fconfigure $f -blocking off + proc consume {f} { + global x l + if {[eof $f]} { + set x done + } else { + gets $f + lappend l [fblocked $f] + gets $f + lappend l [fblocked $f] + } + } + set l "" + set x not_done + puts $f {source my_script} + puts $f {set f [open bar r]} + puts $f {copy_slowly $f} + puts $f {exit} + vwait x + close $f + list $x $l +} {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}} +test io-26.4 {lf write, testing readability, ^Z termination, auto read mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + set c [format "abc\ndef\n%c" 26] + puts -nonewline $f $c + close $f + proc consume {f} { + global c x l + if {[eof $f]} { + set x done + close $f + } else { + lappend l [gets $f] + incr c + } + } + set c 0 + set l "" + set f [open test1 r] + fconfigure $f -translation auto -eofchar \x1a + fileevent $f readable [list consume $f] + vwait x + list $c $l +} {3 {abc def {}}} +test io-26.5 {lf write, testing readability, ^Z in middle, auto read mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + set c [format "abc\ndef\n%cfoo\nbar\n" 26] + puts -nonewline $f $c + close $f + proc consume {f} { + global c x l + if {[eof $f]} { + set x done + close $f + } else { + lappend l [gets $f] + incr c + } + } + set c 0 + set l "" + set f [open test1 r] + fconfigure $f -eofchar \x1a -translation auto + fileevent $f readable [list consume $f] + vwait x + list $c $l +} {3 {abc def {}}} +test io-26.6 {cr write, testing readability, ^Z termination, auto read mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr + set c [format "abc\ndef\n%c" 26] + puts -nonewline $f $c + close $f + proc consume {f} { + global c x l + if {[eof $f]} { + set x done + close $f + } else { + lappend l [gets $f] + incr c + } + } + set c 0 + set l "" + set f [open test1 r] + fconfigure $f -translation auto -eofchar \x1a + fileevent $f readable [list consume $f] + vwait x + list $c $l +} {3 {abc def {}}} +test io-26.7 {cr write, testing readability, ^Z in middle, auto read mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr + set c [format "abc\ndef\n%cfoo\nbar\n" 26] + puts -nonewline $f $c + close $f + proc consume {f} { + global c x l + if {[eof $f]} { + set x done + close $f + } else { + lappend l [gets $f] + incr c + } + } + set c 0 + set l "" + set f [open test1 r] + fconfigure $f -eofchar \x1a -translation auto + fileevent $f readable [list consume $f] + vwait x + list $c $l +} {3 {abc def {}}} +test io-26.8 {crlf write, testing readability, ^Z termination, auto read mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + set c [format "abc\ndef\n%c" 26] + puts -nonewline $f $c + close $f + proc consume {f} { + global c x l + if {[eof $f]} { + set x done + close $f + } else { + lappend l [gets $f] + incr c + } + } + set c 0 + set l "" + set f [open test1 r] + fconfigure $f -translation auto -eofchar \x1a + fileevent $f readable [list consume $f] + vwait x + list $c $l +} {3 {abc def {}}} +test io-26.9 {crlf write, testing readability, ^Z in middle, auto read mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + set c [format "abc\ndef\n%cfoo\nbar\n" 26] + puts -nonewline $f $c + close $f + proc consume {f} { + global c x l + if {[eof $f]} { + set x done + close $f + } else { + lappend l [gets $f] + incr c + } + } + set c 0 + set l "" + set f [open test1 r] + fconfigure $f -eofchar \x1a -translation auto + fileevent $f readable [list consume $f] + vwait x + list $c $l +} {3 {abc def {}}} +test io-26.10 {lf write, testing readability, ^Z in middle, lf read mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + set c [format "abc\ndef\n%cfoo\nbar\n" 26] + puts -nonewline $f $c + close $f + proc consume {f} { + global c x l + if {[eof $f]} { + set x done + close $f + } else { + lappend l [gets $f] + incr c + } + } + set c 0 + set l "" + set f [open test1 r] + fconfigure $f -eofchar \x1a -translation lf + fileevent $f readable [list consume $f] + vwait x + list $c $l +} {3 {abc def {}}} +test io-26.11 {lf write, testing readability, ^Z termination, lf read mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + set c [format "abc\ndef\n%c" 26] + puts -nonewline $f $c + close $f + proc consume {f} { + global c x l + if {[eof $f]} { + set x done + close $f + } else { + lappend l [gets $f] + incr c + } + } + set c 0 + set l "" + set f [open test1 r] + fconfigure $f -translation lf -eofchar \x1a + fileevent $f readable [list consume $f] + vwait x + list $c $l +} {3 {abc def {}}} +test io-26.12 {cr write, testing readability, ^Z in middle, cr read mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr + set c [format "abc\ndef\n%cfoo\nbar\n" 26] + puts -nonewline $f $c + close $f + proc consume {f} { + global c x l + if {[eof $f]} { + set x done + close $f + } else { + lappend l [gets $f] + incr c + } + } + set c 0 + set l "" + set f [open test1 r] + fconfigure $f -eofchar \x1a -translation cr + fileevent $f readable [list consume $f] + vwait x + list $c $l +} {3 {abc def {}}} +test io-26.13 {cr write, testing readability, ^Z termination, cr read mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr + set c [format "abc\ndef\n%c" 26] + puts -nonewline $f $c + close $f + proc consume {f} { + global c x l + if {[eof $f]} { + set x done + close $f + } else { + lappend l [gets $f] + incr c + } + } + set c 0 + set l "" + set f [open test1 r] + fconfigure $f -translation cr -eofchar \x1a + fileevent $f readable [list consume $f] + vwait x + list $c $l +} {3 {abc def {}}} +test io-26.14 {crlf write, testing readability, ^Z in middle, crlf read mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + set c [format "abc\ndef\n%cfoo\nbar\n" 26] + puts -nonewline $f $c + close $f + proc consume {f} { + global c x l + if {[eof $f]} { + set x done + close $f + } else { + lappend l [gets $f] + incr c + } + } + set c 0 + set l "" + set f [open test1 r] + fconfigure $f -eofchar \x1a -translation crlf + fileevent $f readable [list consume $f] + vwait x + list $c $l +} {3 {abc def {}}} +test io-26.15 {crlf write, testing readability, ^Z termi, crlf read mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + set c [format "abc\ndef\n%c" 26] + puts -nonewline $f $c + close $f + proc consume {f} { + global c x l + if {[eof $f]} { + set x done + close $f + } else { + lappend l [gets $f] + incr c + } + } + set c 0 + set l "" + set f [open test1 r] + fconfigure $f -translation crlf -eofchar \x1a + fileevent $f readable [list consume $f] + vwait x + list $c $l +} {3 {abc def {}}} + +test io-27.1 {testing handler deletion} { + removeFile test1 + set f [open test1 w] + close $f + set f [open test1 r] + testchannelevent $f add readable [list delhandler $f] + proc delhandler {f} { + global z + set z called + testchannelevent $f delete 0 + } + set z not_called + update + close $f + set z +} called +test io-27.2 {testing handler deletion with multiple handlers} { + removeFile test1 + set f [open test1 w] + close $f + set f [open test1 r] + testchannelevent $f add readable [list delhandler $f 1] + testchannelevent $f add readable [list delhandler $f 0] + proc delhandler {f i} { + global z + lappend z "called delhandler $f $i" + testchannelevent $f delete 0 + } + set z "" + update + close $f + string compare [string tolower $z] \ + [list [list called delhandler $f 0] [list called delhandler $f 1]] +} 0 +test io-27.3 {testing handler deletion with multiple handlers} { + removeFile test1 + set f [open test1 w] + close $f + set f [open test1 r] + testchannelevent $f add readable [list notcalled $f 1] + testchannelevent $f add readable [list delhandler $f 0] + set z "" + proc notcalled {f i} { + global z + lappend z "notcalled was called!! $f $i" + } + proc delhandler {f i} { + global z + testchannelevent $f delete 1 + lappend z "delhandler $f $i called" + testchannelevent $f delete 0 + lappend z "delhandler $f $i deleted myself" + } + set z "" + update + close $f + string compare [string tolower $z] \ + [list [list delhandler $f 0 called] \ + [list delhandler $f 0 deleted myself]] +} 0 +test io-27.4 {testing handler deletion vs reentrant calls} { + removeFile test1 + set f [open test1 w] + close $f + set f [open test1 r] + testchannelevent $f add readable [list delrecursive $f] + proc delrecursive {f} { + global z u + if {"$u" == "recursive"} { + testchannelevent $f delete 0 + lappend z "delrecursive deleting recursive" + } else { + lappend z "delrecursive calling recursive" + set u recursive + update + } + } + set u toplevel + set z "" + update + close $f + string compare [string tolower $z] \ + {{delrecursive calling recursive} {delrecursive deleting recursive}} +} 0 +test io-27.5 {testing handler deletion vs reentrant calls} { + removeFile test1 + set f [open test1 w] + close $f + set f [open test1 r] + testchannelevent $f add readable [list notcalled $f] + testchannelevent $f add readable [list del $f] + proc notcalled {f} { + global z + lappend z "notcalled was called!! $f" + } + proc del {f} { + global z u + if {"$u" == "recursive"} { + testchannelevent $f delete 1 + testchannelevent $f delete 0 + lappend z "del deleted notcalled" + lappend z "del deleted myself" + } else { + set u recursive + lappend z "del calling recursive" + update + lappend z "del after update" + } + } + set z "" + set u toplevel + update + close $f + string compare [string tolower $z] \ + [list {del calling recursive} {del deleted notcalled} \ + {del deleted myself} {del after update}] +} 0 +test io-27.6 {testing handler deletion vs reentrant calls} { + removeFile test1 + set f [open test1 w] + close $f + set f [open test1 r] + testchannelevent $f add readable [list second $f] + testchannelevent $f add readable [list first $f] + proc first {f} { + global u z + if {"$u" == "toplevel"} { + lappend z "first called" + set u first + update + lappend z "first after update" + } else { + lappend z "first called not toplevel" + } + } + proc second {f} { + global u z + if {"$u" == "first"} { + lappend z "second called, first time" + set u second + testchannelevent $f delete 0 + } elseif {"$u" == "second"} { + lappend z "second called, second time" + testchannelevent $f delete 0 + } else { + lappend z "second called, cannot happen!" + testchannelevent $f removeall + } + } + set z "" + set u toplevel + update + close $f + string compare [string tolower $z] \ + [list {first called} {first called not toplevel} \ + {second called, first time} {second called, second time} \ + {first after update}] +} 0 + +removeFile longfile +removeFile script +removeFile output +removeFile test1 +removeFile pipe +removeFile my_script +removeFile foo +removeFile bar +removeFile test2 +removeFile test3 + +set x "" +unset x diff --git a/tcl7.6/tests/ioCmd.test b/tcl7.6/tests/ioCmd.test new file mode 100644 index 0000000..80a8f14 --- /dev/null +++ b/tcl7.6/tests/ioCmd.test @@ -0,0 +1,394 @@ +# Commands covered: open, close, gets, read, puts, seek, tell, eof, flush, +# fblocked, fconfigure, open, channel +# +# 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-1994 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# "@(#) ioCmd.test 1.37 96/04/12 11:44:23" + +if {[string compare test [info procs test]] == 1} then {source defs} + +removeFile test1 +removeFile pipe + +set executable [list [info nameofexecutable]] + +#test iocmd-1.0 {copyfile command} { +# list [catch {copyfile a b c d e f} msg] $msg +#} {1 {wrong # args: should be "copyfile inChanId outChanId ?chunkSize?"}} +#test iocmd-1.1 {copyfile command} { +# list [catch {copyfile f1} msg] $msg +#} {1 {wrong # args: should be "copyfile inChanId outChanId ?chunkSize?"}} +#test iocmd-1.2 {copyfile command} { +# list [catch {copyfile f1 f2} msg] $msg +#} {1 {can not find channel named "f1"}} +#test iocmd-1.3 {copyfile command} { +# list [catch {copyfile stdin f2} msg] $msg +#} {1 {can not find channel named "f2"}} +#test iocmd-1.4 {copyfile command} { +# list [catch {copyfile stdin stdout booboo} msg] $msg +#} {1 {expected integer but got "booboo"}} +#test iocmd-1.5 {copyfile command} { +# list [catch {copyfile stdout stdin} msg] $msg +#} {1 {channel "stdout" wasn't opened for reading}} +#test iocmd-1.6 {copyfile command} { +# list [catch {copyfile stdin stdin} msg] $msg +#} {1 {channel "stdin" wasn't opened for writing}} + +test iocmd-2.1 {puts command} { + list [catch {puts} msg] $msg +} {1 {wrong # args: should be "puts ?-nonewline? ?channelId? string"}} +test iocmd-2.2 {puts command} { + list [catch {puts a b c d e f g} msg] $msg +} {1 {wrong # args: should be "puts ?-nonewline? ?channelId? string"}} +test iocmd-2.3 {puts command} { + list [catch {puts froboz -nonewline kablooie} msg] $msg +} {1 {bad argument "kablooie": should be "nonewline"}} +test iocmd-2.4 {puts command} { + list [catch {puts froboz hello} msg] $msg +} {1 {can not find channel named "froboz"}} +test iocmd-2.5 {puts command} { + list [catch {puts stdin hello} msg] $msg +} {1 {channel "stdin" wasn't opened for writing}} + +test iocmd-3.0 {flush command} { + list [catch {flush} msg] $msg +} {1 {wrong # args: should be "flush channelId"}} +test iocmd-3.1 {flush command} { + list [catch {flush a b c d e} msg] $msg +} {1 {wrong # args: should be "flush channelId"}} +test iocmd-3.3 {flush command} { + list [catch {flush foo} msg] $msg +} {1 {can not find channel named "foo"}} +test iocmd-3.4 {flush command} { + list [catch {flush stdin} msg] $msg +} {1 {channel "stdin" wasn't opened for writing}} + +test iocmd-4.0 {gets command} { + list [catch {gets} msg] $msg +} {1 {wrong # args: should be "gets channelId ?varName?"}} +test iocmd-4.1 {gets command} { + list [catch {gets a b c d e f g} msg] $msg +} {1 {wrong # args: should be "gets channelId ?varName?"}} +test iocmd-4.2 {gets command} { + list [catch {gets aaa} msg] $msg +} {1 {can not find channel named "aaa"}} +test iocmd-4.2 {gets command} { + list [catch {gets stdout} msg] $msg +} {1 {channel "stdout" wasn't opened for reading}} + +test iocmd-5.0 {read command} { + list [catch {read} msg] $msg +} {1 {wrong # args: should be "read channelId ?numBytes?" or "read ?-nonewline? channelId"}} +test iocmd-5.1 {read command} { + list [catch {read a b c d e f g h} msg] $msg +} {1 {wrong # args: should be "read channelId ?numBytes?" or "read ?-nonewline? channelId"}} +test iocmd-5.2 {read command} { + list [catch {read aaa} msg] $msg +} {1 {can not find channel named "aaa"}} +test iocmd-5.3 {read command} { + list [catch {read -nonewline} msg] $msg +} {1 {wrong # args: should be "read channelId ?numBytes?" or "read ?-nonewline? channelId"}} +test iocmd-5.4 {read command} { + list [catch {read -nonew file4} msg] $msg $errorCode +} {1 {can not find channel named "-nonew"} NONE} +test iocmd-5.5 {read command} { + list [catch {read stdout} msg] $msg +} {1 {channel "stdout" wasn't opened for reading}} +test iocmd-5.6 {read command} { + list [catch {read -nonewline stdout} msg] $msg +} {1 {channel "stdout" wasn't opened for reading}} +test iocmd-5.23 {read command with incorrect combination of arguments} { + removeFile test1 + set f [open test1 w] + puts $f "Two lines: this one" + puts $f "and this one" + close $f + set f [open test1] + set x [list [catch {read -nonewline $f 20 z} msg] $msg $errorCode] + close $f + set x +} {1 {wrong # args: should be "read channelId ?numBytes?" or "read ?-nonewline? channelId"} NONE} +test iocmd-5.24 {read command} { + list [catch {read stdin foo} msg] $msg $errorCode +} {1 {bad argument "foo": should be "nonewline"} NONE} +test iocmd-5.25 {read command} { + list [catch {read file107} msg] $msg $errorCode +} {1 {can not find channel named "file107"} NONE} +test iocmd-5.26 {read command} { + set f [open test3 w] + set x [list [catch {read $f} msg] $msg $errorCode] + close $f + string compare [string tolower $x] \ + [list 1 [format "channel \"%s\" wasn't opened for reading" $f] none] +} 0 +test iocmd-5.27 {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 iocmd-6.0 {seek command} { + list [catch {seek} msg] $msg +} {1 {wrong # args: should be "seek channelId offset ?origin?"}} +test iocmd-6.1 {seek command} { + list [catch {seek a b c d e f g} msg] $msg +} {1 {wrong # args: should be "seek channelId offset ?origin?"}} +test iocmd-6.2 {seek command} { + list [catch {seek stdin gugu} msg] $msg +} {1 {expected integer but got "gugu"}} +test iocmd-6.3 {seek command} { + list [catch {seek stdin 100 gugu} msg] $msg +} {1 {bad origin "gugu": should be start, current, or end}} + +test iocmd-7.0 {tell command} { + list [catch {tell} msg] $msg +} {1 {wrong # args: should be "tell channelId"}} +test iocmd-7.1 {tell command} { + list [catch {tell a b c d e} msg] $msg +} {1 {wrong # args: should be "tell channelId"}} +test iocmd-7.2 {tell command} { + list [catch {tell aaa} msg] $msg +} {1 {can not find channel named "aaa"}} + +test iocmd-8.0 {close command} { + list [catch {close} msg] $msg +} {1 {wrong # args: should be "close channelId"}} +test iocmd-8.1 {close command} { + list [catch {close a b c d e} msg] $msg +} {1 {wrong # args: should be "close channelId"}} +test iocmd-8.2 {close command} { + list [catch {close aaa} msg] $msg +} {1 {can not find channel named "aaa"}} + +test iocmd-9.0 {fconfigure command} { + list [catch {fconfigure} msg] $msg +} {1 {wrong # args: should be "fconfigure channelId ?optionName? ?value? ?optionName value?..."}} +test iocmd-9.1 {fconfigure command} { + list [catch {fconfigure a b c d e f} msg] $msg +} {1 {wrong # args: should be "fconfigure channelId ?optionName? ?value? ?optionName value?..."}} +test iocmd-9.2 {fconfigure command} { + list [catch {fconfigure a b} msg] $msg +} {1 {can not find channel named "a"}} +test iocmd-9.3 {fconfigure command} { + removeFile test1 + set f1 [open test1 w] + set x [list [catch {fconfigure $f1 froboz} msg] $msg] + close $f1 + set x +} {1 {bad option "froboz": must be -blocking, -buffering, -buffersize, -eofchar, -translation, or a channel type specific option}} +test iocmd-9.4 {fconfigure command} { + list [catch {fconfigure stdin -buffering froboz} msg] $msg +} {1 {bad value for -buffering: must be one of full, line, or none}} +test iocmd-9.4 {fconfigure command} { + list [catch {fconfigure stdin -translation froboz} msg] $msg +} {1 {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform}} +test iocmd-9.5 {fconfigure command} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -eofchar {} + set x [fconfigure $f1] + close $f1 + set x +} {-blocking 1 -buffering full -buffersize 4096 -eofchar {} -translation lf} +test iocmd-9.6 {fconfigure command} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -buffering line -buffersize 3030 \ + -eofchar {} + set x "" + lappend x [fconfigure $f1 -buffering] + lappend x [fconfigure $f1] + close $f1 + set x +} {line {-blocking 1 -buffering line -buffersize 3030 -eofchar {} -translation lf}} +test iocmd-9.7 {fconfigure command} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation binary -buffering none -buffersize 4040 \ + -eofchar {} + set x [fconfigure $f1] + close $f1 + set x +} {-blocking 1 -buffering none -buffersize 4040 -eofchar {} -translation lf} +test iocmd-9.8 {fconfigure command} { + list [catch {fconfigure a b} msg] $msg +} {1 {can not find channel named "a"}} +test iocmd-9.9 {fconfigure command} { + list [catch {fconfigure stdout -froboz blarfo} msg] $msg +} {1 {bad option "-froboz": should be -blocking, -buffering, -buffersize, -eofchar, -translation, or channel type specific option}} +test iocmd-9.10 {fconfigure command} { + list [catch {fconfigure stdout -b blarfo} msg] $msg +} {1 {bad option "-b": should be -blocking, -buffering, -buffersize, -eofchar, -translation, or channel type specific option}} +test iocmd-9.11 {fconfigure command} { + list [catch {fconfigure stdout -buffer blarfo} msg] $msg +} {1 {bad option "-buffer": should be -blocking, -buffering, -buffersize, -eofchar, -translation, or channel type specific option}} +test iocmd-9.12 {fconfigure command} { + fconfigure stdin -buffers +} 4096 + +test iocmd-10.1 {eof command} { + list [catch {eof} msg] $msg $errorCode +} {1 {wrong # args: should be "eof channelId"} NONE} +test iocmd-10.2 {eof command} { + list [catch {eof a b} msg] $msg $errorCode +} {1 {wrong # args: should be "eof channelId"} NONE} +test iocmd-10.3 {eof command} { + catch {close file100} + list [catch {eof file100} msg] $msg $errorCode +} {1 {can not find channel named "file100"} NONE} + +test iocmd-11.0 {fblocked command} { + list [catch {fblocked} msg] $msg +} {1 {wrong # args: should be "fblocked channelId"}} +test iocmd-11.1 {fblocked command} { + list [catch {fblocked a b c d e f g} msg] $msg +} {1 {wrong # args: should be "fblocked channelId"}} +test iocmd-11.2 {fblocked command} { + list [catch {fblocked file1000} msg] $msg +} {1 {can not find channel named "file1000"}} +test iocmd-11.3 {fblocked command} { + list [catch {fblocked stdout} msg] $msg +} {1 {channel "stdout" wasn't opened for reading}} +test iocmd-11.4 {fblocked command} { + fblocked stdin +} 0 + +test iocmd-12.1 {I/O to command pipelines} {unixOrPc unixExecs} { + list [catch {open "| cat < test1 > test3" w} msg] $msg $errorCode +} {1 {can't write input to command: standard input was redirected} NONE} +test iocmd-12.2 {I/O to command pipelines} {unixOrPc unixExecs} { + list [catch {open "| echo > test3" r} msg] $msg $errorCode +} {1 {can't read output from command: standard output was redirected} NONE} +test iocmd-12.3 {I/O to command pipelines} {unixOrPc unixExecs} { + list [catch {open "| echo > test3" r+} msg] $msg $errorCode +} {1 {can't read output from command: standard output was redirected} NONE} + +test iocmd-13.1 {POSIX open access modes: RDONLY} { + removeFile test1 + set f [open test1 w] + puts $f "Two lines: this one" + puts $f "and this one" + close $f + set f [open test1 RDONLY] + set x [list [gets $f] [catch {puts $f Test} msg] $msg] + close $f + string compare $x \ + "{Two lines: this one} 1 [list [format "channel \"%s\" wasn't opened for writing" $f]]" +} 0 +test iocmd-13.2 {POSIX open access modes: RDONLY} { + removeFile test3 + string tolower [list [catch {open test3 RDONLY} msg] $msg] +} {1 {couldn't open "test3": no such file or directory}} +test iocmd-13.3 {POSIX open access modes: WRONLY} { + removeFile test3 + string tolower [list [catch {open test3 WRONLY} msg] $msg] +} {1 {couldn't open "test3": no such file or directory}} +# +# Test 13.4 relies on assigning the same channel name twice. +# +test iocmd-13.4 {POSIX open access modes: WRONLY} {unixOnly} { + removeFile test3 + set f [open test3 w] + fconfigure $f -eofchar {} + puts $f xyzzy + close $f + set f [open test3 WRONLY] + fconfigure $f -eofchar {} + puts -nonewline $f "ab" + seek $f 0 current + set x [list [catch {gets $f} msg] $msg] + close $f + set f [open test3 r] + fconfigure $f -eofchar {} + lappend x [gets $f] + close $f + set y [list 1 [format "channel \"%s\" wasn't opened for reading" $f] abzzy] + string compare $x $y +} 0 +test iocmd-13.5 {POSIX open access modes: RDWR} { + removeFile test3 + string tolower [list [catch {open test3 RDWR} msg] $msg] +} {1 {couldn't open "test3": no such file or directory}} +test iocmd-13.15 {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 iocmd-13.16 {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 iocmd-13.17 {POSIX open access modes: errors} { + list [catch {open test3 {TRUNC CREAT}} msg] $msg +} {1 {access mode must include either RDONLY, WRONLY, or RDWR}} + +test iocmd-14.1 {errors in open command} { + list [catch {open} msg] $msg +} {1 {wrong # args: should be "open fileName ?access? ?permissions?"}} +test iocmd-14.2 {errors in open command} { + list [catch {open a b c d} msg] $msg +} {1 {wrong # args: should be "open fileName ?access? ?permissions?"}} +test iocmd-14.3 {errors in open command} { + list [catch {open test1 x} msg] $msg +} {1 {illegal access mode "x"}} +test iocmd-14.4 {errors in open command} { + list [catch {open test1 rw} msg] $msg +} {1 {illegal access mode "rw"}} +test iocmd-14.5 {errors in open command} { + list [catch {open test1 r+1} msg] $msg +} {1 {illegal access mode "r+1"}} +test iocmd-14.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}}} + +test iocmd-15.1 {file id parsing errors} { + list [catch {eof gorp} msg] $msg $errorCode +} {1 {can not find channel named "gorp"} NONE} +test iocmd-15.2 {file id parsing errors} { + list [catch {eof filex} msg] $msg +} {1 {can not find channel named "filex"}} +test iocmd-15.3 {file id parsing errors} { + list [catch {eof file12a} msg] $msg +} {1 {can not find channel named "file12a"}} +test iocmd-15.4 {file id parsing errors} { + list [catch {eof file123} msg] $msg +} {1 {can not find channel named "file123"}} +test iocmd-15.5 {file id parsing errors} { + list [catch {eof stdout} msg] $msg +} {0 0} +test iocmd-15.6 {file id parsing errors} { + list [catch {eof stdin} msg] $msg +} {0 0} +test iocmd-15.7 {file id parsing errors} { + list [catch {eof stdout} msg] $msg +} {0 0} +test iocmd-15.8 {file id parsing errors} { + list [catch {eof stderr} msg] $msg +} {0 0} +test iocmd-15.9 {file id parsing errors} { + list [catch {eof stderr1} msg] $msg +} {1 {can not find channel named "stderr1"}} +set f [open test1] +close $f +set expect "1 {can not find channel named \"$f\"}" +test iocmd-15.10 {file id parsing errors} { + list [catch {eof $f} msg] $msg +} $expect + +removeFile test1 +removeFile test2 +removeFile test3 +removeFile pipe +removeFile output +set x "" +set x diff --git a/tcl7.6/tests/join.test b/tcl7.6/tests/join.test new file mode 100644 index 0000000..4023de2 --- /dev/null +++ b/tcl7.6/tests/join.test @@ -0,0 +1,38 @@ +# 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. +# Copyright (c) 1994 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) join.test 1.6 96/02/16 08:56:02 + +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/tcl7.6/tests/license.terms b/tcl7.6/tests/license.terms new file mode 100644 index 0000000..96ad966 --- /dev/null +++ b/tcl7.6/tests/license.terms @@ -0,0 +1,39 @@ +This software is copyrighted by the Regents of the University of +California, Sun Microsystems, Inc., and other parties. The following +terms apply to all files associated with the software unless explicitly +disclaimed in individual files. + +The authors hereby grant permission to use, copy, modify, distribute, +and license this software and its documentation for any purpose, provided +that existing copyright notices are retained in all copies and that this +notice is included verbatim in any distributions. No written agreement, +license, or royalty fee is required for any of the authorized uses. +Modifications to this software may be copyrighted by their authors +and need not follow the licensing terms described here, provided that +the new terms are clearly indicated on the first page of each file where +they apply. + +IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY +FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES +ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY +DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + +THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE +IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE +NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR +MODIFICATIONS. + +GOVERNMENT USE: If you are acquiring this software on behalf of the +U.S. government, the Government shall have only "Restricted Rights" +in the software and related documentation as defined in the Federal +Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you +are acquiring the software on behalf of the Department of Defense, the +software shall be classified as "Commercial Computer Software" and the +Government shall have only "Restricted Rights" as defined in Clause +252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the +authors grant the U.S. Government and others acting in its behalf +permission to use and distribute the software in accordance with the +terms specified in this license. diff --git a/tcl7.3/tests/lindex.test b/tcl7.6/tests/lindex.test similarity index 62% rename from tcl7.3/tests/lindex.test rename to tcl7.6/tests/lindex.test index f215a4e..66ff3ac 100644 --- a/tcl7.3/tests/lindex.test +++ b/tcl7.6/tests/lindex.test @@ -5,26 +5,12 @@ # 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. +# Copyright (c) 1994 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) lindex.test 1.5 96/02/16 08:56:03 if {[string compare test [info procs test]] == 1} then {source defs} @@ -39,6 +25,21 @@ test lindex-1.4 {basic tests} { test lindex-1.5 {basic tests} { list [catch {lindex {a b c} -1} msg] $msg } {0 {}} +test lindex-1.6 {basic tests} { + lindex {a b c d} end +} d +test lindex-1.7 {basic tests} { + lindex {a b c d} 100 +} {} +test lindex-1.8 {basic tests} { + lindex {a} e +} a +test lindex-1.9 {basic tests} { + lindex {} end +} {} +test lindex-1.10 {basic tests} { + lindex {a b c d} 3 +} d test lindex-2.1 {error conditions} { list [catch {lindex msg} msg] $msg diff --git a/tcl7.3/tests/link.test b/tcl7.6/tests/link.test similarity index 61% rename from tcl7.3/tests/link.test rename to tcl7.6/tests/link.test index 1181714..4cc3976 100644 --- a/tcl7.3/tests/link.test +++ b/tcl7.6/tests/link.test @@ -5,26 +5,12 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1993 The Regents of the University of California. -# All rights reserved. +# Copyright (c) 1994 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) link.test 1.11 96/08/09 16:22:45 if {[info commands testlink] == {}} { puts "This application hasn't been compiled with the \"testlink\"" @@ -143,6 +129,106 @@ test link-6.1 {errors in setting up link} { set int(44) 1 list [catch {testlink create 1 1 1 1} msg] $msg } {1 {can't set "int": variable is array}} +catch {unset int} + +test link-7.1 {access to linked variables via upvar} { + proc x {} { + upvar int y + unset y + } + testlink delete + testlink create 1 0 0 0 + testlink set 14 {} {} {} + x + list [catch {set int} msg] $msg +} {0 14} +test link-7.2 {access to linked variables via upvar} { + proc x {} { + upvar int y + return [set y] + } + testlink delete + testlink create 1 0 0 0 + testlink set 0 {} {} {} + set int + testlink set 23 {} {} {} + x + list [x] $int +} {23 23} +test link-7.3 {access to linked variables via upvar} { + proc x {} { + upvar int y + set y 44 + } + testlink delete + testlink create 0 0 0 0 + testlink set 11 {} {} {} + list [catch x msg] $msg $int +} {1 {can't set "y": linked variable is read-only} 11} +test link-7.4 {access to linked variables via upvar} { + proc x {} { + upvar int y + set y abc + } + testlink delete + testlink create 1 1 1 1 + testlink set -4 {} {} {} + list [catch x msg] $msg $int +} {1 {can't set "y": variable must have integer value} -4} +test link-7.5 {access to linked variables via upvar} { + proc x {} { + upvar real y + set y abc + } + testlink delete + testlink create 1 1 1 1 + testlink set -4 16.3 {} {} + list [catch x msg] $msg $real +} {1 {can't set "y": variable must have real value} 16.3} +test link-7.6 {access to linked variables via upvar} { + proc x {} { + upvar bool y + set y abc + } + testlink delete + testlink create 1 1 1 1 + testlink set -4 16.3 1 {} + list [catch x msg] $msg $bool +} {1 {can't set "y": variable must have boolean value} 1} + +test link-8.1 {Tcl_UpdateLinkedVar procedure} { + proc x args { + global x int real bool string + lappend x $args $int $real $bool $string + } + set x {} + testlink create 1 1 1 1 + testlink set 14 -2.0 0 xyzzy + trace var int w x + testlink update 32 4.0 3 abcd + trace vdelete int w x + set x +} {{int {} w} 32 -2.0 0 xyzzy} +test link-8.2 {Tcl_UpdateLinkedVar procedure} { + proc x args { + global x int real bool string + lappend x $args $int $real $bool $string + } + set x {} + testlink create 1 1 1 1 + testlink set 14 -2.0 0 xyzzy + testlink delete + trace var int w x + testlink update 32 4.0 6 abcd + trace vdelete int w x + set x +} {} +test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} { + testlink create 0 0 0 0 + list [catch {testlink update 47 {} {} {}} msg] $msg $int +} {0 {} 47} testlink delete -unset int real bool string +foreach i {int real bool string} { + catch {unset $i} +} diff --git a/tcl7.3/tests/linsert.test b/tcl7.6/tests/linsert.test similarity index 68% rename from tcl7.3/tests/linsert.test rename to tcl7.6/tests/linsert.test index 0201405..a77a907 100644 --- a/tcl7.3/tests/linsert.test +++ b/tcl7.6/tests/linsert.test @@ -5,26 +5,12 @@ # 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. +# Copyright (c) 1994 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) linsert.test 1.8 96/02/16 08:56:07 if {[string compare test [info procs test]] == 1} then {source defs} @@ -76,6 +62,15 @@ test linsert-1.15 {linsert command} { test linsert-1.16 {linsert command} { linsert {a b c \{ abc} 4 q r } {a b c \{ q r abc} +test linsert-1.17 {linsert command} { + linsert {a b c} end q r +} {a b c q r} +test linsert-1.18 {linsert command} { + linsert {a} end q r +} {a q r} +test linsert-1.19 {linsert command} { + linsert {} end q r +} {q r} test linsert-2.1 {linsert errors} { list [catch linsert msg] $msg diff --git a/tcl7.3/tests/list.test b/tcl7.6/tests/list.test similarity index 70% rename from tcl7.3/tests/list.test rename to tcl7.6/tests/list.test index 8bc0781..e901391 100644 --- a/tcl7.3/tests/list.test +++ b/tcl7.6/tests/list.test @@ -5,26 +5,12 @@ # 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. +# Copyright (c) 1994 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) list.test 1.20 96/02/16 08:56:09 if {[string compare test [info procs test]] == 1} then {source defs} diff --git a/tcl7.6/tests/llength.test b/tcl7.6/tests/llength.test new file mode 100644 index 0000000..badfd17 --- /dev/null +++ b/tcl7.6/tests/llength.test @@ -0,0 +1,35 @@ +# 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. +# Copyright (c) 1994 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) llength.test 1.4 96/02/16 08:56:11 + +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/tcl7.6/tests/load.test b/tcl7.6/tests/load.test new file mode 100644 index 0000000..f7dd249 --- /dev/null +++ b/tcl7.6/tests/load.test @@ -0,0 +1,164 @@ +# Commands covered: load +# +# 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) 1995 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) load.test 1.17 96/09/24 08:46:05 + +if {[string compare test [info procs test]] == 1} then {source defs} + +# Figure out what extension is used for shared libraries on this +# platform. + +if {$tcl_platform(platform) == "macintosh"} { + puts "can't run dynamic library tests on macintosh machines" + return +} +set ext [info sharedlibextension] +set testDir [file join [file dirname [info nameofexecutable]] dltest] +if ![file readable [file join $testDir pkga$ext]] { + puts "libraries in $testDir haven't been compiled: skipping tests" + return +} + +if [string match *pkga* [set alreadyLoaded [info loaded {}]]] { + puts "load tests have already been run once: skipping (can't rerun)" + return +} + +set alreadyTotalLoaded [info loaded] + +test load-1.1 {basic errors} { + list [catch {load} msg] $msg +} {1 {wrong # args: should be "load fileName ?packageName? ?interp?"}} +test load-1.2 {basic errors} { + list [catch {load a b c d} msg] $msg +} {1 {wrong # args: should be "load fileName ?packageName? ?interp?"}} +test load-1.3 {basic errors} { + list [catch {load a b foobar} msg] $msg +} {1 {couldn't find slave interpreter named "foobar"}} +test load-1.4 {basic errors} { + list [catch {load {}} msg] $msg +} {1 {must specify either file name or package name}} +test load-1.5 {basic errors} { + list [catch {load {} {}} msg] $msg +} {1 {must specify either file name or package name}} +test load-1.6 {basic errors} { + list [catch {load {} Unknown} msg] $msg +} {1 {package "Unknown" isn't loaded statically}} + +test load-2.1 {basic loading, with guess for package name} { + load [file join $testDir pkga$ext] + list [pkga_eq abc def] [info commands pkga_*] +} {0 {pkga_eq pkga_quote}} +interp create -safe child +test load-2.2 {loading into a safe interpreter, with package name conversion} { + load [file join $testDir pkgb$ext] pKgB child + list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \ + [catch {pkgb_sub 12 10} msg2] $msg2 +} {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}} +test load-2.3 {loading with no _Init procedure} { + list [catch {load [file join $testDir pkgc$ext] foo} msg] $msg +} {1 {couldn't find procedure Foo_Init}} +test load-2.4 {loading with no _SafeInit procedure} { + list [catch {load [file join $testDir pkga$ext] {} child} msg] $msg +} {1 {can't use package in a safe interpreter: no Pkga_SafeInit procedure}} + +test load-3.1 {error in _Init procedure, same interpreter} { + list [catch {load [file join $testDir pkge$ext] pkge} msg] $msg $errorInfo $errorCode +} {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory + while executing +"open non_existent" + invoked from within +"if 44 {open non_existent}" + invoked from within +"load [file join $testDir pkge$ext] pkge"} {POSIX ENOENT {no such file or directory}}} +test load-3.2 {error in _Init procedure, slave interpreter} { + catch {interp delete x} + interp create x + set errorCode foo + set errorInfo bar + set result [list [catch {load [file join $testDir pkge$ext] pkge x} msg] \ + $msg $errorInfo $errorCode] + interp delete x + set result +} {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory + while executing +"open non_existent" + invoked from within +"if 44 {open non_existent}" + invoked from within +"load [file join $testDir pkge$ext] pkge x"} {POSIX ENOENT {no such file or directory}}} + +test load-4.1 {reloading package into same interpreter} { + list [catch {load [file join $testDir pkga$ext] pkga} msg] $msg +} {0 {}} +test load-4.2 {reloading package into same interpreter} { + list [catch {load [file join $testDir pkga$ext] pkgb} msg] $msg +} "1 {file \"[file join $testDir pkga$ext\"] is already loaded for package \"Pkga\"}" + +test load-5.1 {file name not specified and no static package: pick default} { + catch {interp delete x} + interp create x + load [file join $testDir pkga$ext] pkga + load {} pkga x + set result [info loaded x] + interp delete x + set result +} "{[file join $testDir pkga$ext] Pkga}" + +# On some platforms, like SunOS 4.1.3, these tests can't be run because +# they cause the process to exit. + +test load-6.1 {errors loading file} {nonPortable} { + catch {load foo foo} +} {1} + +if {[info command teststaticpkg] != ""} { + test load-7.1 {Tcl_StaticPackage procedure} { + set x "not loaded" + teststaticpkg Test 1 0 + load {} Test + load {} Test child + list [set x] [child eval set x] + } {loaded loaded} + test load-7.2 {Tcl_StaticPackage procedure} { + set x "not loaded" + teststaticpkg Another 0 0 + load {} Another + child eval {set x "not loaded"} + list [catch {load {} Another child} msg] $msg [child eval set x] [set x] + } {1 {can't use package in a safe interpreter: no Another_SafeInit procedure} {not loaded} loaded} + test load-7.3 {Tcl_StaticPackage procedure} { + set x "not loaded" + teststaticpkg More 0 1 + load {} More + set x + } {not loaded} + test load-7.4 {Tcl_StaticPackage procedure, redundant calls} { + teststaticpkg Double 0 1 + teststaticpkg Double 0 1 + info loaded + } "{{} Double} {{} More} {{} Another} {{} Test} {[file join $testDir pkge$ext] Pkge} {[file join $testDir pkgb$ext] Pkgb} {[file join $testDir pkga$ext] Pkga} {{} Tcltest}" + + test load-8.1 {TclGetLoadedPackages procedure} { + info loaded + } "{{} Double} {{} More} {{} Another} {{} Test} {[file join $testDir pkge$ext] Pkge} {[file join $testDir pkgb$ext] Pkgb} {[file join $testDir pkga$ext] Pkga} $alreadyTotalLoaded" + test load-8.2 {TclGetLoadedPackages procedure} { + list [catch {info loaded gorp} msg] $msg + } {1 {couldn't find slave interpreter named "gorp"}} + test load-8.3 {TclGetLoadedPackages procedure} { + list [info loaded {}] [info loaded child] + } "{{{} Double} {{} More} {{} Another} {{} Test} {[file join $testDir pkga$ext] Pkga} $alreadyTotalLoaded} {{{} Test} {[file join $testDir pkgb$ext] Pkgb}}" + test load-8.4 {TclGetLoadedPackages procedure} { + load [file join $testDir pkgb$ext] pkgb + list [info loaded {}] [lsort [info commands pkgb_*]] + } "{{[file join $testDir pkgb$ext] Pkgb} {{} Double} {{} More} {{} Another} {{} Test} {[file join $testDir pkga$ext] Pkga} $alreadyTotalLoaded} {pkgb_sub pkgb_unsafe}" + interp delete child +} diff --git a/tcl7.3/tests/lrange.test b/tcl7.6/tests/lrange.test similarity index 65% rename from tcl7.3/tests/lrange.test rename to tcl7.6/tests/lrange.test index b8aef6b..91f4439 100644 --- a/tcl7.3/tests/lrange.test +++ b/tcl7.6/tests/lrange.test @@ -5,26 +5,12 @@ # 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. +# Copyright (c) 1994 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) lrange.test 1.6 96/07/10 17:16:47 if {[string compare test [info procs test]] == 1} then {source defs} @@ -58,6 +44,21 @@ test lrange-1.9 {range of list elements} { test lrange-1.10 {range of list elements} { lrange "a b\{c d" 1 2 } "b\{c d" +test lrange-1.11 {range of list elements} { + lrange "a b c d" end end +} d +test lrange-1.12 {range of list elements} { + lrange "a b c d" end 100000 +} d +test lrange-1.13 {range of list elements} { + lrange "a b c d" e 3 +} d +test lrange-1.14 {range of list elements} { + lrange "a b c d" end 2 +} {} +test lrange-1.14 {range of list elements} { + concat \"[lrange {a b \{\ } 0 2]" +} {"a b \{\ "} test lrange-2.1 {error conditions} { list [catch {lrange a b} msg] $msg diff --git a/tcl7.3/tests/lreplace.test b/tcl7.6/tests/lreplace.test similarity index 68% rename from tcl7.3/tests/lreplace.test rename to tcl7.6/tests/lreplace.test index d302528..75cddb2 100644 --- a/tcl7.3/tests/lreplace.test +++ b/tcl7.6/tests/lreplace.test @@ -5,26 +5,12 @@ # 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. +# Copyright (c) 1994 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) lreplace.test 1.13 96/07/10 17:16:47 if {[string compare test [info procs test]] == 1} then {source defs} @@ -48,7 +34,7 @@ test lreplace-1.6 {lreplace command} { } {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} +} {a 1 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} @@ -82,6 +68,28 @@ test lreplace-1.17 {lreplace command} { test lreplace-1.18 {lreplace command} { lreplace {1 2 3 4 {5 6}} 4 4 a } {1 2 3 4 a} +test lreplace-1.19 {lreplace command} { + lreplace {1 2 3 4} 2 end x y z +} {1 2 x y z} +test lreplace-1.20 {lreplace command} { + lreplace {1 2 3 4} end end a +} {1 2 3 a} +test lreplace-1.21 {lreplace command} { + lreplace {1 2 3 4} end 3 a +} {1 2 3 a} +test lreplace-1.22 {lreplace command} { + lreplace {1 2 3 4} end end +} {1 2 3} +test lreplace-1.23 {lreplace command} { + lreplace {1 2 3 4} 2 -1 xy +} {1 2 xy 3 4} +test lreplace-1.24 {lreplace command} { + lreplace {1 2 3 4} end -1 z +} {1 2 3 z 4} +test lreplace-1.25 {lreplace command} { + concat \"[lreplace {\}\ hello} end end]\" +} {"\}\ "} + test lreplace-2.1 {lreplace errors} { list [catch lreplace msg] $msg @@ -91,16 +99,16 @@ test lreplace-2.2 {lreplace errors} { } {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"}} +} {1 {bad index "a": must be integer or "end"}} 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"}} +} {1 {bad index "1x": must be integer or "end"}} test lreplace-2.6 {lreplace errors} { list [catch {lreplace x 3 2} msg] $msg -} {1 {first index must not be greater than second}} +} {1 {list doesn't contain element 3}} test lreplace-2.7 {lreplace errors} { list [catch {lreplace x 1 1} msg] $msg } {1 {list doesn't contain element 1}} diff --git a/tcl7.3/tests/lsearch.test b/tcl7.6/tests/lsearch.test similarity index 65% rename from tcl7.3/tests/lsearch.test rename to tcl7.6/tests/lsearch.test index 73bbdaf..95df872 100644 --- a/tcl7.3/tests/lsearch.test +++ b/tcl7.6/tests/lsearch.test @@ -5,26 +5,12 @@ # 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. +# Copyright (c) 1994 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) lsearch.test 1.5 96/02/16 08:56:15 if {[string compare test [info procs test]] == 1} then {source defs} diff --git a/tcl7.3/tests/lsort.test b/tcl7.6/tests/lsort.test similarity index 80% rename from tcl7.3/tests/lsort.test rename to tcl7.6/tests/lsort.test index 0020eb5..907dfbf 100644 --- a/tcl7.3/tests/lsort.test +++ b/tcl7.6/tests/lsort.test @@ -5,26 +5,12 @@ # 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. +# Copyright (c) 1994 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) lsort.test 1.8 96/02/16 08:56:17 if {[string compare test [info procs test]] == 1} then {source defs} @@ -134,3 +120,7 @@ test lsort-5.3 {lsort errors} { 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}} +test lsort-5.5 {lsort errors: disallow recursion} { + proc x args {lsort {a b c}} + list [catch {lsort -command x {3 7}} msg] $msg +} {1 {can't invoke "lsort" recursively}} diff --git a/tcl7.3/tests/misc.test b/tcl7.6/tests/misc.test similarity index 62% rename from tcl7.3/tests/misc.test rename to tcl7.6/tests/misc.test index d05a63f..b53759d 100644 --- a/tcl7.3/tests/misc.test +++ b/tcl7.6/tests/misc.test @@ -6,26 +6,12 @@ # releases. # # Copyright (c) 1992-1993 The Regents of the University of California. -# All rights reserved. +# Copyright (c) 1994 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) misc.test 1.5 96/02/16 08:56:18 if {[string compare test [info procs test]] == 1} then {source defs} diff --git a/tcl7.3/tests/parse.test b/tcl7.6/tests/parse.test similarity index 63% rename from tcl7.3/tests/parse.test rename to tcl7.6/tests/parse.test index fde5101..fa1c6f5 100644 --- a/tcl7.3/tests/parse.test +++ b/tcl7.6/tests/parse.test @@ -1,30 +1,17 @@ -# Commands covered: set (plus basic command syntax) +# Commands covered: set (plus basic command syntax). Also tests +# the procedures in the file tclParse.c. # # 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. +# Copyright (c) 1994 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) parse.test 1.34 96/03/02 14:29:03 if {[string compare test [info procs test]] == 1} then {source defs} @@ -257,25 +244,25 @@ bsCheck \xa 10 bsCheck \x41 65 bsCheck \x541 65 -test parse-7.1 {backslash substitution} { +test parse-6.1 {backslash substitution} { set a "\a\c\n\]\}" string length $a } 5 -test parse-7.2 {backslash substitution} { +test parse-6.2 {backslash substitution} { set a {\a\c\n\]\}} string length $a } 10 -test parse-7.3 {backslash substitution} { +test parse-6.3 {backslash substitution} { set a "abc\ def" set a } {abc def} -test parse-7.4 {backslash substitution} { +test parse-6.4 {backslash substitution} { set a {abc\ def} set a } {abc def} -test parse-7.5 {backslash substitution} { +test parse-6.5 {backslash substitution} { set msg {} set a xxx set error [catch {if {24 < \ @@ -283,39 +270,42 @@ test parse-7.5 {backslash substitution} { a 33}} msg] list $error $msg $a } {0 22 22} -test parse-7.6 {backslash substitution} { +test parse-6.6 {backslash substitution} { eval "concat abc\\" } "abc\\" -test parse-7.7 {backslash substitution} { +test parse-6.7 {backslash substitution} { eval "concat \\\na" } "a" -test parse-7.8 {backslash substitution} { - eval "concat x\\\n \na" +test parse-6.8 {backslash substitution} { + eval "concat x\\\n a" } "x a" -test parse-7.9 {backslash substitution} { +test parse-6.9 {backslash substitution} { eval "concat \\x" } "x" -test parse-7.10 {backslash substitution} { +test parse-6.10 {backslash substitution} { eval "list a b\\\nc d" } {a b c d} +test parse-6.11 {backslash substitution} { + eval "list a \"b c\"\\\nd e" +} {a {b c} d e} # Semi-colon. -test parse-8.1 {semi-colons} { +test parse-7.1 {semi-colons} { set b 0 getArgs a;set b 2 set argv } a -test parse-8.2 {semi-colons} { +test parse-7.2 {semi-colons} { set b 0 getArgs a;set b 2 set b } 2 -test parse-8.3 {semi-colons} { +test parse-7.3 {semi-colons} { getArgs a b ; set b 1 set argv } {a b} -test parse-8.4 {semi-colons} { +test parse-7.4 {semi-colons} { getArgs a b ; set b 1 set b } 1 @@ -323,95 +313,99 @@ test parse-8.4 {semi-colons} { # 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} { +test parse-8.1 {result initialization} {concat abc} abc +test parse-8.2 {result initialization} {concat abc; proc foo {} {}} {} +test parse-8.3 {result initialization} {concat abc; proc foo {} $a} {} +test parse-8.4 {result initialization} {proc foo {} [concat abc]} {} +test parse-8.5 {result initialization} {concat abc; } abc +test parse-8.6 {result initialization} { eval { concat abc }} abc -test parse-9.7 {result initialization} {} {} -test parse-9.8 {result initialization} {concat abc; ; ;} abc +test parse-8.7 {result initialization} {} {} +test parse-8.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} { +test parse-9.1 {syntax errors} {catch "set a \{bcd" msg} 1 +test parse-9.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} { +test parse-9.3 {syntax errors} {catch {set a "bcd} msg} 1 +test parse-9.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} { +test parse-9.5 {syntax errors} {catch {set a "bcd"xy} msg} 1 +test parse-9.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} { +test parse-9.7 {syntax errors} {catch "set a {bcd}xy" msg} 1 +test parse-9.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} { +test parse-9.9 {syntax errors} {catch {set a [format abc} msg} 1 +test parse-9.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} { +test parse-9.11 {syntax errors} {catch gorp-a-lot msg} 1 +test parse-9.12 {syntax errors} { catch gorp-a-lot msg set msg -} {invalid command name: "gorp-a-lot"} -test parse-10.13 {syntax errors} { +} {invalid command name "gorp-a-lot"} +test parse-9.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} +test parse-9.14 {syntax errors} { + list [catch {eval \$x[format "%01000d" 0](} msg] $msg $errorInfo +} {1 {missing )} {missing ) + (parsing index for array "x000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000") + invoked from within +"$x0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 ..." + ("eval" body line 1) + invoked from within +"eval \$x[format "%01000d" 0]("}} # 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} { +test parse-10.1 {long values} { string length $a } 214 -test parse-11.2 {long values} { +test parse-10.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} { +test parse-10.3 {long values} { set b "$a" set b } $a -test parse-11.5 {long values} { +test parse-10.4 {long values} { set b [set a] set b } $a -test parse-11.6 {long values} { +test parse-10.5 {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} { +test parse-10.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] llength $b } 43 -test parse-11.8 {long values} { +test parse-10.7 {long values} { set b } $a -test parse-11.9 {long values} { +test parse-10.8 {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 @@ -420,10 +414,107 @@ foreach j [concat 0000 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cc set test [string index 0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ $i] set test $test$test$test$test set i [expr $i+1] - test parse-11.10 {long values} { + test parse-10.9 {long values} { set j } $test } -test parse-11.10 {test buffer overflow in backslashes in braces} { +test parse-10.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 + +test parse-11.1 {comments} { + set a old + eval { # set a new} + set a +} {old} +test parse-11.2 {comments} { + set a old + eval " # set a new\nset a new" + set a +} {new} +test parse-11.3 {comments} { + set a old + eval " # set a new\\\nset a new" + set a +} {old} +test parse-11.4 {comments} { + set a old + eval " # set a new\\\\\nset a new" + set a +} {new} + +test parse-12.1 {comments at the end of a bracketed script} { + set x "[ +expr 1+1 +# skip this! +]" +} {2} + +if {[info command testwordend] == "testwordend"} { + test parse-13.1 {TclWordEnd procedure} { + testwordend " \n abc" + } {c} + test parse-13.2 {TclWordEnd procedure} { + testwordend " \\\n" + } {} + test parse-13.3 {TclWordEnd procedure} { + testwordend " \\\n " + } { } + test parse-13.4 {TclWordEnd procedure} { + testwordend {"abc"} + } {"} + test parse-13.5 {TclWordEnd procedure} { + testwordend {{xyz}} + } \} + test parse-13.6 {TclWordEnd procedure} { + testwordend {{a{}b{}\}} xyz} + } "\} xyz" + test parse-13.7 {TclWordEnd procedure} { + testwordend {abc[this is a]def ghi} + } {f ghi} + test parse-13.8 {TclWordEnd procedure} { + testwordend "puts\\\n\n " + } "s\\\n\n " + test parse-13.9 {TclWordEnd procedure} { + testwordend "puts\\\n " + } "s\\\n " + test parse-13.10 {TclWordEnd procedure} { + testwordend "puts\\\n xyz" + } "s\\\n xyz" + test parse-13.11 {TclWordEnd procedure} { + testwordend {a$x.$y(a long index) foo} + } ") foo" + test parse-13.12 {TclWordEnd procedure} { + testwordend {abc; def} + } {; def} + test parse-13.13 {TclWordEnd procedure} { + testwordend {abc def} + } {c def} + test parse-13.14 {TclWordEnd procedure} { + testwordend {abc def} + } {c def} + test parse-13.15 {TclWordEnd procedure} { + testwordend "abc\ndef" + } "c\ndef" + test parse-13.16 {TclWordEnd procedure} { + testwordend "abc" + } {c} +} + +test parse-14.1 {TclScriptEnd procedure} { + info complete {puts [ + expr 1+1 + #this is a comment ]} +} {0} +test parse-14.2 {TclScriptEnd procedure} { + info complete "abc\\\n" +} {0} +test parse-14.3 {TclScriptEnd procedure} { + info complete "abc\\\\\n" +} {1} +test parse-14.4 {TclScriptEnd procedure} { + info complete "xyz \[abc \{abc\]" +} {0} +test parse-14.5 {TclScriptEnd procedure} { + info complete "xyz \[abc" +} {0} diff --git a/tcl7.6/tests/pid.test b/tcl7.6/tests/pid.test new file mode 100644 index 0000000..1f6e039 --- /dev/null +++ b/tcl7.6/tests/pid.test @@ -0,0 +1,52 @@ +# 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. +# Copyright (c) 1994-1995 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) pid.test 1.12 96/04/12 11:14:43 + +# If pid is not defined just return with no error +# Some platforms may not have the pid command implemented +if {[info commands pid] == ""} { + puts "pid is not implemented for this machine" + return +} + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {removeFile test1} + +test pid-1.1 {pid command} { + regexp {(^[0-9]+$)|(^0x[0-9a-fA-F]+$)} [pid] +} 1 +test pid-1.2 {pid command} {unixOrPc unixExecs} { + set f [open {| echo foo | cat >test1} w] + set pids [pid $f] + close $f + catch {removeFile test1} + 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 pid-1.3 {pid command} { + set f [open test1 w] + set pids [pid $f] + close $f + set pids +} {} +test pid-1.4 {pid command} { + list [catch {pid a b} msg] $msg +} {1 {wrong # args: should be "pid ?channelId?"}} +test pid-1.5 {pid command} { + list [catch {pid gorp} msg] $msg +} {1 {can not find channel named "gorp"}} + +catch {removeFile test1} +concat {} diff --git a/tcl7.6/tests/pkg.test b/tcl7.6/tests/pkg.test new file mode 100644 index 0000000..66c1658 --- /dev/null +++ b/tcl7.6/tests/pkg.test @@ -0,0 +1,549 @@ +# Commands covered: pkg +# +# 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) 1995 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) pkg.test 1.6 96/03/20 10:50:27 + +if {[string compare test [info procs test]] == 1} then {source defs} + +eval package forget [package names] +package unknown {} +set oldPath auto_path +set auto_path "" + +test pkg-1.1 {Tcl_PkgProvide procedure} { + package forget t + package provide t 2.3 +} {} +test pkg-1.2 {Tcl_PkgProvide procedure} { + package forget t + package provide t 2.3 + list [catch {package provide t 2.2} msg] $msg +} {1 {conflicting versions provided for package "t": 2.3, then 2.2}} +test pkg-1.3 {Tcl_PkgProvide procedure} { + package forget t + package provide t 2.3 + list [catch {package provide t 2.4} msg] $msg +} {1 {conflicting versions provided for package "t": 2.3, then 2.4}} +test pkg-1.4 {Tcl_PkgProvide procedure} { + package forget t + package provide t 2.3 + list [catch {package provide t 3.3} msg] $msg +} {1 {conflicting versions provided for package "t": 2.3, then 3.3}} +test pkg-1.5 {Tcl_PkgProvide procedure} { + package forget t + package provide t 2.3 + package provide t 2.3 +} {} + +test pkg-2.1 {Tcl_PkgRequire procedure, picking best version} { + package forget t + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i; package provide t $i" + } + set x xxx + package require t + set x +} {3.4} +test pkg-2.2 {Tcl_PkgRequire procedure, picking best version} { + package forget t + foreach i {1.4 3.4 2.3 2.4 2.2 3.5 3.2} { + package ifneeded t $i "set x $i; package provide t $i" + } + set x xxx + package require t + set x +} {3.5} +test pkg-2.3 {Tcl_PkgRequire procedure, picking best version} { + package forget t + foreach i {3.5 2.1 2.3} { + package ifneeded t $i "set x $i; package provide t $i" + } + set x xxx + package require t 2.2 + set x +} {2.3} +test pkg-2.4 {Tcl_PkgRequire procedure, picking best version} { + package forget t + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i; package provide t $i" + } + set x xxx + package require -exact t 2.3 + set x +} {2.3} +test pkg-2.5 {Tcl_PkgRequire procedure, picking best version} { + package forget t + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i; package provide t $i" + } + set x xxx + package require t 2.1 + set x +} {2.4} +test pkg-2.6 {Tcl_PkgRequire procedure, can't find suitable version} { + package forget t + package unknown {} + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + list [catch {package require t 2.5} msg] $msg +} {1 {can't find package t 2.5}} +test pkg-2.7 {Tcl_PkgRequire procedure, can't find suitable version} { + package forget t + package unknown {} + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + list [catch {package require t 4.1} msg] $msg +} {1 {can't find package t 4.1}} +test pkg-2.8 {Tcl_PkgRequire procedure, can't find suitable version} { + package forget t + package unknown {} + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + list [catch {package require -exact t 1.3} msg] $msg +} {1 {can't find package t 1.3}} +test pkg-2.9 {Tcl_PkgRequire procedure, can't find suitable version} { + package forget t + package unknown {} + list [catch {package require t} msg] $msg +} {1 {can't find package t}} +test pkg-2.10 {Tcl_PkgRequire procedure, error in ifneeded script} { + package forget t + package ifneeded t 2.1 {package provide t 2.1; error "ifneeded test"} + list [catch {package require t 2.1} msg] $msg $errorInfo +} {1 {ifneeded test} {ifneeded test + while executing +"error "ifneeded test"" + ("package ifneeded" script) + invoked from within +"package require t 2.1"}} +test pkg-2.11 {Tcl_PkgRequire procedure, ifneeded script doesn't provide package} { + package forget t + package ifneeded t 2.1 "set x invoked" + set x xxx + list [catch {package require t 2.1} msg] $msg $x +} {1 {can't find package t 2.1} invoked} +test pkg-2.12 {Tcl_PkgRequire procedure, self-deleting script} { + package forget t + package ifneeded t 1.2 "package forget t; set x 1.2; package provide t 1.2" + set x xxx + package require t 1.2 + set x +} {1.2} +test pkg-2.13 {Tcl_PkgRequire procedure, "package unknown" support} { + proc pkgUnknown args { + global x + set x $args + package provide [lindex $args 0] [lindex $args 1] + } + package forget t + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + package unknown pkgUnknown + set x xxx + package require -exact t 1.5 + package unknown {} + set x +} {t 1.5 -exact} +test pkg-2.14 {Tcl_PkgRequire procedure, "package unknown" support} { + proc pkgUnknown args { + package ifneeded t 1.2 "set x loaded; package provide t 1.2" + } + package forget t + package unknown pkgUnknown + set x xxx + set result [list [package require t] $x] + package unknown {} + set result +} {1.2 loaded} +test pkg-2.15 {Tcl_PkgRequire procedure, "package unknown" support} { + proc pkgUnknown args { + global x + set x $args + package provide [lindex $args 0] 2.0 + } + package forget {a b} + package unknown pkgUnknown + set x xxx + package require {a b} + package unknown {} + set x +} {{a b} {}} +test pkg-2.16 {Tcl_PkgRequire procedure, "package unknown" error} { + proc pkgUnknown args { + error "testing package unknown" + } + package forget t + package unknown pkgUnknown + set result [list [catch {package require t} msg] $msg $errorInfo] + package unknown {} + set result +} {1 {testing package unknown} {testing package unknown + while executing +"error "testing package unknown"" + (procedure "pkgUnknown" line 2) + invoked from within +"pkgUnknown t {}" + ("package unknown" script) + invoked from within +"package require t"}} +test pkg-2.17 {Tcl_PkgRequire procedure, "package unknown" doesn't load package} { + proc pkgUnknown args { + global x + set x $args + } + package forget t + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + package unknown pkgUnknown + set x xxx + set result [list [catch {package require -exact t 1.5} msg] $msg $x] + package unknown {} + set result +} {1 {can't find package t 1.5} {t 1.5 -exact}} +test pkg-2.18 {Tcl_PkgRequire procedure, version checks} { + package forget t + package provide t 2.3 + package require t +} {2.3} +test pkg-2.19 {Tcl_PkgRequire procedure, version checks} { + package forget t + package provide t 2.3 + package require t 2.1 +} {2.3} +test pkg-2.20 {Tcl_PkgRequire procedure, version checks} { + package forget t + package provide t 2.3 + package require t 2.3 +} {2.3} +test pkg-2.21 {Tcl_PkgRequire procedure, version checks} { + package forget t + package provide t 2.3 + list [catch {package require t 2.4} msg] $msg +} {1 {version conflict for package "t": have 2.3, need 2.4}} +test pkg-2.22 {Tcl_PkgRequire procedure, version checks} { + package forget t + package provide t 2.3 + list [catch {package require t 1.2} msg] $msg +} {1 {version conflict for package "t": have 2.3, need 1.2}} +test pkg-2.23 {Tcl_PkgRequire procedure, version checks} { + package forget t + package provide t 2.3 + package require -exact t 2.3 +} {2.3} +test pkg-2.24 {Tcl_PkgRequire procedure, version checks} { + package forget t + package provide t 2.3 + list [catch {package require -exact t 2.2} msg] $msg +} {1 {version conflict for package "t": have 2.3, need 2.2}} + +test pkg-3.1 {Tcl_PackageCmd procedure} { + list [catch {package} msg] $msg +} {1 {wrong # args: should be "package option ?arg arg ...?"}} +test pkg-3.2 {Tcl_PackageCmd procedure, "forget" option} { + foreach i [package names] { + package forget $i + } + package names +} {} +test pkg-3.3 {Tcl_PackageCmd procedure, "forget" option} { + foreach i [package names] { + package forget $i + } + package forget foo +} {} +test pkg-3.4 {Tcl_PackageCmd procedure, "forget" option} { + foreach i [package names] { + package forget $i + } + package ifneeded t 1.1 {first script} + package ifneeded t 2.3 {second script} + package ifneeded x 1.4 {x's script} + set result {} + lappend result [lsort [package names]] [package versions t] + package forget t + lappend result [lsort [package names]] [package versions t] +} {{t x} {1.1 2.3} x {}} +test pkg-3.5 {Tcl_PackageCmd procedure, "forget" option} { + foreach i [package names] { + package forget $i + } + package ifneeded a 1.1 {first script} + package ifneeded b 2.3 {second script} + package ifneeded c 1.4 {third script} + package forget + set result [list [lsort [package names]]] + package forget a c + lappend result [lsort [package names]] +} {{a b c} b} +test pkg-3.6 {Tcl_PackageCmd procedure, "ifneeded" option} { + list [catch {package ifneeded a} msg] $msg +} {1 {wrong # args: should be "package ifneeded package version ?script?"}} +test pkg-3.7 {Tcl_PackageCmd procedure, "ifneeded" option} { + list [catch {package ifneeded a b c d} msg] $msg +} {1 {wrong # args: should be "package ifneeded package version ?script?"}} +test pkg-3.8 {Tcl_PackageCmd procedure, "ifneeded" option} { + list [catch {package ifneeded t xyz} msg] $msg +} {1 {expected version number but got "xyz"}} +test pkg-3.9 {Tcl_PackageCmd procedure, "ifneeded" option} { + foreach i [package names] { + package forget $i + } + list [package ifneeded foo 1.1] [package names] +} {{} {}} +test pkg-3.10 {Tcl_PackageCmd procedure, "ifneeded" option} { + package forget t + package ifneeded t 1.4 "script for t 1.4" + list [package names] [package ifneeded t 1.4] [package versions t] +} {t {script for t 1.4} 1.4} +test pkg-3.11 {Tcl_PackageCmd procedure, "ifneeded" option} { + package forget t + package ifneeded t 1.4 "script for t 1.4" + list [package ifneeded t 1.5] [package names] [package versions t] +} {{} t 1.4} +test pkg-3.12 {Tcl_PackageCmd procedure, "ifneeded" option} { + package forget t + package ifneeded t 1.4 "script for t 1.4" + package ifneeded t 1.4 "second script for t 1.4" + list [package ifneeded t 1.4] [package names] [package versions t] +} {{second script for t 1.4} t 1.4} +test pkg-3.13 {Tcl_PackageCmd procedure, "ifneeded" option} { + package forget t + package ifneeded t 1.4 "script for t 1.4" + package ifneeded t 1.2 "second script" + package ifneeded t 3.1 "last script" + list [package ifneeded t 1.2] [package versions t] +} {{second script} {1.4 1.2 3.1}} +test pkg-3.14 {Tcl_PackageCmd procedure, "names" option} { + list [catch {package names a} msg] $msg +} {1 {wrong # args: should be "package names"}} +test pkg-3.15 {Tcl_PackageCmd procedure, "names" option} { + foreach i [package names] { + package forget $i + } + package names +} {} +test pkg-3.16 {Tcl_PackageCmd procedure, "names" option} { + foreach i [package names] { + package forget $i + } + package ifneeded x 1.2 {dummy} + package provide x 1.3 + package provide y 2.4 + catch {package require z 47.16} + lsort [package names] +} {x y} +test pkg-3.17 {Tcl_PackageCmd procedure, "provide" option} { + list [catch {package provide} msg] $msg +} {1 {wrong # args: should be "package provide package ?version?"}} +test pkg-3.18 {Tcl_PackageCmd procedure, "provide" option} { + list [catch {package provide a b c} msg] $msg +} {1 {wrong # args: should be "package provide package ?version?"}} +test pkg-3.19 {Tcl_PackageCmd procedure, "provide" option} { + package forget t + package provide t +} {} +test pkg-3.20 {Tcl_PackageCmd procedure, "provide" option} { + package forget t + package provide t 2.3 + package provide t +} {2.3} +test pkg-3.21 {Tcl_PackageCmd procedure, "provide" option} { + package forget t + list [catch {package provide t a.b} msg] $msg +} {1 {expected version number but got "a.b"}} +test pkg-3.22 {Tcl_PackageCmd procedure, "require" option} { + list [catch {package require} msg] $msg +} {1 {wrong # args: should be "package require ?-exact? package ?version?"}} +test pkg-3.23 {Tcl_PackageCmd procedure, "require" option} { + list [catch {package require a b c} msg] $msg +} {1 {wrong # args: should be "package require ?-exact? package ?version?"}} +test pkg-3.24 {Tcl_PackageCmd procedure, "require" option} { + list [catch {package require -exact a b c} msg] $msg +} {1 {wrong # args: should be "package require ?-exact? package ?version?"}} +test pkg-3.25 {Tcl_PackageCmd procedure, "require" option} { + list [catch {package require -bs a b} msg] $msg +} {1 {wrong # args: should be "package require ?-exact? package ?version?"}} +test pkg-3.26 {Tcl_PackageCmd procedure, "require" option} { + list [catch {package require x a.b} msg] $msg +} {1 {expected version number but got "a.b"}} +test pkg-3.27 {Tcl_PackageCmd procedure, "require" option} { + list [catch {package require -exact x a.b} msg] $msg +} {1 {expected version number but got "a.b"}} +test pkg-3.28 {Tcl_PackageCmd procedure, "require" option} { + list [catch {package require -exact x} msg] $msg +} {1 {wrong # args: should be "package require ?-exact? package ?version?"}} +test pkg-3.29 {Tcl_PackageCmd procedure, "require" option} { + list [catch {package require -exact} msg] $msg +} {1 {wrong # args: should be "package require ?-exact? package ?version?"}} +test pkg-3.30 {Tcl_PackageCmd procedure, "require" option} { + package forget t + package provide t 2.3 + package require t 2.1 +} {2.3} +test pkg-3.31 {Tcl_PackageCmd procedure, "require" option} { + package forget t + list [catch {package require t} msg] $msg +} {1 {can't find package t}} +test pkg-3.32 {Tcl_PackageCmd procedure, "require" option} { + package forget t + package ifneeded t 2.3 "error {synthetic error}" + list [catch {package require t 2.3} msg] $msg +} {1 {synthetic error}} +test pkg-3.33 {Tcl_PackageCmd procedure, "unknown" option} { + list [catch {package unknown a b} msg] $msg +} {1 {wrong # args: should be "package unknown ?command?"}} +test pkg-3.34 {Tcl_PackageCmd procedure, "unknown" option} { + package unknown "test script" + package unknown +} {test script} +test pkg-3.35 {Tcl_PackageCmd procedure, "unknown" option} { + package unknown "test script" + package unknown {} + package unknown +} {} +test pkg-3.36 {Tcl_PackageCmd procedure, "vcompare" option} { + list [catch {package vcompare a} msg] $msg +} {1 {wrong # args: should be "package vcompare version1 version2"}} +test pkg-3.37 {Tcl_PackageCmd procedure, "vcompare" option} { + list [catch {package vcompare a b c} msg] $msg +} {1 {wrong # args: should be "package vcompare version1 version2"}} +test pkg-3.38 {Tcl_PackageCmd procedure, "vcompare" option} { + list [catch {package vcompare x.y 3.4} msg] $msg +} {1 {expected version number but got "x.y"}} +test pkg-3.39 {Tcl_PackageCmd procedure, "vcompare" option} { + list [catch {package vcompare 2.1 a.b} msg] $msg +} {1 {expected version number but got "a.b"}} +test pkg-3.40 {Tcl_PackageCmd procedure, "vcompare" option} { + package vc 2.1 2.3 +} {-1} +test pkg-3.41 {Tcl_PackageCmd procedure, "vcompare" option} { + package vc 2.2.4 2.2.4 +} {0} +test pkg-3.42 {Tcl_PackageCmd procedure, "versions" option} { + list [catch {package versions} msg] $msg +} {1 {wrong # args: should be "package versions package"}} +test pkg-3.43 {Tcl_PackageCmd procedure, "versions" option} { + list [catch {package versions a b} msg] $msg +} {1 {wrong # args: should be "package versions package"}} +test pkg-3.44 {Tcl_PackageCmd procedure, "versions" option} { + package forget t + package versions t +} {} +test pkg-3.45 {Tcl_PackageCmd procedure, "versions" option} { + package forget t + package provide t 2.3 + package versions t +} {} +test pkg-3.46 {Tcl_PackageCmd procedure, "versions" option} { + package forget t + package ifneeded t 2.3 x + package ifneeded t 2.4 y + package versions t +} {2.3 2.4} +test pkg-3.47 {Tcl_PackageCmd procedure, "vsatisfies" option} { + list [catch {package vsatisfies a} msg] $msg +} {1 {wrong # args: should be "package vsatisfies version1 version2"}} +test pkg-3.48 {Tcl_PackageCmd procedure, "vsatisfies" option} { + list [catch {package vsatisfies a b c} msg] $msg +} {1 {wrong # args: should be "package vsatisfies version1 version2"}} +test pkg-3.49 {Tcl_PackageCmd procedure, "vsatisfies" option} { + list [catch {package vsatisfies x.y 3.4} msg] $msg +} {1 {expected version number but got "x.y"}} +test pkg-3.50 {Tcl_PackageCmd procedure, "vsatisfies" option} { + list [catch {package vcompare 2.1 a.b} msg] $msg +} {1 {expected version number but got "a.b"}} +test pkg-3.51 {Tcl_PackageCmd procedure, "vsatisfies" option} { + package vs 2.3 2.1 +} {1} +test pkg-3.52 {Tcl_PackageCmd procedure, "vsatisfies" option} { + package vs 2.3 1.2 +} {0} +test pkg-3.53 {Tcl_PackageCmd procedure, "versions" option} { + list [catch {package foo} msg] $msg +} {1 {bad option "foo": should be forget, ifneeded, names, provide, require, unknown, vcompare, versions, or vsatisfies}} + +# No tests for FindPackage; can't think up anything detectable +# errors. + +test pkg-4.1 {TclFreePackageInfo procedure} { + interp create foo + foo eval { + package ifneeded t 2.3 x + package ifneeded t 2.4 y + package ifneeded x 3.1 z + package provide q 4.3 + package unknown "will this get freed?" + } + interp delete foo +} {} +test pkg-4.2 {TclFreePackageInfo procedure} { + interp create foo + foo eval { + package ifneeded t 2.3 x + package ifneeded t 2.4 y + package ifneeded x 3.1 z + package provide q 4.3 + } + foo alias z kill + proc kill {} { + interp delete foo + } + list [catch {foo eval package require x 3.1} msg] $msg +} {1 {can't find package x 3.1}} + +test pkg-5.1 {CheckVersion procedure} { + list [catch {package vcompare 1 2.1} msg] $msg +} {0 -1} +test pkg-5.2 {CheckVersion procedure} { + list [catch {package vcompare .1 2.1} msg] $msg +} {1 {expected version number but got ".1"}} +test pkg-5.3 {CheckVersion procedure} { + list [catch {package vcompare 111.2a.3 2.1} msg] $msg +} {1 {expected version number but got "111.2a.3"}} +test pkg-5.4 {CheckVersion procedure} { + list [catch {package vcompare 1.2.3. 2.1} msg] $msg +} {1 {expected version number but got "1.2.3."}} + +test pkg-6.1 {ComparePkgVersions procedure} { + package vcompare 1.23 1.22 +} {1} +test pkg-6.2 {ComparePkgVersions procedure} { + package vcompare 1.22.1.2.3 1.22.1.2.3 +} {0} +test pkg-6.3 {ComparePkgVersions procedure} { + package vcompare 1.21 1.22 +} {-1} +test pkg-6.4 {ComparePkgVersions procedure} { + package vcompare 1.21 1.21.2 +} {-1} +test pkg-6.5 {ComparePkgVersions procedure} { + package vcompare 1.21.1 1.21 +} {1} +test pkg-6.6 {ComparePkgVersions procedure} { + package vsatisfies 1.21.1 1.21 +} {1} +test pkg-6.7 {ComparePkgVersions procedure} { + package vsatisfies 2.22.3 1.21 +} {0} +test pkg-6.8 {ComparePkgVersions procedure} { + package vsatisfies 1 1 +} {1} +test pkg-6.9 {ComparePkgVersions procedure} { + package vsatisfies 2 1 +} {0} + +set auto_path oldPath +concat diff --git a/tcl7.3/tests/proc.test b/tcl7.6/tests/proc.test similarity index 89% rename from tcl7.3/tests/proc.test rename to tcl7.6/tests/proc.test index f321b76..6eef73c 100644 --- a/tcl7.3/tests/proc.test +++ b/tcl7.6/tests/proc.test @@ -5,26 +5,12 @@ # 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. +# Copyright (c) 1994 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) proc.test 1.21 96/02/16 08:56:21 if {[string compare test [info procs test]] == 1} then {source defs} @@ -294,7 +280,7 @@ test proc-5.11 {error conditions} { proc tproc {x {} z} {return foo} } list [catch {tproc 1} msg] $msg -} {1 {invalid command name: "tproc"}} +} {1 {invalid command name "tproc"}} test proc-5.12 {error conditions} { proc tproc {} { set a 22 @@ -339,6 +325,31 @@ test proc-5.15 {error conditions} { } {invoked "continue" outside of a loop while executing "tproc"} +test proc-5.16 {error conditions} { + proc foo args { + global fooMsg + set fooMsg "foo was called: $args" + } + proc tproc {} { + set x 44 + trace var x u foo + while {$x < 100} { + error "Nested error" + } + } + set fooMsg "foo not called" + list [catch tproc msg] $msg $errorInfo $fooMsg +} {1 {Nested error} {Nested error + while executing +"error "Nested error"" + ("while" body line 2) + invoked from within +"while {$x < 100} { + error "Nested error" + }" + (procedure "tproc" line 4) + invoked from within +"tproc"} {foo was called: x {} u}} # The tests below will really only be useful when run under Purify or # some other system that can detect accesses to freed memory... @@ -407,7 +418,7 @@ test proc-7.11 {return with special completion code} { catch {open _bad_file_name r} msg return -code error -errorinfo $errorInfo -errorcode $errorCode $msg } - string tolower [list [catch tproc2 msg] $msg $errorInfo $errorCode] + normalizeMsg [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" @@ -419,7 +430,7 @@ test proc-7.12 {return with special completion code} { catch {open _bad_file_name r} msg return -code error -errorcode $errorCode $msg } - string tolower [list [catch tproc2 msg] $msg $errorInfo $errorCode] + normalizeMsg [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}}} @@ -429,7 +440,7 @@ test proc-7.13 {return with special completion code} { catch {open _bad_file_name r} msg return -code error -errorinfo $errorInfo $msg } - string tolower [list [catch tproc2 msg] $msg $errorInfo $errorCode] + normalizeMsg [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" @@ -441,7 +452,7 @@ test proc-7.14 {return with special completion code} { catch {open _bad_file_name r} msg return -code error $msg } - string tolower [list [catch tproc2 msg] $msg $errorInfo $errorCode] + normalizeMsg [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} diff --git a/tcl7.3/tests/regexp.test b/tcl7.6/tests/regexp.test similarity index 86% rename from tcl7.3/tests/regexp.test rename to tcl7.6/tests/regexp.test index 5f0bc7c..1f1aecf 100644 --- a/tcl7.3/tests/regexp.test +++ b/tcl7.6/tests/regexp.test @@ -5,26 +5,12 @@ # 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. +# Copyright (c) 1994 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) regexp.test 1.20 96/04/02 15:03:53 if {[string compare test [info procs test]] == 1} then {source defs} @@ -64,11 +50,12 @@ test regexp-2.4 {getting substrings back from regexp} { } {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} + set f6 {}; set f7 {}; set f8 {}; set f9 {}; set fa {}; set fb {}; + list [regexp (1*)(2*)(3*)(4*)(5*)(6*)(7*)(8*)(9*)(a*)(b*) \ + 12223345556789999aabbb \ + foo f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb] $foo $f1 $f2 $f3 $f4 $f5 \ + $f6 $f7 $f8 $f9 $fa $fb +} {1 12223345556789999aabbb 1 222 33 4 555 6 7 8 9999 aa bbb} 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 @@ -78,6 +65,7 @@ test regexp-2.7 {getting substrings back from regexp} { 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 @@ -191,9 +179,12 @@ 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}} + list [catch {regexp a a f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1} msg] $msg +} {0 1} test regexp-6.7 {regexp errors} { + list [catch {regexp (x)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.) xyzzy} msg] $msg +} {1 {couldn't compile regular expression pattern: too many ()}} +test regexp-6.8 {regexp errors} { set f1 44 list [catch {regexp abc abc f1(f2)} msg] $msg } {1 {couldn't set variable "f1(f2)"}} @@ -279,11 +270,11 @@ test regexp-8.6 {case conversion in regsub} { 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|} +} {4 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|} +} {4 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 @@ -295,7 +286,7 @@ test regexp-9.4 {-all option to regsub} { 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}} +} {2 {yy yy more}} test regexp-9.6 {-all option to regsub} { set foo xxx list [regsub -all ^ xxx 123 foo] $foo diff --git a/tcl7.6/tests/remote.tcl b/tcl7.6/tests/remote.tcl new file mode 100644 index 0000000..3ede61a --- /dev/null +++ b/tcl7.6/tests/remote.tcl @@ -0,0 +1,161 @@ +# This file contains Tcl code to implement a remote server that can be +# used during testing of Tcl socket code. This server is used by some +# of the tests in socket.test. +# +# Source this file in the remote server you are using to test Tcl against. +# +# Copyright (c) 1995-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# @(#) remote.tcl 1.5 96/04/17 08:21:19" + +# Initialize message delimitor + +# Initialize command array +catch {unset command} +set command(0) "" +set callerSocket "" + +# Detect whether we should print out connection messages etc. +if {![info exists VERBOSE]} { + set VERBOSE 0 +} + +proc __doCommands__ {l s} { + global callerSocket VERBOSE + + if {$VERBOSE} { + puts "--- Server executing the following for socket $s:" + puts $l + puts "---" + } + set callerSocket $s + if {[catch {uplevel #0 $l} msg]} { + list error $msg + } else { + list success $msg + } +} + +proc __readAndExecute__ {s} { + global command VERBOSE + + set l [gets $s] + if {[string compare $l "--Marker--Marker--Marker--"] == 0} { + if {[info exists command($s)]} { + puts $s [list error incomplete_command] + } + puts $s "--Marker--Marker--Marker--" + return + } + if {[string compare $l ""] == 0} { + if {[eof $s]} { + if {$VERBOSE} { + puts "Server closing $s, eof from client" + } + close $s + } + return + } + append command($s) $l "\n" + if {[info complete $command($s)]} { + set cmds $command($s) + unset command($s) + puts $s [__doCommands__ $cmds $s] + } + if {[eof $s]} { + if {$VERBOSE} { + puts "Server closing $s, eof from client" + } + close $s + } +} + +proc __accept__ {s a p} { + global VERBOSE + + if {$VERBOSE} { + puts "Server accepts new connection from $a:$p on $s" + } + fileevent $s readable [list __readAndExecute__ $s] + fconfigure $s -buffering line -translation crlf +} + +set serverIsSilent 0 +for {set i 0} {$i < $argc} {incr i} { + if {[string compare -serverIsSilent [lindex $argv $i]] == 0} { + set serverIsSilent 1 + break + } +} +if {![info exists serverPort]} { + if {[info exists env(serverPort)]} { + set serverPort $env(serverPort) + } +} +if {![info exists serverPort]} { + for {set i 0} {$i < $argc} {incr i} { + if {[string compare -port [lindex $argv $i]] == 0} { + if {$i < [expr $argc - 1]} { + set serverPort [lindex $argv [expr $i + 1]] + } + break + } + } +} +if {![info exists serverPort]} { + set serverPort 2048 +} + +if {![info exists serverAddress]} { + if {[info exists env(serverAddress)]} { + set serverAddress $env(serverAddress) + } +} +if {![info exists serverAddress]} { + for {set i 0} {$i < $argc} {incr i} { + if {[string compare -address [lindex $argv $i]] == 0} { + if {$i < [expr $argc - 1]} { + set serverAddress [lindex $argv [expr $i + 1]] + } + break + } + } +} +if {![info exists serverAddress]} { + set serverAddress 0.0.0.0 +} + +if {$serverIsSilent == 0} { + set l "Remote server listening on port $serverPort, IP $serverAddress." + puts "" + puts $l + for {set c [string length $l]} {$c > 0} {incr c -1} {puts -nonewline "-"} + puts "" + puts "" + puts "You have set the Tcl variables serverAddress to $serverAddress and" + puts "serverPort to $serverPort. You can set these with the -address and" + puts "-port command line options, or as environment variables in your" + puts "shell." + puts "" + puts "NOTE: The tests will not work properly if serverAddress is set to" + puts "\"localhost\" or 127.0.0.1." + puts "" + puts "When you invoke tcltest to run the tests, set the variables" + puts "remoteServerPort to $serverPort and remoteServerIP to" + puts "[info hostname]. You can set these as environment variables" + puts "from the shell. The tests will not work properly if you set" + puts "remoteServerIP to \"localhost\" or 127.0.0.1." + puts "" + puts -nonewline "Type Ctrl-C to terminate--> " + flush stdout +} + +if {[catch {set serverSocket \ + [socket -myaddr $serverAddress -server __accept__ $serverPort]} msg]} { + puts "Server on $serverAddress:$serverPort cannot start: $msg" +} else { + vwait __server_wait_variable__ +} diff --git a/tcl7.6/tests/rename.test b/tcl7.6/tests/rename.test new file mode 100644 index 0000000..1613445 --- /dev/null +++ b/tcl7.6/tests/rename.test @@ -0,0 +1,131 @@ +# 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. +# Copyright (c) 1994 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) rename.test 1.13 96/03/20 10:49:22 + +if {[string compare test [info procs test]] == 1} then {source defs} + +# Must eliminate the "unknown" command while the test is running, +# especially if the test is being run in a program with its +# own special-purpose unknown command. + +catch {rename unknown unknown.old} + +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}} + +catch {rename unknown {}} +catch {rename unknown.old unknown} + +if {[info command testdel] == "testdel"} { + test rename-4.1 {reentrancy issues with command deletion and renaming} { + set x {} + testdel {} foo {lappend x deleted; rename bar {}; lappend x [info command bar]} + rename foo bar + lappend x | + rename bar {} + set x + } {| deleted {}} + test rename-4.2 {reentrancy issues with command deletion and renaming} { + set x {} + testdel {} foo {lappend x deleted; rename foo bar} + rename foo {} + set x + } {deleted} + test rename-4.3 {reentrancy issues with command deletion and renaming} { + set x {} + testdel {} foo {lappend x deleted; testdel {} foo {lappend x deleted2}} + rename foo {} + lappend x | + rename foo {} + set x + } {deleted | deleted2} + test rename-4.4 {reentrancy issues with command deletion and renaming} { + set x {} + testdel {} foo {lappend x deleted; rename foo bar} + rename foo {} + lappend x | [info command bar] + } {deleted | {}} + test rename-4.5 {reentrancy issues with command deletion and renaming} { + set env(value) before + interp create foo + testdel foo cmd {set env(value) deleted} + interp delete foo + set env(value) + } {deleted} + test rename-4.6 {reentrancy issues with command deletion and renaming} { + proc kill args { + interp delete foo + } + set env(value) before + interp create foo + foo alias kill kill + testdel foo cmd {set env(value) deleted; kill} + list [catch {foo eval {rename cmd {}}} msg] $msg $env(value) + } {0 {} deleted} + test rename-4.7 {reentrancy issues with command deletion and renaming} { + proc kill args { + interp delete foo + } + set env(value) before + interp create foo + foo alias kill kill + testdel foo cmd {set env(value) deleted; kill} + list [catch {interp delete foo} msg] $msg $env(value) + } {0 {} deleted} +} diff --git a/tcl7.6/tests/resource.test b/tcl7.6/tests/resource.test new file mode 100644 index 0000000..d3669b9 --- /dev/null +++ b/tcl7.6/tests/resource.test @@ -0,0 +1,45 @@ +# Commands covered: resource +# +# 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) 1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) resource.test 1.1 96/10/08 14:35:23 + +# Only run this test on Macintosh systems +if {$tcl_platform(platform) != "macintosh"} { + return +} +if {[string compare test [info procs test]] == 1} then {source defs} + +test resource-1.1 {resource tests} { + list [catch {resource} msg] $msg +} {1 {wrong # args: should be "resource option ?arg ...?"}} +test resource-1.2 {resource tests} { + list [catch {resource _bad_} msg] $msg +} {1 {unknown option "_bad_": should be close, getSTR, getSTR#, getTEXT, list, open or types}} + +# resource open & close tests +test resource-2.1 {resource open & close tests} { + list [catch {resource open} msg] $msg +} {1 {wrong # args: should be "resource open fileName"}} +test resource-2.2 {resource open & close tests} { + list [catch {resource open _bad_file_} msg] $msg +} {1 {path doesn't lead to a file}} +test resource-2.3 {resource open & close tests} { + testWriteTextResource -rsrc fileRsrcName -file rsrc.file {error "don't source me"} + set id [resource open rsrc.file] + resource close $id +} {} +test resource-2.4 {resource open & close tests} { + list [catch {resource close _bad_resource_} msg] $msg +} {1 {invalid resource file reference "_bad_resource_"}} + +# Clean up and return +catch {file delete rsrc.file} +return diff --git a/tcl7.3/tests/scan.test b/tcl7.6/tests/scan.test similarity index 84% rename from tcl7.3/tests/scan.test rename to tcl7.6/tests/scan.test index c0219d5..7b7644b 100644 --- a/tcl7.3/tests/scan.test +++ b/tcl7.6/tests/scan.test @@ -4,27 +4,13 @@ # 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. +# Copyright (c) 1991-1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) scan.test 1.24 96/08/06 13:55:45 if {[string compare test [info procs test]] == 1} then {source defs} @@ -69,12 +55,15 @@ 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} -} +# +# The behavior for scaning intergers larger than MAX_INT is +# not defined by the ANSI spec. Some implementations wrap the +# input (-16) some return MAX_INT. +# +test scan-1.11 {integer scanning} {nonPortable} { + 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 {} @@ -88,29 +77,27 @@ 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} { +# +# Some libc implementations consider 3.e- bad input. The ANSI +# spec states that digits must follow the - sign. +# +test scan-2.4 {floating-point scanning} {nonPortable} { + 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 {}; 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} { +test scan-2.6 {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} { +test scan-2.7 {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} { +test scan-2.8 {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 {} {}} @@ -208,6 +195,9 @@ 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-4.20 {error conditions} { + list [catch {scan abc {%[}} msg] $msg +} {1 {unmatched [ in format string}} 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 diff --git a/tcl7.3/tests/set.test b/tcl7.6/tests/set.test similarity index 78% rename from tcl7.3/tests/set.test rename to tcl7.6/tests/set.test index f8622e3..8a8d887 100644 --- a/tcl7.3/tests/set.test +++ b/tcl7.6/tests/set.test @@ -5,26 +5,12 @@ # 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. +# Copyright (c) 1994-1995 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) set.test 1.18 96/02/16 08:56:25 if {[string compare test [info procs test]] == 1} then {source defs} @@ -73,7 +59,7 @@ test set-2.5 {basic array operations} { } {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}} +} {1 {can't read "a": variable is array}} test set-2.7 {basic array operations} { format %s $a(44) } 3 @@ -94,13 +80,10 @@ test set-2.11 {basic array operations} { 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} { +test set-2.13 {basic array operations} { list [catch {set a(xyz)} msg] $msg } {1 {can't read "a(xyz)": no such variable}} @@ -139,7 +122,7 @@ 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}} +} {0 {}} test set-4.4 {parsing array names} { catch {unset a abcd)} set abcd) 33 @@ -176,7 +159,7 @@ 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}} +} {1 {can't read "a": variable is array}} # Errors and other special cases in writing variables @@ -276,7 +259,7 @@ test set-7.11 {unset command} { 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}} +} {1 {can't read "a(14)": no such variable} 0 {}} # Array command. @@ -284,64 +267,174 @@ 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}} + list [catch {array a} msg] $msg +} {1 {wrong # args: should be "array option arrayName ?arg ...?"}} test set-8.3 {array command} { catch {unset a} - set a 44 - list [catch {array names a} msg] $msg + list [catch {array anymore a b} 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} { + set a 44 + list [catch {array anymore a b} msg] $msg +} {1 {"a" isn't an array}} +test set-8.5 {array command} { + proc foo {} { + set a 44 + upvar 0 a x + list [catch {array anymore x b} msg] $msg + } + foo +} {1 {"x" isn't an array}} +test set-8.6 {array command} { 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} { + list [catch {array gorp a} msg] $msg +} {1 {bad option "gorp": should be anymore, donesearch, exists, get, names, nextelement, set, size, or startsearch}} +test set-8.7 {array command, anymore option} { + catch {unset a} + list [catch {array anymore a x} msg] $msg +} {1 {"a" isn't an array}} +test set-8.8 {array command, donesearch option} { + catch {unset a} + list [catch {array donesearch a x} msg] $msg +} {1 {"a" isn't an array}} +test set-8.9 {array command, exists option} { + list [catch {array exists a b} msg] $msg +} {1 {wrong # args: should be "array exists arrayName"}} +test set-8.10 {array command, exists option} { + catch {unset a} + array exists a +} {0} +test set-8.11 {array command, exists option} { + catch {unset a} + set a(0) 1 + array exists a +} {1} +test set-8.12 {array command, get option} { + list [catch {array get} msg] $msg +} {1 {wrong # args: should be "array option arrayName ?arg ...?"}} +test set-8.13 {array command, get option} { + list [catch {array get a b c} msg] $msg +} {1 {wrong # args: should be "array get arrayName ?pattern?"}} +test set-8.14 {array command, get option} { + catch {unset a} + array get a +} {} +test set-8.15 {array command, get option} { + catch {unset a} + set a(22) 3 + set {a(long name)} {} + array get a +} {22 3 {long name} {}} +test set-8.16 {array command, get option (unset variable)} { + catch {unset a} + set a(x) 3 + trace var a(y) w ignore + array get a +} {x 3} +test set-8.17 {array command, get option, with pattern} { + catch {unset a} + set a(x1) 3 + set a(x2) 4 + set a(x3) 5 + set a(b1) 24 + set a(b2) 25 + array get a x* +} {x1 3 x2 4 x3 5} +test set-8.18 {array command, names option} { + catch {unset a} + set a(22) 3 + list [catch {array names a 4 5} msg] $msg +} {1 {wrong # args: should be "array names arrayName ?pattern?"}} +test set-8.19 {array command, names option} { + catch {unset a} + array names a +} {} +test set-8.20 {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} { +test set-8.21 {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} { +test set-8.22 {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} { +test set-8.23 {array command, names option} { catch {unset a} - set a(22) 3 + set a(axy) 3 + set a(bxy) 44 + set a(no) yes + set a(xxx) value + list [lsort [array names a *xy]] [lsort [array names a]] +} {{axy bxy} {axy bxy no xxx}} +test set-8.24 {array command, nextelement option} { + list [catch {array nextelement a} msg] $msg +} {1 {wrong # args: should be "array nextelement arrayName searchId"}} +test set-8.25 {array command, nextelement option} { + catch {unset a} + list [catch {array nextelement a b} msg] $msg +} {1 {"a" isn't an array}} +test set-8.26 {array command, set option} { + list [catch {array set a} msg] $msg +} {1 {wrong # args: should be "array set arrayName list"}} +test set-8.27 {array command, set option} { + list [catch {array set a 1 2} msg] $msg +} {1 {wrong # args: should be "array set arrayName list"}} +test set-8.28 {array command, set option} { + list [catch {array set a "a \{ c"} msg] $msg +} {1 {unmatched open brace in list}} +test set-8.29 {array command, set option} { + catch {unset a} + set a 44 + list [catch {array set a {a b c d}} msg] $msg +} {1 {can't set "a(a)": variable isn't array}} +test set-8.30 {array command, set option} { + catch {unset a} + set a(xx) yy + array set a {b c d e} + array get a +} {d e xx yy b c} +test set-8.31 {array command, size option} { list [catch {array size a 4} msg] $msg } {1 {wrong # args: should be "array size arrayName"}} -test set-8.10 {array command, size option} { +test set-8.32 {array command, size option} { + catch {unset a} + array size a +} {0} +test set-8.33 {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} { +test set-8.34 {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} { +test set-8.35 {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-8.36 {array command, startsearch option} { + list [catch {array startsearch a b} msg] $msg +} {1 {wrong # args: should be "array startsearch arrayName"}} +test set-8.37 {array command, startsearch option} { + catch {unset a} + list [catch {array startsearch a} msg] $msg +} {1 {"a" isn't an array}} test set-9.1 {ids for array enumeration} { catch {unset a} diff --git a/tcl7.6/tests/socket.test b/tcl7.6/tests/socket.test new file mode 100644 index 0000000..6982166 --- /dev/null +++ b/tcl7.6/tests/socket.test @@ -0,0 +1,1289 @@ +# Commands tested in this file: socket. +# +# 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) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# Running socket tests with a remote server: +# ------------------------------------------ +# +# Some tests in socket.test depend on the existence of a remote server to +# which they connect. The remote server must be an instance of tcltest and it +# must run the script found in the file "remote.tcl" in this directory. You +# can start the remote server on any machine reachable from the machine on +# which you want to run the socket tests, by issuing: +# +# tcltest remote.tcl -port 2048 # Or choose another port number. +# +# If the machine you are running the remote server on has several IP +# interfaces, you can choose which interface the server listens on for +# connections by specifying the -address command line flag, so: +# +# tcltest remote.tcl -address your.machine.com +# +# These options can also be set by environment variables. On Unix, you can +# type these commands to the shell from which the remote server is started: +# +# shell% setenv serverPort 2048 +# shell% setenv serverAddress your.machine.com +# +# and subsequently you can start the remote server with: +# +# tcltest remote.tcl +# +# to have it listen on port 2048 on the interface your.machine.com. +# +# When the server starts, it prints out a detailed message containing its +# configuration information, and it will block until killed with a Ctrl-C. +# Once the remote server exists, you can run the tests in socket.test with +# the server by setting two Tcl variables: +# +# % set remoteServerIP +# % set remoteServerPort 2048 +# +# These variables are also settable from the environment. On Unix, you can: +# +# shell% setenv remoteServerIP machine.where.server.runs +# shell% senetv remoteServerPort 2048 +# +# The preamble of the socket.test file checks to see if the variables are set +# either in Tcl or in the environment; if they are, it attempts to connect to +# the server. If the connection is successful, the tests using the remote +# server will be performed; otherwise, it will attempt to start the remote +# server (via exec) on platforms that support this, on the local host, +# listening at port 2048. If all fails, a message is printed and the tests +# using the remote server are not performed. +# +# SCCS: @(#) socket.test 1.62 96/08/01 15:57:49 + +if {[string compare test [info procs test]] == 1} then {source defs} + +# +# If remoteServerIP or remoteServerPort are not set, check in the +# environment variables for externally set values. +# + +if {![info exists remoteServerIP]} { + if {[info exists env(remoteServerIP)]} { + set remoteServerIP $env(remoteServerIP) + } +} +if {![info exists remoteServerPort]} { + if {[info exists env(remoteServerIP)]} { + set remoteServerPort $env(remoteServerPort) + } else { + if {[info exists remoteServerIP]} { + set remoteServerPort 2048 + } + } +} + +# +# Check if we're supposed to do tests against the remote server +# + +set doTestsWithRemoteServer 1 +if {![info exists remoteServerIP] && ($tcl_platform(platform) != "macintosh")} { + set remoteServerIP localhost +} +if {($doTestsWithRemoteServer == 1) && (![info exists remoteServerPort])} { + set remoteServerPort 2048 +} + +# Attempt to connect to a remote server if one is already running. If it +# is not running or for some other reason the connect fails, attempt to +# start the remote server on the local host listening on port 2048. This +# is only done on platforms that support exec (i.e. not on the Mac). On +# platforms that do not support exec, the remote server must be started +# by the user before running the tests. + +set remoteProcChan "" +set commandSocket "" +if {$doTestsWithRemoteServer == 1} { + catch {close $commandSocket} + if {[catch {set commandSocket [socket $remoteServerIP \ + $remoteServerPort]}] != 0} { + if {[info commands exec] == ""} { + set noRemoteTestReason "can't exec" + set doTestsWithRemoteServer 0 + } else { + set remoteServerIP localhost + if {[catch {set remoteProcChan \ + [open "|$tcltest remote.tcl \ + -serverIsSilent \ + -port $remoteServerPort \ + -address $remoteServerIP" \ + w+]} \ + msg] == 0} { + after 1000 + if {[catch {set commandSocket [socket $remoteServerIP \ + $remoteServerPort]} msg] == 0} { + fconfigure $commandSocket -translation crlf -buffering line + } else { + set noRemoteTestReason $msg + set doTestsWithRemoteServer 0 + } + } else { + set noRemoteTestReason "$msg $tcltest" + set doTestsWithRemoteServer 0 + } + } + } else { + fconfigure $commandSocket -translation crlf -buffering line + } +} + +if {$doTestsWithRemoteServer == 0} { + puts "Skipping tests with remote server. See tests/socket.test for" + puts "information on how to run remote server." + if {[info exists VERBOSE] && ($VERBOSE != 0)} { + puts "Reason for not doing remote tests: $noRemoteTestReason" + } +} + +# +# If we do the tests, define a command to send a command to the +# remote server. +# + +if {$doTestsWithRemoteServer == 1} { + proc sendCommand {c} { + global commandSocket + + if {[eof $commandSocket]} { + error "remote server disappeared" + } + + if {[catch {puts $commandSocket $c} msg]} { + error "remote server disappaered: $msg" + } + if {[catch {puts $commandSocket "--Marker--Marker--Marker--"} msg]} { + error "remote server disappeared: $msg" + } + + set resp "" + while {1} { + set line [gets $commandSocket] + if {[eof $commandSocket]} { + error "remote server disappaered" + } + if {[string compare $line "--Marker--Marker--Marker--"] == 0} { + if {[string compare [lindex $resp 0] error] == 0} { + error [lindex $resp 1] + } else { + return [lindex $resp 1] + } + } else { + append resp $line "\n" + } + } + } +} + +test socket-1.1 {arg parsing for socket command} { + list [catch {socket -server} msg] $msg +} {1 {no argument given for -server option}} +test socket-1.2 {arg parsing for socket command} { + list [catch {socket -server foo} msg] $msg +} {1 {wrong # args: should be either: +socket ?-myaddr addr? ?-myport myport? ?-async? host port +socket -server command ?-myaddr addr? port}} +test socket-1.3 {arg parsing for socket command} { + list [catch {socket -myaddr} msg] $msg +} {1 {no argument given for -myaddr option}} +test socket-1.4 {arg parsing for socket command} { + list [catch {socket -myaddr 127.0.0.1} msg] $msg +} {1 {wrong # args: should be either: +socket ?-myaddr addr? ?-myport myport? ?-async? host port +socket -server command ?-myaddr addr? port}} +test socket-1.5 {arg parsing for socket command} { + list [catch {socket -myport} msg] $msg +} {1 {no argument given for -myport option}} +test socket-1.6 {arg parsing for socket command} { + list [catch {socket -myport xxxx} msg] $msg +} {1 {expected integer but got "xxxx"}} +test socket-1.7 {arg parsing for socket command} { + list [catch {socket -myport 2522} msg] $msg +} {1 {wrong # args: should be either: +socket ?-myaddr addr? ?-myport myport? ?-async? host port +socket -server command ?-myaddr addr? port}} +test socket-1.8 {arg parsing for socket command} { + list [catch {socket -froboz} msg] $msg +} {1 {bad option "-froboz", must be -async, -myaddr, -myport, or -server}} +test socket-1.9 {arg parsing for socket command} { + list [catch {socket -server foo -myport 2521 3333} msg] $msg +} {1 {Option -myport is not valid for servers}} +test socket-1.10 {arg parsing for socket command} { + list [catch {socket host 2528 -junk} msg] $msg +} {1 {wrong # args: should be either: +socket ?-myaddr addr? ?-myport myport? ?-async? host port +socket -server command ?-myaddr addr? port}} +test socket-1.11 {arg parsing for socket command} { + list [catch {socket -server callback 2520 --} msg] $msg +} {1 {wrong # args: should be either: +socket ?-myaddr addr? ?-myport myport? ?-async? host port +socket -server command ?-myaddr addr? port}} +test socket-1.12 {arg parsing for socket command} { + list [catch {socket foo badport} msg] $msg +} {1 {expected integer but got "badport"}} + +test socket-2.1 {tcp connection} {unixOrPc} { + removeFile script + set f [open script w] + puts $f { + set f [socket -server accept 2828] + proc accept {file addr port} { + global x + set x done + close $file + } + puts ready + vwait x + close $f + puts done + } + close $f + set f [open "|$tcltest script" r] + gets $f x + if {[catch {socket localhost 2828} msg]} { + set x $msg + } else { + lappend x [gets $f] + close $msg + } + lappend x [gets $f] + close $f + set x +} {ready done {}} + +if [info exists port] { + incr port +} else { + set port [expr 2048 + [pid]%1024] +} +test socket-2.2 {tcp connection with client port specified} {unixOrPc} { + removeFile script + set f [open script w] + puts $f { + set f [socket -server accept 2828] + proc accept {file addr port} { + global x + puts "[gets $file] $port" + close $file + set x done + } + puts ready + vwait x + close $f + } + close $f + set f [open "|$tcltest script" r] + gets $f x + global port + if {[catch {socket -myport $port localhost 2828} sock]} { + set x $sock + close [socket localhost 2828] + puts stderr $sock + } else { + puts $sock hello + flush $sock + lappend x [gets $f] + close $sock + } + close $f + set x +} [list ready "hello $port"] +test socket-2.3 {tcp connection with client interface specified} {unixOrPc} { + removeFile script + set f [open script w] + puts $f { + set f [socket -server accept 2828] + proc accept {file addr port} { + global x + puts "[gets $file] $addr" + close $file + set x done + } + puts ready + vwait x + close $f + } + close $f + set f [open "|$tcltest script" r] + gets $f x + if {[catch {socket -myaddr localhost localhost 2828} sock]} { + set x $sock + } else { + puts $sock hello + flush $sock + lappend x [gets $f] + close $sock + } + close $f + set x +} {ready {hello 127.0.0.1}} +test socket-2.4 {tcp connection with server interface specified} {unixOrPc} { + removeFile script + set f [open script w] + puts $f { + set f [socket -server accept -myaddr [info hostname] 2828] + proc accept {file addr port} { + global x + puts "[gets $file]" + close $file + set x done + } + puts ready + vwait x + close $f + } + close $f + set f [open "|$tcltest script" r] + gets $f x + if {[catch {socket [info hostname] 2828} sock]} { + set x $sock + } else { + puts $sock hello + flush $sock + lappend x [gets $f] + close $sock + } + close $f + set x +} {ready hello} +test socket-2.5 {tcp connection with redundant server port} {unixOrPc} { + removeFile script + set f [open script w] + puts $f { + set f [socket -server accept 2828] + proc accept {file addr port} { + global x + puts "[gets $file]" + close $file + set x done + } + puts ready + vwait x + close $f + } + close $f + set f [open "|$tcltest script" r] + gets $f x + if {[catch {socket localhost 2828} sock]} { + set x $sock + } else { + puts $sock hello + flush $sock + lappend x [gets $f] + close $sock + } + close $f + set x +} {ready hello} +test socket-2.6 {tcp connection} {unixOrPc} { + set status ok + if {![catch {set sock [socket localhost 2828]}]} { + if {![catch {gets $sock}]} { + set status broken + } + close $sock + } + set status +} ok +test socket-2.7 {echo server, one line} {unixOrPc} { + removeFile script + set f [open script w] + puts $f { + set f [socket -server accept 2828] + proc accept {s a p} { + fileevent $s readable [list echo $s] + fconfigure $s -translation lf -buffering line + } + proc echo {s} { + set l [gets $s] + if {[eof $s]} { + global x + close $s + set x done + } else { + puts $s $l + } + } + puts ready + vwait x + close $f + puts done + } + close $f + set f [open "|$tcltest script" r] + gets $f + set s [socket localhost 2828] + fconfigure $s -buffering line -translation lf + puts $s "hello abcdefghijklmnop" + set x [gets $s] + close $s + set y [gets $f] + close $f + list $x $y +} {{hello abcdefghijklmnop} done} +test socket-2.8 {echo server, loop 50 times, single connection} {unixOrPc} { + removeFile script + set f [open script w] + puts $f { + set f [socket -server accept 2828] + proc accept {s a p} { + fileevent $s readable [list echo $s] + fconfigure $s -buffering line + } + proc echo {s} { + global i + set l [gets $s] + if {[eof $s]} { + global x + close $s + set x done + } else { + incr i + puts $s $l + } + } + set i 0 + puts ready + vwait x + close $f + puts "done $i" + } + close $f + set f [open "|$tcltest script" r] + gets $f + set s [socket localhost 2828] + fconfigure $s -buffering line + for {set x 0} {$x < 50} {incr x} { + puts $s "hello abcdefghijklmnop" + gets $s + } + close $s + set x [gets $f] + close $f + set x +} {done 50} +test socket-2.9 {socket conflict} {unixOrPc} { + set s [socket -server accept 2828] + removeFile script + set f [open script w] + puts $f {set f [socket -server accept 2828]} + close $f + set f [open "|$tcltest script" r] + gets $f + after 100 + set x [list [catch {close $f} msg] $msg] + close $s + set x +} {1 {couldn't open socket: address already in use + while executing +"socket -server accept 2828" + invoked from within +"set f [socket -server accept 2828]..." + (file "script" line 1)}} +test socket-2.10 {close on accept, accepted socket lives} { + set done 0 + set ss [socket -server accept 2828] + proc accept {s a p} { + global ss + close $ss + fileevent $s readable "readit $s" + fconfigure $s -trans lf + } + proc readit {s} { + global done + gets $s + close $s + set done 1 + } + set cs [socket [info hostname] 2828] + puts $cs hello + close $cs + vwait done + set done +} 1 + +test socket-3.1 {socket conflict} {unixOrPc} { + removeFile script + set f [open script w] + puts $f { + set f [socket -server accept 2828] + puts ready + gets stdin + close $f + } + close $f + set f [open "|$tcltest script" r+] + gets $f + set x [list [catch {socket -server accept 2828} msg] \ + $msg] + puts $f bye + close $f + set x +} {1 {couldn't open socket: address already in use}} +test socket-3.2 {server with several clients} {unixOrPc} { + removeFile script + set f [open script w] + puts $f { + set counter 0 + set s [socket -server accept 2828] + proc accept {s a p} { + fileevent $s readable [list echo $s] + fconfigure $s -buffering line + } + proc echo {s} { + global x + set l [gets $s] + if {[eof $s]} { + close $s + set x done + } else { + puts $s $l + } + } + puts ready + vwait x + vwait x + vwait x + close $s + puts done + } + close $f + set f [open "|$tcltest script" r+] + set x [gets $f] + set s1 [socket localhost 2828] + fconfigure $s1 -buffering line + set s2 [socket localhost 2828] + fconfigure $s2 -buffering line + set s3 [socket localhost 2828] + fconfigure $s3 -buffering line + for {set i 0} {$i < 100} {incr i} { + puts $s1 hello,s1 + gets $s1 + puts $s2 hello,s2 + gets $s2 + puts $s3 hello,s3 + gets $s3 + } + close $s1 + close $s2 + close $s3 + lappend x [gets $f] + close $f + set x +} {ready done} + +test socket-4.1 {server with several clients} {unixOrPc} { + removeFile script + set f [open script w] + puts $f { + gets stdin + set s [socket localhost 2828] + fconfigure $s -buffering line + for {set i 0} {$i < 100} {incr i} { + puts $s hello + gets $s + } + close $s + puts bye + gets stdin + } + close $f + set p1 [open "|$tcltest script" r+] + fconfigure $p1 -buffering line + set p2 [open "|$tcltest script" r+] + fconfigure $p2 -buffering line + set p3 [open "|$tcltest script" r+] + fconfigure $p3 -buffering line + proc accept {s a p} { + fconfigure $s -buffering line + fileevent $s readable [list echo $s] + } + proc echo {s} { + global x + set l [gets $s] + if {[eof $s]} { + close $s + set x done + } else { + puts $s $l + } + } + set s [socket -server accept 2828] + puts $p1 open + puts $p2 open + puts $p3 open + vwait x + vwait x + vwait x + close $s + set l "" + lappend l [list p1 [gets $p1]] + lappend l [list p2 [gets $p2]] + lappend l [list p3 [gets $p3]] + puts $p1 bye + puts $p2 bye + puts $p3 bye + close $p1 + close $p2 + close $p3 + set l +} {{p1 bye} {p2 bye} {p3 bye}} +test socket-4.2 {byte order problems, socket numbers, htons} { + set x ok + if {[catch {socket -server dodo 0x3000} msg]} { + set x $msg + } else { + close $msg + } + set x +} ok + +test socket-5.1 {byte order problems, socket numbers, htons} {unixOnly} { + # + # THIS TEST WILL FAIL if you are running as superuser. + # + set x {couldn't open socket: not owner} + if {![catch {socket -server dodo 0x1} msg]} { + set x {htons problem, should be disallowed, are you running as SU?} + close $msg + } + set x +} {couldn't open socket: not owner} +test socket-5.2 {byte order problems, socket numbers, htons} { + set x {couldn't open socket: port number too high} + if {![catch {socket -server dodo 0x10000} msg]} { + set x {port resolution problem, should be disallowed} + close $msg + } + set x +} {couldn't open socket: port number too high} +test socket-5.3 {byte order problems, socket numbers, htons} {unixOnly} { + # + # THIS TEST WILL FAIL if you are running as superuser. + # + set x {couldn't open socket: not owner} + if {![catch {socket -server dodo 21} msg]} { + set x {htons problem, should be disallowed, are you running as SU?} + close $msg + } + set x +} {couldn't open socket: not owner} + +test socket-6.1 {accept callback error} {unixOrPc} { + removeFile script + set f [open script w] + puts $f { + gets stdin + socket localhost 2848 + } + close $f + set f [open "|$tcltest script" r+] + proc bgerror args { + global x + set x $args + } + proc accept {s a p} {expr 10 / 0} + set s [socket -server accept 2848] + puts $f hello + close $f + vwait x + close $s + rename bgerror {} + set x +} {{divide by zero}} + +test socket-7.1 {testing socket specific options} {unixOrPc} { + removeFile script + set f [open script w] + puts $f { + socket -server accept 2828 + proc accept args { + global x + set x done + } + puts ready + vwait x + } + close $f + set f [open "|$tcltest script" r] + gets $f + set s [socket localhost 2828] + set p [fconfigure $s -peername] + close $s + close $f + set l "" + lappend l [string compare [lindex $p 0] 127.0.0.1] + lappend l [string compare [lindex $p 2] 2828] + lappend l [llength $p] +} {0 0 3} +test socket-7.2 {testing socket specific options} {unixOrPc} { + removeFile script + set f [open script w] + puts $f { + socket -server accept 2828 + proc accept args { + global x + set x done + } + puts ready + vwait x + } + close $f + set f [open "|$tcltest script" r] + gets $f + set s [socket localhost 2828] + set p [fconfigure $s -sockname] + close $s + close $f + set l "" + lappend l [llength $p] + lappend l [lindex $p 0] + lappend l [expr [lindex $p 2] == 2828] +} {3 127.0.0.1 0} +test socket-7.3 {testing socket specific options} { + set s [socket -server accept 2828] + set l [fconfigure $s] + close $s + llength $l +} 10 +test socket-7.4 {testing socket specific options} { + set s [socket -server accept 2828] + proc accept {s a p} { + global x + set x [fconfigure $s -sockname] + close $s + } + set s1 [socket [info hostname] 2828] + vwait x + close $s + close $s1 + set l "" + lappend l [lindex $x 2] [llength $x] +} {2828 3} +test socket-7.5 {testing socket specific options} {unixOrPc} { + set s [socket -server accept 2829] + proc accept {s a p} { + global x + set x [fconfigure $s -sockname] + close $s + } + set s1 [socket localhost 2829] + vwait x + close $s + close $s1 + set l "" + lappend l [lindex $x 0] [lindex $x 2] [llength $x] +} {127.0.0.1 2829 3} + +test socket-8.1 {testing -async flag on sockets} { + # NOTE: This test may fail on some Solaris 2.4 systems. If it does, + # check that you have these patches installed (using showrev -p): + # + # 101907-05, 101925-02, 101945-14, 101959-03, 101969-05, 101973-03, + # 101977-03, 101981-02, 101985-01, 102001-03, 102003-01, 102007-01, + # 102011-02, 102024-01, 102039-01, 102044-01, 102048-01, 102062-03, + # 102066-04, 102070-01, 102105-01, 102153-03, 102216-01, 102232-01, + # 101878-03, 101879-01, 101880-03, 101933-01, 101950-01, 102030-01, + # 102057-08, 102140-01, 101920-02, 101921-09, 101922-07, 101923-03 + # + # If after installing these patches you are still experiencing a + # problem, please email jyl@eng.sun.com. We have not observed this + # failure on Solaris 2.5, so another option (instead of installing + # these patches) is to upgrade to Solaris 2.5. + set s [socket -server accept 2830] + proc accept {s a p} { + global x + puts $s bye + close $s + set x done + } + set s1 [socket -async [info hostname] 2830] + vwait x + set z [gets $s1] + close $s + close $s1 + set z +} bye + +test socket-9.1 {testing spurious events} { + set len 0 + set spurious 0 + set done 0 + proc readlittle {s} { + global spurious done len + set l [read $s 1] + if {[string length $l] == 0} { + if {![eof $s]} { + incr spurious + } else { + close $s + set done 1 + } + } else { + incr len [string length $l] + } + } + proc accept {s a p} { + fconfigure $s -buffering none -blocking off + fileevent $s readable [list readlittle $s] + } + set s [socket -server accept 2831] + set c [socket [info hostname] 2831] + puts -nonewline $c 01234567890123456789012345678901234567890123456789 + close $c + vwait done + close $s + list $spurious $len +} {0 50} +test socket-9.2 {testing async write, fileevents, flush on close} { + set firstblock "" + for {set i 0} {$i < 5} {incr i} {set firstblock "a$firstblock$firstblock"} + set secondblock "" + for {set i 0} {$i < 16} {incr i} { + set secondblock "b$secondblock$secondblock" + } + set l [socket -server accept 2832] + proc accept {s a p} { + fconfigure $s -blocking 0 -translation lf -buffersize 16384 \ + -buffering line + fileevent $s readable "readable $s" + } + proc readable {s} { + set l [gets $s] + fileevent $s readable {} + after 1000 respond $s + } + proc respond {s} { + global firstblock + puts -nonewline $s $firstblock + after 1000 writedata $s + } + proc writedata {s} { + global secondblock + puts -nonewline $s $secondblock + close $s + } + set s [socket [info hostname] 2832] + fconfigure $s -blocking 0 -trans lf -buffering line + set count 0 + puts $s hello + proc readit {s} { + global count done + set l [read $s] + incr count [string length $l] + if {[eof $s]} { + close $s + set done 1 + } + } + fileevent $s readable "readit $s" + vwait done + close $l + set count +} 65566 +test socket-9.3 {testing EOF stickyness} { + proc count_to_eof {s} { + global count done timer + set l [gets $s] + if {[eof $s]} { + incr count + if {$count > 9} { + close $s + set done true + set count {eof is sticky} + after cancel $timer + } + } + } + proc timerproc {} { + global done count c + set done true + set count {timer went off, eof is not sticky} + close $c + } + set count 0 + set done false + proc write_then_close {s} { + puts $s bye + close $s + } + proc accept {s a p} { + fileevent $s writable "write_then_close $s" + } + set s [socket -server accept 2833] + set c [socket [info hostname] 2833] + fconfigure $c -blocking off + fileevent $c readable "count_to_eof $c" + set timer [after 1000 timerproc] + vwait done + close $s + set count +} {eof is sticky} + +removeFile script + +# +# The rest of the tests are run only if we are doing testing against +# a remote server. +# + +if {$doTestsWithRemoteServer == 0} { + return +} + +test socket-10.1 {tcp connection} { + sendCommand { + set socket9_1_test_server [socket -server accept 2834] + proc accept {s a p} { + puts $s done + close $s + } + } + set s [socket $remoteServerIP 2834] + set r [gets $s] + close $s + sendCommand {close $socket9_1_test_server} + set r +} done +test socket-10.2 {client specifies its port} { + if {[info exists port]} { + incr port + } else { + set port [expr 2048 + [pid]%1024] + } + sendCommand { + set socket9_2_test_server [socket -server accept 2835] + proc accept {s a p} { + puts $s $p + close $s + } + } + set s [socket -myport $port $remoteServerIP 2835] + set r [gets $s] + close $s + sendCommand {close $socket9_2_test_server} + if {$r == $port} { + set result ok + } else { + set result broken + } + set result +} ok +# +# Tests io-10.3, io-10.4 have been removed. +# +test socket-10.5 {trying to connect, no server} { + set status ok + if {![catch {set s [socket $remoteServerIp 2836]}]} { + if {![catch {gets $s}]} { + set status broken + } + close $s + } + set status +} ok +test socket-10.6 {remote echo, one line} { + sendCommand { + set socket10_6_test_server [socket -server accept 2836] + proc accept {s a p} { + fileevent $s readable [list echo $s] + fconfigure $s -buffering line -translation crlf + } + proc echo {s} { + set l [gets $s] + if {[eof $s]} { + close $s + } else { + puts $s $l + } + } + } + set f [socket $remoteServerIP 2836] + fconfigure $f -translation crlf -buffering line + puts $f hello + set r [gets $f] + close $f + sendCommand {close $socket10_6_test_server} + set r +} hello +test socket-10.7 {remote echo, 50 lines} { + sendCommand { + set socket10_7_test_server [socket -server accept 2836] + proc accept {s a p} { + fileevent $s readable [list echo $s] + fconfigure $s -buffering line -translation crlf + } + proc echo {s} { + set l [gets $s] + if {[eof $s]} { + close $s + } else { + puts $s $l + } + } + } + set f [socket $remoteServerIP 2836] + fconfigure $f -translation crlf -buffering line + for {set cnt 0} {$cnt < 50} {incr cnt} { + puts $f "hello, $cnt" + if {[string compare [gets $f] "hello, $cnt"] != 0} { + break + } + } + close $f + sendCommand {close $socket10_7_test_server} + set cnt +} 50 +# Macintosh sockets can have more than one server per port +if {$tcl_platform(platform) == "macintosh"} { + set conflictResult {0 2836} +} else { + set conflictResult {1 {couldn't open socket: address already in use}} +} +test socket-10.8 {socket conflict} { + set s1 [socket -server accept 2836] + if {[catch {set s2 [socket -server accept 2836]} msg]} { + set result [list 1 $msg] + } else { + set result [list 0 [lindex [fconfigure $s2 -sockname] 2]] + close $s2 + } + close $s1 + set result +} $conflictResult +test socket-10.9 {server with several clients} { + sendCommand { + set socket10_9_test_server [socket -server accept 2836] + proc accept {s a p} { + fconfigure $s -buffering line + fileevent $s readable [list echo $s] + } + proc echo {s} { + set l [gets $s] + if {[eof $s]} { + close $s + } else { + puts $s $l + } + } + } + set s1 [socket $remoteServerIP 2836] + fconfigure $s1 -buffering line + set s2 [socket $remoteServerIP 2836] + fconfigure $s2 -buffering line + set s3 [socket $remoteServerIP 2836] + fconfigure $s3 -buffering line + for {set i 0} {$i < 100} {incr i} { + puts $s1 hello,s1 + gets $s1 + puts $s2 hello,s2 + gets $s2 + puts $s3 hello,s3 + gets $s3 + } + close $s1 + close $s2 + close $s3 + sendCommand {close $socket10_9_test_server} + set i +} 100 +test socket-10.10 {client with several servers} { + sendCommand { + set s1 [socket -server "accept 3000" 3000] + set s2 [socket -server "accept 3001" 3001] + set s3 [socket -server "accept 3002" 3002] + proc accept {mp s a p} { + puts $s $mp + close $s + } + } + set s1 [socket $remoteServerIP 3000] + set s2 [socket $remoteServerIP 3001] + set s3 [socket $remoteServerIP 3002] + set l "" + lappend l [gets $s1] [gets $s1] [eof $s1] [gets $s2] [gets $s2] [eof $s2] \ + [gets $s3] [gets $s3] [eof $s3] + close $s1 + close $s2 + close $s3 + sendCommand { + close $s1 + close $s2 + close $s3 + } + set l +} {3000 {} 1 3001 {} 1 3002 {} 1} +test socket-10.11 {accept callback error} { + set s [socket -server accept 2836] + proc accept {s a p} {expr 10 / 0} + proc bgerror args { + global x + set x $args + } + if {[catch {sendCommand { + set peername [fconfigure $callerSocket -peername] + set s [socket [lindex $peername 0] 2836] + close $s + }} msg]} { + close $s + error $msg + } + vwait x + close $s + rename bgerror {} + set x +} {{divide by zero}} +test socket-10.12 {testing socket specific options} { + sendCommand { + set socket10_12_test_server [socket -server accept 2836] + proc accept {s a p} {close $s} + } + set s [socket $remoteServerIP 2836] + set p [fconfigure $s -peername] + set n [fconfigure $s -sockname] + set l "" + lappend l [lindex $p 2] [llength $p] [llength $p] + close $s + sendCommand {close $socket10_12_test_server} + set l +} {2836 3 3} +test socket-10.13 {testing spurious events} { + sendCommand { + set socket10_13_test_server [socket -server accept 2836] + proc accept {s a p} { + fconfigure $s -translation "auto lf" + after 100 writesome $s + } + proc writesome {s} { + for {set i 0} {$i < 100} {incr i} { + puts $s "line $i from remote server" + } + close $s + } + } + set len 0 + set spurious 0 + set done 0 + proc readlittle {s} { + global spurious done len + set l [read $s 1] + if {[string length $l] == 0} { + if {![eof $s]} { + incr spurious + } else { + close $s + set done 1 + } + } else { + incr len [string length $l] + } + } + set c [socket [info hostname] 2836] + fileevent $c readable "readlittle $c" + vwait done + sendCommand {close $socket10_13_test_server} + list $spurious $len +} {0 2690} +test socket-10.14 {testing EOF stickyness} { + set counter 0 + set done 0 + proc count_up {s} { + global counter done after_id + set l [gets $s] + if {[eof $s]} { + incr counter + if {$counter > 9} { + set done {EOF is sticky} + after cancel $after_id + close $s + } + } + } + proc timed_out {} { + global c done + set done {timed_out, EOF is not sticky} + close $c + } + sendCommand { + set socket10_14_test_server [socket -server accept 2836] + proc accept {s a p} { + after 100 close $s + } + } + set c [socket [info hostname] 2836] + fileevent $c readable "count_up $c" + set after_id [after 1000 timed_out] + vwait done + sendCommand {close $socket10_14_test_server} + set done +} {EOF is sticky} +test socket-10.15 {testing async write, async flush, async close} { + proc readit {s} { + global count done + set l [read $s] + incr count [string length $l] + if {[eof $s]} { + close $s + set done 1 + } + } + sendCommand { + set firstblock "" + for {set i 0} {$i < 5} {incr i} { + set firstblock "a$firstblock$firstblock" + } + set secondblock "" + for {set i 0} {$i < 16} {incr i} { + set secondblock "b$secondblock$secondblock" + } + set l [socket -server accept 8080] + proc accept {s a p} { + fconfigure $s -blocking 0 -translation lf -buffersize 16384 \ + -buffering line + fileevent $s readable "readable $s" + } + proc readable {s} { + set l [gets $s] + fileevent $s readable {} + after 1000 respond $s + } + proc respond {s} { + global firstblock + puts -nonewline $s $firstblock + after 1000 writedata $s + } + proc writedata {s} { + global secondblock + puts -nonewline $s $secondblock + close $s + } + } + set s [socket [info hostname] 8080] + fconfigure $s -blocking 0 -trans lf -buffering line + set count 0 + puts $s hello + fileevent $s readable "readit $s" + vwait done + sendCommand {close $l} + set count +} 65566 + +if {[string match sock* $commandSocket] == 1} { + puts $commandSocket exit + flush $commandSocket +} +catch {close $commandSocket} +catch {close $remoteProcChan} + +set x "" +unset x diff --git a/tcl7.6/tests/source.test b/tcl7.6/tests/source.test new file mode 100644 index 0000000..7978f31 --- /dev/null +++ b/tcl7.6/tests/source.test @@ -0,0 +1,180 @@ +# 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. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) source.test 1.23 96/10/04 15:35:23 + +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" + makeFile { + 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} { + makeFile {list result} source.file + source source.file +} result + +# The mac version of source returns a differnt result for +# the next two tests. + +if {$tcl_platform(platform) == "macintosh"} { + set retMsg1 {1 {wrong # args: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}} + set retMsg2 {1 {bad argument: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}} +} else { + set retMsg1 {1 {wrong # args: should be "source fileName"}} + set retMsg2 {1 {wrong # args: should be "source fileName"}} +} +test source-2.1 {source error conditions} { + list [catch {source} msg] $msg +} $retMsg1 +test source-2.2 {source error conditions} { + list [catch {source a b} msg] $msg +} $retMsg2 +test source-2.3 {source error conditions} { + makeFile { + 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} { + makeFile {break} source.file + catch {source source.file} +} 3 +test source-2.5 {source error conditions} { + makeFile {continue} source.file + catch {source source.file} +} 4 +test source-2.6 {source error conditions} { + normalizeMsg [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} { + makeFile { + 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} +test source-3.2 {return with special code etc.} { + makeFile { + set x new-x + return -code break "Silly result" + set y new-y + } source.file + list [catch {source source.file} msg] $msg +} {3 {Silly result}} +test source-3.3 {return with special code etc.} { + makeFile { + set x new-x + return -code error "Simulated error" + set y new-y + } source.file + list [catch {source source.file} msg] $msg $errorInfo $errorCode +} {1 {Simulated error} {Simulated error + while executing +"source source.file"} NONE} +test source-3.4 {return with special code etc.} { + makeFile { + set x new-x + return -code error -errorinfo "Simulated errorInfo stuff" + set y new-y + } source.file + list [catch {source source.file} msg] $msg $errorInfo $errorCode +} {1 {} {Simulated errorInfo stuff + invoked from within +"source source.file"} NONE} +test source-3.5 {return with special code etc.} { + makeFile { + set x new-x + return -code error -errorinfo "Simulated errorInfo stuff" \ + -errorcode {a b c} + set y new-y + } source.file + list [catch {source source.file} msg] $msg $errorInfo $errorCode +} {1 {} {Simulated errorInfo stuff + invoked from within +"source source.file"} {a b c}} + +# Test for the Macintosh specfic features of the source command +test source-4.1 {source error conditions} {macOnly} { + list [catch {source -rsrc _no_exist_} msg] $msg +} [list 1 "The resource \"_no_exist_\" could not be loaded from application."] +test source-4.2 {source error conditions} {macOnly} { + list [catch {source -rsrcid bad_id} msg] $msg +} [list 1 "expected integer but got \"bad_id\""] +test source-4.3 {source error conditions} {macOnly} { + list [catch {source -rsrc rsrcName fileName extra} msg] $msg +} $retMsg1 +test source-4.4 {source error conditions} {macOnly} { + list [catch {source non_switch rsrcName} msg] $msg +} $retMsg2 +test source-4.5 {source error conditions} {macOnly} { + list [catch {source -bad_switch argument} msg] $msg +} $retMsg2 +test source-5.1 {source resource files} {macOnly} { + list [catch {source -rsrc rsrcName bad_file} msg] $msg +} [list 1 "Error finding the file: \"bad_file\"."] +test source-5.2 {source resource files} {macOnly} { + makeFile {return} source.file + list [catch {source -rsrc rsrcName source.file} msg] $msg +} [list 1 "Error reading the file: \"source.file\"."] +test source-5.3 {source resource files} {macOnly} { + testWriteTextResource -rsrc rsrcName -file rsrc.file {set msg2 ok; return} + set result [catch {source -rsrc rsrcName rsrc.file} msg] + removeFile rsrc.file + list $msg2 $result $msg +} [list ok 0 {}] +test source-5.4 {source resource files} {macOnly} { + catch {unset msg2} + testWriteTextResource -rsrc fileRsrcName -file rsrc.file {set msg2 ok; return} + source -rsrc fileRsrcName rsrc.file + set result [catch {source -rsrc fileRsrcName} msg] + removeFile rsrc.file + list $msg2 $result $msg +} [list ok 1 {The resource "fileRsrcName" could not be loaded from application.}] +test source-5.5 {source resource files} {macOnly} { + testWriteTextResource -rsrcid 200 -file rsrc.file {set msg2 hello; set msg3 bye} + set result [catch {source -rsrcid 200 rsrc.file} msg] + removeFile rsrc.file + list $msg2 $result $msg +} [list hello 0 bye] +test source-5.6 {source resource files} {macOnly} { + testWriteTextResource -rsrcid 200 -file rsrc.file {set msg2 hello; error bad; set msg3 bye} + set result [catch {source -rsrcid 200 rsrc.file} msg] + removeFile rsrc.file + list $msg2 $result $msg +} [list hello 1 bad] + +catch {removeFile source.file} + +# Generate null final value + +concat {} diff --git a/tcl7.3/tests/split.test b/tcl7.6/tests/split.test similarity index 53% rename from tcl7.3/tests/split.test rename to tcl7.6/tests/split.test index 1e2a3d8..e87fcd4 100644 --- a/tcl7.3/tests/split.test +++ b/tcl7.6/tests/split.test @@ -5,26 +5,12 @@ # 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. +# Copyright (c) 1994 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) split.test 1.8 96/02/16 08:56:28 if {[string compare test [info procs test]] == 1} then {source defs} diff --git a/tcl7.3/tests/string.test b/tcl7.6/tests/string.test similarity index 77% rename from tcl7.3/tests/string.test rename to tcl7.6/tests/string.test index e0bc44a..9670798 100644 --- a/tcl7.3/tests/string.test +++ b/tcl7.6/tests/string.test @@ -5,26 +5,12 @@ # 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. +# Copyright (c) 1994 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) string.test 1.13 96/05/14 10:46:40 if {[string compare test [info procs test]] == 1} then {source defs} @@ -193,9 +179,12 @@ test string-6.26 {string match} { string match "" "" } 1 test string-6.27 {string match} { + string match \[a a +} 1 +test string-6.28 {string match} { list [catch {string match a} msg] $msg } {1 {wrong # args: should be "string match pattern string"}} -test string-6.28 {string match} { +test string-6.29 {string match} { list [catch {string match a b c} msg] $msg } {1 {wrong # args: should be "string match pattern string"}} @@ -234,10 +223,16 @@ test string-7.11 {string range} { } {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"}} +} {1 {expected integer or "end" 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-7.14 {string range} { + string range abcdefghijklmnop end end +} {p} +test string-7.15 {string range} { + string range abcdefghijklmnop e 1000 +} {p} test string-8.1 {string trim} { string trim " XYZ " @@ -291,7 +286,7 @@ test string-10.4 {string trimright errors} { } {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}} +} {1 {bad option "trimg": should be compare, first, index, last, length, match, range, tolower, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-11.1 {string tolower} { string tolower ABCDeF @@ -325,9 +320,62 @@ 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} { +test string-13.1 {string wordend} { + list [catch {string wordend a} msg] $msg +} {1 {wrong # args: should be "string wordend string index"}} +test string-13.2 {string wordend} { + list [catch {string wordend a b c} msg] $msg +} {1 {wrong # args: should be "string wordend string index"}} +test string-13.3 {string wordend} { + list [catch {string wordend a gorp} msg] $msg +} {1 {expected integer but got "gorp"}} +test string-13.4 {string wordend} { + string wordend abc. -1 +} 3 +test string-13.5 {string wordend} { + string wordend abc. 100 +} 4 +test string-13.6 {string wordend} { + string wordend "word_one two three" 2 +} 8 +test string-13.7 {string wordend} { + string wordend "one .&# three" 5 +} 6 +test string-13.8 {string wordend} { + string worde "x.y" 0 +} 1 + +test string-14.1 {string wordstart} { + list [catch {string word a} msg] $msg +} {1 {bad option "word": should be compare, first, index, last, length, match, range, tolower, toupper, trim, trimleft, trimright, wordend, or wordstart}} +test string-14.2 {string wordstart} { + list [catch {string wordstart a} msg] $msg +} {1 {wrong # args: should be "string wordstart string index"}} +test string-14.3 {string wordstart} { + list [catch {string wordstart a b c} msg] $msg +} {1 {wrong # args: should be "string wordstart string index"}} +test string-14.4 {string wordstart} { + list [catch {string wordstart a gorp} msg] $msg +} {1 {expected integer but got "gorp"}} +test string-14.5 {string wordstart} { + string wordstart "one two three_words" 400 +} 8 +test string-14.6 {string wordstart} { + string wordstart "one two three_words" 2 +} 0 +test string-14.7 {string wordend} { + string wordstart "one two three_words" -2 +} 0 +test string-14.8 {string wordend} { + string wordstart "one .*&^ three" 6 +} 6 +test string-14.9 {string wordend} { + string wordstart "one two three" 4 +} 4 + +test string-15.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} { +} {1 {bad option "gorp": should be compare, first, index, last, length, match, range, tolower, toupper, trim, trimleft, trimright, wordend, or wordstart}} +test string-15.2 {error conditions} { list [catch {string} msg] $msg } {1 {wrong # args: should be "string option arg ?arg ...?"}} diff --git a/tcl7.6/tests/subst.test b/tcl7.6/tests/subst.test new file mode 100644 index 0000000..5c7f556 --- /dev/null +++ b/tcl7.6/tests/subst.test @@ -0,0 +1,106 @@ +# Commands covered: subst +# +# 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) 1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) subst.test 1.7 96/02/16 08:56:30 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test subst-1.1 {basics} { + list [catch {subst} msg] $msg +} {1 {wrong # args: should be "subst ?-nobackslashes? ?-nocommands? ?-novariables? string"}} +test subst-1.2 {basics} { + list [catch {subst a b c} msg] $msg +} {1 {wrong # args: should be "subst ?-nobackslashes? ?-nocommands? ?-novariables? string"}} + +test subst-2.1 {simple strings} { + subst {} +} {} +test subst-2.2 {simple strings} { + subst a +} a +test subst-2.3 {simple strings} { + subst abcdefg +} abcdefg + +test subst-3.1 {backslash substitutions} { + subst {\x\$x\[foo bar]\\} +} "x\$x\[foo bar]\\" + +test subst-4.1 {variable substitutions} { + set a 44 + subst {$a} +} {44} +test subst-4.2 {variable substitutions} { + set a 44 + subst {x$a.y{$a}.z} +} {x44.y{44}.z} +test subst-4.3 {variable substitutions} { + catch {unset a} + set a(13) 82 + set i 13 + subst {x.$a($i)} +} {x.82} +catch {unset a} +set long {This is a very long string, intentionally made so long that it + will overflow the static character size for dstrings, so that + additional memory will have to be allocated by subst. That way, + if the subst procedure forgets to free up memory while returning + an error, there will be memory that isn't freed (this will be + detected when the tests are run under a checking memory allocator + such as Purify).} +test subst-4.4 {variable substitutions} { + list [catch {subst {$long $a}} msg] $msg +} {1 {can't read "a": no such variable}} + +test subst-5.1 {command substitutions} { + subst {[concat {}]} +} {} +test subst-5.2 {command substitutions} { + subst {[concat A test string]} +} {A test string} +test subst-5.3 {command substitutions} { + subst {x.[concat foo].y.[concat bar].z} +} {x.foo.y.bar.z} +test subst-5.3 {command substitutions} { + list [catch {subst {$long [set long] [bogus_command]}} msg] $msg +} {1 {invalid command name "bogus_command"}} + +test subst-6.1 {clear the result after command substitution} { + catch {unset a} + list [catch {subst {[concat foo] $a}} msg] $msg +} {1 {can't read "a": no such variable}} + +test subst-7.1 {switches} { + list [catch {subst foo bar} msg] $msg +} {1 {wrong # args: should be "subst ?-nobackslashes? ?-nocommands? ?-novariables? string"}} +test subst-7.2 {switches} { + list [catch {subst -no bar} msg] $msg +} {1 {bad switch "-no": must be -nobackslashes, -nocommands, or -novariables}} +test subst-7.3 {switches} { + list [catch {subst -bogus bar} msg] $msg +} {1 {bad switch "-bogus": must be -nobackslashes, -nocommands, or -novariables}} +test subst-7.4 {switches} { + set x 123 + subst -nobackslashes {abc $x [expr 1+2] \\\x41} +} {abc 123 3 \\\x41} +test subst-7.5 {switches} { + set x 123 + subst -nocommands {abc $x [expr 1+2] \\\x41} +} {abc 123 [expr 1+2] \A} +test subst-7.6 {switches} { + set x 123 + subst -novariables {abc $x [expr 1+2] \\\x41} +} {abc $x 3 \A} +test subst-7.7 {switches} { + set x 123 + subst -nov -nob -noc {abc $x [expr 1+2] \\\x41} +} {abc $x [expr 1+2] \\\x41} diff --git a/tcl7.3/tests/switch.test b/tcl7.6/tests/switch.test similarity index 80% rename from tcl7.3/tests/switch.test rename to tcl7.6/tests/switch.test index dd2baa2..740ecb1 100644 --- a/tcl7.3/tests/switch.test +++ b/tcl7.6/tests/switch.test @@ -5,26 +5,12 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1993 The Regents of the University of California. -# All rights reserved. +# Copyright (c) 1994 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) switch.test 1.5 96/02/16 08:56:31 if {[string compare test [info procs test]] == 1} then {source defs} @@ -181,4 +167,4 @@ test switch-7.3 {"-" bodies} { c - } } msg] $msg -} {1 {invalid command name: "-foo"}} +} {1 {invalid command name "-foo"}} diff --git a/tcl7.3/tests/trace.test b/tcl7.6/tests/trace.test similarity index 78% rename from tcl7.3/tests/trace.test rename to tcl7.6/tests/trace.test index 02fc051..9077906 100644 --- a/tcl7.3/tests/trace.test +++ b/tcl7.6/tests/trace.test @@ -5,26 +5,12 @@ # 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. +# Copyright (c) 1994 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) trace.test 1.24 96/02/16 08:56:32 if {[string compare test [info procs test]] == 1} then {source defs} @@ -32,6 +18,10 @@ proc traceScalar {name1 name2 op} { global info set info [list $name1 $name2 $op [catch {uplevel set $name1} msg] $msg] } +proc traceScalarAppend {name1 name2 op} { + global info + lappend info $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] @@ -152,16 +142,34 @@ test trace-2.5 {trace variable writes} { set info } {} +test trace-3.1 {trace variable read-modify-writes} { + catch {unset x} + set info {} + trace var x r traceScalarAppend + append x 123 + append x 456 + lappend x 789 + set info +} {x {} r 1 {can't read "x": no such variable} x {} r 0 123 x {} r 0 123456} +test trace-3.2 {trace variable read-modify-writes} { + catch {unset x} + set info {} + trace var x rw traceScalarAppend + append x 123 + lappend x 456 + set info +} {x {} r 1 {can't read "x": no such variable} x {} w 0 123 x {} r 0 123 x {} w 0 {123 456}} + # Basic unset-tracing on variables -test trace-3.1 {trace variable unsets} { +test trace-4.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} { +test trace-4.2 {variable mustn't exist during unset trace} { catch {unset x} set x 1234 set info {} @@ -169,7 +177,7 @@ test trace-3.2 {variable mustn't exist during unset trace} { 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} { +test trace-4.3 {unset traces mustn't be called during reads and writes} { catch {unset x} set info {} trace var x u traceScalar @@ -177,7 +185,7 @@ test trace-3.3 {unset traces mustn't be called during reads and writes} { set x set info } {} -test trace-3.4 {trace unsets on array elements} { +test trace-4.4 {trace unsets on array elements} { catch {unset x} set x(0) 18 set info {} @@ -185,7 +193,7 @@ test trace-3.4 {trace unsets on array elements} { 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} { +test trace-4.5 {trace unsets on array elements} { catch {unset x} set x(1) 18 set info {} @@ -193,7 +201,7 @@ test trace-3.5 {trace unsets on array elements} { 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} { +test trace-4.6 {trace unsets on array elements} { catch {unset x} set x(1) 18 set info {} @@ -201,7 +209,7 @@ test trace-3.6 {trace unsets on array elements} { 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} { +test trace-4.7 {trace unsets on whole arrays} { catch {unset x} set x(1) 18 set info {} @@ -209,7 +217,7 @@ test trace-3.7 {trace unsets on whole arrays} { catch {unset x(0)} set info } {} -test trace-3.8 {trace unsets on whole arrays} { +test trace-4.8 {trace unsets on whole arrays} { catch {unset x} set x(1) 18 set x(2) 144 @@ -219,7 +227,7 @@ test trace-3.8 {trace unsets on whole arrays} { unset x(1) set info } {x 1 u} -test trace-3.9 {trace unsets on whole arrays} { +test trace-4.9 {trace unsets on whole arrays} { catch {unset x} set x(1) 18 set x(2) 144 @@ -232,7 +240,7 @@ test trace-3.9 {trace unsets on whole arrays} { # Trace multiple trace types at once. -test trace-4.1 {multiple ops traced at once} { +test trace-5.1 {multiple ops traced at once} { catch {unset x} set info {} trace var x rwu traceProc @@ -243,7 +251,7 @@ test trace-4.1 {multiple ops traced at once} { unset x set info } {x {} r x {} w x {} r x {} w x {} u} -test trace-4.2 {multiple ops traced on array element} { +test trace-5.2 {multiple ops traced on array element} { catch {unset x} set info {} trace var x(0) rwu traceProc @@ -255,7 +263,7 @@ test trace-4.2 {multiple ops traced on array element} { 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} { +test trace-5.3 {multiple ops traced on whole array} { catch {unset x} set info {} trace var x rwu traceProc @@ -270,7 +278,7 @@ test trace-4.3 {multiple ops traced on whole array} { # Check order of invocation of traces -test trace-5.1 {order of invocation of traces} { +test trace-6.1 {order of invocation of traces} { catch {unset x} set info {} trace var x r "traceTag 1" @@ -281,7 +289,7 @@ test trace-5.1 {order of invocation of traces} { set x set info } {3 2 1 3 2 1} -test trace-5.2 {order of invocation of traces} { +test trace-6.2 {order of invocation of traces} { catch {unset x} set x(0) 44 set info {} @@ -291,7 +299,7 @@ test trace-5.2 {order of invocation of traces} { set x(0) set info } {3 2 1} -test trace-5.3 {order of invocation of traces} { +test trace-6.3 {order of invocation of traces} { catch {unset x} set x(0) 44 set info {} @@ -307,7 +315,7 @@ test trace-5.3 {order of invocation of traces} { # Check effects of errors in trace procedures -test trace-6.1 {error returns from traces} { +test trace-7.1 {error returns from traces} { catch {unset x} set x 123 set info {} @@ -315,7 +323,7 @@ test trace-6.1 {error returns from traces} { 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} { +test trace-7.2 {error returns from traces} { catch {unset x} set x 123 set info {} @@ -323,7 +331,15 @@ test trace-6.2 {error returns from traces} { 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} { +test trace-7.3 {error returns from traces} { + catch {unset x} + set x 123 + set info {} + trace var x r traceError + trace var x w traceScalar + list [catch {append x 44} msg] $msg $info +} {1 {can't read "x": trace returned error} {}} +test trace-7.4 {error returns from traces} { catch {unset x} set x 123 set info {} @@ -331,7 +347,7 @@ test trace-6.3 {error returns from traces} { trace var x u traceError list [catch {unset x} msg] $msg $info } {0 {} 1} -test trace-6.4 {error returns from traces} { +test trace-7.5 {error returns from traces} { catch {unset x} set x(0) 123 set info {} @@ -341,13 +357,13 @@ test trace-6.4 {error returns from traces} { 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} { +test trace-7.6 {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} { +test trace-7.7 {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. @@ -363,7 +379,7 @@ test trace-6.6 {error returns from traces} { # 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} { +test trace-8.1 {be sure variable is unset before trace is called} { catch {unset x} set x 33 set info {} @@ -371,7 +387,7 @@ test trace-7.1 {be sure variable is unset before trace is called} { 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} { +test trace-8.2 {be sure variable is unset before trace is called} { catch {unset x} set x 33 set info {} @@ -379,7 +395,7 @@ test trace-7.2 {be sure variable is unset before trace is called} { 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} { +test trace-8.3 {be sure traces are cleared before unset trace called} { catch {unset x} set x 33 set info {} @@ -387,7 +403,7 @@ test trace-7.3 {be sure traces are cleared before unset trace called} { unset x set info } {0 {}} -test trace-7.4 {set new trace during unset trace} { +test trace-8.4 {set new trace during unset trace} { catch {unset x} set x 33 set info {} @@ -396,7 +412,7 @@ test trace-7.4 {set new trace during unset trace} { concat $info [trace vinfo x] } {0 {} {u traceProc}} -test trace-8.1 {make sure array elements are unset before traces are called} { +test trace-9.1 {make sure array elements are unset before traces are called} { catch {unset x} set x(0) 33 set info {} @@ -404,7 +420,7 @@ test trace-8.1 {make sure array elements are unset before traces are called} { 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} { +test trace-9.2 {make sure array elements are unset before traces are called} { catch {unset x} set x(0) 33 set info {} @@ -412,7 +428,7 @@ test trace-8.2 {make sure array elements are unset before traces are called} { 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} { +test trace-9.3 {array elements are unset before traces are called} { catch {unset x} set x(0) 33 set info {} @@ -420,7 +436,7 @@ test trace-8.3 {array elements are unset before traces are called} { unset x(0) set info } {0 {}} -test trace-8.4 {set new array element trace during unset trace} { +test trace-9.4 {set new array element trace during unset trace} { catch {unset x} set x(0) 33 set info {} @@ -429,7 +445,7 @@ test trace-8.4 {set new array element trace during unset trace} { concat $info [trace vinfo x(0)] } {0 {} {r {}}} -test trace-9.1 {make sure arrays are unset before traces are called} { +test trace-10.1 {make sure arrays are unset before traces are called} { catch {unset x} set x(0) 33 set info {} @@ -437,7 +453,7 @@ test trace-9.1 {make sure arrays are unset before traces are called} { 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} { +test trace-10.2 {make sure arrays are unset before traces are called} { catch {unset x} set x(y) 33 set info {} @@ -445,15 +461,15 @@ test trace-9.2 {make sure arrays are unset before traces are called} { 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} { +test trace-10.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}} + trace var x u {traceCheck {uplevel array exists x}} unset x set info -} {1 {"x" isn't an array}} -test trace-9.4 {make sure arrays are unset before traces are called} { +} {0 0} +test trace-10.4 {make sure arrays are unset before traces are called} { catch {unset x} set x(y) 33 set info {} @@ -462,7 +478,7 @@ test trace-9.4 {make sure arrays are unset before traces are called} { unset x set info } {0 {}} -test trace-9.5 {set new array trace during unset trace} { +test trace-10.5 {set new array trace during unset trace} { catch {unset x} set x(y) 33 set info {} @@ -470,7 +486,7 @@ test trace-9.5 {set new array trace during unset trace} { unset x concat $info [trace vinfo x] } {0 {} {r {}}} -test trace-9.6 {create scalar during array unset trace} { +test trace-10.6 {create scalar during array unset trace} { catch {unset x} set x(y) 33 set info {} @@ -481,52 +497,52 @@ test trace-9.6 {create scalar during array unset trace} { # Check special conditions (e.g. errors) in Tcl_TraceVar2. -test trace-10.1 {creating array when setting variable traces} { +test trace-11.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} { +test trace-11.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} { +test trace-11.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} { +test trace-11.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} { +test trace-11.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} { +test trace-11.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} { +test trace-11.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} { +test trace-11.8 {errors when setting variable traces} { catch {unset x} set x 44 list [catch {trace var x(0) w traceProc} msg] $msg @@ -534,7 +550,7 @@ test trace-10.8 {errors when setting variable traces} { # Check deleting one trace from another. -test trace-11.1 {delete one trace from another} { +test trace-12.1 {delete one trace from another} { proc delTraces {args} { global x trace vdel x r {traceTag 2} @@ -556,37 +572,37 @@ test trace-11.1 {delete one trace from another} { # Check operation and syntax of "trace" command. -test trace-12.1 {trace command (overall)} { +test trace-13.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)} { +test trace-13.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)} { +test trace-13.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)} { +test trace-13.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)} { +test trace-13.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)} { +test trace-13.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)} { +test trace-13.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)} { +test trace-13.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)} { +test trace-13.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)} { +test trace-13.10 {trace command ("vdelete" option)} { catch {unset x} set info {} trace var x w traceProc @@ -594,7 +610,7 @@ test trace-12.10 {trace command ("vdelete" option)} { set x 12345 set info } {} -test trace-12.11 {trace command ("vdelete" option)} { +test trace-13.11 {trace command ("vdelete" option)} { catch {unset x} set info {} trace var x w {traceTag 1} @@ -609,7 +625,7 @@ test trace-12.11 {trace command ("vdelete" option)} { set x gorp set info } {2 x {} w 1 2 1 2} -test trace-12.12 {trace command ("vdelete" option)} { +test trace-13.12 {trace command ("vdelete" option)} { catch {unset x} set info {} trace var x w {traceTag 1} @@ -617,33 +633,33 @@ test trace-12.12 {trace command ("vdelete" option)} { set x 12345 set info } {1} -test trace-12.13 {trace command ("vinfo" option)} { +test trace-13.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)} { +test trace-13.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)} { +test trace-13.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)} { +test trace-13.16 {trace command ("vinfo" option)} { catch {unset x} trace vinfo x } {} -test trace-12.17 {trace command ("vinfo" option)} { +test trace-13.17 {trace command ("vinfo" option)} { catch {unset x} trace vinfo x(0) } {} -test trace-12.18 {trace command ("vinfo" option)} { +test trace-13.18 {trace command ("vinfo" option)} { catch {unset x} set x 44 trace vinfo x(0) } {} -test trace-12.19 {trace command ("vinfo" option)} { +test trace-13.19 {trace command ("vinfo" option)} { catch {unset x} set x 44 trace var x w {traceTag 1} @@ -653,7 +669,7 @@ test trace-12.19 {trace command ("vinfo" option)} { # Check fancy trace commands (long ones, weird arguments, etc.) -test trace-13.1 {long trace command} { +test trace-14.1 {long trace command} { catch {unset x} set info {} trace var x w {traceTag {This is a very very long argument. It's \ @@ -668,7 +684,7 @@ test trace-13.1 {long trace command} { 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} { +test trace-14.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"} @@ -678,7 +694,7 @@ test trace-13.2 {long trace command result to ignore} { set x 5 set x abcde } abcde -test trace-13.3 {special list-handling in trace commands} { +test trace-14.3 {special list-handling in trace commands} { catch {unset "x y z"} set "x y z(a\n\{)" 44 set info {} @@ -709,7 +725,7 @@ proc traceAppend {string name1 name2 op} { lappend info $string } -test trace-14.1 {unsets during read traces} { +test trace-15.1 {unsets during read traces} { catch {unset y} set y 1234 set info {} @@ -717,49 +733,49 @@ test trace-14.1 {unsets during read traces} { 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} { +test trace-15.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} { +test trace-15.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} { +test trace-15.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} { +test trace-15.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} { +test trace-15.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} { +test trace-15.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} { +test trace-15.8 {unsets during write traces} { catch {unset y} set y 1234 set info {} @@ -767,91 +783,91 @@ test trace-14.8 {unsets during write traces} { 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} { +test trace-15.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} { +test trace-15.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} { +test trace-15.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} { +test trace-15.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} { +test trace-15.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} { +test trace-15.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} { +test trace-15.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} { +test trace-15.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} { +test trace-15.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} { +test trace-15.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} { +test trace-15.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} { +test trace-15.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} { +test trace-15.21 {unsets cancelling traces} { catch {unset y} set y 1234 set info {} @@ -861,7 +877,7 @@ test trace-14.21 {unsets cancelling traces} { 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} { +test trace-15.22 {unsets cancelling traces} { catch {unset y} set y(0) 1234 set info {} @@ -874,19 +890,19 @@ test trace-14.22 {unsets cancelling traces} { # Check various non-interference between traces and other things. -test trace-15.1 {trace doesn't prevent unset errors} { +test trace-16.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} { +test trace-16.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} { +test trace-16.3 {traced variables must survive procedure exits} { catch {unset x} set info {} proc p1 {} {global x; trace var x w traceProc} @@ -898,7 +914,7 @@ test trace-15.3 {traced variables must survive procedure exits} { # Be sure that procedure frames are released before unset traces # are invoked. -test trace-16.1 {unset traces on procedure returns} { +test trace-17.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 {} diff --git a/tcl7.6/tests/unixFCmd.test b/tcl7.6/tests/unixFCmd.test new file mode 100644 index 0000000..71f7435 --- /dev/null +++ b/tcl7.6/tests/unixFCmd.test @@ -0,0 +1,122 @@ +# This file tests the tclUnixFCmd.c 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) 1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) unixFCmd.test 1.4 96/10/08 17:12:20 + +if {[string compare test [info procs test]] == 1} then {source defs} + +if {$tcl_platform(platform) != "unix"} { + return +} + +if {$user == "root"} { + puts "Skipping unixFCmd tests. They depend on not being able to write to" + puts "certain directories. It would be too dangerous to run them as root." + return +} + +proc cleanup {args} { + foreach p ". $args" { + set x "" + catch { + set x [glob [file join $p tf*] [file join $p td*]] + } + if {$x != ""} { + eval file delete -force -- $x + } + } +} + +test unixFCmd-1.1 {TclpRenameFile: EACCES} { + cleanup + file mkdir td1/td2/td3 + exec chmod 000 td1/td2 + set msg [list [catch {file rename td1/td2/td3 td2} msg] $msg] + exec chmod 755 td1/td2 + set msg +} {1 {error renaming "td1/td2/td3": permission denied}} +test unixFCmd-1.2 {TclpRenameFile: EEXIST} { + cleanup + file mkdir td1/td2 + file mkdir td2 + list [catch {file rename td2 td1} msg] $msg +} {1 {error renaming "td2" to "td1/td2": file already exists}} +test unixFCmd-1.3 {TclpRenameFile: EINVAL} { + cleanup + file mkdir td1 + list [catch {file rename td1 td1} msg] $msg +} {1 {error renaming "td1" to "td1/td1": trying to rename a volume or move a directory into itself}} +test unixFCmd-1.4 {TclpRenameFile: EISDIR} { + # can't make it happen +} {} +test unixFCmd-1.5 {TclpRenameFile: ENOENT} { + cleanup + file mkdir td1 + list [catch {file rename td2 td1} msg] $msg +} {1 {error renaming "td2": no such file or directory}} +test unixFCmd-1.6 {TclpRenameFile: ENOTDIR} { + # can't make it happen +} {} +test unixFCmd-1.7 {TclpRenameFile: EXDEV} {nonPortable} { + cleanup + file mkdir td1 + if [file exists /kernel] { + set msg [list [catch {file rename /kernel td1} msg] $msg] + set a1 {1 {can't unlink "/kernel": permission denied}} + expr {$msg == $a1} + } else { + list 1 + } +} {1} + +test unixFCmd-2.1 {TclpCopyFile: target exists: lstat(dst) == 0} { + cleanup + exec touch tf1 + exec touch tf2 + file copy -force tf1 tf2 +} {} +test unixFCmd-2.2 {TclpCopyFile: src is symlink} { + cleanup + exec ln -s tf1 tf2 + file copy tf2 tf3 + file type tf3 +} {link} +test unixFCmd-2.3 {TclpCopyFile: src is block} { + cleanup + set null "/dev/null" + while {[file type $null] != "characterSpecial"} { + set null [file join [file dirname $null] [file readlink $null]] + } + # file copy $null tf1 +} {} +test unixFCmd-2.4 {TclpCopyFile: src is fifo} { + cleanup + if [catch {exec mknod tf1 p}] { + list 1 + } else { + file copy tf1 tf2 + expr {"[file type tf1]" == "[file type tf2]"} + } +} {1} +test unixFCmd-2.5 {TclpCopyFile: copy attributes} { + cleanup + exec touch tf1 + exec chmod 472 tf1 + file copy tf1 tf2 + string range [exec ls -l tf2] 0 9 +} {-r--rwx-w-} + +cleanup + + + + + diff --git a/tcl7.3/tests/unknown.test b/tcl7.6/tests/unknown.test similarity index 54% rename from tcl7.3/tests/unknown.test rename to tcl7.6/tests/unknown.test index e80258a..fd41109 100644 --- a/tcl7.3/tests/unknown.test +++ b/tcl7.6/tests/unknown.test @@ -5,34 +5,20 @@ # 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. +# Copyright (c) 1994 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) unknown.test 1.11 96/02/16 08:56:34 if {[string compare test [info procs test]] == 1} then {source defs} -catch {rename unknown {}} +catch {rename unknown unknown.old} test unknown-1.1 {non-existent "unknown" command} { list [catch {_non-existent_ foo bar} msg] $msg -} {1 {invalid command name: "_non-existent_"}} +} {1 {invalid command name "_non-existent_"}} proc unknown {args} { global x @@ -70,4 +56,5 @@ test unknown-4.1 {errors in "unknown" procedure} { } {1 {unknown failed} NONE} catch {rename unknown {}} +catch {rename unknown.old unknown} return {} diff --git a/tcl7.3/tests/uplevel.test b/tcl7.6/tests/uplevel.test similarity index 69% rename from tcl7.3/tests/uplevel.test rename to tcl7.6/tests/uplevel.test index 675cb33..84daa03 100644 --- a/tcl7.3/tests/uplevel.test +++ b/tcl7.6/tests/uplevel.test @@ -5,26 +5,12 @@ # 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. +# Copyright (c) 1994 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) uplevel.test 1.13 96/02/16 08:56:35 if {[string compare test [info procs test]] == 1} then {source defs} diff --git a/tcl7.3/tests/upvar.test b/tcl7.6/tests/upvar.test similarity index 73% rename from tcl7.3/tests/upvar.test rename to tcl7.6/tests/upvar.test index bfef720..e4d88bc 100644 --- a/tcl7.3/tests/upvar.test +++ b/tcl7.6/tests/upvar.test @@ -5,26 +5,12 @@ # 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. +# Copyright (c) 1994 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) upvar.test 1.13 96/09/17 12:49:45 if {[string compare test [info procs test]] == 1} then {source defs} @@ -62,7 +48,7 @@ test upvar-1.4 {reading variables with upvar} { } p1 } {47 55 47} -test upvar-1.4 {reading array elements with upvar} { +test upvar-1.5 {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 @@ -286,6 +272,17 @@ test upvar-7.3 {upvar to same level} { } p1 xyz abc } {abc abc} +test upvar-7.4 {upvar to same level: tricky problems when deleting variable table} { + proc tt {} {upvar #1 toto loc; return $loc} + list [catch tt msg] $msg +} {1 {can't read "loc": no such variable}} +test upvar-7.5 {potential memory leak when deleting variable table} { + proc leak {} { + array set foo {1 2 3 4} + upvar 0 foo(1) bar + } + leak +} {} test upvar-8.1 {errors in upvar command} { list [catch upvar msg] $msg @@ -298,6 +295,83 @@ test upvar-8.3 {errors in upvar command} { 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 {} {upvar 0 b b} + list [catch p1 msg] $msg +} {1 {can't upvar from variable to itself}} +test upvar-8.5 {errors in upvar command} { + proc p1 {} {upvar 0 a b; upvar 0 b a} + list [catch p1 msg] $msg +} {1 {can't upvar from variable to itself}} +test upvar-8.6 {errors in upvar command} { proc p1 {} {set a 33; upvar b a} list [catch p1 msg] $msg } {1 {variable "a" already exists}} +test upvar-8.7 {errors in upvar command} { + proc p1 {} {trace variable a w foo; upvar b a} + list [catch p1 msg] $msg +} {1 {variable "a" has traces: can't use for upvar}} + +if {[info commands testupvar] != {}} { + test upvar-9.1 {Tcl_UpVar2 procedure} { + list [catch {testupvar xyz a {} x global} msg] $msg + } {1 {bad level "xyz"}} + test upvar-9.2 {Tcl_UpVar2 procedure} { + catch {unset a} + catch {unset x} + set a 44 + list [catch {testupvar #0 a 1 x global} msg] $msg + } {1 {can't access "a(1)": variable isn't array}} + test upvar-9.3 {Tcl_UpVar2 procedure} { + proc foo {} { + testupvar 1 a {} x local + set x + } + catch {unset a} + catch {unset x} + set a 44 + foo + } {44} + test upvar-9.4 {Tcl_UpVar2 procedure} { + proc foo {} { + testupvar 1 a {} _up_ global + list [catch {set x} msg] $msg + } + catch {unset a} + catch {unset _up_} + set a 44 + concat [foo] $_up_ + } {1 {can't read "x": no such variable} 44} + test upvar-9.5 {Tcl_UpVar2 procedure} { + proc foo {} { + testupvar 1 a b x local + set x + } + catch {unset a} + catch {unset x} + set a(b) 1234 + foo + } {1234} + test upvar-9.6 {Tcl_UpVar procedure} { + proc foo {} { + testupvar 1 a x local + set x + } + catch {unset a} + catch {unset x} + set a xyzzy + foo + } {xyzzy} + test upvar-9.7 {Tcl_UpVar procedure} { + proc foo {} { + testupvar #0 a(b) x local + set x + } + catch {unset a} + catch {unset x} + set a(b) 1234 + foo + } {1234} +} +catch {unset a} + +concat diff --git a/tcl7.3/tests/while.test b/tcl7.6/tests/while.test similarity index 69% rename from tcl7.3/tests/while.test rename to tcl7.6/tests/while.test index 48a08e1..ad3d328 100644 --- a/tcl7.3/tests/while.test +++ b/tcl7.6/tests/while.test @@ -5,26 +5,12 @@ # 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. +# Copyright (c) 1994 Sun Microsystems, Inc. # -# 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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) +# SCCS: @(#) while.test 1.9 96/02/16 08:56:37 if {[string compare test [info procs test]] == 1} then {source defs} diff --git a/tcl7.6/tests/winFCmd.test b/tcl7.6/tests/winFCmd.test new file mode 100644 index 0000000..40aa437 --- /dev/null +++ b/tcl7.6/tests/winFCmd.test @@ -0,0 +1,815 @@ +# This file tests the tclWinFCmd.c 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) 1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) winFCmd.test 1.4 96/10/08 17:37:23 +# + +if {[string compare test [info procs test]] == 1} then {source defs} + +if {$tcl_platform(platform) != "windows"} { + return +} + +proc createfile {file {string a}} { + set f [open $file w] + puts -nonewline $f $string + close $f + return $string +} + +proc contents {file} { + set f [open $file r] + set r [read $f] + close $f + set r +} + +proc cleanup {args} { + foreach p ". $args" { + set x "" + catch { + set x [glob [file join $p tf*] [file join $p td*]] + } + if {$x != ""} { + eval file delete -force -- $x + } + } +} + +set testConfig(95) 0 +set testConfig(NT) 0 +set testConfig(cdrom) 0 +set testConfig(exdev) 0 + +# find a CD-ROM so we can test read-only filesystems. + +set cdrom {} +set nodrive x: +foreach p {d e f g h i j k l m n o p q r s t u v w x y z} { + set name ${p}:/dummy~~.fil + if [catch {set fd [open $name w]}] { + set err [lindex $errorCode 1] + if {$cdrom == "" && $err == "EACCES"} { + set cdrom ${p}: + } + if {$err == "ENOENT"} { + set nodrive ${p}: + } + } else { + close $fd + file delete $name + } +} + +proc findfile {dir} { + foreach p [glob $dir/*] { + if {[file type $p] == "file"} { + return $p + } + } + foreach p [glob $dir/*] { + if {[file type $p] == "directory"} { + set f [findfile $p] + if {$f != ""} { + return $f + } + } + } + return "" +} + +if {$cdrom == ""} { + puts "Couldn't find a CD-ROM. Skipping tests that access CD-ROM." + puts "If you have a CD-ROM, insert a data disk and rerun tests." +} else { + set testConfig(cdrom) 1 + set cdfile [findfile $cdrom] +} + +if {[file exists c:/] && [file exists d:/]} { + catch {file delete d:/tf1} + if {[catch {close [open d:/tf1 w]}] == 0} { + file delete d:/tf1 + set testConfig(exdev) 1 + } +} + +switch $tcl_platform(os) { + "Windows NT" {set testConfig(NT) 1} + "Windows 95" {set testConfig(95) 1} +} + +# A really long file name +# length of longname is 1216 chars, which should be greater than any static +# buffer or allowable filename. + +set longname "abcdefghihjllmnopqrstuvwxyz01234567890" +append longname $longname +append longname $longname +append longname $longname +append longname $longname +append longname $longname + +# Uses the "testfile" command instead of the "file" command. The "file" +# command provides several layers of sanity checks on the arguments and +# it can be difficult to actually forward "insane" arguments to the +# low-level posix emulation layer. + +test winFCmd-1.1 {TclpRenameFile: errno: EACCES} {cdrom} { + list [catch {testfile mv $cdfile $cdrom/dummy~~.fil} msg] $msg +} {1 EACCES} +test winFCmd-1.2 {TclpRenameFile: errno: EEXIST} { + cleanup + file mkdir td1/td2/td3 + file mkdir td2 + list [catch {testfile mv td2 td1/td2} msg] $msg +} {1 EEXIST} +test winFCmd-1.3 {TclpRenameFile: errno: EINVAL} { + cleanup + list [catch {testfile mv / td1} msg] $msg +} {1 EINVAL} +test winFCmd-1.4 {TclpRenameFile: errno: EINVAL} { + cleanup + file mkdir td1 + list [catch {testfile mv td1 td1/td2} msg] $msg +} {1 EINVAL} +test winFCmd-1.5 {TclpRenameFile: errno: EISDIR} { + cleanup + file mkdir td1 + createfile tf1 + list [catch {testfile mv tf1 td1} msg] $msg +} {1 EISDIR} +test winFCmd-1.6 {TclpRenameFile: errno: ENOENT} { + cleanup + list [catch {testfile mv tf1 tf2} msg] $msg +} {1 ENOENT} +test winFCmd-1.7 {TclpRenameFile: errno: ENOENT} { + cleanup + list [catch {testfile mv "" tf2} msg] $msg +} {1 ENOENT} +test winFCmd-1.8 {TclpRenameFile: errno: ENOENT} { + cleanup + createfile tf1 + list [catch {testfile mv tf1 ""} msg] $msg +} {1 ENOENT} +test winFCmd-1.9 {TclpRenameFile: errno: ENOTDIR} { + cleanup + file mkdir td1 + createfile tf1 + list [catch {testfile mv td1 tf1} msg] $msg +} {1 ENOTDIR} +test winFCmd-1.10 {TclpRenameFile: errno: EXDEV} {exdev} { + file delete -force d:/tf1 + file mkdir c:/tf1 + set msg [list [catch {testfile mv c:/tf1 d:/tf1} msg] $msg] + file delete -force c:/tf1 + set msg +} {1 EXDEV} +test winFCmd-1.11 {TclpRenameFile: errno: EACCES} { + cleanup + set fd [open tf1 w] + set msg [list [catch {testfile mv tf1 tf2} msg] $msg] + close $fd + set msg +} {1 EACCES} +test winFCmd-1.12 {TclpRenameFile: errno: EACCES} { + cleanup + createfile tf1 + set fd [open tf2 w] + set msg [list [catch {testfile mv tf1 tf2} msg] $msg] + close $fd + set msg +} {1 EACCES} +test winFCmd-1.13 {TclpRenameFile: errno: EACCES} { + cleanup + list [catch {testfile mv nul tf1} msg] $msg +} {1 EACCES} +test winFCmd-1.14 {TclpRenameFile: errno: EACCES} {95} { + cleanup + createfile tf1 + list [catch {testfile mv tf1 nul} msg] $msg +} {1 EACCES} +test winFCmd-1.15 {TclpRenameFile: errno: EEXIST} {NT} { + cleanup + createfile tf1 + list [catch {testfile mv tf1 nul} msg] $msg +} {1 EEXIST} +test winFCmd-1.16 {TclpRenameFile: MoveFile() != FALSE} { + cleanup + createfile tf1 tf1 + testfile mv tf1 tf2 + list [file exists tf1] [contents tf2] +} {0 tf1} +test winFCmd-1.17 {TclpRenameFile: MoveFile() == FALSE} { + cleanup + list [catch {testfile mv tf1 tf2} msg] $msg +} {1 ENOENT} +test winFCmd-1.18 {TclpRenameFile: srcAttr == -1} { + cleanup + list [catch {testfile mv tf1 tf2} msg] $msg +} {1 ENOENT} +test winFCmd-1.19 {TclpRenameFile: errno == EACCES} { + cleanup + list [catch {testfile mv nul g} msg] $msg +} {1 EACCES} +# under 95, this would actually move the current dir out from under yourself. +test winFCmd-1.20 {TclpRenameFile: src is dir} {NT} { + cleanup + file delete /tf1 + list [catch {testfile mv [pwd] /tf1} msg] $msg +} {1 EACCES} +test winFCmd-1.21 {TclpRenameFile: obscenely long src} { + list [catch {testfile mv $longname tf1} msg] $msg +} {1 ENAMETOOLONG} +test winFCmd-1.22 {TclpRenameFile: obscenely long dst} {NT} { + # return ENOENT if name is too long! + cleanup + createfile tf1 + list [catch {testfile mv tf1 $longname} msg] $msg +} {1 ENOENT} +test winFCmd-1.23 {TclpRenameFile: obscenely long dst} {95} { + cleanup + createfile tf1 + list [catch {testfile mv tf1 $longname} msg] $msg +} {1 ENAMETOOLONG} +test winFCmd-1.24 {TclpRenameFile: move dir into self} { + cleanup + file mkdir td1 + list [catch {testfile mv [pwd]/td1 td1/td2} msg] $msg +} {1 EINVAL} +test winFCmd-1.25 {TclpRenameFile: move a root dir} { + cleanup + list [catch {testfile mv / $nodrive} msg] $msg +} {1 EINVAL} +test winFCmd-1.26 {TclpRenameFile: cross file systems} {cdrom} { + cleanup + file mkdir td1 + list [catch {testfile mv td1 $cdrom/td1} msg] $msg +} {1 EXDEV} +test winFCmd-1.27 {TclpRenameFile: readonly fs} {cdrom} { + cleanup + list [catch {testfile mv $cdfile $cdrom/dummy~~.fil} msg] $msg +} {1 EACCES} +test winFCmd-1.28 {TclpRenameFile: open file} { + cleanup + set fd [open tf1 w] + set msg [list [catch {testfile mv tf1 tf2} msg] $msg] + close $fd + set msg +} {1 EACCES} +test winFCmd-1.29 {TclpRenameFile: errno == EEXIST} { + cleanup + createfile tf1 + createfile tf2 + testfile mv tf1 tf2 + list [file exist tf1] [file exist tf2] +} {0 1} +test winFCmd-1.30 {TclpRenameFile: src is dir} { + cleanup + file mkdir td1 + createfile tf1 + list [catch {testfile mv td1 tf1} msg] $msg +} {1 ENOTDIR} +test winFCmd-1.31 {TclpRenameFile: dst is dir} { + cleanup + file mkdir td1 + file mkdir td2/td2 + list [catch {testfile mv td1 td2} msg] $msg +} {1 EEXIST} +test winFCmd-1.32 {TclpRenameFile: TclpRemoveDirectory fails} { + cleanup + file mkdir td1 + file mkdir td2/td2 + list [catch {testfile mv td1 td2} msg] $msg +} {1 EEXIST} +test winFCmd-1.33 {TclpRenameFile: TclpRemoveDirectory succeeds} { + cleanup + file mkdir td1/td2 + file mkdir td2 + testfile mv td1 td2 + list [file exist td1] [file exist td2] [file exist td2/td2] +} {0 1 1} +test winFCmd-1.34 {TclpRenameFile: After removing dst dir, MoveFile fails} {exdev} { + file mkdir d:/td1 + testchmod 000 d:/td1 + set msg [list [catch {testfile mv c:/windows d:/td1} msg] $msg] + set msg "$msg [file writable d:/td1]" + file delete d:/td1 + set msg +} {1 EXDEV 0} +test winFCmd-1.35 {TclpRenameFile: src is dir, dst is not} { + file mkdir td1 + createfile tf1 + list [catch {testfile mv td1 tf1} msg] $msg +} {1 ENOTDIR} +test winFCmd-1.36 {TclpRenameFile: src is not dir, dst is} { + file mkdir td1 + createfile tf1 + list [catch {testfile mv tf1 td1} msg] $msg +} {1 EISDIR} +test winFCmd-1.37 {TclpRenameFile: src and dst not dir} { + createfile tf1 tf1 + createfile tf2 tf2 + testfile mv tf1 tf2 + contents tf2 +} {tf1} +test winFCmd-1.38 {TclpRenameFile: need to restore temp file} { + # Can't figure out how to cause this. + # Need a file that can't be copied. +} {} + +test winFCmd-2.1 {TclpCopyFile: errno: EACCES} {cdrom} { + cleanup + list [catch {testfile cp $cdfile $cdrom/dummy~~.fil} msg] $msg +} {1 EACCES} +test winFCmd-2.2 {TclpCopyFile: errno: EISDIR} { + cleanup + file mkdir td1 + list [catch {testfile cp td1 tf1} msg] $msg +} {1 EISDIR} +test winFCmd-2.3 {TclpCopyFile: errno: EISDIR} { + cleanup + createfile tf1 + file mkdir td1 + list [catch {testfile cp tf1 td1} msg] $msg +} {1 EISDIR} +test winFCmd-2.4 {TclpCopyFile: errno: ENOENT} { + cleanup + list [catch {testfile cp tf1 tf2} msg] $msg +} {1 ENOENT} +test winFCmd-2.5 {TclpCopyFile: errno: ENOENT} { + cleanup + list [catch {testfile cp "" tf2} msg] $msg +} {1 ENOENT} +test winFCmd-2.6 {TclpCopyFile: errno: ENOENT} { + cleanup + createfile tf1 + list [catch {testfile cp tf1 ""} msg] $msg +} {1 ENOENT} +test winFCmd-2.7 {TclpCopyFile: errno: EACCES} {95} { + cleanup + createfile tf1 + set fd [open tf2 w] + set msg [list [catch {testfile cp tf1 tf2} msg] $msg] + close $fd + set msg +} {1 EACCES} +test winFCmd-2.8 {TclpCopyFile: errno: EACCES} {NT} { + cleanup + list [catch {testfile cp nul tf1} msg] $msg +} {1 EACCES} +test winFCmd-2.9 {TclpCopyFile: errno: ENOENT} {95} { + cleanup + list [catch {testfile cp nul tf1} msg] $msg +} {1 ENOENT} +test winFCmd-2.10 {TclpCopyFile: CopyFile succeeds} { + cleanup + createfile tf1 tf1 + testfile cp tf1 tf2 + list [contents tf1] [contents tf2] +} {tf1 tf1} +test winFCmd-2.11 {TclpCopyFile: CopyFile succeeds} { + cleanup + createfile tf1 tf1 + createfile tf2 tf2 + testfile cp tf1 tf2 + list [contents tf1] [contents tf2] +} {tf1 tf1} +test winFCmd-2.12 {TclpCopyFile: CopyFile succeeds} { + cleanup + createfile tf1 tf1 + testchmod 000 tf1 + testfile cp tf1 tf2 + list [contents tf2] [file writable tf2] +} {tf1 0} +test winFCmd-2.13 {TclpCopyFile: CopyFile fails} { + cleanup + createfile tf1 + file mkdir td1 + list [catch {testfile cp tf1 td1} msg] $msg +} {1 EISDIR} +test winFCmd-2.14 {TclpCopyFile: errno == EACCES} { + cleanup + file mkdir td1 + list [catch {testfile cp td1 tf1} msg] $msg +} {1 EISDIR} +test winFCmd-2.15 {TclpCopyFile: src is directory} { + cleanup + file mkdir td1 + list [catch {testfile cp td1 tf1} msg] $msg +} {1 EISDIR} +test winFCmd-2.16 {TclpCopyFile: dst is directory} { + cleanup + createfile tf1 + file mkdir td1 + list [catch {testfile cp tf1 td1} msg] $msg +} {1 EISDIR} +test winFCmd-2.17 {TclpCopyFile: dst is readonly} { + cleanup + createfile tf1 tf1 + createfile tf2 tf2 + testchmod 000 tf2 + testfile cp tf1 tf2 + list [file writable tf2] [contents tf2] +} {1 tf1} +test winFCmd-2.18 {TclpCopyFile: still can't copy onto dst} {95} { + cleanup + createfile tf1 + createfile tf2 + testchmod 000 tf2 + set fd [open tf2] + set msg [list [catch {testfile cp tf1 tf2} msg] $msg] + close $fd + set msg "$msg [file writable tf2]" +} {1 EACCES 0} + +test winFCmd-3.1 {TclpDeleteFile: errno: EACCES} {cdrom} { + list [catch {testfile rm $cdfile $cdrom/dummy~~.fil} msg] $msg +} {1 EACCES} +test winFCmd-3.2 {TclpDeleteFile: errno: EISDIR} { + cleanup + file mkdir td1 + list [catch {testfile rm td1} msg] $msg +} {1 EISDIR} +test winFCmd-3.3 {TclpDeleteFile: errno: ENOENT} { + cleanup + list [catch {testfile rm tf1} msg] $msg +} {1 ENOENT} +test winFCmd-3.4 {TclpDeleteFile: errno: ENOENT} { + cleanup + list [catch {testfile rm ""} msg] $msg +} {1 ENOENT} +test winFCmd-3.5 {TclpDeleteFile: errno: EACCES} { + cleanup + set fd [open tf1 w] + set msg [list [catch {testfile rm tf1} msg] $msg] + close $fd + set msg +} {1 EACCES} +test winFCmd-3.6 {TclpDeleteFile: errno: EACCES} { + cleanup + list [catch {testfile rm nul} msg] $msg +} {1 EACCES} +test winFCmd-3.7 {TclpDeleteFile: DeleteFile succeeds} { + cleanup + createfile tf1 + testfile rm tf1 + file exist tf1 +} {0} +test winFCmd-3.8 {TclpDeleteFile: DeleteFile fails} { + cleanup + file mkdir td1 + list [catch {testfile rm td1} msg] $msg +} {1 EISDIR} +test winFCmd-3.9 {TclpDeleteFile: errno == EACCES} { + cleanup + set fd [open tf1 w] + set msg [list [catch {testfile rm tf1} msg] $msg] + close $fd + set msg +} {1 EACCES} +test winFCmd-3.10 {TclpDeleteFile: path is readonly} { + cleanup + createfile tf1 + testchmod 000 tf1 + testfile rm tf1 + file exists tf1 +} {0} +test winFCmd-3.11 {TclpDeleteFile: still can't remove path} { + cleanup + set fd [open tf1 w] + testchmod 000 tf1 + set msg [list [catch {testfile rm tf1} msg] $msg] + close $fd + set msg +} {1 EACCES} + +test winFCmd-4.1 {TclpCreateDirectory: errno: EACCES} {cdrom NT} { + list [catch {testfile mkdir $cdrom/dummy~~.dir} msg] $msg +} {1 EACCES} +test winFCmd-4.2 {TclpCreateDirectory: errno: EACCES} {cdrom 95} { + list [catch {testfile mkdir $cdrom/dummy~~.dir} msg] $msg +} {1 ENOSPC} +test winFCmd-4.3 {TclpCreateDirectory: errno: EEXIST} { + cleanup + file mkdir td1 + list [catch {testfile mkdir td1} msg] $msg +} {1 EEXIST} +test winFCmd-4.4 {TclpCreateDirectory: errno: ENOENT} { + cleanup + list [catch {testfile mkdir td1/td2} msg] $msg +} {1 ENOENT} +test winFCmd-4.5 {TclpCreateDirectory: CreateDirectory succeeds} { + cleanup + testfile mkdir td1 + file type td1 +} {directory} + +test winFCmd-5.1 {TclpCopyDirectory: calls TraverseWinTree} { + cleanup + file mkdir td1 + testfile cpdir td1 td2 + list [file type td1] [file type td2] +} {directory directory} + +test winFCmd-6.1 {TclpRemoveDirectory: errno: EACCES} { + cleanup + file mkdir td1 + testchmod 000 td1 + testfile rmdir td1 + file exist td1 +} {0} +test winFCmd-6.2 {TclpRemoveDirectory: errno: EEXIST} { + cleanup + file mkdir td1/td2 + list [catch {testfile rmdir td1} msg] $msg +} {1 {td1 EEXIST}} +test winFCmd-6.3 {TclpRemoveDirectory: errno: EACCES} { + # can't test this w/o removing everything on your hard disk first! + # testfile rmdir / +} {} +test winFCmd-6.4 {TclpRemoveDirectory: errno: ENOENT} { + cleanup + list [catch {testfile rmdir td1} msg] $msg +} {1 {td1 ENOENT}} +test winFCmd-6.5 {TclpRemoveDirectory: errno: ENOENT} { + cleanup + list [catch {testfile rmdir ""} msg] $msg +} {1 ENOENT} +test winFCmd-6.6 {TclpRemoveDirectory: errno: ENOTDIR} { + cleanup + createfile tf1 + list [catch {testfile rmdir tf1} msg] $msg +} {1 {tf1 ENOTDIR}} +test winFCmd-6.7 {TclpRemoveDirectory: RemoveDirectory succeeds} { + cleanup + file mkdir td1 + testfile rmdir td1 + file exists td1 +} {0} +test winFCmd-6.8 {TclpRemoveDirectory: RemoveDirectory fails} { + cleanup + createfile tf1 + list [catch {testfile rmdir tf1} msg] $msg +} {1 {tf1 ENOTDIR}} +test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} { + cleanup + file mkdir td1 + testchmod 000 td1 + testfile rmdir td1 + file exists td1 +} {0} +test winFCmd-6.10 {TclpRemoveDirectory: attr == -1} {95} { + cleanup + list [catch {testfile rmdir nul} msg] $msg +} {1 {nul EACCES}} +test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} {NT} { + cleanup + list [catch {testfile rmdir /} msg] $msg +} {1 {\ EACCES}} +test winFCmd-6.12 {TclpRemoveDirectory: errno == EACCES} {95} { + cleanup + createfile tf1 + list [catch {testfile rmdir tf1} msg] $msg +} {1 {tf1 ENOTDIR}} +test winFCmd-6.13 {TclpRemoveDirectory: write-protected} { + cleanup + file mkdir td1 + testchmod 000 td1 + testfile rmdir td1 + file exists td1 +} {0} +test winFCmd-6.14 {TclpRemoveDirectory: check if empty dir} {95} { + cleanup + file mkdir td1/td2 + list [catch {testfile rmdir td1} msg] $msg +} {1 {td1 EEXIST}} +test winFCmd-6.15 {TclpRemoveDirectory: !recursive} { + cleanup + file mkdir td1/td2 + list [catch {testfile rmdir td1} msg] $msg +} {1 {td1 EEXIST}} +test winFCmd-6.16 {TclpRemoveDirectory: recursive, but errno != EEXIST} { + cleanup + createfile tf1 + list [catch {testfile rmdir -force tf1} msg] $msg +} {1 {tf1 ENOTDIR}} +test winFCmd-6.17 {TclpRemoveDirectory: calls TraverseWinTree} { + cleanup + file mkdir td1/td2 + testfile rmdir -force td1 + file exists td1 +} {0} + +test winFCmd-7.1 {TraverseWinTree: targetPtr == NULL} { + cleanup + file mkdir td1/td2/td3 + testfile rmdir -force td1 + file exists td1 +} {0} +test winFCmd-7.2 {TraverseWinTree: targetPtr != NULL} { + cleanup + file mkdir td1/td2/td3 + testfile cpdir td1 td2 + list [file exists td1] [file exists td2] +} {1 1} +test winFCmd-7.3 {TraverseWinTree: sourceAttr == -1} { + cleanup + list [catch {testfile cpdir td1 td2} msg] $msg +} {1 {td1 ENOENT}} +test winFCmd-7.4 {TraverseWinTree: source isn't directory} { + cleanup + file mkdir td1 + createfile td1/tf1 tf1 + testfile cpdir td1 td2 + contents td2/tf1 +} {tf1} +test winFCmd-7.5 {TraverseWinTree: call TraversalCopy: DOTREE_F} { + cleanup + file mkdir td1 + createfile td1/tf1 tf1 + testfile cpdir td1 td2 + contents td2/tf1 +} {tf1} +test winFCmd-7.6 {TraverseWinTree: call TraversalDelete: DOTREE_F} { + cleanup + file mkdir td1 + createfile td1/tf1 tf1 + testfile rmdir -force td1 + file exists td1 +} {0} +test winFCmd-7.7 {TraverseWinTree: append \ to source if necessary} { + cleanup + file mkdir td1 + createfile td1/tf1 tf1 + testfile cpdir td1 td2 + contents td2/tf1 +} {tf1} +test winFCmd-7.8 {TraverseWinTree: append \ to source if necessary} {95 cdrom} { + list [catch {testfile rmdir $cdrom/} msg] $msg +} "1 {$cdrom\\ EEXIST}" +test winFCmd-7.9 {TraverseWinTree: append \ to source if necessary} {NT cdrom} { + list [catch {testfile rmdir $cdrom/} msg] $msg +} "1 {$cdrom\\ EACCES}" +test winFCmd-7.10 {TraverseWinTree: can't read directory: handle == INVALID} { + # can't make it happen +} {} +test winFCmd-7.11 {TraverseWinTree: call TraversalCopy: DOTREE_PRED} { + cleanup + file mkdir td1 + testchmod 000 td1 + createfile td1/tf1 tf1 + testfile cpdir td1 td2 + list [file exists td2] [file writable td2] +} {1 0} +test winFCmd-7.12 {TraverseWinTree: call TraversalDelete: DOTREE_PRED} { + cleanup + file mkdir td1 + createfile td1/tf1 tf1 + testfile rmdir -force td1 + file exists td1 +} {0} +test winFCmd-7.13 {TraverseWinTree: append \ to target if necessary} { + cleanup + file mkdir td1 + createfile td1/tf1 tf1 + testfile cpdir td1 td2 + contents td2/tf1 +} {tf1} +test winFCmd-7.14 {TraverseWinTree: append \ to target if necessary} {95} { + cleanup + file mkdir td1 + list [catch {testfile cpdir td1 /} msg] $msg +} {1 {\ EEXIST}} +test winFCmd-7.15 {TraverseWinTree: append \ to target if necessary} {NT} { + cleanup + file mkdir td1 + list [catch {testfile cpdir td1 /} msg] $msg +} {1 {\ EACCES}} +test winFCmd-7.16 {TraverseWinTree: recurse on files: no files} { + cleanup + file mkdir td1 + testfile cpdir td1 td2 +} {} +test winFCmd-7.17 {TraverseWinTree: recurse on files: one file} { + cleanup + file mkdir td1 + createfile td1/td2 + testfile cpdir td1 td2 + glob td2/* +} {td2/td2} +test winFCmd-7.18 {TraverseWinTree: recurse on files: several files and dir} { + cleanup + file mkdir td1 + createfile td1/tf1 + createfile td1/tf2 + file mkdir td1/td2/td3 + createfile td1/tf3 + createfile td1/tf4 + testfile cpdir td1 td2 + glob td2/* +} {td2/tf1 td2/tf2 td2/td2 td2/tf3 td2/tf4} +test winFCmd-7.19 {TraverseWinTree: call TraversalCopy: DOTREE_POSTD} { + cleanup + file mkdir td1 + testchmod 000 td1 + createfile td1/tf1 tf1 + testfile cpdir td1 td2 + list [file exists td2] [file writable td2] +} {1 0} +test winFCmd-7.20 {TraverseWinTree: call TraversalDelete: DOTREE_POSTD} { + cleanup + file mkdir td1 + createfile td1/tf1 tf1 + testfile rmdir -force td1 + file exists td1 +} {0} +test winFCmd-7.21 {TraverseWinTree: fill errorPtr} { + cleanup + list [catch {testfile cpdir td1 td2} msg] $msg +} {1 {td1 ENOENT}} + +test winFCmd-8.1 {TraversalCopy: DOTREE_F} { + cleanup + file mkdir td1 + list [catch {testfile cpdir td1 td1} msg] $msg +} {1 {td1 EEXIST}} +test winFCmd-8.2 {TraversalCopy: DOTREE_PRED} { + cleanup + file mkdir td1/td2 + testchmod 000 td1 + testfile cpdir td1 td2 + list [file writable td1] [file writable td1/td2] +} {0 1} +test winFCmd-8.3 {TraversalCopy: DOTREE_POSTD} { + cleanup + file mkdir td1 + testfile cpdir td1 td2 +} {} + +test winFCmd-9.1 {TraversalDelete: DOTREE_F} { + cleanup + file mkdir td1 + createfile td1/tf1 + testfile rmdir -force td1 +} {} +test winFCmd-9.2 {TraversalDelete: DOTREE_F} {95} { + cleanup + file mkdir td1 + set fd [open td1/tf1 w] + set msg [list [catch {testfile rmdir -force td1} msg] $msg] + close $fd + set msg +} {1 {td1\tf1 EACCES}} +test winFCmd-9.3 {TraversalDelete: DOTREE_PRED} { + cleanup + file mkdir td1/td2 + testchmod 000 td1 + testfile rmdir -force td1 + file exists td1 +} {0} +test winFCmd-9.4 {TraversalDelete: DOTREE_POSTD} { + cleanup + file mkdir td1/td1/td3/td4/td5 + testfile rmdir -force td1 +} {} + +cleanup + + + +return + +foreach source {tef ted tnf tnd "" nul com1} { + foreach chmodsrc {000 755} { + foreach dest "tfn tfe tdn tdempty tdfull td1/td2 $p $p/td1 {} nul" { + foreach chmoddst {000 755} { + puts hi + cleanup + file delete -force ted tef + file mkdir ted + createfile tef + createfile tfe + file mkdir tdempty + file mkdir tdfull/td1/td2 + + catch {testchmod $chmodsrc $source} + catch {testchmod $chmoddst $dest} + + if [catch {file rename $source $dest} msg] { + puts "file rename $source ($chmodsrc) $dest ($chmoddst)" + puts $msg + } + } + } + } +} + diff --git a/tcl7.6/tests/winPipe.test b/tcl7.6/tests/winPipe.test new file mode 100644 index 0000000..320fa93 --- /dev/null +++ b/tcl7.6/tests/winPipe.test @@ -0,0 +1,287 @@ +# +# winPipe.test -- +# +# This file contains a collection of tests for tclWinPipe.c +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright (c) 1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) winPipe.test 1.6 96/10/08 17:44:24 + +if {$tcl_platform(platform) != "windows"} { + return +} + +set cat16 [file join $tcl_library ../win/cat16.exe] +set cat32 [file join $tcl_library ../win/cat32.exe] + +if {[string compare test [info procs test]] == 1} then {source defs} + +switch $tcl_platform(os) { + "Windows NT" {set testConfig(NT) 1} + "Windows 95" {set testConfig(95) 1} +} + +if [catch {puts console1 ""}] { + set testConfig(AllocConsole) 1 +} else { + set testConfig(.console) 1 +} + +set big aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\n +append big $big +append big $big +append big $big +append big $big +append big $big +append big $big + +set f [open "little" w] +puts -nonewline $f "little" +close $f + +set f [open "big" w] +puts -nonewline $f $big +close $f + +proc contents {file} { + set f [open $file r] + set r [read $f] + close $f + set r +} + +if [file exists $cat32] { +test winpipe-1.1 {32 bit comprehensive tests: from little file} { + exec $cat32 < little > stdout 2> stderr + list [contents stdout] [contents stderr] +} "little stderr32" +test winpipe-1.2 {32 bit comprehensive tests: from big file} { + exec $cat32 < big > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{$big} stderr32" +test winpipe-1.3 {32 bit comprehensive tests: a little from pipe} {NT} { + exec more < little | $cat32 > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{little\n} stderr32" +test winpipe-1.4 {32 bit comprehensive tests: a little from pipe} {95} { + exec more < little |& $cat32 > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{\nlittle} stderr32" +test winpipe-1.5 {32 bit comprehensive tests: a lot from pipe} {NT} { + exec more < big | $cat32 > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{$big} stderr32" +test winpipe-1.6 {32 bit comprehensive tests: a lot from pipe} {95} { + exec command /c type big |& $cat32 > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{$big} stderr32" +test winpipe-1.7 {32 bit comprehensive tests: from console} {AllocConsole} { + # would block waiting for human input +} {} +test winpipe-1.8 {32 bit comprehensive tests: from NUL} { + exec $cat32 < nul > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{} stderr32" +test winpipe-1.9 {32 bit comprehensive tests: from socket} { + # doesn't work +} {} +test winpipe-1.10 {32 bit comprehensive tests: from nowhere} {.console} { + exec $cat32 > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{} stderr32" +test winpipe-1.11 {32 bit comprehensive tests: from file handle} { + set f [open "little" r] + exec $cat32 <@$f > stdout 2> stderr + close $f + list [contents stdout] [contents stderr] +} "little stderr32" +test winpipe-1.12 {32 bit comprehensive tests: read from application} { + set f [open "|$cat32 < little" r] + gets $f line + catch {close $f} msg + list $line $msg +} "little stderr32" +test winpipe-1.13 {32 bit comprehensive tests: a little to file} { + exec $cat32 < little > stdout 2> stderr + list [contents stdout] [contents stderr] +} "little stderr32" +test winpipe-1.14 {32 bit comprehensive tests: a lot to file} { + exec $cat32 < big > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{$big} stderr32" +test winpipe-1.15 {32 bit comprehensive tests: a little to pipe} {NT} { + exec $cat32 < little | more > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{little\n} stderr32" +test winpipe-1.16 {32 bit comprehensive tests: a little to pipe} {95} { + exec $cat32 < little | more > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{\nlittle} stderr32" +test winpipe-1.17 {32 bit comprehensive tests: a lot to pipe} {NT} { + exec $cat32 < big | more > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{$big\n} stderr32" +test winpipe-1.18 {32 bit comprehensive tests: a lot to pipe} {95} { + exec $cat32 < big | more > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{\n$big} stderr32" +test winpipe-1.19 {32 bit comprehensive tests: to console} { + catch {exec $cat32 << "You should see this\n" >@stdout} msg + set msg +} stderr32 +test winpipe-1.20 {32 bit comprehensive tests: to NUL} { + # some apps hang when sending a large amount to NUL. $cat32 isn't one. + catch {exec $cat32 < big > nul} msg + set msg +} stderr32 +test winpipe-1.21 {32 bit comprehensive tests: to nowhere} {.console} { + exec $cat32 < big >&@stdout +} {} +test winpipe-1.22 {32 bit comprehensive tests: to file handle} { + set f1 [open "stdout" w] + set f2 [open "stderr" w] + exec $cat32 < little >@$f1 2>@$f2 + close $f1 + close $f2 + list [contents stdout] [contents stderr] +} "little stderr32" +test winpipe-1.23 {32 bit comprehensive tests: write to application} { + set f [open "|$cat32 > stdout" w] + puts -nonewline $f "foo" + catch {close $f} msg + list [contents stdout] $msg +} "foo stderr32" +test winpipe-1.24 {32 bit comprehensive tests: read/write application} { + set f [open "|$cat32" r+] + puts $f $big + puts $f \032 + flush $f + set r [read $f 64] + catch {close $f} + set r +} "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" +test winpipe-1.25 {32 bit comprehensive tests: to socket} { + # doesn't work +} {} +} + +if [file exists $cat16] { +test winpipe-2.1 {16 bit comprehensive tests: from little file} { + exec $cat16 < little > stdout 2> stderr + list [contents stdout] [contents stderr] +} "little stderr16" +test winpipe-2.2 {16 bit comprehensive tests: from big file} { + exec $cat16 < big > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{$big} stderr16" +test winpipe-2.3 {16 bit comprehensive tests: a little from pipe} {NT} { + exec more < little | $cat16 > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{little\n} stderr16" +test winpipe-2.4 {16 bit comprehensive tests: a little from pipe} {95} { + exec more < little | $cat16 > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{\nlittle} stderr16" +test winpipe-2.5 {16 bit comprehensive tests: a lot from pipe} {NT} { + exec $cat16 < big | $cat16 > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{$big} stderr16stderr16" +test winpipe-2.6 {16 bit comprehensive tests: a lot from pipe} {95} { + exec more < big | $cat16 > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{\n$big} stderr16" +test winpipe-2.7 {16 bit comprehensive tests: from console} {AllocConsole} { + # would block waiting for human input +} {} +test winpipe-2.8 {16 bit comprehensive tests: from NUL} {NT} { + exec $cat16 < nul > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{} stderr16" +test winpipe-2.9 {16 bit comprehensive tests: from socket} { + # doesn't work +} {} +test winpipe-2.10 {16 bit comprehensive tests: from nowhere} {.console} { + exec $cat16 > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{} stderr16" +test winpipe-2.11 {16 bit comprehensive tests: from file handle} { + set f [open "little" r] + exec $cat16 <@$f > stdout 2> stderr + close $f + list [contents stdout] [contents stderr] +} "little stderr16" +test winpipe-2.12 {16 bit comprehensive tests: read from application} { + set f [open "|$cat16 < little" r] + gets $f line + catch {close $f} msg + list $line $msg +} {little stderr16} +test winpipe-2.13 {16 bit comprehensive tests: a little to file} { + exec $cat16 < little > stdout 2> stderr + list [contents stdout] [contents stderr] +} "little stderr16" +test winpipe-2.14 {16 bit comprehensive tests: a lot to file} { + exec $cat16 < big > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{$big} stderr16" +test winpipe-2.15 {16 bit comprehensive tests: a little to pipe} {NT} { + catch {exec $cat16 < little | more > stdout 2> stderr} + list [contents stdout] [contents stderr] +} "{little\n} stderr16" +test winpipe-2.16 {16 bit comprehensive tests: a little to pipe} {95} { + exec $cat16 < little | more > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{\nlittle} stderr16" +test winpipe-2.17 {16 bit comprehensive tests: a lot to pipe} {NT} { + catch {exec $cat16 < big | more > stdout 2> stderr} + list [contents stdout] [contents stderr] +} "{$big\n} stderr16" +test winpipe-2.18 {16 bit comprehensive tests: a lot to pipe} {95} { + exec $cat16 < big | more > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{\n$big} stderr16" +test winpipe-2.19 {16 bit comprehensive tests: to console} { + catch {exec $cat16 << "You should see this\n" >@stdout} msg + set msg +} stderr16 +test winpipe-2.20 {16 bit comprehensive tests: to NUL} {NT} { + # some apps hang when sending a large amount to NUL. cat16 isn't one. + catch {exec $cat16 < big > nul} msg + set msg +} stderr16 +test winpipe-2.21 {16 bit comprehensive tests: to nowhere} {.console} { + exec $cat16 < big >&@stdout +} {} +test winpipe-2.22 {16 bit comprehensive tests: to file handle} { + set f1 [open "stdout" w] + set f2 [open "stderr" w] + exec $cat16 < little >@$f1 2>@$f2 + close $f1 + close $f2 + list [contents stdout] [contents stderr] +} "little stderr16" +test winpipe-2.23 {16 bit comprehensive tests: write to application} { + set f [open "|$cat16 > stdout" w] + puts -nonewline $f "foo" + catch {close $f} msg + list [contents stdout] $msg +} "foo stderr16" +test winpipe-2.24 {16 bit comprehensive tests: read/write application} {NT} { + set f [open "|$cat16" r+] + puts $f $big + puts $f \032 + flush $f + set r [read $f 64] + catch {close $f} + set r +} "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" +test winpipe-2.25 {16 bit comprehensive tests: to socket} { + # doesn't work +} {} +} + diff --git a/tcl7.6/unix/Makefile.in b/tcl7.6/unix/Makefile.in new file mode 100644 index 0000000..492e124 --- /dev/null +++ b/tcl7.6/unix/Makefile.in @@ -0,0 +1,857 @@ +# +# This file is a Makefile for Tcl. If it has the name "Makefile.in" +# then it is a template for a Makefile; to generate the actual Makefile, +# run "./configure", which is a configuration script generated by the +# "autoconf" program (constructs like "@foo@" will get replaced in the +# actual Makefile. +# +# SCCS: @(#) Makefile.in 1.151 96/10/04 10:28:42 + +# Current Tcl version; used in various names. + +VERSION = @TCL_VERSION@ + +#---------------------------------------------------------------- +# Things you can change to personalize the Makefile for your own +# site (you can make these changes in either Makefile.in or +# Makefile, but changes to Makefile will get lost if you re-run +# the configuration script). +#---------------------------------------------------------------- + +# Default top-level directories in which to install architecture- +# specific files (exec_prefix) and machine-independent files such +# as scripts (prefix). The values specified here may be overridden +# at configure-time with the --exec-prefix and --prefix options +# to the "configure" script. + +prefix = @prefix@ +exec_prefix = @exec_prefix@ + +# The following definition can be set to non-null for special systems +# like AFS with replication. It allows the pathnames used for installation +# to be different than those used for actually reference files at +# run-time. INSTALL_ROOT is prepended to $prefix and $exec_prefix +# when installing files. +INSTALL_ROOT = + +# Directory from which applications will reference the library of Tcl +# scripts (note: you can set the TCL_LIBRARY environment variable at +# run-time to override this value): +TCL_LIBRARY = $(prefix)/lib/tcl$(VERSION) + +# Path name to use when installing library scripts: +SCRIPT_INSTALL_DIR = $(INSTALL_ROOT)$(TCL_LIBRARY) + +# Directory in which to install libtcl.so or libtcl.a: +LIB_INSTALL_DIR = $(INSTALL_ROOT)$(exec_prefix)/lib + +# Path to use at runtime to refer to LIB_INSTALL_DIR: +LIB_RUNTIME_DIR = $(exec_prefix)/lib + +# Directory in which to install the program tclsh: +BIN_INSTALL_DIR = $(INSTALL_ROOT)$(exec_prefix)/bin + +# Directory in which to install the include file tcl.h: +INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(prefix)/include + +# Top-level directory in which to install manual entries: +MAN_INSTALL_DIR = $(INSTALL_ROOT)$(prefix)/man + +# Directory in which to install manual entry for tclsh: +MAN1_INSTALL_DIR = $(MAN_INSTALL_DIR)/man1 + +# Directory in which to install manual entries for Tcl's C library +# procedures: +MAN3_INSTALL_DIR = $(MAN_INSTALL_DIR)/man3 + +# Directory in which to install manual entries for the built-in +# Tcl commands: +MANN_INSTALL_DIR = $(MAN_INSTALL_DIR)/mann + +# To change the compiler switches, for example to change from -O +# to -g, change the following line: +CFLAGS = -O + +# To disable ANSI-C procedure prototypes reverse the comment characters +# on the following lines: +PROTO_FLAGS = +#PROTO_FLAGS = -DNO_PROTOTYPE + +# Mathematical functions like sin and atan2 are enabled for expressions +# by default. To disable them, reverse the comment characters on the +# following pairs of lines: +MATH_FLAGS = +#MATH_FLAGS = -DTCL_NO_MATH +MATH_LIBS = @MATH_LIBS@ +#MATH_LIBS = + +# If you use the setenv, putenv, or unsetenv procedures to modify +# environment variables in your application and you'd like those +# modifications to appear in the "env" Tcl variable, switch the +# comments on the two lines below so that Tcl provides these +# procedures instead of your standard C library. + +ENV_FLAGS = +#ENV_FLAGS = -DTclSetEnv=setenv -DTcl_PutEnv=putenv -DTclUnsetEnv=unsetenv + +# To compile for non-UNIX systems (so that only the non-UNIX-specific +# commands are available), reverse the comment characters on the +# following pairs of lines. In addition, you'll have to provide your +# own replacement for the "panic" procedure (see panic.c for what +# the current one does). +GENERIC_FLAGS = +#GENERIC_FLAGS = -DTCL_GENERIC_ONLY +UNIX_OBJS = tclMtherr.o tclUnixChan.o tclUnixFCmd.o tclUnixFile.o \ + tclUnixNotfy.o tclUnixPipe.o tclUnixSock.o tclUnixTime.o \ + tclUnixInit.o +#UNIX_OBJS = + +# To enable memory debugging reverse the comment characters on the following +# lines. Warning: if you enable memory debugging, you must do it +# *everywhere*, including all the code that calls Tcl, and you must use +# ckalloc and ckfree everywhere instead of malloc and free. +MEM_DEBUG_FLAGS = +#MEM_DEBUG_FLAGS = -DTCL_MEM_DEBUG + +# Some versions of make, like SGI's, use the following variable to +# determine which shell to use for executing commands: +SHELL = /bin/sh + +# Tcl used to let the configure script choose which program to use +# for installing, but there are just too many different versions of +# "install" around; better to use the install-sh script that comes +# with the distribution, which is slower but guaranteed to work. + +INSTALL = @srcdir@/install-sh -c +INSTALL_PROGRAM = ${INSTALL} +INSTALL_DATA = ${INSTALL} -m 644 + +# The following symbol defines additional compiler flags to enable +# Tcl itself to be a shared library. If Tcl isn't going to be a +# shared library then the symbol has an empty definition. + +TCL_SHLIB_CFLAGS = @TCL_SHLIB_CFLAGS@ +#TCL_SHLIB_CFLAGS = + +# The symbols below provide support for dynamic loading and shared +# libraries. See configure.in for a description of what the +# symbols mean. The values of the symbols are normally set by the +# configure script. You shouldn't normally need to modify any of +# these definitions by hand. + +SHLIB_LD = @SHLIB_LD@ + +SHLIB_SUFFIX = @SHLIB_SUFFIX@ +#SHLIB_SUFFIX = + +DLTEST_TARGETS = dltest/pkg5${SHLIB_SUFFIX} dltest/Makefile + +# The following symbol is defined to "$(DLTEST_TARGETS)" if dynamic +# loading is available; this causes everything in the "dltest" +# subdirectory to be built when making "tcltest. If dynamic loading +# isn't available, configure defines this symbol to an empty string, +# in which case the shared libraries aren't built. +BUILD_DLTEST = @BUILD_DLTEST@ +#BUILD_DLTEST = + +TCL_LIB_FILE = @TCL_LIB_FILE@ +#TCL_LIB_FILE = libtcl.a + +#---------------------------------------------------------------- +# The information below is modified by the configure script when +# Makefile is generated from Makefile.in. You shouldn't normally +# modify any of this stuff by hand. +#---------------------------------------------------------------- + +COMPAT_OBJS = @LIBOBJS@ + +AC_FLAGS = @DEFS@ +RANLIB = @RANLIB@ +SRC_DIR = @srcdir@ +TOP_DIR = @srcdir@/.. +GENERIC_DIR = $(TOP_DIR)/generic +COMPAT_DIR = $(TOP_DIR)/compat +DLTEST_DIR = @srcdir@/dltest +UNIX_DIR = @srcdir@ +CC = @CC@ + +#---------------------------------------------------------------- +# The information below should be usable as is. The configure +# script won't modify it and you shouldn't need to modify it +# either. +#---------------------------------------------------------------- + + +CC_SWITCHES = ${CFLAGS} ${TCL_SHLIB_CFLAGS} -I${GENERIC_DIR} -I${SRC_DIR} \ +${AC_FLAGS} ${MATH_FLAGS} ${GENERIC_FLAGS} ${PROTO_FLAGS} ${MEM_DEBUG_FLAGS} \ +${ENV_FLAGS} -DTCL_SHLIB_EXT=\"${SHLIB_SUFFIX}\" + +LIBS = @DL_LIBS@ @LIBS@ $(MATH_LIBS) -lc + +DEPEND_SWITCHES = ${CFLAGS} -I${GENERIC_DIR} -I${SRC_DIR} \ +${AC_FLAGS} ${MATH_FLAGS} \ +${GENERIC_FLAGS} ${PROTO_FLAGS} ${MEM_DEBUG_FLAGS} \ +-DTCL_SHLIB_EXT=\"${SHLIB_SUFFIX}\" + +TCLSH_OBJS = tclAppInit.o + +TCLTEST_OBJS = tclTestInit.o tclTest.o tclUnixTest.o + +GENERIC_OBJS = panic.o regexp.o tclAsync.o tclBasic.o tclCkalloc.o \ + tclClock.o tclCmdAH.o tclCmdIL.o tclCmdMZ.o tclDate.o tclEnv.o \ + tclEvent.o tclExpr.o tclFCmd.o \ + tclFHandle.o tclFileName.o tclGet.o tclHash.o \ + tclHistory.o tclInterp.o tclIO.o tclIOCmd.o \ + tclIOSock.o tclIOUtil.o tclLink.o tclLoad.o tclMain.o tclNotify.o \ + tclParse.o tclPkg.o tclPosixStr.o tclPreserve.o tclProc.o \ + tclUtil.o tclVar.o + +OBJS = ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} @DL_OBJS@ + +GENERIC_HDRS = \ + $(GENERIC_DIR)/tclRegexp.h \ + $(GENERIC_DIR)/tcl.h \ + $(GENERIC_DIR)/tclInt.h \ + $(GENERIC_DIR)/tclPort.h \ + $(GENERIC_DIR)/tclPatch.h + +GENERIC_SRCS = \ + $(GENERIC_DIR)/regexp.c \ + $(GENERIC_DIR)/tclAsync.c \ + $(GENERIC_DIR)/tclBasic.c \ + $(GENERIC_DIR)/tclCkalloc.c \ + $(GENERIC_DIR)/tclClock.c \ + $(GENERIC_DIR)/tclCmdAH.c \ + $(GENERIC_DIR)/tclCmdIL.c \ + $(GENERIC_DIR)/tclCmdMZ.c \ + $(GENERIC_DIR)/tclDate.c \ + $(GENERIC_DIR)/tclEnv.c \ + $(GENERIC_DIR)/tclEvent.c \ + $(GENERIC_DIR)/tclExpr.c \ + $(GENERIC_DIR)/tclFCmd.c \ + $(GENERIC_DIR)/tclFHandle.c \ + $(GENERIC_DIR)/tclFileName.c \ + $(GENERIC_DIR)/tclGet.c \ + $(GENERIC_DIR)/tclHash.c \ + $(GENERIC_DIR)/tclHistory.c \ + $(GENERIC_DIR)/tclInterp.c \ + $(GENERIC_DIR)/tclIO.c \ + $(GENERIC_DIR)/tclIOCmd.c \ + $(GENERIC_DIR)/tclIOSock.c \ + $(GENERIC_DIR)/tclIOUtil.c \ + $(GENERIC_DIR)/tclLink.c \ + $(GENERIC_DIR)/tclLoad.c \ + $(GENERIC_DIR)/tclMain.c \ + $(GENERIC_DIR)/tclNotify.c \ + $(GENERIC_DIR)/tclParse.c \ + $(GENERIC_DIR)/tclPkg.c \ + $(GENERIC_DIR)/tclPosixStr.c \ + $(GENERIC_DIR)/tclPreserve.c \ + $(GENERIC_DIR)/tclProc.c \ + $(GENERIC_DIR)/tclTest.c \ + $(GENERIC_DIR)/tclUtil.c \ + $(GENERIC_DIR)/tclVar.c + +UNIX_HDRS = \ + $(UNIX_DIR)/tclUnixPort.h + +UNIX_SRCS = \ + $(UNIX_DIR)/tclAppInit.c \ + $(UNIX_DIR)/tclMtherr.c \ + $(UNIX_DIR)/tclUnixChan.c \ + $(UNIX_DIR)/tclUnixFCmd.c \ + $(UNIX_DIR)/tclUnixFile.c \ + $(UNIX_DIR)/tclUnixNotfy.c \ + $(UNIX_DIR)/tclUnixPipe.c \ + $(UNIX_DIR)/tclUnixSock.c \ + $(UNIX_DIR)/tclUnixTest.c \ + $(UNIX_DIR)/tclUnixTime.c \ + $(UNIX_DIR)/tclUnixInit.c + +DL_SRCS = \ + $(UNIX_DIR)/tclLoadAix.c \ + $(UNIX_DIR)/tclLoadAout.c \ + $(UNIX_DIR)/tclLoadDl.c \ + $(UNIX_DIR)/tclLoadDl2.c \ + $(UNIX_DIR)/tclLoadDld.c \ + $(GENERIC_DIR)/tclLoadNone.c \ + $(UNIX_DIR)/tclLoadOSF.c \ + $(UNIX_DIR)/tclLoadShl.c + +# Note: don't include DL_SRCS in SRCS: most of those files won't +# compile on the current machine, and they will cause problems for +# things like "make depend". + +SRCS = $(GENERIC_SRCS) $(UNIX_SRCS) + +all: ${TCL_LIB_FILE} tclsh + +# The following target is configured by autoconf to generate either +# a shared library or non-shared library for Tcl. + +${TCL_LIB_FILE}: ${OBJS} + rm -f ${TCL_LIB_FILE} + @MAKE_LIB@ + $(RANLIB) ${TCL_LIB_FILE} + +tclsh: ${TCLSH_OBJS} ${TCL_LIB_FILE} + ${CC} @LD_FLAGS@ ${TCLSH_OBJS} @TCL_BUILD_LIB_SPEC@ ${LIBS} \ + @TCL_LD_SEARCH_FLAGS@ -o tclsh + +tcltest: ${TCLTEST_OBJS} ${TCL_LIB_FILE} ${BUILD_DLTEST} + ${CC} @LD_FLAGS@ ${TCLTEST_OBJS} @TCL_BUILD_LIB_SPEC@ ${LIBS} \ + @TCL_LD_SEARCH_FLAGS@ -o tcltest + +# Note, in the target below TCL_LIBRARY needs to be set or else +# "make test" won't work in the case where the compilation directory +# isn't the same as the source directory. + +test: tcltest + LD_LIBRARY_PATH=`pwd`:${LD_LIBRARY_PATH}; export LD_LIBRARY_PATH; \ + TCL_LIBRARY=${TOP_DIR}/library; export TCL_LIBRARY; \ + ( echo cd $(TOP_DIR)/tests\; source all ) | ./tcltest + +# The following target outputs the name of the top-level source directory +# for Tcl (it is used by Tk's configure script, for example). The +# .NO_PARALLEL line is needed to avoid problems under Sun's "pmake". +# Note: this target is now obsolete (use the autoconf variable +# TCL_SRC_DIR from tclConfig.sh instead). + +.NO_PARALLEL: topDirName +topDirName: + @cd $(TOP_DIR); pwd + +# The following target generates the file generic/tclDate.c +# from the yacc grammar found in generic/tclGetDate.y. This is +# only run by hand as yacc is not available in all environments. +# The name of the .c file is different than the name of the .y file +# so that make doesn't try to automatically regenerate the .c file. + +gendate: + yacc -l $(GENERIC_DIR)/tclGetDate.y + sed -e 's/yy/TclDate/g' -e '/^#include /d' \ + -e 's/SCCSID/%Z\% %M\% %I\% %E\% %U\%/g' \ + -e '/#ifdef __STDC__/,/#endif/d' -e '/TclDateerrlab:/d' \ + -e '/TclDatenewstate:/d' -e '/#pragma/d' \ + $(GENERIC_DIR)/tclDate.c + rm y.tab.c + +# The following targets generate the shared libraries in dltest that +# are used for testing; they are included as part of the "tcltest" +# target (via the BUILD_DLTEST variable) if dynamic loading is supported +# on this platform. The ".." environment variable stuff is needed +# because on some platforms tclsh scripts will be executed as part of +# building the shared libraries, and they need to be able to use the +# uninstalled tclsh that is present in this directory. The "make tclsh" +# command is needed for the same reason (must make sure that it exists). + +dltest/pkg5${SHLIB_SUFFIX}: dltest/Makefile + if test ! -f tclsh; then make tclsh; else true; fi + cd dltest; PATH=..:${PATH} TCL_LIBRARY=../../library make + +dltest/Makefile: $(DLTEST_DIR)/configure $(DLTEST_DIR)/Makefile.in tclConfig.sh + if test ! -d dltest; then mkdir dltest; else true; fi + cd dltest; if test -f configure; then ./configure; else \ + $(DLTEST_DIR)/configure; fi + +install: install-binaries install-libraries install-man + +# Note: before running ranlib below, must cd to target directory because +# some ranlibs write to current directory, and this might not always be +# possible (e.g. if installing as root). + +install-binaries: $(TCL_LIB_FILE) tclsh + @for i in $(LIB_INSTALL_DIR) $(BIN_INSTALL_DIR) ; \ + do \ + if [ ! -d $$i ] ; then \ + echo "Making directory $$i"; \ + mkdir $$i; \ + chmod 755 $$i; \ + else true; \ + fi; \ + done; + @echo "Installing $(TCL_LIB_FILE)" + @$(INSTALL_DATA) $(TCL_LIB_FILE) $(LIB_INSTALL_DIR)/$(TCL_LIB_FILE) + @(cd $(LIB_INSTALL_DIR); $(RANLIB) $(TCL_LIB_FILE)) + @chmod 555 $(LIB_INSTALL_DIR)/$(TCL_LIB_FILE) + @echo "Installing tclsh" + @$(INSTALL_PROGRAM) tclsh $(BIN_INSTALL_DIR)/tclsh$(VERSION) + @echo "Installing tclConfig.sh" + @$(INSTALL_DATA) tclConfig.sh $(LIB_INSTALL_DIR)/tclConfig.sh + +install-libraries: + @for i in $(INSTALL_ROOT)$(prefix)/lib $(INCLUDE_INSTALL_DIR) \ + $(SCRIPT_INSTALL_DIR) ; \ + do \ + if [ ! -d $$i ] ; then \ + echo "Making directory $$i"; \ + mkdir $$i; \ + chmod 755 $$i; \ + else true; \ + fi; \ + done; + @echo "Installing tcl.h" + @$(INSTALL_DATA) $(GENERIC_DIR)/tcl.h $(INCLUDE_INSTALL_DIR)/tcl.h + @for i in $(TOP_DIR)/library/*.tcl $(TOP_DIR)/library/tclIndex $(UNIX_DIR)/tclAppInit.c; \ + do \ + echo "Installing $$i"; \ + $(INSTALL_DATA) $$i $(SCRIPT_INSTALL_DIR); \ + done; + +install-man: + @for i in $(MAN_INSTALL_DIR) $(MAN1_INSTALL_DIR) $(MAN3_INSTALL_DIR) $(MANN_INSTALL_DIR) ; \ + do \ + if [ ! -d $$i ] ; then \ + echo "Making directory $$i"; \ + mkdir $$i; \ + chmod 755 $$i; \ + else true; \ + fi; \ + done; + @cd $(TOP_DIR)/doc; for i in *.1; \ + do \ + echo "Installing doc/$$i"; \ + rm -f $(MAN1_INSTALL_DIR)/$$i; \ + sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \ + $$i > $(MAN1_INSTALL_DIR)/$$i; \ + chmod 444 $(MAN1_INSTALL_DIR)/$$i; \ + done; + $(UNIX_DIR)/mkLinks $(MAN1_INSTALL_DIR) + @cd $(TOP_DIR)/doc; for i in *.3; \ + do \ + echo "Installing doc/$$i"; \ + rm -f $(MAN3_INSTALL_DIR)/$$i; \ + sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \ + $$i > $(MAN3_INSTALL_DIR)/$$i; \ + chmod 444 $(MAN3_INSTALL_DIR)/$$i; \ + done; + $(UNIX_DIR)/mkLinks $(MAN3_INSTALL_DIR) + @cd $(TOP_DIR)/doc; for i in *.n; \ + do \ + echo "Installing doc/$$i"; \ + rm -f $(MANN_INSTALL_DIR)/$$i; \ + sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \ + $$i > $(MANN_INSTALL_DIR)/$$i; \ + chmod 444 $(MANN_INSTALL_DIR)/$$i; \ + done; + $(UNIX_DIR)/mkLinks $(MANN_INSTALL_DIR) + +Makefile: $(UNIX_DIR)/Makefile.in + $(SHELL) config.status + +clean: + rm -f *.a *.o libtcl* core errs *~ \#* TAGS *.E a.out \ + errors tclsh tcltest lib.exp + if test -f dltest/Makefile; then cd dltest; make clean; fi + +distclean: clean + rm -rf Makefile config.status config.cache config.log tclConfig.sh \ + SUNWtcl.* prototype + if test -f dltest/Makefile; then cd dltest; make distclean; fi + +depend: + makedepend -- $(DEPEND_SWITCHES) -- $(SRCS) + +bp: $(UNIX_DIR)/bp.c + $(CC) $(CC_SWITCHES) $(UNIX_DIR)/bp.c -o bp + +# Test binaries. The rule for tclTestInit.o is complicated because +# it is is compiled from tclAppInit.c. Can't use the "-o" option +# because this doesn't work on some strange compilers (e.g. UnixWare). + +tclTestInit.o: $(UNIX_DIR)/tclAppInit.c + @if test -f tclAppInit.o ; then \ + rm -f tclAppInit.sav; \ + mv tclAppInit.o tclAppInit.sav; \ + fi; + $(CC) -c $(CC_SWITCHES) -DTCL_TEST $(UNIX_DIR)/tclAppInit.c + rm -f tclTestInit.o + mv tclAppInit.o tclTestInit.o + @if test -f tclAppInit.sav ; then \ + mv tclAppInit.sav tclAppInit.o; \ + fi; + +# Object files used on all Unix systems: + +panic.o: $(GENERIC_DIR)/panic.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/panic.c + +regexp.o: $(GENERIC_DIR)/regexp.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/regexp.c + +tclAppInit.o: $(UNIX_DIR)/tclAppInit.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclAppInit.c + +tclAsync.o: $(GENERIC_DIR)/tclAsync.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAsync.c + +tclBasic.o: $(GENERIC_DIR)/tclBasic.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclBasic.c + +tclCkalloc.o: $(GENERIC_DIR)/tclCkalloc.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCkalloc.c + +tclClock.o: $(GENERIC_DIR)/tclClock.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclClock.c + +tclCmdAH.o: $(GENERIC_DIR)/tclCmdAH.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCmdAH.c + +tclCmdIL.o: $(GENERIC_DIR)/tclCmdIL.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCmdIL.c + +tclCmdMZ.o: $(GENERIC_DIR)/tclCmdMZ.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCmdMZ.c + +tclDate.o: $(GENERIC_DIR)/tclDate.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclDate.c + +tclEnv.o: $(GENERIC_DIR)/tclEnv.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclEnv.c + +tclEvent.o: $(GENERIC_DIR)/tclEvent.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclEvent.c + +tclExpr.o: $(GENERIC_DIR)/tclExpr.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclExpr.c + +tclFCmd.o: $(GENERIC_DIR)/tclFCmd.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclFCmd.c + +tclFHandle.o: $(GENERIC_DIR)/tclFHandle.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclFHandle.c + +tclFileName.o: $(GENERIC_DIR)/tclFileName.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclFileName.c + +tclGet.o: $(GENERIC_DIR)/tclGet.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclGet.c + +tclHash.o: $(GENERIC_DIR)/tclHash.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclHash.c + +tclHistory.o: $(GENERIC_DIR)/tclHistory.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclHistory.c + +tclInterp.o: $(GENERIC_DIR)/tclInterp.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclInterp.c + +tclIO.o: $(GENERIC_DIR)/tclIO.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIO.c + +tclIOCmd.o: $(GENERIC_DIR)/tclIOCmd.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIOCmd.c + +tclIOSock.o: $(GENERIC_DIR)/tclIOSock.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIOSock.c + +tclIOUtil.o: $(GENERIC_DIR)/tclIOUtil.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIOUtil.c + +tclLink.o: $(GENERIC_DIR)/tclLink.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLink.c + +tclLoad.o: $(GENERIC_DIR)/tclLoad.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLoad.c + +tclLoadAix.o: $(UNIX_DIR)/tclLoadAix.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadAix.c + +tclLoadAout.o: $(UNIX_DIR)/tclLoadAout.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadAout.c + +tclLoadDl.o: $(UNIX_DIR)/tclLoadDl.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadDl.c + +tclLoadDl2.o: $(UNIX_DIR)/tclLoadDl2.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadDl2.c + +tclLoadDld.o: $(UNIX_DIR)/tclLoadDld.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadDld.c + +tclLoadNone.o: $(GENERIC_DIR)/tclLoadNone.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLoadNone.c + +tclLoadOSF.o: $(UNIX_DIR)/tclLoadOSF.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadOSF.c + +tclLoadShl.o: $(UNIX_DIR)/tclLoadShl.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadShl.c + +tclMain.o: $(GENERIC_DIR)/tclMain.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclMain.c + +tclMtherr.o: $(UNIX_DIR)/tclMtherr.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclMtherr.c + +tclNotify.o: $(GENERIC_DIR)/tclNotify.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclNotify.c + +tclParse.o: $(GENERIC_DIR)/tclParse.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclParse.c + +tclPkg.o: $(GENERIC_DIR)/tclPkg.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclPkg.c + +tclPosixStr.o: $(GENERIC_DIR)/tclPosixStr.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclPosixStr.c + +tclPreserve.o: $(GENERIC_DIR)/tclPreserve.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclPreserve.c + +tclProc.o: $(GENERIC_DIR)/tclProc.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclProc.c + +tclUtil.o: $(GENERIC_DIR)/tclUtil.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclUtil.c + +tclVar.o: $(GENERIC_DIR)/tclVar.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclVar.c + +tclTest.o: $(GENERIC_DIR)/tclTest.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTest.c + +tclUnixChan.o: $(UNIX_DIR)/tclUnixChan.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixChan.c + +tclUnixFCmd.o: $(UNIX_DIR)/tclUnixFCmd.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixFCmd.c + +tclUnixFile.o: $(UNIX_DIR)/tclUnixFile.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixFile.c + +tclUnixNotfy.o: $(UNIX_DIR)/tclUnixNotfy.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixNotfy.c + +tclUnixPipe.o: $(UNIX_DIR)/tclUnixPipe.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixPipe.c + +tclUnixSock.o: $(UNIX_DIR)/tclUnixSock.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixSock.c + +tclUnixTest.o: $(UNIX_DIR)/tclUnixTest.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixTest.c + +tclUnixTime.o: $(UNIX_DIR)/tclUnixTime.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixTime.c + +tclUnixInit.o: $(UNIX_DIR)/tclUnixInit.c tclConfig.sh + $(CC) -c $(CC_SWITCHES) -DTCL_LIBRARY=\"${TCL_LIBRARY}\" \ + -DTCL_PACKAGE_PATH='"@TCL_PACKAGE_PATH@"' \ + $(UNIX_DIR)/tclUnixInit.c + +# compat binaries + +fixstrtod.o: $(COMPAT_DIR)/fixstrtod.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/fixstrtod.c + +getcwd.o: $(COMPAT_DIR)/getcwd.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/getcwd.c + +opendir.o: $(COMPAT_DIR)/opendir.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/opendir.c + +strncasecmp.o: $(COMPAT_DIR)/strncasecmp.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/strncasecmp.c + +strstr.o: $(COMPAT_DIR)/strstr.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/strstr.c + +strtod.o: $(COMPAT_DIR)/strtod.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/strtod.c + +strtol.o: $(COMPAT_DIR)/strtol.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/strtol.c + +strtoul.o: $(COMPAT_DIR)/strtoul.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/strtoul.c + +tmpnam.o: $(COMPAT_DIR)/tmpnam.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/tmpnam.c + +waitpid.o: $(COMPAT_DIR)/waitpid.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/waitpid.c + +.c.o: + $(CC) -c $(CC_SWITCHES) $< + +# +# Target to check for proper usage of UCHAR macro. +# + +checkuchar: + -egrep isalnum\|isalpha\|iscntrl\|isdigit\|islower\|isprint\|ispunct\|isspace\|isupper\|isxdigit\|toupper\|tolower $(SRCS) | grep -v UCHAR + +# +# Target to make sure that only symbols with "Tcl" prefixes are +# exported. +# + +checkexports: $(TCL_LIB_FILE) + -nm -p $(TCL_LIB_FILE) | awk '$$2 ~ /[TDB]/ { print $$3 }' | sort -n | grep -v '^[Tt]cl' + +# +# Target to create a proper Tcl distribution from information in the +# master source directory. DISTDIR must be defined to indicate where +# to put the distribution. +# + +DISTDIR = /proj/tcl/dist/tcl7.6 +$(UNIX_DIR)/configure: $(UNIX_DIR)/configure.in + autoconf $(UNIX_DIR)/configure.in > $(UNIX_DIR)/configure +dist: $(UNIX_DIR)/configure + rm -rf $(DISTDIR) + mkdir $(DISTDIR) + mkdir $(DISTDIR)/unix + cp -p $(UNIX_DIR)/*.c $(UNIX_DIR)/*.h $(DISTDIR)/unix + rm -f $(DISTDIR)/unix/bp.c + cp $(UNIX_DIR)/Makefile.in $(DISTDIR)/unix + chmod 664 $(DISTDIR)/unix/Makefile.in + cp $(UNIX_DIR)/configure $(UNIX_DIR)/configure.in \ + $(UNIX_DIR)/tclConfig.sh.in $(UNIX_DIR)/install-sh \ + $(UNIX_DIR)/porting.notes $(UNIX_DIR)/porting.old \ + $(UNIX_DIR)/README $(UNIX_DIR)/ldAix $(DISTDIR)/unix + chmod 775 $(DISTDIR)/unix/configure $(DISTDIR)/unix/configure.in + chmod 775 $(DISTDIR)/unix/ldAix + chmod +x $(DISTDIR)/unix/install-sh + tclsh $(UNIX_DIR)/mkLinks.tcl \ + $(UNIX_DIR)/../doc/*.[13n] > $(DISTDIR)/unix/mkLinks + chmod +x $(DISTDIR)/unix/mkLinks + mkdir $(DISTDIR)/generic + cp -p $(GENERIC_DIR)/*.c $(GENERIC_DIR)/*.h $(DISTDIR)/generic + cp -p $(GENERIC_DIR)/README $(DISTDIR)/generic + cp -p $(GENERIC_DIR)/tclGetDate.y $(DISTDIR)/generic + cp -p $(TOP_DIR)/changes $(TOP_DIR)/README $(TOP_DIR)/license.terms \ + $(DISTDIR) + mkdir $(DISTDIR)/library + cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/library/*.tcl \ + $(TOP_DIR)/library/tclIndex $(DISTDIR)/library + mkdir $(DISTDIR)/doc + cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/doc/*.[13n] \ + $(TOP_DIR)/doc/man.macros $(DISTDIR)/doc + mkdir $(DISTDIR)/compat + cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/compat/*.c \ + $(TOP_DIR)/compat/*.h $(TOP_DIR)/compat/README \ + $(DISTDIR)/compat + mkdir $(DISTDIR)/tests + cp -p $(TOP_DIR)/license.terms $(DISTDIR)/tests + cp -p $(TOP_DIR)/tests/*.test $(TOP_DIR)/tests/README \ + $(TOP_DIR)/tests/all $(TOP_DIR)/tests/remote.tcl \ + $(TOP_DIR)/tests/defs $(DISTDIR)/tests + mkdir $(DISTDIR)/win + cp -p $(TOP_DIR)/win/*.c $(TOP_DIR)/win/*.h $(TOP_DIR)/win/*.rc \ + $(DISTDIR)/win + cp -p $(TOP_DIR)/win/makefile.* $(DISTDIR)/win + cp -p $(TOP_DIR)/win/README $(DISTDIR)/win + cp -p $(TOP_DIR)/license.terms $(DISTDIR)/win + mkdir $(DISTDIR)/mac + sccs edit -s $(TOP_DIR)/mac/tclMacProjects.sit.hqx + cp -p tclMacProjects.sit.hqx $(DISTDIR)/mac + sccs unedit $(TOP_DIR)/mac/tclMacProjects.sit.hqx + rm -f tclMacProjects.sit.hqx + cp -p $(TOP_DIR)/mac/*.c $(TOP_DIR)/mac/*.h $(TOP_DIR)/mac/*.r \ + $(DISTDIR)/mac + cp -p $(TOP_DIR)/mac/porting.notes $(TOP_DIR)/mac/README $(DISTDIR)/mac + cp -p $(TOP_DIR)/mac/*.doc $(TOP_DIR)/mac/*.pch $(DISTDIR)/mac + cp -p $(TOP_DIR)/license.terms $(DISTDIR)/mac + mkdir $(DISTDIR)/unix/dltest + cp -p $(UNIX_DIR)/dltest/*.c $(UNIX_DIR)/dltest/Makefile.in \ + $(DISTDIR)/unix/dltest + cp -p $(UNIX_DIR)/dltest/configure.in $(UNIX_DIR)/dltest/configure \ + $(UNIX_DIR)/dltest/README $(DISTDIR)/unix/dltest + +# +# Target to create a Macintosh version of the distribution. This will +# do a normal distribution and then massage the output to prepare it +# for moving to the Mac platform. This requires a few scripts and +# programs found only in the Tcl group's tool workspace. +# + +TOOLDIR = /home/rjohnson/Projects/tools +macdist: dist + rm -f $(DISTDIR)/mac/tclMacProjects.sit.hqx + tclsh $(TOOLDIR)/generic/man2html.tcl $(DISTDIR)/tmp ../.. tcl$(VERSION) + mv $(DISTDIR)/tmp/tcl$(VERSION) $(DISTDIR)/html + rm -rf $(DISTDIR)/doc + rm -rf $(DISTDIR)/tmp + tclsh $(TOOLDIR)/mac/cvtEOL.tcl $(DISTDIR) + +# +# Targets to build Solaris package of the distribution for the current +# architecture. To build stream packages for both sun4 and i86pc +# architectures: +# +# On the sun4 machine, execute the following: +# make distclean; ./configure +# make DISTDIR= package +# +# Once the build is complete, execute the following on the i86pc +# machine: +# make DISTDIR= package-quick +# +# is the absolute path to a directory where the build should +# take place. These steps will generate the SUNWtcl.sun4 and +# SUNWtcl.i86pc stream packages. It is important that the packages be +# built in this fashion in order to ensure that the architecture +# independent files are exactly the same, including timestamps, in +# both packages. +# + +package: dist package-config package-common package-binaries package-generate +package-quick: package-config package-binaries package-generate + +# +# Configure for the current architecture in the dist directory. +# +package-config: + mkdir -p $(DISTDIR)/unix/`arch` + cd $(DISTDIR)/unix/`arch`; \ + ../configure --prefix=/opt/SUNWtcl/$(VERSION) \ + --exec_prefix=/opt/SUNWtcl/$(VERSION)/`arch` \ + --enable-shared + mkdir -p $(DISTDIR)/SUNWtcl/$(VERSION) + mkdir -p $(DISTDIR)/SUNWtcl/$(VERSION)/`arch` + +# +# Build and install the architecture independent files in the dist directory. +# + +package-common: + cd $(DISTDIR)/unix/`arch`;\ + $(MAKE); \ + $(MAKE) prefix=$(DISTDIR)/SUNWtcl/$(VERSION) \ + exec_prefix=$(DISTDIR)/SUNWtcl/$(VERSION)/`arch` \ + install-libraries install-man + mkdir -p $(DISTDIR)/SUNWtcl/$(VERSION)/bin + sed -e "s/TCLVERSION/$(VERSION)/g" < $(UNIX_DIR)/tclsh.sh \ + > $(DISTDIR)/SUNWtcl/$(VERSION)/bin/tclsh$(VERSION) + chmod 755 $(DISTDIR)/SUNWtcl/$(VERSION)/bin/tclsh$(VERSION) + +# +# Build and install the architecture specific files in the dist directory. +# + +package-binaries: + cd $(DISTDIR)/unix/`arch`; \ + $(MAKE); \ + $(MAKE) install-binaries prefix=$(DISTDIR)/SUNWtcl/$(VERSION) \ + exec_prefix=$(DISTDIR)/SUNWtcl/$(VERSION)/`arch` + +# +# Generate a package from the installed files in the dist directory for the +# current architecture. +# + +package-generate: + pkgproto $(DISTDIR)/SUNWtcl/$(VERSION)/bin=bin \ + $(DISTDIR)/SUNWtcl/$(VERSION)/include=include \ + $(DISTDIR)/SUNWtcl/$(VERSION)/lib=lib \ + $(DISTDIR)/SUNWtcl/$(VERSION)/man=man \ + $(DISTDIR)/SUNWtcl/$(VERSION)/`arch`=`arch` \ + | tclsh $(UNIX_DIR)/mkProto.tcl \ + $(VERSION) $(UNIX_DIR) > prototype + pkgmk -o -d . -f prototype -a `arch` + pkgtrans -s . SUNWtcl.`arch` SUNWtcl + rm -rf SUNWtcl + +# DO NOT DELETE THIS LINE -- make depend depends on it. diff --git a/tcl7.6/unix/README b/tcl7.6/unix/README new file mode 100644 index 0000000..ff025d3 --- /dev/null +++ b/tcl7.6/unix/README @@ -0,0 +1,110 @@ +This is the directory where you configure, compile, test, and install +UNIX versions of Tcl. This directory also contains source files for Tcl +that are specific to UNIX. Some of the files in this directory are +used on the PC or Mac platform too, but they all depend on UNIX +(POSIX/ANSI C) interfaces and some of them only make sense under UNIX. + +The rest of this file contains instructions on how to do this. The +release should compile and run either "out of the box" or with trivial +changes on any UNIX-like system that approximates POSIX, BSD, or System +V. We know that it runs on workstations from Sun, H-P, DEC, IBM, and +SGI, as well as PCs running Linux, BSDI, and SCO UNIX. To compile for +a PC running Windows, see the README file in the directory ../win. To +compile for a Macintosh, see the README file in the directory ../mac. + +SCCS: @(#) README 1.14 96/10/06 15:08:35 + +How To Compile And Install Tcl: +------------------------------- + +(a) Check for patches as described in ../README. + +(b) If you have already compiled Tcl once in this directory and are now + preparing to compile again in the same directory but for a different + platform, or if you have applied patches, type "make distclean" to + discard all the configuration information computed previously. + +(c) Type "./configure". 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, + type "./configure -help" or refer to the autoconf documentation (not + included here). Tcl's "configure" supports the following special + switches in addition to the standard ones: + --enable-gcc If this switch is set, Tcl will configure + itself to use gcc if it is available on your + system. Note: it is not safe to modify the + Makefile to use gcc after configure is run; + if you do this, then information related to + dynamic linking will be incorrect. + --disable-load If this switch is specified then Tcl will + configure itself not to allow dynamic loading, + even if your system appears to support it. + Normally you can leave this switch out and + Tcl will build itself for dynamic loading + if your system supports it. + --enable-shared If this switch is specified, Tcl will compile + itself as a shared library if it can figure + out how to do that on this platform. + Note: be sure to use only absolute path names (those starting with "/") + in the --prefix and --exec_prefix options. + +(d) Type "make". This will create a library archive called "libtcl.a" + or "libtcl.so" and an interpreter application called "tclsh" that + allows you to type Tcl commands interactively or execute script files. + +(e) 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. Then look at the porting Web page + described later in this file. 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. + +(f) Type "make install" to install Tcl binaries and script files in + standard places. You'll need write permission on the installation + directories to do this. The installation directories are + determined by the "configure" script and may be specified with + the --prefix and --exec_prefix options to "configure". See the + Makefile for information on what directories were chosen; you + can override these choices by modifying the "prefix" and + "exec_prefix" variables in the Makefile. + +(g) 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. Note that + the installed versions of tclsh, libtcl.a, and libtcl.so have a + version number in their names, such as "tclsh7.6" or "libtcl7.6.so"; + to use the installed versions, either specify the version number + or create a symbolic link (e.g. from "tclsh" to "tclsh7.6"). + +If you have trouble compiling Tcl, read through the file" porting.notes". +It contains information that people have provided about changes they had +to make to compile Tcl in various environments. Or, check out the +following Web URL: + http://www.sunlabs.com/cgi-bin/tcl/info.4.2 +This is an on-line database of porting information. We make no guarantees +that this information is accurate, complete, or up-to-date, but you may +find it useful. If you get Tcl running on a new configuration, we would +be happy to receive new information to add to "porting.notes". You can +also make a new entry into the on-line Web database. We're also interested +in hearing how to change the configuration setup so that Tcl compiles out +of the box on more platforms. + +Test suite +---------- + +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. Note: don't run the tests as superuser: +this will cause several of them to fail. + +The Tcl test suite is very sensitive to proper implementation of +ANSI C library procedures such as sprintf and sscanf. If the test +suite generates errors, most likely they are due to non-conformance +of your system's ANSI C library; such problems are unlikely to +affect any real applications so it's probably safe to ignore them. diff --git a/tcl7.6/unix/configure b/tcl7.6/unix/configure new file mode 100755 index 0000000..9074352 --- /dev/null +++ b/tcl7.6/unix/configure @@ -0,0 +1,4154 @@ +#! /bin/sh + +# Guess values for system-dependent variables and create Makefiles. +# Generated automatically using autoconf version 2.4 +# Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc. +# +# This configure script is free software; the Free Software Foundation +# gives unlimited permission to copy, distribute and modify it. + +# Defaults: +ac_help= +ac_default_prefix=/usr/local +# Any additions from configure.in: +ac_help="$ac_help + --enable-gcc allow use of gcc if available" +ac_help="$ac_help + --disable-load disallow dynamic loading and "load" command" +ac_help="$ac_help + --enable-shared build libtcl as a shared library" + +# Initialize some variables set by options. +# The variables have the same names as the options, with +# dashes changed to underlines. +build=NONE +cache_file=./config.cache +exec_prefix=NONE +host=NONE +no_create= +nonopt=NONE +no_recursion= +prefix=NONE +program_prefix=NONE +program_suffix=NONE +program_transform_name=s,x,x, +silent= +site= +srcdir= +target=NONE +verbose= +x_includes=NONE +x_libraries=NONE + +# Initialize some other variables. +subdirs= + +ac_prev= +for ac_option +do + + # If the previous option needs an argument, assign it. + if test -n "$ac_prev"; then + eval "$ac_prev=\$ac_option" + ac_prev= + continue + fi + + case "$ac_option" in + -*=*) ac_optarg=`echo "$ac_option" | sed 's/[-_a-zA-Z0-9]*=//'` ;; + *) ac_optarg= ;; + esac + + # Accept the important Cygnus configure options, so we can diagnose typos. + + case "$ac_option" in + + -build | --build | --buil | --bui | --bu | --b) + ac_prev=build ;; + -build=* | --build=* | --buil=* | --bui=* | --bu=* | --b=*) + build="$ac_optarg" ;; + + -cache-file | --cache-file | --cache-fil | --cache-fi \ + | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) + ac_prev=cache_file ;; + -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ + | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) + cache_file="$ac_optarg" ;; + + -disable-* | --disable-*) + ac_feature=`echo $ac_option|sed -e 's/-*disable-//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_feature| sed 's/[-a-zA-Z0-9_]//g'`"; then + { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } + fi + ac_feature=`echo $ac_feature| sed 's/-/_/g'` + eval "enable_${ac_feature}=no" ;; + + -enable-* | --enable-*) + ac_feature=`echo $ac_option|sed -e 's/-*enable-//' -e 's/=.*//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_feature| sed 's/[-_a-zA-Z0-9]//g'`"; then + { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } + fi + ac_feature=`echo $ac_feature| sed 's/-/_/g'` + case "$ac_option" in + *=*) ;; + *) ac_optarg=yes ;; + esac + eval "enable_${ac_feature}='$ac_optarg'" ;; + + -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ + | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ + | --exec | --exe | --ex) + ac_prev=exec_prefix ;; + -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ + | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ + | --exec=* | --exe=* | --ex=*) + exec_prefix="$ac_optarg" ;; + + -gas | --gas | --ga | --g) + # Obsolete; use --with-gas. + with_gas=yes ;; + + -help | --help | --hel | --he) + # Omit some internal or obsolete options to make the list less imposing. + # This message is too long to be a string in the A/UX 3.1 sh. + cat << EOF +Usage: configure [options] [host] +Options: [defaults in brackets after descriptions] +Configuration: + --cache-file=FILE cache test results in FILE + --help print this message + --no-create do not create output files + --quiet, --silent do not print \`checking...' messages + --version print the version of autoconf that created configure +Directory and file names: + --prefix=PREFIX install architecture-independent files in PREFIX + [$ac_default_prefix] + --exec-prefix=PREFIX install architecture-dependent files in PREFIX + [same as prefix] + --srcdir=DIR find the sources in DIR [configure dir or ..] + --program-prefix=PREFIX prepend PREFIX to installed program names + --program-suffix=SUFFIX append SUFFIX to installed program names + --program-transform-name=PROGRAM run sed PROGRAM on installed program names +Host type: + --build=BUILD configure for building on BUILD [BUILD=HOST] + --host=HOST configure for HOST [guessed] + --target=TARGET configure for TARGET [TARGET=HOST] +Features and packages: + --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) + --enable-FEATURE[=ARG] include FEATURE [ARG=yes] + --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] + --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) + --x-includes=DIR X include files are in DIR + --x-libraries=DIR X library files are in DIR +--enable and --with options recognized:$ac_help +EOF + exit 0 ;; + + -host | --host | --hos | --ho) + ac_prev=host ;; + -host=* | --host=* | --hos=* | --ho=*) + host="$ac_optarg" ;; + + -nfp | --nfp | --nf) + # Obsolete; use --without-fp. + with_fp=no ;; + + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c) + no_create=yes ;; + + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) + no_recursion=yes ;; + + -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) + ac_prev=prefix ;; + -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) + prefix="$ac_optarg" ;; + + -program-prefix | --program-prefix | --program-prefi | --program-pref \ + | --program-pre | --program-pr | --program-p) + ac_prev=program_prefix ;; + -program-prefix=* | --program-prefix=* | --program-prefi=* \ + | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) + program_prefix="$ac_optarg" ;; + + -program-suffix | --program-suffix | --program-suffi | --program-suff \ + | --program-suf | --program-su | --program-s) + ac_prev=program_suffix ;; + -program-suffix=* | --program-suffix=* | --program-suffi=* \ + | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) + program_suffix="$ac_optarg" ;; + + -program-transform-name | --program-transform-name \ + | --program-transform-nam | --program-transform-na \ + | --program-transform-n | --program-transform- \ + | --program-transform | --program-transfor \ + | --program-transfo | --program-transf \ + | --program-trans | --program-tran \ + | --progr-tra | --program-tr | --program-t) + ac_prev=program_transform_name ;; + -program-transform-name=* | --program-transform-name=* \ + | --program-transform-nam=* | --program-transform-na=* \ + | --program-transform-n=* | --program-transform-=* \ + | --program-transform=* | --program-transfor=* \ + | --program-transfo=* | --program-transf=* \ + | --program-trans=* | --program-tran=* \ + | --progr-tra=* | --program-tr=* | --program-t=*) + program_transform_name="$ac_optarg" ;; + + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + silent=yes ;; + + -site | --site | --sit) + ac_prev=site ;; + -site=* | --site=* | --sit=*) + site="$ac_optarg" ;; + + -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) + ac_prev=srcdir ;; + -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) + srcdir="$ac_optarg" ;; + + -target | --target | --targe | --targ | --tar | --ta | --t) + ac_prev=target ;; + -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) + target="$ac_optarg" ;; + + -v | -verbose | --verbose | --verbos | --verbo | --verb) + verbose=yes ;; + + -version | --version | --versio | --versi | --vers) + echo "configure generated by autoconf version 2.4" + exit 0 ;; + + -with-* | --with-*) + ac_package=`echo $ac_option|sed -e 's/-*with-//' -e 's/=.*//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_package| sed 's/[-_a-zA-Z0-9]//g'`"; then + { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } + fi + ac_package=`echo $ac_package| sed 's/-/_/g'` + case "$ac_option" in + *=*) ;; + *) ac_optarg=yes ;; + esac + eval "with_${ac_package}='$ac_optarg'" ;; + + -without-* | --without-*) + ac_package=`echo $ac_option|sed -e 's/-*without-//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_package| sed 's/[-a-zA-Z0-9_]//g'`"; then + { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } + fi + ac_package=`echo $ac_package| sed 's/-/_/g'` + eval "with_${ac_package}=no" ;; + + --x) + # Obsolete; use --with-x. + with_x=yes ;; + + -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ + | --x-incl | --x-inc | --x-in | --x-i) + ac_prev=x_includes ;; + -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ + | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) + x_includes="$ac_optarg" ;; + + -x-libraries | --x-libraries | --x-librarie | --x-librari \ + | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) + ac_prev=x_libraries ;; + -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ + | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) + x_libraries="$ac_optarg" ;; + + -*) { echo "configure: error: $ac_option: invalid option; use --help to show usage" 1>&2; exit 1; } + ;; + + *) + if test -n "`echo $ac_option| sed 's/[-a-z0-9.]//g'`"; then + echo "configure: warning: $ac_option: invalid host type" 1>&2 + fi + if test "x$nonopt" != xNONE; then + { echo "configure: error: can only configure for one host and one target at a time" 1>&2; exit 1; } + fi + nonopt="$ac_option" + ;; + + esac +done + +if test -n "$ac_prev"; then + { echo "configure: error: missing argument to --`echo $ac_prev | sed 's/_/-/g'`" 1>&2; exit 1; } +fi + +trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 + +# File descriptor usage: +# 0 standard input +# 1 file creation +# 2 errors and warnings +# 3 some systems may open it to /dev/tty +# 4 used on the Kubota Titan +# 6 checking for... messages and results +# 5 compiler messages saved in config.log +if test "$silent" = yes; then + exec 6>/dev/null +else + exec 6>&1 +fi +exec 5>./config.log + +echo "\ +This file contains any messages produced by compilers while +running configure, to aid debugging if configure makes a mistake. +" 1>&5 + +# Strip out --no-create and --no-recursion so they do not pile up. +# Also quote any args containing shell metacharacters. +ac_configure_args= +for ac_arg +do + case "$ac_arg" in + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c) ;; + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) ;; + *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?]*) + ac_configure_args="$ac_configure_args '$ac_arg'" ;; + *) ac_configure_args="$ac_configure_args $ac_arg" ;; + esac +done + +# NLS nuisances. +# Only set LANG and LC_ALL to C if already set. +# 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 + +# confdefs.h avoids OS command line length limits that DEFS can exceed. +rm -rf conftest* confdefs.h +# AIX cpp loses on an empty file, so make sure it contains at least a newline. +echo > confdefs.h + +# 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. +ac_unique_file=../generic/tcl.h + +# Find the source files, if location was not specified. +if test -z "$srcdir"; then + ac_srcdir_defaulted=yes + # Try the directory containing this script, then its parent. + ac_prog=$0 + ac_confdir=`echo $ac_prog|sed 's%/[^/][^/]*$%%'` + test "x$ac_confdir" = "x$ac_prog" && ac_confdir=. + srcdir=$ac_confdir + if test ! -r $srcdir/$ac_unique_file; then + srcdir=.. + fi +else + ac_srcdir_defaulted=no +fi +if test ! -r $srcdir/$ac_unique_file; then + if test "$ac_srcdir_defaulted" = yes; then + { echo "configure: error: can not find sources in $ac_confdir or .." 1>&2; exit 1; } + else + { echo "configure: error: can not find sources in $srcdir" 1>&2; exit 1; } + fi +fi +srcdir=`echo "${srcdir}" | sed 's%\([^/]\)/*$%\1%'` + +# Prefer explicitly selected file to automatically selected ones. +if test -z "$CONFIG_SITE"; then + if test "x$prefix" != xNONE; then + CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site" + else + CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" + fi +fi +for ac_site_file in $CONFIG_SITE; do + if test -r "$ac_site_file"; then + echo "loading site script $ac_site_file" + . "$ac_site_file" + fi +done + +if test -r "$cache_file"; then + echo "loading cache $cache_file" + . $cache_file +else + echo "creating cache $cache_file" + > $cache_file +fi + +ac_ext=c +# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. +ac_cpp='$CPP $CPPFLAGS' +ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5 2>&5' +ac_link='${CC-cc} -o conftest $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5 2>&5' + +if (echo "testing\c"; echo 1,2,3) | grep c >/dev/null; then + # Stardent Vistra SVR4 grep lacks -e, says ghazi@caip.rutgers.edu. + if (echo -n testing; echo 1,2,3) | sed s/-n/xn/ | grep xn >/dev/null; then + ac_n= ac_c=' +' ac_t=' ' + else + ac_n=-n ac_c= ac_t= + fi +else + ac_n= ac_c='\c' ac_t= +fi + + +# SCCS: @(#) configure.in 1.120 96/10/08 08:32:30 + +TCL_VERSION=7.6 +TCL_MAJOR_VERSION=7 +TCL_MINOR_VERSION=6 +VERSION=${TCL_VERSION} + +if test "${prefix}" = "NONE"; then + prefix=/usr/local +fi +if test "${exec_prefix}" = "NONE"; then + exec_prefix=$prefix +fi +TCL_SRC_DIR=`cd $srcdir/..; pwd` + +# Extract the first word of "ranlib", so it can be a program name with args. +set dummy ranlib; ac_word=$2 +echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_prog_RANLIB'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test -n "$RANLIB"; then + ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test. +else + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}:" + for ac_dir in $PATH; do + test -z "$ac_dir" && ac_dir=. + if test -f $ac_dir/$ac_word; then + ac_cv_prog_RANLIB="ranlib" + break + fi + done + IFS="$ac_save_ifs" + test -z "$ac_cv_prog_RANLIB" && ac_cv_prog_RANLIB=":" +fi +fi +RANLIB="$ac_cv_prog_RANLIB" +if test -n "$RANLIB"; then + echo "$ac_t""$RANLIB" 1>&6 +else + echo "$ac_t""no" 1>&6 +fi + +# Check whether --enable-gcc or --disable-gcc was given. +enableval="$enable_gcc" +if test -n "$enableval"; then + tcl_ok=$enableval +else + tcl_ok=no +fi + +if test "$tcl_ok" = "yes"; then + # Extract the first word of "gcc", so it can be a program name with args. +set dummy gcc; ac_word=$2 +echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}:" + for ac_dir in $PATH; do + test -z "$ac_dir" && ac_dir=. + if test -f $ac_dir/$ac_word; then + ac_cv_prog_CC="gcc" + break + fi + done + IFS="$ac_save_ifs" + test -z "$ac_cv_prog_CC" && ac_cv_prog_CC="cc" +fi +fi +CC="$ac_cv_prog_CC" +if test -n "$CC"; then + echo "$ac_t""$CC" 1>&6 +else + echo "$ac_t""no" 1>&6 +fi + + +echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_prog_gcc'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.c <&5 | egrep yes >/dev/null 2>&1; then + ac_cv_prog_gcc=yes +else + ac_cv_prog_gcc=no +fi +fi +echo "$ac_t""$ac_cv_prog_gcc" 1>&6 +if test $ac_cv_prog_gcc = yes; then + GCC=yes + if test "${CFLAGS+set}" != set; then + echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_prog_gcc_g'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + echo 'void f(){}' > conftest.c +if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then + ac_cv_prog_gcc_g=yes +else + ac_cv_prog_gcc_g=no +fi +rm -f conftest* + +fi + echo "$ac_t""$ac_cv_prog_gcc_g" 1>&6 + if test $ac_cv_prog_gcc_g = yes; then + CFLAGS="-g -O" + else + CFLAGS="-O" + fi + fi +else + GCC= + test "${CFLAGS+set}" = set || CFLAGS="-g" +fi + +else + CC=${CC-cc} + +fi +# If we cannot run a trivial program, we must be cross compiling. +echo $ac_n "checking whether cross-compiling""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_c_cross'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test "$cross_compiling" = yes; then + ac_cv_c_cross=yes +else +cat > conftest.$ac_ext </dev/null; then + ac_cv_c_cross=no +else + ac_cv_c_cross=yes +fi +fi +rm -fr conftest* +fi +cross_compiling=$ac_cv_c_cross +echo "$ac_t""$ac_cv_c_cross" 1>&6 + + +#-------------------------------------------------------------------- +# Supply substitutes for missing POSIX library procedures, or +# set flags so Tcl uses alternate procedures. +#-------------------------------------------------------------------- + +for ac_func in getcwd opendir strstr +do +echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +/* Override any gcc2 internal prototype to avoid an error. */ +char $ac_func(); + +int main() { return 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_$ac_func) || defined (__stub___$ac_func) +choke me +#else +$ac_func(); +#endif + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_func_$ac_func=yes" +else + rm -rf conftest* + eval "ac_cv_func_$ac_func=no" +fi +rm -f conftest* + +fi +if eval "test \"`echo '$ac_cv_func_'$ac_func`\" = yes"; then + echo "$ac_t""yes" 1>&6 + : +else + echo "$ac_t""no" 1>&6 +LIBOBJS="$LIBOBJS ${ac_func}.o" +fi + +done + +for ac_func in strtol tmpnam waitpid +do +echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +/* Override any gcc2 internal prototype to avoid an error. */ +char $ac_func(); + +int main() { return 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_$ac_func) || defined (__stub___$ac_func) +choke me +#else +$ac_func(); +#endif + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_func_$ac_func=yes" +else + rm -rf conftest* + eval "ac_cv_func_$ac_func=no" +fi +rm -f conftest* + +fi +if eval "test \"`echo '$ac_cv_func_'$ac_func`\" = yes"; then + echo "$ac_t""yes" 1>&6 + : +else + echo "$ac_t""no" 1>&6 +LIBOBJS="$LIBOBJS ${ac_func}.o" +fi + +done + +echo $ac_n "checking for strerror""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_func_strerror'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +/* Override any gcc2 internal prototype to avoid an error. */ +char strerror(); + +int main() { return 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_strerror) || defined (__stub___strerror) +choke me +#else +strerror(); +#endif + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_func_strerror=yes" +else + rm -rf conftest* + eval "ac_cv_func_strerror=no" +fi +rm -f conftest* + +fi +if eval "test \"`echo '$ac_cv_func_'strerror`\" = yes"; then + echo "$ac_t""yes" 1>&6 + : +else + echo "$ac_t""no" 1>&6 +cat >> confdefs.h <<\EOF +#define NO_STRERROR 1 +EOF + +fi + +echo $ac_n "checking for getwd""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_func_getwd'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +/* Override any gcc2 internal prototype to avoid an error. */ +char getwd(); + +int main() { return 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 +getwd(); +#endif + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_func_getwd=yes" +else + rm -rf conftest* + eval "ac_cv_func_getwd=no" +fi +rm -f conftest* + +fi +if eval "test \"`echo '$ac_cv_func_'getwd`\" = yes"; then + echo "$ac_t""yes" 1>&6 + : +else + echo "$ac_t""no" 1>&6 +cat >> confdefs.h <<\EOF +#define NO_GETWD 1 +EOF + +fi + +echo $ac_n "checking for wait3""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_func_wait3'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +/* Override any gcc2 internal prototype to avoid an error. */ +char wait3(); + +int main() { return 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 +wait3(); +#endif + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_func_wait3=yes" +else + rm -rf conftest* + eval "ac_cv_func_wait3=no" +fi +rm -f conftest* + +fi +if eval "test \"`echo '$ac_cv_func_'wait3`\" = yes"; then + echo "$ac_t""yes" 1>&6 + : +else + echo "$ac_t""no" 1>&6 +cat >> confdefs.h <<\EOF +#define NO_WAIT3 1 +EOF + +fi + +echo $ac_n "checking for uname""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_func_uname'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +/* Override any gcc2 internal prototype to avoid an error. */ +char uname(); + +int main() { return 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_uname) || defined (__stub___uname) +choke me +#else +uname(); +#endif + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_func_uname=yes" +else + rm -rf conftest* + eval "ac_cv_func_uname=no" +fi +rm -f conftest* + +fi +if eval "test \"`echo '$ac_cv_func_'uname`\" = yes"; then + echo "$ac_t""yes" 1>&6 + : +else + echo "$ac_t""no" 1>&6 +cat >> confdefs.h <<\EOF +#define NO_UNAME 1 +EOF + +fi + + +#-------------------------------------------------------------------- +# On a few very rare systems, all of the libm.a stuff is +# already in libc.a. Set compiler flags accordingly. +# Also, Linux requires the "ieee" library for math to work +# right (and it must appear before "-lm"). +#-------------------------------------------------------------------- + +echo $ac_n "checking for sin""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_func_sin'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +/* Override any gcc2 internal prototype to avoid an error. */ +char sin(); + +int main() { return 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_sin) || defined (__stub___sin) +choke me +#else +sin(); +#endif + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_func_sin=yes" +else + rm -rf conftest* + eval "ac_cv_func_sin=no" +fi +rm -f conftest* + +fi +if eval "test \"`echo '$ac_cv_func_'sin`\" = yes"; then + echo "$ac_t""yes" 1>&6 + MATH_LIBS="" +else + echo "$ac_t""no" 1>&6 +MATH_LIBS="-lm" +fi + +echo $ac_n "checking for -lieee""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_lib_ieee'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + ac_save_LIBS="$LIBS" +LIBS="-lieee $LIBS" +cat > conftest.$ac_ext <&6 + MATH_LIBS="-lieee $MATH_LIBS" +else + echo "$ac_t""no" 1>&6 +fi + + +#-------------------------------------------------------------------- +# Supply substitutes for missing POSIX header files. Special +# notes: +# - stdlib.h doesn't define strtol, strtoul, or +# strtod insome versions of SunOS +# - some versions of string.h don't declare procedures such +# as strstr +#-------------------------------------------------------------------- + +echo $ac_n "checking dirent.h""... $ac_c" 1>&6 +cat > conftest.$ac_ext < +#include +int main() { return 0; } +int t() { + +#ifndef _POSIX_SOURCE +# ifdef __Lynx__ + /* + * Generate compilation error to make the test fail: Lynx headers + * are only valid if really in the POSIX environment. + */ + + missing_procedure(); +# endif +#endif +DIR *d; +struct dirent *entryPtr; +char *p; +d = opendir("foobar"); +entryPtr = readdir(d); +p = entryPtr->d_name; +closedir(d); + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + tcl_ok=yes +else + rm -rf conftest* + tcl_ok=no +fi +rm -f conftest* + +if test $tcl_ok = no; then + cat >> confdefs.h <<\EOF +#define NO_DIRENT_H 1 +EOF + +fi +echo "$ac_t""$tcl_ok" 1>&6 +echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6 +# On Suns, sometimes $CPP names a directory. +if test -n "$CPP" && test -d "$CPP"; then + CPP= +fi +if test -z "$CPP"; then +if eval "test \"`echo '$''{'ac_cv_prog_CPP'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + # This must be in double quotes, not single quotes, because CPP may get + # substituted into the Makefile and "${CC-cc}" will confuse make. + CPP="${CC-cc} -E" + # On the NeXT, cc -E runs the code through the compiler's parser, + # not just through cpp. + cat > conftest.$ac_ext < +Syntax Error +EOF +eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + : +else + echo "$ac_err" >&5 + rm -rf conftest* + CPP="${CC-cc} -E -traditional-cpp" + cat > conftest.$ac_ext < +Syntax Error +EOF +eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + : +else + echo "$ac_err" >&5 + rm -rf conftest* + CPP=/lib/cpp +fi +rm -f conftest* +fi +rm -f conftest* + ac_cv_prog_CPP="$CPP" +fi + CPP="$ac_cv_prog_CPP" +else + ac_cv_prog_CPP="$CPP" +fi +echo "$ac_t""$CPP" 1>&6 + +ac_safe=`echo "errno.h" | tr './\055' '___'` +echo $ac_n "checking for errno.h""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +EOF +eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + rm -rf conftest* + eval "ac_cv_header_$ac_safe=yes" +else + echo "$ac_err" >&5 + rm -rf conftest* + eval "ac_cv_header_$ac_safe=no" +fi +rm -f conftest* +fi +if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then + echo "$ac_t""yes" 1>&6 + : +else + echo "$ac_t""no" 1>&6 +cat >> confdefs.h <<\EOF +#define NO_ERRNO_H 1 +EOF + +fi + +ac_safe=`echo "float.h" | tr './\055' '___'` +echo $ac_n "checking for float.h""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +EOF +eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + rm -rf conftest* + eval "ac_cv_header_$ac_safe=yes" +else + echo "$ac_err" >&5 + rm -rf conftest* + eval "ac_cv_header_$ac_safe=no" +fi +rm -f conftest* +fi +if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then + echo "$ac_t""yes" 1>&6 + : +else + echo "$ac_t""no" 1>&6 +cat >> confdefs.h <<\EOF +#define NO_FLOAT_H 1 +EOF + +fi + +ac_safe=`echo "limits.h" | tr './\055' '___'` +echo $ac_n "checking for limits.h""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +EOF +eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + rm -rf conftest* + eval "ac_cv_header_$ac_safe=yes" +else + echo "$ac_err" >&5 + rm -rf conftest* + eval "ac_cv_header_$ac_safe=no" +fi +rm -f conftest* +fi +if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then + echo "$ac_t""yes" 1>&6 + : +else + echo "$ac_t""no" 1>&6 +cat >> confdefs.h <<\EOF +#define NO_LIMITS_H 1 +EOF + +fi + +ac_safe=`echo "stdlib.h" | tr './\055' '___'` +echo $ac_n "checking for stdlib.h""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +EOF +eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + rm -rf conftest* + eval "ac_cv_header_$ac_safe=yes" +else + echo "$ac_err" >&5 + rm -rf conftest* + eval "ac_cv_header_$ac_safe=no" +fi +rm -f conftest* +fi +if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then + echo "$ac_t""yes" 1>&6 + tcl_ok=1 +else + echo "$ac_t""no" 1>&6 +tcl_ok=0 +fi + +cat > conftest.$ac_ext < +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "strtol" >/dev/null 2>&1; then + : +else + rm -rf conftest* + tcl_ok=0 +fi +rm -f conftest* + +cat > conftest.$ac_ext < +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "strtoul" >/dev/null 2>&1; then + : +else + rm -rf conftest* + tcl_ok=0 +fi +rm -f conftest* + +cat > conftest.$ac_ext < +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "strtod" >/dev/null 2>&1; then + : +else + rm -rf conftest* + tcl_ok=0 +fi +rm -f conftest* + +if test $tcl_ok = 0; then + cat >> confdefs.h <<\EOF +#define NO_STDLIB_H 1 +EOF + +fi +ac_safe=`echo "string.h" | tr './\055' '___'` +echo $ac_n "checking for string.h""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +EOF +eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + rm -rf conftest* + eval "ac_cv_header_$ac_safe=yes" +else + echo "$ac_err" >&5 + rm -rf conftest* + eval "ac_cv_header_$ac_safe=no" +fi +rm -f conftest* +fi +if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then + echo "$ac_t""yes" 1>&6 + tcl_ok=1 +else + echo "$ac_t""no" 1>&6 +tcl_ok=0 +fi + +cat > conftest.$ac_ext < +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "strstr" >/dev/null 2>&1; then + : +else + rm -rf conftest* + tcl_ok=0 +fi +rm -f conftest* + +cat > conftest.$ac_ext < +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "strerror" >/dev/null 2>&1; then + : +else + rm -rf conftest* + tcl_ok=0 +fi +rm -f conftest* + +if test $tcl_ok = 0; then + cat >> confdefs.h <<\EOF +#define NO_STRING_H 1 +EOF + +fi +ac_safe=`echo "sys/wait.h" | tr './\055' '___'` +echo $ac_n "checking for sys/wait.h""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +EOF +eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + rm -rf conftest* + eval "ac_cv_header_$ac_safe=yes" +else + echo "$ac_err" >&5 + rm -rf conftest* + eval "ac_cv_header_$ac_safe=no" +fi +rm -f conftest* +fi +if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then + echo "$ac_t""yes" 1>&6 + : +else + echo "$ac_t""no" 1>&6 +cat >> confdefs.h <<\EOF +#define NO_SYS_WAIT_H 1 +EOF + +fi + +ac_safe=`echo "dlfcn.h" | tr './\055' '___'` +echo $ac_n "checking for dlfcn.h""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +EOF +eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + rm -rf conftest* + eval "ac_cv_header_$ac_safe=yes" +else + echo "$ac_err" >&5 + rm -rf conftest* + eval "ac_cv_header_$ac_safe=no" +fi +rm -f conftest* +fi +if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then + echo "$ac_t""yes" 1>&6 + : +else + echo "$ac_t""no" 1>&6 +cat >> confdefs.h <<\EOF +#define NO_DLFCN_H 1 +EOF + +fi + +for ac_hdr in unistd.h +do +ac_safe=`echo "$ac_hdr" | tr './\055' '___'` +echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +EOF +eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + rm -rf conftest* + eval "ac_cv_header_$ac_safe=yes" +else + echo "$ac_err" >&5 + rm -rf conftest* + eval "ac_cv_header_$ac_safe=no" +fi +rm -f conftest* +fi +if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then + echo "$ac_t""yes" 1>&6 + ac_tr_hdr=HAVE_`echo $ac_hdr | tr 'abcdefghijklmnopqrstuvwxyz./\055' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ___'` + cat >> confdefs.h <&6 +fi +done + + +#-------------------------------------------------------------------- +# Include sys/select.h if it exists and if it supplies things +# that appear to be useful and aren't already in sys/types.h. +# This appears to be true only on the RS/6000 under AIX. Some +# systems like OSF/1 have a sys/select.h that's of no use, and +# other systems like SCO UNIX have a sys/select.h that's +# pernicious. If "fd_set" isn't defined anywhere then set a +# special flag. +#-------------------------------------------------------------------- + +echo $ac_n "checking fd_set and sys/select""... $ac_c" 1>&6 +cat > conftest.$ac_ext < +int main() { return 0; } +int t() { +fd_set readMask, writeMask; +; return 0; } +EOF +if eval $ac_compile; then + rm -rf conftest* + tk_ok=yes +else + rm -rf conftest* + tk_ok=no +fi +rm -f conftest* + +if test $tk_ok = no; then + cat > conftest.$ac_ext < +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "fd_mask" >/dev/null 2>&1; then + rm -rf conftest* + tk_ok=yes +fi +rm -f conftest* + + if test $tk_ok = yes; then + cat >> confdefs.h <<\EOF +#define HAVE_SYS_SELECT_H 1 +EOF + + fi +fi +echo "$ac_t""$tk_ok" 1>&6 +if test $tk_ok = no; then + cat >> confdefs.h <<\EOF +#define NO_FD_SET 1 +EOF + +fi + +#------------------------------------------------------------------------------ +# Find out all about time handling differences. +#------------------------------------------------------------------------------ + +for ac_hdr in sys/time.h +do +ac_safe=`echo "$ac_hdr" | tr './\055' '___'` +echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +EOF +eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + rm -rf conftest* + eval "ac_cv_header_$ac_safe=yes" +else + echo "$ac_err" >&5 + rm -rf conftest* + eval "ac_cv_header_$ac_safe=no" +fi +rm -f conftest* +fi +if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then + echo "$ac_t""yes" 1>&6 + ac_tr_hdr=HAVE_`echo $ac_hdr | tr 'abcdefghijklmnopqrstuvwxyz./\055' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ___'` + cat >> confdefs.h <&6 +fi +done + +echo $ac_n "checking whether time.h and sys/time.h may both be included""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_header_time'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +#include +#include +int main() { return 0; } +int t() { +struct tm *tp; +; return 0; } +EOF +if eval $ac_compile; then + rm -rf conftest* + ac_cv_header_time=yes +else + rm -rf conftest* + ac_cv_header_time=no +fi +rm -f conftest* + +fi +echo "$ac_t""$ac_cv_header_time" 1>&6 +if test $ac_cv_header_time = yes; then + cat >> confdefs.h <<\EOF +#define TIME_WITH_SYS_TIME 1 +EOF + +fi + +echo $ac_n "checking whether struct tm is in sys/time.h or time.h""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_struct_tm'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +#include +int main() { return 0; } +int t() { +struct tm *tp; tp->tm_sec; +; return 0; } +EOF +if eval $ac_compile; then + rm -rf conftest* + ac_cv_struct_tm=time.h +else + rm -rf conftest* + ac_cv_struct_tm=sys/time.h +fi +rm -f conftest* + +fi +echo "$ac_t""$ac_cv_struct_tm" 1>&6 +if test $ac_cv_struct_tm = sys/time.h; then + cat >> confdefs.h <<\EOF +#define TM_IN_SYS_TIME 1 +EOF + +fi + +echo $ac_n "checking for tm_zone in struct tm""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_struct_tm_zone'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +#include <$ac_cv_struct_tm> +int main() { return 0; } +int t() { +struct tm tm; tm.tm_zone; +; return 0; } +EOF +if eval $ac_compile; then + rm -rf conftest* + ac_cv_struct_tm_zone=yes +else + rm -rf conftest* + ac_cv_struct_tm_zone=no +fi +rm -f conftest* + +fi +echo "$ac_t""$ac_cv_struct_tm_zone" 1>&6 +if test "$ac_cv_struct_tm_zone" = yes; then + cat >> confdefs.h <<\EOF +#define HAVE_TM_ZONE 1 +EOF + +else + echo $ac_n "checking for tzname""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_var_tzname'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +#ifndef tzname /* For SGI. */ +extern char *tzname[]; /* RS6000 and others reject char **tzname. */ +#endif +int main() { return 0; } +int t() { +atoi(*tzname); +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + ac_cv_var_tzname=yes +else + rm -rf conftest* + ac_cv_var_tzname=no +fi +rm -f conftest* + +fi + echo "$ac_t""$ac_cv_var_tzname" 1>&6 + if test $ac_cv_var_tzname = yes; then + cat >> confdefs.h <<\EOF +#define HAVE_TZNAME 1 +EOF + + fi +fi + + +echo $ac_n "checking tm_tzadj in struct tm""... $ac_c" 1>&6 +cat > conftest.$ac_ext < +int main() { return 0; } +int t() { +struct tm tm; tm.tm_tzadj; +; return 0; } +EOF +if eval $ac_compile; then + rm -rf conftest* + cat >> confdefs.h <<\EOF +#define HAVE_TM_TZADJ 1 +EOF + + echo "$ac_t""yes" 1>&6 +else + rm -rf conftest* + echo "$ac_t""no" 1>&6 +fi +rm -f conftest* + + +echo $ac_n "checking tm_gmtoff in struct tm""... $ac_c" 1>&6 +cat > conftest.$ac_ext < +int main() { return 0; } +int t() { +struct tm tm; tm.tm_gmtoff; +; return 0; } +EOF +if eval $ac_compile; then + rm -rf conftest* + cat >> confdefs.h <<\EOF +#define HAVE_TM_GMTOFF 1 +EOF + + echo "$ac_t""yes" 1>&6 +else + rm -rf conftest* + echo "$ac_t""no" 1>&6 +fi +rm -f conftest* + + +# +# Its important to include time.h in this check, as some systems (like convex) +# have timezone functions, etc. +# +have_timezone=no +echo $ac_n "checking long timezone variable""... $ac_c" 1>&6 +cat > conftest.$ac_ext < +int main() { return 0; } +int t() { +extern long timezone; + timezone += 1; + exit (0); +; return 0; } +EOF +if eval $ac_compile; then + rm -rf conftest* + have_timezone=yes + cat >> confdefs.h <<\EOF +#define HAVE_TIMEZONE_VAR 1 +EOF + + echo "$ac_t""yes" 1>&6 +else + rm -rf conftest* + echo "$ac_t""no" 1>&6 +fi +rm -f conftest* + + +# +# On some systems (eg IRIX 6.2), timezone is a time_t and not a long. +# +if test "$have_timezone" = no; then + echo $ac_n "checking time_t timezone variable""... $ac_c" 1>&6 + cat > conftest.$ac_ext < +int main() { return 0; } +int t() { +extern time_t timezone; + timezone += 1; + exit (0); +; return 0; } +EOF +if eval $ac_compile; then + rm -rf conftest* + cat >> confdefs.h <<\EOF +#define HAVE_TIMEZONE_VAR 1 +EOF + + echo "$ac_t""yes" 1>&6 +else + rm -rf conftest* + echo "$ac_t""no" 1>&6 +fi +rm -f conftest* + +fi + +#-------------------------------------------------------------------- +# On some systems strstr is broken: it returns a pointer even +# even if the original string is empty. +#-------------------------------------------------------------------- + +echo $ac_n "checking proper strstr implementation""... $ac_c" 1>&6 +if test "$cross_compiling" = yes; then + tcl_ok=no +else +cat > conftest.$ac_ext </dev/null; then + tcl_ok=yes +else + tcl_ok=no +fi +fi +rm -fr conftest* +if test $tcl_ok = yes; then + echo "$ac_t""yes" 1>&6 +else + echo "$ac_t""broken, using substitute" 1>&6 + LIBOBJS="$LIBOBJS strstr.o" +fi + +#-------------------------------------------------------------------- +# Check for strtoul function. This is tricky because under some +# versions of AIX strtoul returns an incorrect terminator +# pointer for the string "0". +#-------------------------------------------------------------------- + +echo $ac_n "checking for strtoul""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_func_strtoul'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +/* Override any gcc2 internal prototype to avoid an error. */ +char strtoul(); + +int main() { return 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 +strtoul(); +#endif + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_func_strtoul=yes" +else + rm -rf conftest* + eval "ac_cv_func_strtoul=no" +fi +rm -f conftest* + +fi +if eval "test \"`echo '$ac_cv_func_'strtoul`\" = yes"; then + echo "$ac_t""yes" 1>&6 + tcl_ok=1 +else + echo "$ac_t""no" 1>&6 +tcl_ok=0 +fi + +if test "$cross_compiling" = yes; then + tcl_ok=0 +else +cat > conftest.$ac_ext </dev/null; then + : +else + tcl_ok=0 +fi +fi +rm -fr conftest* +if test "$tcl_ok" = 0; then + test -n "$verbose" && echo " Adding strtoul.o." + LIBOBJS="$LIBOBJS strtoul.o" +fi + +#-------------------------------------------------------------------- +# Check for the strtod function. This is tricky because in some +# versions of Linux strtod mis-parses strings starting with "+". +#-------------------------------------------------------------------- + +echo $ac_n "checking for strtod""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_func_strtod'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +/* Override any gcc2 internal prototype to avoid an error. */ +char strtod(); + +int main() { return 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 +strtod(); +#endif + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_func_strtod=yes" +else + rm -rf conftest* + eval "ac_cv_func_strtod=no" +fi +rm -f conftest* + +fi +if eval "test \"`echo '$ac_cv_func_'strtod`\" = yes"; then + echo "$ac_t""yes" 1>&6 + tcl_ok=1 +else + echo "$ac_t""no" 1>&6 +tcl_ok=0 +fi + +if test "$cross_compiling" = yes; then + tcl_ok=0 +else +cat > conftest.$ac_ext </dev/null; then + : +else + tcl_ok=0 +fi +fi +rm -fr conftest* +if test "$tcl_ok" = 0; then + test -n "$verbose" && echo " Adding strtod.o." + LIBOBJS="$LIBOBJS strtod.o" +fi + +#-------------------------------------------------------------------- +# Under Solaris 2.4, strtod returns the wrong value for the +# terminating character under some conditions. Check for this +# and if the problem exists use a substitute procedure +# "fixstrtod" that corrects the error. +#-------------------------------------------------------------------- + +echo $ac_n "checking for strtod""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_func_strtod'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +/* Override any gcc2 internal prototype to avoid an error. */ +char strtod(); + +int main() { return 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 +strtod(); +#endif + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_func_strtod=yes" +else + rm -rf conftest* + eval "ac_cv_func_strtod=no" +fi +rm -f conftest* + +fi +if eval "test \"`echo '$ac_cv_func_'strtod`\" = yes"; then + echo "$ac_t""yes" 1>&6 + tcl_strtod=1 +else + echo "$ac_t""no" 1>&6 +tcl_strtod=0 +fi + +if test "$tcl_strtod" = 1; then + echo $ac_n "checking for Solaris strtod bug""... $ac_c" 1>&6 + if test "$cross_compiling" = yes; then + tcl_ok=0 +else +cat > conftest.$ac_ext </dev/null; then + tcl_ok=1 +else + tcl_ok=0 +fi +fi +rm -fr conftest* + if test $tcl_ok = 1; then + echo "$ac_t""ok" 1>&6 + else + echo "$ac_t""buggy" 1>&6 + LIBOBJS="$LIBOBJS fixstrtod.o" + cat >> confdefs.h <<\EOF +#define strtod fixstrtod +EOF + + fi +fi + +#-------------------------------------------------------------------- +# Check for various typedefs and provide substitutes if +# they don't exist. +#-------------------------------------------------------------------- + +echo $ac_n "checking for ANSI C header files""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_header_stdc'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +#include +#include +#include +EOF +eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + rm -rf conftest* + ac_cv_header_stdc=yes +else + echo "$ac_err" >&5 + rm -rf conftest* + ac_cv_header_stdc=no +fi +rm -f conftest* + +if test $ac_cv_header_stdc = yes; then + # SunOS 4.x string.h does not declare mem*, contrary to ANSI. +cat > conftest.$ac_ext < +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "memchr" >/dev/null 2>&1; then + : +else + rm -rf conftest* + ac_cv_header_stdc=no +fi +rm -f conftest* + +fi + +if test $ac_cv_header_stdc = yes; then + # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. +cat > conftest.$ac_ext < +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "free" >/dev/null 2>&1; then + : +else + rm -rf conftest* + ac_cv_header_stdc=no +fi +rm -f conftest* + +fi + +if test $ac_cv_header_stdc = yes; then + # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. +if test "$cross_compiling" = yes; then + ac_cv_header_stdc=no +else +cat > conftest.$ac_ext < +#define ISLOWER(c) ('a' <= (c) && (c) <= 'z') +#define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) +#define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) +int main () { int i; for (i = 0; i < 256; i++) +if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) exit(2); +exit (0); } + +EOF +eval $ac_link +if test -s conftest && (./conftest; exit) 2>/dev/null; then + : +else + ac_cv_header_stdc=no +fi +fi +rm -fr conftest* +fi +fi +echo "$ac_t""$ac_cv_header_stdc" 1>&6 +if test $ac_cv_header_stdc = yes; then + cat >> confdefs.h <<\EOF +#define STDC_HEADERS 1 +EOF + +fi + +echo $ac_n "checking for mode_t""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_type_mode_t'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +#if STDC_HEADERS +#include +#endif +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "mode_t" >/dev/null 2>&1; then + rm -rf conftest* + ac_cv_type_mode_t=yes +else + rm -rf conftest* + ac_cv_type_mode_t=no +fi +rm -f conftest* + +fi +echo "$ac_t""$ac_cv_type_mode_t" 1>&6 +if test $ac_cv_type_mode_t = no; then + cat >> confdefs.h <<\EOF +#define mode_t int +EOF + +fi + +echo $ac_n "checking for pid_t""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_type_pid_t'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +#if STDC_HEADERS +#include +#endif +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "pid_t" >/dev/null 2>&1; then + rm -rf conftest* + ac_cv_type_pid_t=yes +else + rm -rf conftest* + ac_cv_type_pid_t=no +fi +rm -f conftest* + +fi +echo "$ac_t""$ac_cv_type_pid_t" 1>&6 +if test $ac_cv_type_pid_t = no; then + cat >> confdefs.h <<\EOF +#define pid_t int +EOF + +fi + +echo $ac_n "checking for size_t""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_type_size_t'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +#if STDC_HEADERS +#include +#endif +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "size_t" >/dev/null 2>&1; then + rm -rf conftest* + ac_cv_type_size_t=yes +else + rm -rf conftest* + ac_cv_type_size_t=no +fi +rm -f conftest* + +fi +echo "$ac_t""$ac_cv_type_size_t" 1>&6 +if test $ac_cv_type_size_t = no; then + cat >> confdefs.h <<\EOF +#define size_t unsigned +EOF + +fi + +echo $ac_n "checking for uid_t in sys/types.h""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_type_uid_t'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "uid_t" >/dev/null 2>&1; then + rm -rf conftest* + ac_cv_type_uid_t=yes +else + rm -rf conftest* + ac_cv_type_uid_t=no +fi +rm -f conftest* + +fi +echo "$ac_t""$ac_cv_type_uid_t" 1>&6 +if test $ac_cv_type_uid_t = no; then + cat >> confdefs.h <<\EOF +#define uid_t int +EOF + + cat >> confdefs.h <<\EOF +#define gid_t int +EOF + +fi + + +#-------------------------------------------------------------------- +# 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 $ac_n "checking for opendir""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_func_opendir'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +/* Override any gcc2 internal prototype to avoid an error. */ +char opendir(); + +int main() { return 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 +opendir(); +#endif + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_func_opendir=yes" +else + rm -rf conftest* + eval "ac_cv_func_opendir=no" +fi +rm -f conftest* + +fi +if eval "test \"`echo '$ac_cv_func_'opendir`\" = yes"; then + echo "$ac_t""yes" 1>&6 + : +else + echo "$ac_t""no" 1>&6 +cat >> confdefs.h <<\EOF +#define USE_DIRENT2_H 1 +EOF + +fi + + +#-------------------------------------------------------------------- +# The check below checks whether defines the type +# "union wait" correctly. It's needed because of weirdness in +# HP-UX where "union wait" is defined in both the BSD and SYS-V +# environments. Checking the usability of WIFEXITED seems to do +# the trick. +#-------------------------------------------------------------------- + +echo $ac_n "checking union wait""... $ac_c" 1>&6 +cat > conftest.$ac_ext < +#include +int main() { return 0; } +int t() { + +union wait x; +WIFEXITED(x); /* Generates compiler error if WIFEXITED + * uses an int. */ + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + tcl_ok=yes +else + rm -rf conftest* + tcl_ok=no +fi +rm -f conftest* + +echo "$ac_t""$tcl_ok" 1>&6 +if test $tcl_ok = no; then + cat >> confdefs.h <<\EOF +#define NO_UNION_WAIT 1 +EOF + +fi + +#-------------------------------------------------------------------- +# Check to see whether the system supports the matherr function +# and its associated type "struct exception". +#-------------------------------------------------------------------- + +echo $ac_n "checking matherr support""... $ac_c" 1>&6 +cat > conftest.$ac_ext < +int main() { return 0; } +int t() { + +struct exception x; +x.type = DOMAIN; +x.type = SING; + +; return 0; } +EOF +if eval $ac_compile; then + rm -rf conftest* + tcl_ok=yes +else + rm -rf conftest* + tcl_ok=no +fi +rm -f conftest* + +echo "$ac_t""$tcl_ok" 1>&6 +if test $tcl_ok = yes; then + cat >> confdefs.h <<\EOF +#define NEED_MATHERR 1 +EOF + +fi + +#-------------------------------------------------------------------- +# Check to see whether the system provides a vfork kernel call. +# If not, then use fork instead. Also, check for a problem with +# vforks and signals that can cause core dumps if a vforked child +# resets a signal handler. If the problem exists, then use fork +# instead of vfork. +#-------------------------------------------------------------------- + +echo $ac_n "checking for vfork""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_func_vfork'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +/* Override any gcc2 internal prototype to avoid an error. */ +char vfork(); + +int main() { return 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_vfork) || defined (__stub___vfork) +choke me +#else +vfork(); +#endif + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_func_vfork=yes" +else + rm -rf conftest* + eval "ac_cv_func_vfork=no" +fi +rm -f conftest* + +fi +if eval "test \"`echo '$ac_cv_func_'vfork`\" = yes"; then + echo "$ac_t""yes" 1>&6 + tcl_ok=1 +else + echo "$ac_t""no" 1>&6 +tcl_ok=0 +fi + +if test "$tcl_ok" = 1; then + echo $ac_n "checking vfork/signal bug""... $ac_c" 1>&6; + if test "$cross_compiling" = yes; then + tcl_ok=0 +else +cat > conftest.$ac_ext < + #include + #include + int gotSignal = 0; + sigProc(sig) + int sig; + { + gotSignal = 1; + } + main() + { + int pid, sts; + (void) signal(SIGCHLD, sigProc); + pid = vfork(); + if (pid < 0) { + exit(1); + } else if (pid == 0) { + (void) signal(SIGCHLD, SIG_DFL); + _exit(0); + } else { + (void) wait(&sts); + } + exit((gotSignal) ? 0 : 1); + } +EOF +eval $ac_link +if test -s conftest && (./conftest; exit) 2>/dev/null; then + tcl_ok=1 +else + tcl_ok=0 +fi +fi +rm -fr conftest* + if test "$tcl_ok" = 1; then + echo "$ac_t""ok" 1>&6 + else + echo "$ac_t""buggy, using fork instead" 1>&6 + fi +fi +rm -f core +if test "$tcl_ok" = 0; then + cat >> confdefs.h <<\EOF +#define vfork fork +EOF + +fi + +#-------------------------------------------------------------------- +# Check whether there is an strncasecmp function on this system. +# This is a bit tricky because under SCO it's in -lsocket and +# under Sequent Dynix it's in -linet. +#-------------------------------------------------------------------- + +echo $ac_n "checking for strncasecmp""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_func_strncasecmp'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +/* Override any gcc2 internal prototype to avoid an error. */ +char strncasecmp(); + +int main() { return 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_strncasecmp) || defined (__stub___strncasecmp) +choke me +#else +strncasecmp(); +#endif + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_func_strncasecmp=yes" +else + rm -rf conftest* + eval "ac_cv_func_strncasecmp=no" +fi +rm -f conftest* + +fi +if eval "test \"`echo '$ac_cv_func_'strncasecmp`\" = yes"; then + echo "$ac_t""yes" 1>&6 + tcl_ok=1 +else + echo "$ac_t""no" 1>&6 +tcl_ok=0 +fi + +if test "$tcl_ok" = 0; then + echo $ac_n "checking for -lsocket""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_lib_socket'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + ac_save_LIBS="$LIBS" +LIBS="-lsocket $LIBS" +cat > conftest.$ac_ext <&6 + tcl_ok=1 +else + echo "$ac_t""no" 1>&6 +tcl_ok=0 +fi + +fi +if test "$tcl_ok" = 0; then + echo $ac_n "checking for -linet""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_lib_inet'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + ac_save_LIBS="$LIBS" +LIBS="-linet $LIBS" +cat > conftest.$ac_ext <&6 + tcl_ok=1 +else + echo "$ac_t""no" 1>&6 +tcl_ok=0 +fi + +fi +if test "$tcl_ok" = 0; then + LIBOBJS="$LIBOBJS strncasecmp.o" +fi + +#-------------------------------------------------------------------- +# The code below deals with several issues related to gettimeofday: +# 1. Some systems don't provide a gettimeofday function at all +# (set NO_GETTOD if this is the case). +# 2. SGI systems don't use the BSD form of the gettimeofday function, +# but they have a BSDgettimeofday function that can be used instead. +# 3. See if gettimeofday is declared in the header file. +# if not, set the GETTOD_NOT_DECLARED flag so that tclPort.h can +# declare it. +#-------------------------------------------------------------------- + +echo $ac_n "checking for BSDgettimeofday""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_func_BSDgettimeofday'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +/* Override any gcc2 internal prototype to avoid an error. */ +char BSDgettimeofday(); + +int main() { return 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_BSDgettimeofday) || defined (__stub___BSDgettimeofday) +choke me +#else +BSDgettimeofday(); +#endif + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_func_BSDgettimeofday=yes" +else + rm -rf conftest* + eval "ac_cv_func_BSDgettimeofday=no" +fi +rm -f conftest* + +fi +if eval "test \"`echo '$ac_cv_func_'BSDgettimeofday`\" = yes"; then + echo "$ac_t""yes" 1>&6 + cat >> confdefs.h <<\EOF +#define HAVE_BSDGETTIMEOFDAY 1 +EOF + +else + echo "$ac_t""no" 1>&6 +echo $ac_n "checking for gettimeofday""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_func_gettimeofday'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +/* Override any gcc2 internal prototype to avoid an error. */ +char gettimeofday(); + +int main() { return 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 +gettimeofday(); +#endif + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_func_gettimeofday=yes" +else + rm -rf conftest* + eval "ac_cv_func_gettimeofday=no" +fi +rm -f conftest* + +fi +if eval "test \"`echo '$ac_cv_func_'gettimeofday`\" = yes"; then + echo "$ac_t""yes" 1>&6 + : +else + echo "$ac_t""no" 1>&6 +cat >> confdefs.h <<\EOF +#define NO_GETTOD 1 +EOF + +fi + +fi + +echo $ac_n "checking for gettimeofday declaration""... $ac_c" 1>&6 +cat > conftest.$ac_ext < +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "gettimeofday" >/dev/null 2>&1; then + rm -rf conftest* + echo "$ac_t""present" 1>&6 +else + rm -rf conftest* + + echo "$ac_t""missing" 1>&6 + cat >> confdefs.h <<\EOF +#define GETTOD_NOT_DECLARED 1 +EOF + + +fi +rm -f conftest* + + +#-------------------------------------------------------------------- +# Interactive UNIX requires -linet instead of -lsocket, plus it +# needs net/errno.h to define the socket-related error codes. +#-------------------------------------------------------------------- + +echo $ac_n "checking for -linet""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_lib_inet'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + ac_save_LIBS="$LIBS" +LIBS="-linet $LIBS" +cat > conftest.$ac_ext <&6 + LIBS="$LIBS -linet" +else + echo "$ac_t""no" 1>&6 +fi + +ac_safe=`echo "net/errno.h" | tr './\055' '___'` +echo $ac_n "checking for net/errno.h""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +EOF +eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + rm -rf conftest* + eval "ac_cv_header_$ac_safe=yes" +else + echo "$ac_err" >&5 + rm -rf conftest* + eval "ac_cv_header_$ac_safe=no" +fi +rm -f conftest* +fi +if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then + echo "$ac_t""yes" 1>&6 + cat >> confdefs.h <<\EOF +#define HAVE_NET_ERRNO_H 1 +EOF + +else + echo "$ac_t""no" 1>&6 +fi + + +#-------------------------------------------------------------------- +# Check for the existence of the -lsocket and -lnsl libraries. +# The order here is important, so that they end up in the right +# order in the command line generated by make. Here are some +# special considerations: +# 1. Use "connect" and "accept" to check for -lsocket, and +# "gethostbyname" to check for -lnsl. +# 2. Use each function name only once: can't redo a check because +# autoconf caches the results of the last check and won't redo it. +# 3. Use -lnsl and -lsocket only if they supply procedures that +# aren't already present in the normal libraries. This is because +# IRIX 5.2 has libraries, but they aren't needed and they're +# bogus: they goof up name resolution if used. +# 4. On some SVR4 systems, can't use -lsocket without -lnsl too. +# To get around this problem, check for both libraries together +# if -lsocket doesn't work by itself. +#-------------------------------------------------------------------- + +tcl_checkBoth=0 +echo $ac_n "checking for connect""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_func_connect'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +/* Override any gcc2 internal prototype to avoid an error. */ +char connect(); + +int main() { return 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_connect) || defined (__stub___connect) +choke me +#else +connect(); +#endif + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_func_connect=yes" +else + rm -rf conftest* + eval "ac_cv_func_connect=no" +fi +rm -f conftest* + +fi +if eval "test \"`echo '$ac_cv_func_'connect`\" = yes"; then + echo "$ac_t""yes" 1>&6 + tcl_checkSocket=0 +else + echo "$ac_t""no" 1>&6 +tcl_checkSocket=1 +fi + +if test "$tcl_checkSocket" = 1; then + echo $ac_n "checking for -lsocket""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_lib_socket'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + ac_save_LIBS="$LIBS" +LIBS="-lsocket $LIBS" +cat > conftest.$ac_ext <&6 + LIBS="$LIBS -lsocket" +else + echo "$ac_t""no" 1>&6 +tcl_checkBoth=1 +fi + +fi +if test "$tcl_checkBoth" = 1; then + tk_oldLibs=$LIBS + LIBS="$LIBS -lsocket -lnsl" + echo $ac_n "checking for accept""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_func_accept'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +/* Override any gcc2 internal prototype to avoid an error. */ +char accept(); + +int main() { return 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_accept) || defined (__stub___accept) +choke me +#else +accept(); +#endif + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_func_accept=yes" +else + rm -rf conftest* + eval "ac_cv_func_accept=no" +fi +rm -f conftest* + +fi +if eval "test \"`echo '$ac_cv_func_'accept`\" = yes"; then + echo "$ac_t""yes" 1>&6 + tcl_checkNsl=0 +else + echo "$ac_t""no" 1>&6 +LIBS=$tk_oldLibs +fi + +fi +echo $ac_n "checking for gethostbyname""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_func_gethostbyname'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +/* Override any gcc2 internal prototype to avoid an error. */ +char gethostbyname(); + +int main() { return 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_gethostbyname) || defined (__stub___gethostbyname) +choke me +#else +gethostbyname(); +#endif + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_func_gethostbyname=yes" +else + rm -rf conftest* + eval "ac_cv_func_gethostbyname=no" +fi +rm -f conftest* + +fi +if eval "test \"`echo '$ac_cv_func_'gethostbyname`\" = yes"; then + echo "$ac_t""yes" 1>&6 + : +else + echo "$ac_t""no" 1>&6 +echo $ac_n "checking for -lnsl""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_lib_nsl'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + ac_save_LIBS="$LIBS" +LIBS="-lnsl $LIBS" +cat > conftest.$ac_ext <&6 + LIBS="$LIBS -lnsl" +else + echo "$ac_t""no" 1>&6 +fi + +fi + + +#-------------------------------------------------------------------- +# The statements below define a collection of symbols related to +# dynamic loading and shared libraries: +# +# DL_OBJS - Name of the object file that implements dynamic +# loading for Tcl on this system. +# DL_LIBS - Library file(s) to include in tclsh and other base +# applications in order for the "load" command to work. +# LD_FLAGS - Flags to pass to the compiler when linking object +# files into an executable application binary such +# as tclsh. +# LD_SEARCH_FLAGS-Flags to pass to ld, such as "-R /usr/local/tcl/lib", +# that tell the run-time dynamic linker where to look +# for shared libraries such as libtcl.so. Depends on +# the variable LIB_RUNTIME_DIR in the Makefile. +# MAKE_LIB - Command to execute to build the Tcl library; +# differs depending on whether or not Tcl is being +# compiled as a shared library. +# SHLIB_CFLAGS - Flags to pass to cc when compiling the components +# of a shared library (may request position-independent +# code, among other things). +# SHLIB_LD - Base command to use for combining object files +# into a shared library. +# SHLIB_LD_LIBS - Dependent libraries for the linker to scan when +# creating shared libraries. This symbol typically +# goes at the end of the "ld" commands that build +# shared libraries. The value of the symbol is +# "${LIBS}" if all of the dependent libraries should +# be specified when creating a shared library. If +# dependent libraries should not be specified (as on +# SunOS 4.x, where they cause the link to fail, or in +# general if Tcl and Tk aren't themselves shared +# libraries), then this symbol has an empty string +# as its value. +# SHLIB_SUFFIX - Suffix to use for the names of dynamically loadable +# extensions. An empty string means we don't know how +# to use shared libraries on this platform. +# TCL_LIB_FILE - Name of the file that contains the Tcl library, such +# as libtcl7.6.so or libtcl7.6.a. +# TCL_LIB_SUFFIX -Specifies everything that comes after the "libtcl" +# in the shared library name, using the $VERSION variable +# to put the version in the right place. This is used +# by platforms that need non-standard library names. +# Examples: ${VERSION}.so.1.1 on NetBSD, since it needs +# to have a version after the .so, and ${VERSION}.a +# on AIX, since the Tcl shared library needs to have +# a .a extension whereas shared objects for loadable +# extensions have a .so extension. Defaults to +# ${VERSION}${SHLIB_SUFFIX}. +#-------------------------------------------------------------------- + +# Step 1: set the variable "system" to hold the name and version number +# for the system. This can usually be done via the "uname" command, but +# there are a few systems, like Next, where this doesn't work. + +echo $ac_n "checking system version (for dynamic loading)""... $ac_c" 1>&6 +if test -f /usr/lib/NextStep/software_version; then + system=NEXTSTEP-`awk '/3/,/3/' /usr/lib/NextStep/software_version` +else + system=`uname -s`-`uname -r` + if test "$?" -ne 0 ; then + echo "$ac_t""unknown (can't find uname command)" 1>&6 + system=unknown + else + # Special check for weird MP-RAS system (uname returns weird + # results, and the version is kept in special file). + + if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then + system=MP-RAS-`awk '{print $3}' /etc/.relid'` + fi + if test "`uname -s`" = "AIX" ; then + system=AIX-`uname -v`.`uname -r` + fi + echo "$ac_t""$system" 1>&6 + fi +fi + +# Step 2: check for existence of -ldl library. This is needed because +# Linux can use either -ldl or -ldld for dynamic loading. + +echo $ac_n "checking for -ldl""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_lib_dl'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + ac_save_LIBS="$LIBS" +LIBS="-ldl $LIBS" +cat > conftest.$ac_ext <&6 + have_dl=yes +else + echo "$ac_t""no" 1>&6 +have_dl=no +fi + + +# Step 3: set configuration options based on system name and version. + +fullSrcDir=`cd $srcdir; pwd` +AIX=no +TCL_SHARED_LIB_SUFFIX="" +TCL_UNSHARED_LIB_SUFFIX="" +TCL_LIB_VERSIONS_OK=ok +case $system in + AIX-*) + SHLIB_CFLAGS="" + SHLIB_LD="$fullSrcDir/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512" + SHLIB_LD_LIBS='${LIBS}' + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o tclLoadAix.o" + DL_LIBS="-lld" + LD_FLAGS="" + LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' + AIX=yes + TCL_SHARED_LIB_SUFFIX='${VERSION}.a' + ;; + BSD/OS-2.1*) + SHLIB_CFLAGS="" + SHLIB_LD="ld -r" + SHLIB_LD_FLAGS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + ;; + HP-UX-*.08.*|HP-UX-*.09.*|HP-UX-*.10.*) + echo $ac_n "checking for -ldld""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_lib_dld'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + ac_save_LIBS="$LIBS" +LIBS="-ldld $LIBS" +cat > conftest.$ac_ext <&6 + tcl_ok=yes +else + echo "$ac_t""no" 1>&6 +tcl_ok=no +fi + + if test "$tcl_ok" = yes; then + SHLIB_CFLAGS="+z" + SHLIB_LD="ld -b" + SHLIB_LD_LIBS='${LIBS}' + SHLIB_SUFFIX=".sl" + DL_OBJS="tclLoadShl.o" + DL_LIBS="-ldld" + LD_FLAGS="-Wl,-E" + LD_SEARCH_FLAGS='-Wl,+b,${LIB_RUNTIME_DIR}:.' + fi + ;; + IRIX-4.*) + SHLIB_CFLAGS="-G 0" + SHLIB_SUFFIX="..o" + SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" + SHLIB_LD_LIBS='${LIBS}' + DL_OBJS="tclLoadAout.o" + DL_LIBS="" + LD_FLAGS="-Wl,-D,08000000" + LD_SEARCH_FLAGS="" + ;; + IRIX-5.*|IRIX-6.*) + SHLIB_CFLAGS="" + SHLIB_LD="ld -shared -rdata_shared" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + ;; + IRIX64-6.*) + SHLIB_CFLAGS="" + SHLIB_LD="ld -32 -shared -rdata_shared -rpath /usr/local/lib" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + ;; + Linux*) + SHLIB_CFLAGS="-fPIC" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + if test "$have_dl" = yes; then + SHLIB_LD="${CC} -shared" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="-rdynamic" + LD_SEARCH_FLAGS="" + else + ac_safe=`echo "dld.h" | tr './\055' '___'` +echo $ac_n "checking for dld.h""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +EOF +eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + rm -rf conftest* + eval "ac_cv_header_$ac_safe=yes" +else + echo "$ac_err" >&5 + rm -rf conftest* + eval "ac_cv_header_$ac_safe=no" +fi +rm -f conftest* +fi +if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then + echo "$ac_t""yes" 1>&6 + + SHLIB_LD="ld -shared" + DL_OBJS="tclLoadDld.o" + DL_LIBS="-ldld" + LD_FLAGS="" + LD_SEARCH_FLAGS="" +else + echo "$ac_t""no" 1>&6 +fi + + fi + ;; + MP-RAS-02*) + SHLIB_CFLAGS="-K PIC" + SHLIB_LD="cc -G" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + ;; + MP-RAS-*) + SHLIB_CFLAGS="-K PIC" + SHLIB_LD="cc -G" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="-Wl,-Bexport" + LD_SEARCH_FLAGS="" + ;; + NetBSD-*|FreeBSD-*) + # Not available on all versions: check for include file. + ac_safe=`echo "dlfcn.h" | tr './\055' '___'` +echo $ac_n "checking for dlfcn.h""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +EOF +eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + rm -rf conftest* + eval "ac_cv_header_$ac_safe=yes" +else + echo "$ac_err" >&5 + rm -rf conftest* + eval "ac_cv_header_$ac_safe=no" +fi +rm -f conftest* +fi +if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then + echo "$ac_t""yes" 1>&6 + + SHLIB_CFLAGS="-fpic" + SHLIB_LD="ld -Bshareable -x" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl2.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + +else + echo "$ac_t""no" 1>&6 + + SHLIB_CFLAGS="" + SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" + SHLIB_LD_LIBS='${LIBS}' + SHLIB_SUFFIX="..o" + DL_OBJS="tclLoadAout.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + +fi + + + # FreeBSD doesn't handle version numbers with dots. Also, have to + # append a dummy version number to .so file names. + + TCL_SHARED_LIB_SUFFIX='`echo ${VERSION} | tr -d .`.so.1.0' + TCL_UNSHARED_LIB_SUFFIX='`echo ${VERSION} | tr -d .`.a' + TCL_LIB_VERSIONS_OK=nodots + ;; + NEXTSTEP-*) + SHLIB_CFLAGS="" + SHLIB_LD="cc -nostdlib -r" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadNext.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + ;; + OSF1-1.0|OSF1-1.1|OSF1-1.2) + # OSF/1 1.[012] from OSF, and derivatives, including Paragon OSF/1 + SHLIB_CFLAGS="" + # Hack: make package name same as library name + SHLIB_LD='ld -R -export $@:' + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadOSF.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + ;; + OSF1-1.*) + # OSF/1 1.3 from OSF using ELF, and derivatives, including AD2 + SHLIB_CFLAGS="-fpic" + SHLIB_LD="ld -shared" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + ;; + OSF1-V*) + # Digital OSF/1 + SHLIB_CFLAGS="" + SHLIB_LD='ld -shared -expect_unresolved "*"' + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + ;; + RISCos-*) + SHLIB_CFLAGS="-G 0" + SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" + SHLIB_LD_LIBS='${LIBS}' + SHLIB_SUFFIX="..o" + DL_OBJS="tclLoadAout.o" + DL_LIBS="" + LD_FLAGS="-Wl,-D,08000000" + LD_SEARCH_FLAGS="" + ;; + SCO_SV-3.2*) + # Note, dlopen is available only on SCO 3.2.5 and greater. However, + # this test works, since "uname -s" was non-standard in 3.2.4 and + # below. + SHLIB_CFLAGS="-Kpic -belf" + SHLIB_LD="ld -G" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="" + LD_FLAGS="-belf -Wl,-Bexport" + LD_SEARCH_FLAGS="" + ;; + SINIX*5.4*) + SHLIB_CFLAGS="-K PIC" + SHLIB_LD="cc -G" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + ;; + SunOS-4*) + SHLIB_CFLAGS="-PIC" + SHLIB_LD="ld" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="" + LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' + + # SunOS can't handle version numbers with dots in them in library + # specs, like -ltcl7.5, so use -ltcl75 instead. Also, it + # requires an extra version number at the end of .so file names. + # So, the library has to have a name like libtcl75.so.1.0 + + TCL_SHARED_LIB_SUFFIX='`echo ${VERSION} | tr -d .`.so.1.0' + TCL_UNSHARED_LIB_SUFFIX='`echo ${VERSION} | tr -d .`.a' + TCL_LIB_VERSIONS_OK=nodots + ;; + SunOS-5*) + SHLIB_CFLAGS="-KPIC" + SHLIB_LD="/usr/ccs/bin/ld -G -z text" + SHLIB_LD_LIBS='${LIBS}' + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="" + LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' + ;; + ULTRIX-4.*) + SHLIB_CFLAGS="-G 0" + SHLIB_SUFFIX="..o" + SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" + SHLIB_LD_LIBS='${LIBS}' + DL_OBJS="tclLoadAout.o" + DL_LIBS="" + LD_FLAGS="-Wl,-D,08000000" + LD_SEARCH_FLAGS="" + ;; + UNIX_SV*) + SHLIB_CFLAGS="-KPIC" + SHLIB_LD="cc -G" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + # Some UNIX_SV* systems (unixware 1.1.2 for example) have linkers + # that don't grok the -Bexport option. Test that it does. + hold_ldflags=$LDFLAGS + echo $ac_n "checking for ld accepts -Bexport flag""... $ac_c" 1>&6 + LDFLAGS="${LDFLAGS} -Wl,-Bexport" + cat > conftest.$ac_ext <&6 + if test $found = yes; then + LD_FLAGS="-Wl,-Bexport" + else + LD_FLAGS="" + fi + LD_SEARCH_FLAGS="" + ;; +esac + +# Step 4: If pseudo-static linking is in use (see K. B. Kenny, "Dynamic +# Loading for Tcl -- What Became of It?". Proc. 2nd Tcl/Tk Workshop, +# New Orleans, LA, Computerized Processes Unlimited, 1994), then we need +# to determine which of several header files defines the a.out file +# format (a.out.h, sys/exec.h, or sys/exec_aout.h). At present, we +# support only a file format that is more or less version-7-compatible. +# In particular, +# - a.out files must begin with `struct exec'. +# - the N_TXTOFF on the `struct exec' must compute the seek address +# of the text segment +# - The `struct exec' must contain a_magic, a_text, a_data, a_bss +# and a_entry fields. +# The following compilation should succeed if and only if either sys/exec.h +# or a.out.h is usable for the purpose. +# +# Note that the modified COFF format used on MIPS Ultrix 4.x is usable; the +# `struct exec' includes a second header that contains information that +# duplicates the v7 fields that are needed. + +if test "x$DL_OBJS" = "xtclLoadAout.o" ; then + echo $ac_n "checking sys/exec.h""... $ac_c" 1>&6 + cat > conftest.$ac_ext < +int main() { return 0; } +int t() { + + struct exec foo; + unsigned long seek; + int flag; +#if defined(__mips) || defined(mips) + seek = N_TXTOFF (foo.ex_f, foo.ex_o); +#else + seek = N_TXTOFF (foo); +#endif + flag = (foo.a_magic == OMAGIC); + return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry; + +; return 0; } +EOF +if eval $ac_compile; then + rm -rf conftest* + tcl_ok=usable +else + rm -rf conftest* + tcl_ok=unusable +fi +rm -f conftest* + + echo "$ac_t""$tcl_ok" 1>&6 + if test $tcl_ok = usable; then + cat >> confdefs.h <<\EOF +#define USE_SYS_EXEC_H 1 +EOF + + else + echo $ac_n "checking a.out.h""... $ac_c" 1>&6 + cat > conftest.$ac_ext < +int main() { return 0; } +int t() { + + struct exec foo; + unsigned long seek; + int flag; +#if defined(__mips) || defined(mips) + seek = N_TXTOFF (foo.ex_f, foo.ex_o); +#else + seek = N_TXTOFF (foo); +#endif + flag = (foo.a_magic == OMAGIC); + return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry; + +; return 0; } +EOF +if eval $ac_compile; then + rm -rf conftest* + tcl_ok=usable +else + rm -rf conftest* + tcl_ok=unusable +fi +rm -f conftest* + + echo "$ac_t""$tcl_ok" 1>&6 + if test $tcl_ok = usable; then + cat >> confdefs.h <<\EOF +#define USE_A_OUT_H 1 +EOF + + else + echo $ac_n "checking sys/exec_aout.h""... $ac_c" 1>&6 + cat > conftest.$ac_ext < +int main() { return 0; } +int t() { + + struct exec foo; + unsigned long seek; + int flag; +#if defined(__mips) || defined(mips) + seek = N_TXTOFF (foo.ex_f, foo.ex_o); +#else + seek = N_TXTOFF (foo); +#endif + flag = (foo.a_midmag == OMAGIC); + return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry; + +; return 0; } +EOF +if eval $ac_compile; then + rm -rf conftest* + tcl_ok=usable +else + rm -rf conftest* + tcl_ok=unusable +fi +rm -f conftest* + + echo "$ac_t""$tcl_ok" 1>&6 + if test $tcl_ok = usable; then + cat >> confdefs.h <<\EOF +#define USE_SYS_EXEC_AOUT_H 1 +EOF + + else + DL_OBJS="" + fi + fi + fi +fi + +# Step 5: disable dynamic loading if requested via a command-line switch. + +# Check whether --enable-load or --disable-load was given. +enableval="$enable_load" +if test -n "$enableval"; then + tcl_ok=$enableval +else + tcl_ok=yes +fi + +if test "$tcl_ok" = "no"; then + DL_OBJS="" +fi + +if test "x$DL_OBJS" != "x" ; then + BUILD_DLTEST="\$(DLTEST_TARGETS)" +else + echo "Can't figure out how to do dynamic loading or shared libraries" + echo "on this system." + SHLIB_CFLAGS="" + SHLIB_LD="" + SHLIB_SUFFIX="" + DL_OBJS="tclLoadNone.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + BUILD_DLTEST="" +fi + +# If we're running gcc, then change the C flags for compiling shared +# libraries to the right flags for gcc, instead of those for the +# standard manufacturer compiler. + +if test "$DL_OBJS" != "tclLoadNone.o" ; then + if test "$CC" = "gcc" -o `$CC -v 2>&1 | grep -c gcc` != "0" ; then + SHLIB_CFLAGS="-fPIC" + fi +fi + +#-------------------------------------------------------------------- +# The statements below check for systems where POSIX-style +# non-blocking I/O (O_NONBLOCK) doesn't work or is unimplemented. +# On these systems (mostly older ones), use the old BSD-style +# FIONBIO approach instead. +#-------------------------------------------------------------------- + +for ac_hdr in sys/ioctl.h +do +ac_safe=`echo "$ac_hdr" | tr './\055' '___'` +echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +EOF +eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + rm -rf conftest* + eval "ac_cv_header_$ac_safe=yes" +else + echo "$ac_err" >&5 + rm -rf conftest* + eval "ac_cv_header_$ac_safe=no" +fi +rm -f conftest* +fi +if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then + echo "$ac_t""yes" 1>&6 + ac_tr_hdr=HAVE_`echo $ac_hdr | tr 'abcdefghijklmnopqrstuvwxyz./\055' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ___'` + cat >> confdefs.h <&6 +fi +done + +for ac_hdr in sys/filio.h +do +ac_safe=`echo "$ac_hdr" | tr './\055' '___'` +echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +EOF +eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + rm -rf conftest* + eval "ac_cv_header_$ac_safe=yes" +else + echo "$ac_err" >&5 + rm -rf conftest* + eval "ac_cv_header_$ac_safe=no" +fi +rm -f conftest* +fi +if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then + echo "$ac_t""yes" 1>&6 + ac_tr_hdr=HAVE_`echo $ac_hdr | tr 'abcdefghijklmnopqrstuvwxyz./\055' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ___'` + cat >> confdefs.h <&6 +fi +done + +echo $ac_n "checking FIONBIO vs. O_NONBLOCK for nonblocking I/O""... $ac_c" 1>&6 +if test -f /usr/lib/NextStep/software_version; then + system=NEXTSTEP-`awk '/3/,/3/' /usr/lib/NextStep/software_version` +else + system=`uname -s`-`uname -r` + if test "$?" -ne 0 ; then + system=unknown + else + # Special check for weird MP-RAS system (uname returns weird + # results, and the version is kept in special file). + + if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then + system=MP-RAS-`awk '{print $3}' /etc/.relid'` + fi + if test "`uname -s`" = "AIX" ; then + system=AIX-`uname -v`.`uname -r` + fi + fi +fi +case $system in + AIX-*) + cat >> confdefs.h <<\EOF +#define USE_FIONBIO 1 +EOF + + echo "$ac_t""FIONBIO" 1>&6 + ;; + OSF*) + cat >> confdefs.h <<\EOF +#define USE_FIONBIO 1 +EOF + + echo "$ac_t""FIONBIO" 1>&6 + ;; + SunOS-4*) + cat >> confdefs.h <<\EOF +#define USE_FIONBIO 1 +EOF + + echo "$ac_t""FIONBIO" 1>&6 + ;; + ULTRIX-4.*) + cat >> confdefs.h <<\EOF +#define USE_FIONBIO 1 +EOF + + echo "$ac_t""FIONBIO" 1>&6 + ;; + *) + echo "$ac_t""O_NONBLOCK" 1>&6 + ;; +esac + +#-------------------------------------------------------------------- +# The statements below define a collection of symbols related to +# building libtcl as a shared library instead of a static library. +#-------------------------------------------------------------------- + +realRanlib=$RANLIB +if test "$TCL_SHARED_LIB_SUFFIX" = "" ; then + TCL_SHARED_LIB_SUFFIX='${VERSION}${SHLIB_SUFFIX}' +fi +if test "$TCL_UNSHARED_LIB_SUFFIX" = "" ; then + TCL_UNSHARED_LIB_SUFFIX='${VERSION}.a' +fi +# Check whether --enable-shared or --disable-shared was given. +enableval="$enable_shared" +if test -n "$enableval"; then + tcl_ok=$enableval +else + tcl_ok=no +fi + +if test "$tcl_ok" = "yes" -a "${SHLIB_SUFFIX}" != "" \ + -a "${DL_OBJS}" != "tclLoadAout.o" ; then + TCL_SHLIB_CFLAGS="${SHLIB_CFLAGS}" + TCL_LD_SEARCH_FLAGS="${LD_SEARCH_FLAGS}" + eval "TCL_LIB_FILE=libtcl${TCL_SHARED_LIB_SUFFIX}" + MAKE_LIB="\${SHLIB_LD} -o ${TCL_LIB_FILE} \${OBJS} ${SHLIB_LD_LIBS}" + RANLIB=":" +else + if test "$AIX" = "no" ; then + SHLIB_LD_LIBS="" + fi + TCL_SHLIB_CFLAGS="" + TCL_LD_SEARCH_FLAGS="" + eval "TCL_LIB_FILE=libtcl${TCL_UNSHARED_LIB_SUFFIX}" + MAKE_LIB="ar cr ${TCL_LIB_FILE} \${OBJS}" +fi + +# Note: in the following variable, it's important to use the absolute +# path name of the Tcl directory rather than "..": this is because +# AIX remembers this path and will attempt to use it at run-time to look +# up the Tcl library. + +if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then + TCL_BUILD_LIB_SPEC="-L`pwd` -ltcl${VERSION}" + TCL_LIB_SPEC="-L${exec_prefix}/lib -ltcl${VERSION}" +else + TCL_BUILD_LIB_SPEC="-L`pwd` -ltcl`echo ${VERSION} | tr -d .`" + TCL_LIB_SPEC="-L${exec_prefix}/lib -ltcl`echo ${VERSION} | tr -d .`" +fi + +#-------------------------------------------------------------------- +# The statements below define the symbol TCL_PACKAGE_PATH, which +# gives a list of directories that may contain packages. The list +# consists of one directory for machine-dependent binaries and +# another for platform-independent scripts. +#-------------------------------------------------------------------- + +if test "$prefix" != "$exec_prefix"; then + TCL_PACKAGE_PATH="${exec_prefix}/lib ${prefix}/lib" +else + TCL_PACKAGE_PATH="${prefix}/lib" +fi + + + + + + + + + + + + + + + + + + + + + + + + + +trap '' 1 2 15 +cat > confcache <<\EOF +# This file is a shell script that caches the results of configure +# tests run on this system so they can be shared between configure +# scripts and configure runs. It is not useful on other systems. +# If it contains results you don't want to keep, you may remove or edit it. +# +# By default, configure uses ./config.cache as the cache file, +# creating it if it does not exist already. You can give configure +# the --cache-file=FILE option to use a different cache file; that is +# what configure does when it calls configure scripts in +# subdirectories, so they share the cache. +# Giving --cache-file=/dev/null disables caching, for debugging configure. +# config.status only pays attention to the cache file if you give it the +# --recheck option to rerun configure. +# +EOF +# Ultrix sh set writes to stderr and can't be redirected directly, +# and sets the high bit in the cache file unless we assign to the vars. +(set) 2>&1 | + sed -n "s/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=\${\1='\2'}/p" \ + >> confcache +if cmp -s $cache_file confcache; then + : +else + if test -w $cache_file; then + echo "updating cache $cache_file" + cat confcache > $cache_file + else + echo "not updating unwritable cache $cache_file" + fi +fi +rm -f confcache + +trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 + +test "x$prefix" = xNONE && prefix=$ac_default_prefix +# Let make expand exec_prefix. +test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' + +# Any assignment to VPATH causes Sun make to only execute +# the first set of double-colon rules, so remove it if not needed. +# If there is a colon in the path, we need to keep it. +if test "x$srcdir" = x.; then + ac_vpsub='/^[ ]*VPATH[ ]*=[^:]*$/d' +fi + +trap 'rm -f $CONFIG_STATUS conftest*; exit 1' 1 2 15 + +# Transform confdefs.h into DEFS. +# Protect against shell expansion while executing Makefile rules. +# Protect against Makefile macro expansion. +cat > conftest.defs <<\EOF +s%#define \([A-Za-z_][A-Za-z0-9_]*\) \(.*\)%-D\1=\2%g +s%[ `~#$^&*(){}\\|;'"<>?]%\\&%g +s%\[%\\&%g +s%\]%\\&%g +s%\$%$$%g +EOF +DEFS=`sed -f conftest.defs confdefs.h | tr '\012' ' '` +rm -f conftest.defs + + +# Without the "./", some shells look in PATH for config.status. +: ${CONFIG_STATUS=./config.status} + +echo creating $CONFIG_STATUS +rm -f $CONFIG_STATUS +cat > $CONFIG_STATUS </dev/null | sed 1q`: +# +# $0 $ac_configure_args +# +# Compiler output produced by configure, useful for debugging +# configure, is in ./config.log if it exists. + +ac_cs_usage="Usage: $CONFIG_STATUS [--recheck] [--version] [--help]" +for ac_option +do + case "\$ac_option" in + -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) + echo "running \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion" + exec \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion ;; + -version | --version | --versio | --versi | --vers | --ver | --ve | --v) + echo "$CONFIG_STATUS generated by autoconf version 2.4" + exit 0 ;; + -help | --help | --hel | --he | --h) + echo "\$ac_cs_usage"; exit 0 ;; + *) echo "\$ac_cs_usage"; exit 1 ;; + esac +done + +ac_given_srcdir=$srcdir + +trap 'rm -fr `echo "Makefile tclConfig.sh" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15 + +# Protect against being on the right side of a sed subst in config.status. +sed 's/%@/@@/; s/@%/@@/; s/%g$/@g/; /@g$/s/[\\\\&%]/\\\\&/g; + s/@@/%@/; s/@@/@%/; s/@g$/%g/' > conftest.subs <<\CEOF +$ac_vpsub +$extrasub +s%@CFLAGS@%$CFLAGS%g +s%@CPPFLAGS@%$CPPFLAGS%g +s%@CXXFLAGS@%$CXXFLAGS%g +s%@DEFS@%$DEFS%g +s%@LDFLAGS@%$LDFLAGS%g +s%@LIBS@%$LIBS%g +s%@exec_prefix@%$exec_prefix%g +s%@prefix@%$prefix%g +s%@program_transform_name@%$program_transform_name%g +s%@RANLIB@%$RANLIB%g +s%@CC@%$CC%g +s%@LIBOBJS@%$LIBOBJS%g +s%@CPP@%$CPP%g +s%@BUILD_DLTEST@%$BUILD_DLTEST%g +s%@DL_LIBS@%$DL_LIBS%g +s%@DL_OBJS@%$DL_OBJS%g +s%@LD_FLAGS@%$LD_FLAGS%g +s%@MAKE_LIB@%$MAKE_LIB%g +s%@MATH_LIBS@%$MATH_LIBS%g +s%@SHLIB_CFLAGS@%$SHLIB_CFLAGS%g +s%@SHLIB_LD@%$SHLIB_LD%g +s%@SHLIB_LD_LIBS@%$SHLIB_LD_LIBS%g +s%@SHLIB_SUFFIX@%$SHLIB_SUFFIX%g +s%@TCL_BUILD_LIB_SPEC@%$TCL_BUILD_LIB_SPEC%g +s%@TCL_LD_SEARCH_FLAGS@%$TCL_LD_SEARCH_FLAGS%g +s%@TCL_LIB_FILE@%$TCL_LIB_FILE%g +s%@TCL_LIB_SPEC@%$TCL_LIB_SPEC%g +s%@TCL_LIB_VERSIONS_OK@%$TCL_LIB_VERSIONS_OK%g +s%@TCL_MAJOR_VERSION@%$TCL_MAJOR_VERSION%g +s%@TCL_MINOR_VERSION@%$TCL_MINOR_VERSION%g +s%@TCL_PACKAGE_PATH@%$TCL_PACKAGE_PATH%g +s%@TCL_SHARED_LIB_SUFFIX@%$TCL_SHARED_LIB_SUFFIX%g +s%@TCL_SHLIB_CFLAGS@%$TCL_SHLIB_CFLAGS%g +s%@TCL_SRC_DIR@%$TCL_SRC_DIR%g +s%@TCL_UNSHARED_LIB_SUFFIX@%$TCL_UNSHARED_LIB_SUFFIX%g +s%@TCL_VERSION@%$TCL_VERSION%g + +CEOF +EOF +cat >> $CONFIG_STATUS <> $CONFIG_STATUS <<\EOF +for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then + # Support "outfile[:infile]", defaulting infile="outfile.in". + case "$ac_file" in + *:*) ac_file_in=`echo "$ac_file"|sed 's%.*:%%'` + ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;; + *) ac_file_in="${ac_file}.in" ;; + esac + + # Adjust relative srcdir, etc. for subdirectories. + + # Remove last slash and all that follows it. Not all systems have dirname. + ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'` + if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then + # The file is in a subdirectory. + test ! -d "$ac_dir" && mkdir "$ac_dir" + ac_dir_suffix="/`echo $ac_dir|sed 's%^\./%%'`" + # A "../" for each directory in $ac_dir_suffix. + ac_dots=`echo $ac_dir_suffix|sed 's%/[^/]*%../%g'` + else + ac_dir_suffix= ac_dots= + fi + + case "$ac_given_srcdir" in + .) srcdir=. + if test -z "$ac_dots"; then top_srcdir=. + else top_srcdir=`echo $ac_dots|sed 's%/$%%'`; fi ;; + /*) srcdir="$ac_given_srcdir$ac_dir_suffix"; top_srcdir="$ac_given_srcdir" ;; + *) # Relative path. + srcdir="$ac_dots$ac_given_srcdir$ac_dir_suffix" + top_srcdir="$ac_dots$ac_given_srcdir" ;; + esac + + echo creating "$ac_file" + rm -f "$ac_file" + configure_input="Generated automatically from `echo $ac_file_in|sed 's%.*/%%'` by configure." + case "$ac_file" in + *Makefile*) ac_comsub="1i\\ +# $configure_input" ;; + *) ac_comsub= ;; + esac + sed -e "$ac_comsub +s%@configure_input@%$configure_input%g +s%@srcdir@%$srcdir%g +s%@top_srcdir@%$top_srcdir%g +" -f conftest.subs $ac_given_srcdir/$ac_file_in > $ac_file +fi; done +rm -f conftest.subs + + + +exit 0 +EOF +chmod +x $CONFIG_STATUS +rm -fr confdefs* $ac_clean_files +test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1 + diff --git a/tcl7.6/unix/configure.in b/tcl7.6/unix/configure.in new file mode 100755 index 0000000..7ea711a --- /dev/null +++ b/tcl7.6/unix/configure.in @@ -0,0 +1,1061 @@ +dnl This file is an input file used by the GNU "autoconf" program to +dnl generate the file "configure", which is run during Tcl installation +dnl to configure the system for the local environment. +AC_INIT(../generic/tcl.h) +# SCCS: @(#) configure.in 1.120 96/10/08 08:32:30 + +TCL_VERSION=7.6 +TCL_MAJOR_VERSION=7 +TCL_MINOR_VERSION=6 +VERSION=${TCL_VERSION} + +if test "${prefix}" = "NONE"; then + prefix=/usr/local +fi +if test "${exec_prefix}" = "NONE"; then + exec_prefix=$prefix +fi +TCL_SRC_DIR=`cd $srcdir/..; pwd` + +AC_PROG_RANLIB +AC_ARG_ENABLE(gcc, [ --enable-gcc allow use of gcc if available], + [tcl_ok=$enableval], [tcl_ok=no]) +if test "$tcl_ok" = "yes"; then + AC_PROG_CC +else + CC=${CC-cc} +AC_SUBST(CC) +fi +AC_C_CROSS + +#-------------------------------------------------------------------- +# Supply substitutes for missing POSIX library procedures, or +# set flags so Tcl uses alternate procedures. +#-------------------------------------------------------------------- + +AC_REPLACE_FUNCS(getcwd opendir strstr) +AC_REPLACE_FUNCS(strtol tmpnam waitpid) +AC_CHECK_FUNC(strerror, , AC_DEFINE(NO_STRERROR)) +AC_CHECK_FUNC(getwd, , AC_DEFINE(NO_GETWD)) +AC_CHECK_FUNC(wait3, , AC_DEFINE(NO_WAIT3)) +AC_CHECK_FUNC(uname, , AC_DEFINE(NO_UNAME)) + +#-------------------------------------------------------------------- +# On a few very rare systems, all of the libm.a stuff is +# already in libc.a. Set compiler flags accordingly. +# Also, Linux requires the "ieee" library for math to work +# right (and it must appear before "-lm"). +#-------------------------------------------------------------------- + +AC_CHECK_FUNC(sin, MATH_LIBS="", MATH_LIBS="-lm") +AC_CHECK_LIB(ieee, main, [MATH_LIBS="-lieee $MATH_LIBS"]) + +#-------------------------------------------------------------------- +# Supply substitutes for missing POSIX header files. Special +# notes: +# - stdlib.h doesn't define strtol, strtoul, or +# strtod insome versions of SunOS +# - some versions of string.h don't declare procedures such +# as strstr +#-------------------------------------------------------------------- + +AC_MSG_CHECKING(dirent.h) +AC_TRY_LINK([#include +#include ], [ +#ifndef _POSIX_SOURCE +# ifdef __Lynx__ + /* + * Generate compilation error to make the test fail: Lynx headers + * are only valid if really in the POSIX environment. + */ + + missing_procedure(); +# endif +#endif +DIR *d; +struct dirent *entryPtr; +char *p; +d = opendir("foobar"); +entryPtr = readdir(d); +p = entryPtr->d_name; +closedir(d); +], tcl_ok=yes, tcl_ok=no) +if test $tcl_ok = no; then + AC_DEFINE(NO_DIRENT_H) +fi +AC_MSG_RESULT($tcl_ok) +AC_CHECK_HEADER(errno.h, , AC_DEFINE(NO_ERRNO_H)) +AC_CHECK_HEADER(float.h, , AC_DEFINE(NO_FLOAT_H)) +AC_CHECK_HEADER(limits.h, , AC_DEFINE(NO_LIMITS_H)) +AC_CHECK_HEADER(stdlib.h, tcl_ok=1, tcl_ok=0) +AC_EGREP_HEADER(strtol, stdlib.h, , tcl_ok=0) +AC_EGREP_HEADER(strtoul, stdlib.h, , tcl_ok=0) +AC_EGREP_HEADER(strtod, stdlib.h, , tcl_ok=0) +if test $tcl_ok = 0; then + AC_DEFINE(NO_STDLIB_H) +fi +AC_CHECK_HEADER(string.h, tcl_ok=1, tcl_ok=0) +AC_EGREP_HEADER(strstr, string.h, , tcl_ok=0) +AC_EGREP_HEADER(strerror, string.h, , tcl_ok=0) +if test $tcl_ok = 0; then + AC_DEFINE(NO_STRING_H) +fi +AC_CHECK_HEADER(sys/wait.h, , AC_DEFINE(NO_SYS_WAIT_H)) +AC_CHECK_HEADER(dlfcn.h, , AC_DEFINE(NO_DLFCN_H)) +AC_HAVE_HEADERS(unistd.h) + +#-------------------------------------------------------------------- +# Include sys/select.h if it exists and if it supplies things +# that appear to be useful and aren't already in sys/types.h. +# This appears to be true only on the RS/6000 under AIX. Some +# systems like OSF/1 have a sys/select.h that's of no use, and +# other systems like SCO UNIX have a sys/select.h that's +# pernicious. If "fd_set" isn't defined anywhere then set a +# special flag. +#-------------------------------------------------------------------- + +AC_MSG_CHECKING([fd_set and sys/select]) +AC_TRY_COMPILE([#include ], + [fd_set readMask, writeMask;], tk_ok=yes, tk_ok=no) +if test $tk_ok = no; then + AC_HEADER_EGREP(fd_mask, sys/select.h, tk_ok=yes) + if test $tk_ok = yes; then + AC_DEFINE(HAVE_SYS_SELECT_H) + fi +fi +AC_MSG_RESULT($tk_ok) +if test $tk_ok = no; then + AC_DEFINE(NO_FD_SET) +fi + +#------------------------------------------------------------------------------ +# Find out all about time handling differences. +#------------------------------------------------------------------------------ + +AC_CHECK_HEADERS(sys/time.h) +AC_HEADER_TIME +AC_STRUCT_TIMEZONE + +AC_MSG_CHECKING([tm_tzadj in struct tm]) +AC_TRY_COMPILE([#include ], [struct tm tm; tm.tm_tzadj;], + [AC_DEFINE(HAVE_TM_TZADJ) + AC_MSG_RESULT(yes)], + AC_MSG_RESULT(no)) + +AC_MSG_CHECKING([tm_gmtoff in struct tm]) +AC_TRY_COMPILE([#include ], [struct tm tm; tm.tm_gmtoff;], + [AC_DEFINE(HAVE_TM_GMTOFF) + AC_MSG_RESULT(yes)], + AC_MSG_RESULT(no)) + +# +# Its important to include time.h in this check, as some systems (like convex) +# have timezone functions, etc. +# +have_timezone=no +AC_MSG_CHECKING([long timezone variable]) +AC_TRY_COMPILE([#include ], + [extern long timezone; + timezone += 1; + exit (0);], + [have_timezone=yes + AC_DEFINE(HAVE_TIMEZONE_VAR) + AC_MSG_RESULT(yes)], + AC_MSG_RESULT(no)) + +# +# On some systems (eg IRIX 6.2), timezone is a time_t and not a long. +# +if test "$have_timezone" = no; then + AC_MSG_CHECKING([time_t timezone variable]) + AC_TRY_COMPILE([#include ], + [extern time_t timezone; + timezone += 1; + exit (0);], + [AC_DEFINE(HAVE_TIMEZONE_VAR) + AC_MSG_RESULT(yes)], + AC_MSG_RESULT(no)) +fi + +#-------------------------------------------------------------------- +# On some systems strstr is broken: it returns a pointer even +# even if the original string is empty. +#-------------------------------------------------------------------- + +AC_MSG_CHECKING([proper strstr implementation]) +AC_TRY_RUN([ +extern int strstr(); +int main() +{ + exit(strstr("\0test", "test") ? 1 : 0); +} +], tcl_ok=yes, tcl_ok=no, tcl_ok=no) +if test $tcl_ok = yes; then + AC_MSG_RESULT(yes) +else + AC_MSG_RESULT([broken, using substitute]) + LIBOBJS="$LIBOBJS strstr.o" +fi + +#-------------------------------------------------------------------- +# Check for strtoul function. This is tricky because under some +# versions of AIX strtoul returns an incorrect terminator +# pointer for the string "0". +#-------------------------------------------------------------------- + +AC_CHECK_FUNC(strtoul, tcl_ok=1, tcl_ok=0) +AC_TRY_RUN([ +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, tcl_ok=0) +if test "$tcl_ok" = 0; then + test -n "$verbose" && echo " Adding strtoul.o." + LIBOBJS="$LIBOBJS strtoul.o" +fi + +#-------------------------------------------------------------------- +# Check for the strtod function. This is tricky because in some +# versions of Linux strtod mis-parses strings starting with "+". +#-------------------------------------------------------------------- + +AC_CHECK_FUNC(strtod, tcl_ok=1, tcl_ok=0) +AC_TRY_RUN([ +extern double strtod(); +int main() +{ + char *string = " +69"; + char *term; + double value; + value = strtod(string, &term); + if ((value != 69) || (term != (string+4))) { + exit(1); + } + exit(0); +}], , tcl_ok=0, tcl_ok=0) +if test "$tcl_ok" = 0; then + test -n "$verbose" && echo " Adding strtod.o." + LIBOBJS="$LIBOBJS strtod.o" +fi + +#-------------------------------------------------------------------- +# Under Solaris 2.4, strtod returns the wrong value for the +# terminating character under some conditions. Check for this +# and if the problem exists use a substitute procedure +# "fixstrtod" that corrects the error. +#-------------------------------------------------------------------- + +AC_CHECK_FUNC(strtod, tcl_strtod=1, tcl_strtod=0) +if test "$tcl_strtod" = 1; then + AC_MSG_CHECKING([for Solaris strtod bug]) + AC_TRY_RUN([ + extern double strtod(); + int main() + { + char *string = "NaN"; + char *term; + strtod(string, &term); + if ((term != string) && (term[-1] == 0)) { + exit(1); + } + exit(0); + }], tcl_ok=1, tcl_ok=0, tcl_ok=0) + if test $tcl_ok = 1; then + AC_MSG_RESULT(ok) + else + AC_MSG_RESULT(buggy) + LIBOBJS="$LIBOBJS fixstrtod.o" + AC_DEFINE(strtod, fixstrtod) + fi +fi + +#-------------------------------------------------------------------- +# Check for various typedefs and provide substitutes if +# they don't exist. +#-------------------------------------------------------------------- + +AC_TYPE_MODE_T +AC_TYPE_PID_T +AC_TYPE_SIZE_T +AC_TYPE_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_CHECK_FUNC(opendir, , AC_DEFINE(USE_DIRENT2_H)) + +#-------------------------------------------------------------------- +# The check below checks whether defines the type +# "union wait" correctly. It's needed because of weirdness in +# HP-UX where "union wait" is defined in both the BSD and SYS-V +# environments. Checking the usability of WIFEXITED seems to do +# the trick. +#-------------------------------------------------------------------- + +AC_MSG_CHECKING([union wait]) +AC_TRY_LINK([#include +#include ], [ +union wait x; +WIFEXITED(x); /* Generates compiler error if WIFEXITED + * uses an int. */ +], tcl_ok=yes, tcl_ok=no) +AC_MSG_RESULT($tcl_ok) +if test $tcl_ok = no; then + AC_DEFINE(NO_UNION_WAIT) +fi + +#-------------------------------------------------------------------- +# Check to see whether the system supports the matherr function +# and its associated type "struct exception". +#-------------------------------------------------------------------- + +AC_MSG_CHECKING([matherr support]) +AC_TRY_COMPILE([#include ], [ +struct exception x; +x.type = DOMAIN; +x.type = SING; +], tcl_ok=yes, tcl_ok=no) +AC_MSG_RESULT($tcl_ok) +if test $tcl_ok = yes; then + AC_DEFINE(NEED_MATHERR) +fi + +#-------------------------------------------------------------------- +# Check to see whether the system provides a vfork kernel call. +# If not, then use fork instead. Also, check for a problem with +# vforks and signals that can cause core dumps if a vforked child +# resets a signal handler. If the problem exists, then use fork +# instead of vfork. +#-------------------------------------------------------------------- + +AC_CHECK_FUNC(vfork, tcl_ok=1, tcl_ok=0) +if test "$tcl_ok" = 1; then + AC_MSG_CHECKING([vfork/signal bug]); + AC_TRY_RUN([ + #include + #include + #include + int gotSignal = 0; + sigProc(sig) + int sig; + { + gotSignal = 1; + } + main() + { + int pid, sts; + (void) signal(SIGCHLD, sigProc); + pid = vfork(); + if (pid < 0) { + exit(1); + } else if (pid == 0) { + (void) signal(SIGCHLD, SIG_DFL); + _exit(0); + } else { + (void) wait(&sts); + } + exit((gotSignal) ? 0 : 1); + }], tcl_ok=1, tcl_ok=0, tcl_ok=0) + if test "$tcl_ok" = 1; then + AC_MSG_RESULT(ok) + else + AC_MSG_RESULT([buggy, using fork instead]) + fi +fi +rm -f core +if test "$tcl_ok" = 0; then + AC_DEFINE(vfork, fork) +fi + +#-------------------------------------------------------------------- +# Check whether there is an strncasecmp function on this system. +# This is a bit tricky because under SCO it's in -lsocket and +# under Sequent Dynix it's in -linet. +#-------------------------------------------------------------------- + +AC_CHECK_FUNC(strncasecmp, tcl_ok=1, tcl_ok=0) +if test "$tcl_ok" = 0; then + AC_CHECK_LIB(socket, strncasecmp, tcl_ok=1, tcl_ok=0) +fi +if test "$tcl_ok" = 0; then + AC_CHECK_LIB(inet, strncasecmp, tcl_ok=1, tcl_ok=0) +fi +if test "$tcl_ok" = 0; then + LIBOBJS="$LIBOBJS strncasecmp.o" +fi + +#-------------------------------------------------------------------- +# The code below deals with several issues related to gettimeofday: +# 1. Some systems don't provide a gettimeofday function at all +# (set NO_GETTOD if this is the case). +# 2. SGI systems don't use the BSD form of the gettimeofday function, +# but they have a BSDgettimeofday function that can be used instead. +# 3. See if gettimeofday is declared in the header file. +# if not, set the GETTOD_NOT_DECLARED flag so that tclPort.h can +# declare it. +#-------------------------------------------------------------------- + +AC_CHECK_FUNC(BSDgettimeofday, AC_DEFINE(HAVE_BSDGETTIMEOFDAY), + AC_CHECK_FUNC(gettimeofday, , AC_DEFINE(NO_GETTOD))) +AC_MSG_CHECKING([for gettimeofday declaration]) +AC_EGREP_HEADER(gettimeofday, sys/time.h, AC_MSG_RESULT(present), [ + AC_MSG_RESULT(missing) + AC_DEFINE(GETTOD_NOT_DECLARED) +]) + +#-------------------------------------------------------------------- +# Interactive UNIX requires -linet instead of -lsocket, plus it +# needs net/errno.h to define the socket-related error codes. +#-------------------------------------------------------------------- + +AC_CHECK_LIB(inet, main, [LIBS="$LIBS -linet"]) +AC_CHECK_HEADER(net/errno.h, AC_DEFINE(HAVE_NET_ERRNO_H)) + +#-------------------------------------------------------------------- +# Check for the existence of the -lsocket and -lnsl libraries. +# The order here is important, so that they end up in the right +# order in the command line generated by make. Here are some +# special considerations: +# 1. Use "connect" and "accept" to check for -lsocket, and +# "gethostbyname" to check for -lnsl. +# 2. Use each function name only once: can't redo a check because +# autoconf caches the results of the last check and won't redo it. +# 3. Use -lnsl and -lsocket only if they supply procedures that +# aren't already present in the normal libraries. This is because +# IRIX 5.2 has libraries, but they aren't needed and they're +# bogus: they goof up name resolution if used. +# 4. On some SVR4 systems, can't use -lsocket without -lnsl too. +# To get around this problem, check for both libraries together +# if -lsocket doesn't work by itself. +#-------------------------------------------------------------------- + +tcl_checkBoth=0 +AC_CHECK_FUNC(connect, tcl_checkSocket=0, tcl_checkSocket=1) +if test "$tcl_checkSocket" = 1; then + AC_CHECK_LIB(socket, main, LIBS="$LIBS -lsocket", tcl_checkBoth=1) +fi +if test "$tcl_checkBoth" = 1; then + tk_oldLibs=$LIBS + LIBS="$LIBS -lsocket -lnsl" + AC_CHECK_FUNC(accept, tcl_checkNsl=0, [LIBS=$tk_oldLibs]) +fi +AC_CHECK_FUNC(gethostbyname, , AC_CHECK_LIB(nsl, main, [LIBS="$LIBS -lnsl"])) + +#-------------------------------------------------------------------- +# The statements below define a collection of symbols related to +# dynamic loading and shared libraries: +# +# DL_OBJS - Name of the object file that implements dynamic +# loading for Tcl on this system. +# DL_LIBS - Library file(s) to include in tclsh and other base +# applications in order for the "load" command to work. +# LD_FLAGS - Flags to pass to the compiler when linking object +# files into an executable application binary such +# as tclsh. +# LD_SEARCH_FLAGS-Flags to pass to ld, such as "-R /usr/local/tcl/lib", +# that tell the run-time dynamic linker where to look +# for shared libraries such as libtcl.so. Depends on +# the variable LIB_RUNTIME_DIR in the Makefile. +# MAKE_LIB - Command to execute to build the Tcl library; +# differs depending on whether or not Tcl is being +# compiled as a shared library. +# SHLIB_CFLAGS - Flags to pass to cc when compiling the components +# of a shared library (may request position-independent +# code, among other things). +# SHLIB_LD - Base command to use for combining object files +# into a shared library. +# SHLIB_LD_LIBS - Dependent libraries for the linker to scan when +# creating shared libraries. This symbol typically +# goes at the end of the "ld" commands that build +# shared libraries. The value of the symbol is +# "${LIBS}" if all of the dependent libraries should +# be specified when creating a shared library. If +# dependent libraries should not be specified (as on +# SunOS 4.x, where they cause the link to fail, or in +# general if Tcl and Tk aren't themselves shared +# libraries), then this symbol has an empty string +# as its value. +# SHLIB_SUFFIX - Suffix to use for the names of dynamically loadable +# extensions. An empty string means we don't know how +# to use shared libraries on this platform. +# TCL_LIB_FILE - Name of the file that contains the Tcl library, such +# as libtcl7.6.so or libtcl7.6.a. +# TCL_LIB_SUFFIX -Specifies everything that comes after the "libtcl" +# in the shared library name, using the $VERSION variable +# to put the version in the right place. This is used +# by platforms that need non-standard library names. +# Examples: ${VERSION}.so.1.1 on NetBSD, since it needs +# to have a version after the .so, and ${VERSION}.a +# on AIX, since the Tcl shared library needs to have +# a .a extension whereas shared objects for loadable +# extensions have a .so extension. Defaults to +# ${VERSION}${SHLIB_SUFFIX}. +#-------------------------------------------------------------------- + +# Step 1: set the variable "system" to hold the name and version number +# for the system. This can usually be done via the "uname" command, but +# there are a few systems, like Next, where this doesn't work. + +AC_MSG_CHECKING([system version (for dynamic loading)]) +if test -f /usr/lib/NextStep/software_version; then + system=NEXTSTEP-`awk '/3/,/3/' /usr/lib/NextStep/software_version` +else + system=`uname -s`-`uname -r` + if test "$?" -ne 0 ; then + AC_MSG_RESULT([unknown (can't find uname command)]) + system=unknown + else + # Special check for weird MP-RAS system (uname returns weird + # results, and the version is kept in special file). + + if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then + system=MP-RAS-`awk '{print $3}' /etc/.relid'` + fi + if test "`uname -s`" = "AIX" ; then + system=AIX-`uname -v`.`uname -r` + fi + AC_MSG_RESULT($system) + fi +fi + +# Step 2: check for existence of -ldl library. This is needed because +# Linux can use either -ldl or -ldld for dynamic loading. + +AC_CHECK_LIB(dl, dlopen, have_dl=yes, have_dl=no) + +# Step 3: set configuration options based on system name and version. + +fullSrcDir=`cd $srcdir; pwd` +AIX=no +TCL_SHARED_LIB_SUFFIX="" +TCL_UNSHARED_LIB_SUFFIX="" +TCL_LIB_VERSIONS_OK=ok +case $system in + AIX-*) + SHLIB_CFLAGS="" + SHLIB_LD="$fullSrcDir/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512" + SHLIB_LD_LIBS='${LIBS}' + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o tclLoadAix.o" + DL_LIBS="-lld" + LD_FLAGS="" + LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' + AIX=yes + TCL_SHARED_LIB_SUFFIX='${VERSION}.a' + ;; + BSD/OS-2.1*) + SHLIB_CFLAGS="" + SHLIB_LD="ld -r" + SHLIB_LD_FLAGS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + ;; + HP-UX-*.08.*|HP-UX-*.09.*|HP-UX-*.10.*) + AC_CHECK_LIB(dld, shl_load, tcl_ok=yes, tcl_ok=no) + if test "$tcl_ok" = yes; then + SHLIB_CFLAGS="+z" + SHLIB_LD="ld -b" + SHLIB_LD_LIBS='${LIBS}' + SHLIB_SUFFIX=".sl" + DL_OBJS="tclLoadShl.o" + DL_LIBS="-ldld" + LD_FLAGS="-Wl,-E" + LD_SEARCH_FLAGS='-Wl,+b,${LIB_RUNTIME_DIR}:.' + fi + ;; + IRIX-4.*) + SHLIB_CFLAGS="-G 0" + SHLIB_SUFFIX="..o" + SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" + SHLIB_LD_LIBS='${LIBS}' + DL_OBJS="tclLoadAout.o" + DL_LIBS="" + LD_FLAGS="-Wl,-D,08000000" + LD_SEARCH_FLAGS="" + ;; + IRIX-5.*|IRIX-6.*) + SHLIB_CFLAGS="" + SHLIB_LD="ld -shared -rdata_shared" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + ;; + IRIX64-6.*) + SHLIB_CFLAGS="" + SHLIB_LD="ld -32 -shared -rdata_shared -rpath /usr/local/lib" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + ;; + Linux*) + SHLIB_CFLAGS="-fPIC" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + if test "$have_dl" = yes; then + SHLIB_LD="${CC} -shared" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="-rdynamic" + LD_SEARCH_FLAGS="" + else + AC_CHECK_HEADER(dld.h, [ + SHLIB_LD="ld -shared" + DL_OBJS="tclLoadDld.o" + DL_LIBS="-ldld" + LD_FLAGS="" + LD_SEARCH_FLAGS=""]) + fi + ;; + MP-RAS-02*) + SHLIB_CFLAGS="-K PIC" + SHLIB_LD="cc -G" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + ;; + MP-RAS-*) + SHLIB_CFLAGS="-K PIC" + SHLIB_LD="cc -G" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="-Wl,-Bexport" + LD_SEARCH_FLAGS="" + ;; + NetBSD-*|FreeBSD-*) + # Not available on all versions: check for include file. + AC_CHECK_HEADER(dlfcn.h, [ + SHLIB_CFLAGS="-fpic" + SHLIB_LD="ld -Bshareable -x" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl2.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + ], [ + SHLIB_CFLAGS="" + SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" + SHLIB_LD_LIBS='${LIBS}' + SHLIB_SUFFIX="..o" + DL_OBJS="tclLoadAout.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + ]) + + # FreeBSD doesn't handle version numbers with dots. Also, have to + # append a dummy version number to .so file names. + + TCL_SHARED_LIB_SUFFIX='`echo ${VERSION} | tr -d .`.so.1.0' + TCL_UNSHARED_LIB_SUFFIX='`echo ${VERSION} | tr -d .`.a' + TCL_LIB_VERSIONS_OK=nodots + ;; + NEXTSTEP-*) + SHLIB_CFLAGS="" + SHLIB_LD="cc -nostdlib -r" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadNext.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + ;; + OSF1-1.0|OSF1-1.1|OSF1-1.2) + # OSF/1 1.[012] from OSF, and derivatives, including Paragon OSF/1 + SHLIB_CFLAGS="" + # Hack: make package name same as library name + SHLIB_LD='ld -R -export $@:' + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadOSF.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + ;; + OSF1-1.*) + # OSF/1 1.3 from OSF using ELF, and derivatives, including AD2 + SHLIB_CFLAGS="-fpic" + SHLIB_LD="ld -shared" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + ;; + OSF1-V*) + # Digital OSF/1 + SHLIB_CFLAGS="" + SHLIB_LD='ld -shared -expect_unresolved "*"' + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + ;; + RISCos-*) + SHLIB_CFLAGS="-G 0" + SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" + SHLIB_LD_LIBS='${LIBS}' + SHLIB_SUFFIX="..o" + DL_OBJS="tclLoadAout.o" + DL_LIBS="" + LD_FLAGS="-Wl,-D,08000000" + LD_SEARCH_FLAGS="" + ;; + SCO_SV-3.2*) + # Note, dlopen is available only on SCO 3.2.5 and greater. However, + # this test works, since "uname -s" was non-standard in 3.2.4 and + # below. + SHLIB_CFLAGS="-Kpic -belf" + SHLIB_LD="ld -G" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="" + LD_FLAGS="-belf -Wl,-Bexport" + LD_SEARCH_FLAGS="" + ;; + SINIX*5.4*) + SHLIB_CFLAGS="-K PIC" + SHLIB_LD="cc -G" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + ;; + SunOS-4*) + SHLIB_CFLAGS="-PIC" + SHLIB_LD="ld" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="" + LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' + + # SunOS can't handle version numbers with dots in them in library + # specs, like -ltcl7.5, so use -ltcl75 instead. Also, it + # requires an extra version number at the end of .so file names. + # So, the library has to have a name like libtcl75.so.1.0 + + TCL_SHARED_LIB_SUFFIX='`echo ${VERSION} | tr -d .`.so.1.0' + TCL_UNSHARED_LIB_SUFFIX='`echo ${VERSION} | tr -d .`.a' + TCL_LIB_VERSIONS_OK=nodots + ;; + SunOS-5*) + SHLIB_CFLAGS="-KPIC" + SHLIB_LD="/usr/ccs/bin/ld -G -z text" + SHLIB_LD_LIBS='${LIBS}' + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="" + LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' + ;; + ULTRIX-4.*) + SHLIB_CFLAGS="-G 0" + SHLIB_SUFFIX="..o" + SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" + SHLIB_LD_LIBS='${LIBS}' + DL_OBJS="tclLoadAout.o" + DL_LIBS="" + LD_FLAGS="-Wl,-D,08000000" + LD_SEARCH_FLAGS="" + ;; + UNIX_SV*) + SHLIB_CFLAGS="-KPIC" + SHLIB_LD="cc -G" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + # Some UNIX_SV* systems (unixware 1.1.2 for example) have linkers + # that don't grok the -Bexport option. Test that it does. + hold_ldflags=$LDFLAGS + AC_MSG_CHECKING(for ld accepts -Bexport flag) + LDFLAGS="${LDFLAGS} -Wl,-Bexport" + AC_TRY_LINK(, [int i;], found=yes, found=no) + LDFLAGS=$hold_ldflags + AC_MSG_RESULT($found) + if test $found = yes; then + LD_FLAGS="-Wl,-Bexport" + else + LD_FLAGS="" + fi + LD_SEARCH_FLAGS="" + ;; +esac + +# Step 4: If pseudo-static linking is in use (see K. B. Kenny, "Dynamic +# Loading for Tcl -- What Became of It?". Proc. 2nd Tcl/Tk Workshop, +# New Orleans, LA, Computerized Processes Unlimited, 1994), then we need +# to determine which of several header files defines the a.out file +# format (a.out.h, sys/exec.h, or sys/exec_aout.h). At present, we +# support only a file format that is more or less version-7-compatible. +# In particular, +# - a.out files must begin with `struct exec'. +# - the N_TXTOFF on the `struct exec' must compute the seek address +# of the text segment +# - The `struct exec' must contain a_magic, a_text, a_data, a_bss +# and a_entry fields. +# The following compilation should succeed if and only if either sys/exec.h +# or a.out.h is usable for the purpose. +# +# Note that the modified COFF format used on MIPS Ultrix 4.x is usable; the +# `struct exec' includes a second header that contains information that +# duplicates the v7 fields that are needed. + +if test "x$DL_OBJS" = "xtclLoadAout.o" ; then + AC_MSG_CHECKING(sys/exec.h) + AC_TRY_COMPILE([#include ],[ + struct exec foo; + unsigned long seek; + int flag; +#if defined(__mips) || defined(mips) + seek = N_TXTOFF (foo.ex_f, foo.ex_o); +#else + seek = N_TXTOFF (foo); +#endif + flag = (foo.a_magic == OMAGIC); + return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry; +], tcl_ok=usable, tcl_ok=unusable) + AC_MSG_RESULT($tcl_ok) + if test $tcl_ok = usable; then + AC_DEFINE(USE_SYS_EXEC_H) + else + AC_MSG_CHECKING(a.out.h) + AC_TRY_COMPILE([#include ],[ + struct exec foo; + unsigned long seek; + int flag; +#if defined(__mips) || defined(mips) + seek = N_TXTOFF (foo.ex_f, foo.ex_o); +#else + seek = N_TXTOFF (foo); +#endif + flag = (foo.a_magic == OMAGIC); + return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry; + ], tcl_ok=usable, tcl_ok=unusable) + AC_MSG_RESULT($tcl_ok) + if test $tcl_ok = usable; then + AC_DEFINE(USE_A_OUT_H) + else + AC_MSG_CHECKING(sys/exec_aout.h) + AC_TRY_COMPILE([#include ],[ + struct exec foo; + unsigned long seek; + int flag; +#if defined(__mips) || defined(mips) + seek = N_TXTOFF (foo.ex_f, foo.ex_o); +#else + seek = N_TXTOFF (foo); +#endif + flag = (foo.a_midmag == OMAGIC); + return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry; + ], tcl_ok=usable, tcl_ok=unusable) + AC_MSG_RESULT($tcl_ok) + if test $tcl_ok = usable; then + AC_DEFINE(USE_SYS_EXEC_AOUT_H) + else + DL_OBJS="" + fi + fi + fi +fi + +# Step 5: disable dynamic loading if requested via a command-line switch. + +AC_ARG_ENABLE(load, [ --disable-load disallow dynamic loading and "load" command], + [tcl_ok=$enableval], [tcl_ok=yes]) +if test "$tcl_ok" = "no"; then + DL_OBJS="" +fi + +if test "x$DL_OBJS" != "x" ; then + BUILD_DLTEST="\$(DLTEST_TARGETS)" +else + echo "Can't figure out how to do dynamic loading or shared libraries" + echo "on this system." + SHLIB_CFLAGS="" + SHLIB_LD="" + SHLIB_SUFFIX="" + DL_OBJS="tclLoadNone.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + BUILD_DLTEST="" +fi + +# If we're running gcc, then change the C flags for compiling shared +# libraries to the right flags for gcc, instead of those for the +# standard manufacturer compiler. + +if test "$DL_OBJS" != "tclLoadNone.o" ; then + if test "$CC" = "gcc" -o `$CC -v 2>&1 | grep -c gcc` != "0" ; then + SHLIB_CFLAGS="-fPIC" + fi +fi + +#-------------------------------------------------------------------- +# The statements below check for systems where POSIX-style +# non-blocking I/O (O_NONBLOCK) doesn't work or is unimplemented. +# On these systems (mostly older ones), use the old BSD-style +# FIONBIO approach instead. +#-------------------------------------------------------------------- + +AC_CHECK_HEADERS(sys/ioctl.h) +AC_CHECK_HEADERS(sys/filio.h) +AC_MSG_CHECKING([FIONBIO vs. O_NONBLOCK for nonblocking I/O]) +if test -f /usr/lib/NextStep/software_version; then + system=NEXTSTEP-`awk '/3/,/3/' /usr/lib/NextStep/software_version` +else + system=`uname -s`-`uname -r` + if test "$?" -ne 0 ; then + system=unknown + else + # Special check for weird MP-RAS system (uname returns weird + # results, and the version is kept in special file). + + if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then + system=MP-RAS-`awk '{print $3}' /etc/.relid'` + fi + if test "`uname -s`" = "AIX" ; then + system=AIX-`uname -v`.`uname -r` + fi + fi +fi +case $system in + AIX-*) + AC_DEFINE(USE_FIONBIO) + AC_MSG_RESULT(FIONBIO) + ;; + OSF*) + AC_DEFINE(USE_FIONBIO) + AC_MSG_RESULT(FIONBIO) + ;; + SunOS-4*) + AC_DEFINE(USE_FIONBIO) + AC_MSG_RESULT(FIONBIO) + ;; + ULTRIX-4.*) + AC_DEFINE(USE_FIONBIO) + AC_MSG_RESULT(FIONBIO) + ;; + *) + AC_MSG_RESULT(O_NONBLOCK) + ;; +esac + +#-------------------------------------------------------------------- +# The statements below define a collection of symbols related to +# building libtcl as a shared library instead of a static library. +#-------------------------------------------------------------------- + +realRanlib=$RANLIB +if test "$TCL_SHARED_LIB_SUFFIX" = "" ; then + TCL_SHARED_LIB_SUFFIX='${VERSION}${SHLIB_SUFFIX}' +fi +if test "$TCL_UNSHARED_LIB_SUFFIX" = "" ; then + TCL_UNSHARED_LIB_SUFFIX='${VERSION}.a' +fi +AC_ARG_ENABLE(shared, + [ --enable-shared build libtcl as a shared library], + [tcl_ok=$enableval], [tcl_ok=no]) +if test "$tcl_ok" = "yes" -a "${SHLIB_SUFFIX}" != "" \ + -a "${DL_OBJS}" != "tclLoadAout.o" ; then + TCL_SHLIB_CFLAGS="${SHLIB_CFLAGS}" + TCL_LD_SEARCH_FLAGS="${LD_SEARCH_FLAGS}" + eval "TCL_LIB_FILE=libtcl${TCL_SHARED_LIB_SUFFIX}" + MAKE_LIB="\${SHLIB_LD} -o ${TCL_LIB_FILE} \${OBJS} ${SHLIB_LD_LIBS}" + RANLIB=":" +else + if test "$AIX" = "no" ; then + SHLIB_LD_LIBS="" + fi + TCL_SHLIB_CFLAGS="" + TCL_LD_SEARCH_FLAGS="" + eval "TCL_LIB_FILE=libtcl${TCL_UNSHARED_LIB_SUFFIX}" + MAKE_LIB="ar cr ${TCL_LIB_FILE} \${OBJS}" +fi + +# Note: in the following variable, it's important to use the absolute +# path name of the Tcl directory rather than "..": this is because +# AIX remembers this path and will attempt to use it at run-time to look +# up the Tcl library. + +if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then + TCL_BUILD_LIB_SPEC="-L`pwd` -ltcl${VERSION}" + TCL_LIB_SPEC="-L${exec_prefix}/lib -ltcl${VERSION}" +else + TCL_BUILD_LIB_SPEC="-L`pwd` -ltcl`echo ${VERSION} | tr -d .`" + TCL_LIB_SPEC="-L${exec_prefix}/lib -ltcl`echo ${VERSION} | tr -d .`" +fi + +#-------------------------------------------------------------------- +# The statements below define the symbol TCL_PACKAGE_PATH, which +# gives a list of directories that may contain packages. The list +# consists of one directory for machine-dependent binaries and +# another for platform-independent scripts. +#-------------------------------------------------------------------- + +if test "$prefix" != "$exec_prefix"; then + TCL_PACKAGE_PATH="${exec_prefix}/lib ${prefix}/lib" +else + TCL_PACKAGE_PATH="${prefix}/lib" +fi + +AC_SUBST(BUILD_DLTEST) +AC_SUBST(DL_LIBS) +AC_SUBST(DL_OBJS) +AC_SUBST(LD_FLAGS) +AC_SUBST(MAKE_LIB) +AC_SUBST(MATH_LIBS) +AC_SUBST(SHLIB_CFLAGS) +AC_SUBST(SHLIB_LD) +AC_SUBST(SHLIB_LD_LIBS) +AC_SUBST(SHLIB_SUFFIX) +AC_SUBST(TCL_BUILD_LIB_SPEC) +AC_SUBST(TCL_LD_SEARCH_FLAGS) +AC_SUBST(TCL_LIB_FILE) +AC_SUBST(TCL_LIB_SPEC) +AC_SUBST(TCL_LIB_VERSIONS_OK) +AC_SUBST(TCL_MAJOR_VERSION) +AC_SUBST(TCL_MINOR_VERSION) +AC_SUBST(TCL_PACKAGE_PATH) +AC_SUBST(TCL_SHARED_LIB_SUFFIX) +AC_SUBST(TCL_SHLIB_CFLAGS) +AC_SUBST(TCL_SRC_DIR) +AC_SUBST(TCL_UNSHARED_LIB_SUFFIX) +AC_SUBST(TCL_VERSION) + +AC_OUTPUT(Makefile tclConfig.sh) diff --git a/tcl7.6/unix/dltest/Makefile.in b/tcl7.6/unix/dltest/Makefile.in new file mode 100644 index 0000000..130ea18 --- /dev/null +++ b/tcl7.6/unix/dltest/Makefile.in @@ -0,0 +1,45 @@ +# This Makefile is used to create several test cases for Tcl's load +# command. It also illustrates how to take advantage of configuration +# exported by Tcl to set up Makefiles for shared libraries. +# SCCS: @(#) Makefile.in 1.11 96/04/15 09:50:19 + +CC = @CC@ +LIBS = @TCL_BUILD_LIB_SPEC@ @TCL_LIBS@ -lc +SHLIB_CFLAGS = @SHLIB_CFLAGS@ +SHLIB_LD = @SHLIB_LD@ +SHLIB_SUFFIX = @SHLIB_SUFFIX@ +SHLIB_VERSION = @SHLIB_VERSION@ +SRC_DIR = @srcdir@ +TCL_VERSION= @TCL_VERSION@ + +CFLAGS = -g +CC_SWITCHES = $(CFLAGS) -I${SRC_DIR}/../../generic -DTCL_MEM_DEBUG \ + ${SHLIB_CFLAGS} + +all: pkga${SHLIB_SUFFIX} pkgb${SHLIB_SUFFIX} pkgc${SHLIB_SUFFIX} pkgd${SHLIB_SUFFIX} pkge${SHLIB_SUFFIX} + +pkga${SHLIB_SUFFIX}: $(SRC_DIR)/pkga.c + $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkga.c + ${SHLIB_LD} pkga.o -o pkga${SHLIB_SUFFIX} @SHLIB_LD_LIBS@ + +pkgb${SHLIB_SUFFIX}: $(SRC_DIR)/pkgb.c + $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgb.c + ${SHLIB_LD} pkgb.o -o pkgb${SHLIB_SUFFIX} @SHLIB_LD_LIBS@ + +pkgc${SHLIB_SUFFIX}: $(SRC_DIR)/pkgc.c + $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgc.c + ${SHLIB_LD} pkgc.o -o pkgc${SHLIB_SUFFIX} @SHLIB_LD_LIBS@ + +pkgd${SHLIB_SUFFIX}: $(SRC_DIR)/pkgd.c + $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgd.c + ${SHLIB_LD} pkgd.o -o pkgd${SHLIB_SUFFIX} @SHLIB_LD_LIBS@ + +pkge${SHLIB_SUFFIX}: $(SRC_DIR)/pkge.c + $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkge.c + ${SHLIB_LD} pkge.o -o pkge${SHLIB_SUFFIX} @SHLIB_LD_LIBS@ + +clean: + rm -f *.o *${SHLIB_SUFFIX} config.cache config.log config.status lib.exp + +distclean: clean + rm -f Makefile diff --git a/tcl7.6/unix/dltest/README b/tcl7.6/unix/dltest/README new file mode 100644 index 0000000..f4e54d4 --- /dev/null +++ b/tcl7.6/unix/dltest/README @@ -0,0 +1,12 @@ +This directory contains several files for testing Tcl's dynamic +loading capabilities. If this directory is present and the files +in here have been compiled, then the "load" test will use the shared +libraries present here to run a series of tests. To compile the +shared libraries, first type "./configure". This will read +configuration information created when Tcl was configured and +create Makefile from Makefile.in. Be sure that you have configured +Tcl before configuring here, since information learned during Tcl's +configure is needed here. Then type "make" to create the shared +libraries. + +sccsid: @(#) README 1.2 95/08/22 08:13:23 diff --git a/tcl7.6/unix/dltest/configure b/tcl7.6/unix/dltest/configure new file mode 100755 index 0000000..fa1663c --- /dev/null +++ b/tcl7.6/unix/dltest/configure @@ -0,0 +1,611 @@ +#! /bin/sh + +# Guess values for system-dependent variables and create Makefiles. +# Generated automatically using autoconf version 2.4 +# Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc. +# +# This configure script is free software; the Free Software Foundation +# gives unlimited permission to copy, distribute and modify it. + +# Defaults: +ac_help= +ac_default_prefix=/usr/local +# Any additions from configure.in: + +# Initialize some variables set by options. +# The variables have the same names as the options, with +# dashes changed to underlines. +build=NONE +cache_file=./config.cache +exec_prefix=NONE +host=NONE +no_create= +nonopt=NONE +no_recursion= +prefix=NONE +program_prefix=NONE +program_suffix=NONE +program_transform_name=s,x,x, +silent= +site= +srcdir= +target=NONE +verbose= +x_includes=NONE +x_libraries=NONE + +# Initialize some other variables. +subdirs= + +ac_prev= +for ac_option +do + + # If the previous option needs an argument, assign it. + if test -n "$ac_prev"; then + eval "$ac_prev=\$ac_option" + ac_prev= + continue + fi + + case "$ac_option" in + -*=*) ac_optarg=`echo "$ac_option" | sed 's/[-_a-zA-Z0-9]*=//'` ;; + *) ac_optarg= ;; + esac + + # Accept the important Cygnus configure options, so we can diagnose typos. + + case "$ac_option" in + + -build | --build | --buil | --bui | --bu | --b) + ac_prev=build ;; + -build=* | --build=* | --buil=* | --bui=* | --bu=* | --b=*) + build="$ac_optarg" ;; + + -cache-file | --cache-file | --cache-fil | --cache-fi \ + | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) + ac_prev=cache_file ;; + -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ + | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) + cache_file="$ac_optarg" ;; + + -disable-* | --disable-*) + ac_feature=`echo $ac_option|sed -e 's/-*disable-//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_feature| sed 's/[-a-zA-Z0-9_]//g'`"; then + { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } + fi + ac_feature=`echo $ac_feature| sed 's/-/_/g'` + eval "enable_${ac_feature}=no" ;; + + -enable-* | --enable-*) + ac_feature=`echo $ac_option|sed -e 's/-*enable-//' -e 's/=.*//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_feature| sed 's/[-_a-zA-Z0-9]//g'`"; then + { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } + fi + ac_feature=`echo $ac_feature| sed 's/-/_/g'` + case "$ac_option" in + *=*) ;; + *) ac_optarg=yes ;; + esac + eval "enable_${ac_feature}='$ac_optarg'" ;; + + -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ + | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ + | --exec | --exe | --ex) + ac_prev=exec_prefix ;; + -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ + | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ + | --exec=* | --exe=* | --ex=*) + exec_prefix="$ac_optarg" ;; + + -gas | --gas | --ga | --g) + # Obsolete; use --with-gas. + with_gas=yes ;; + + -help | --help | --hel | --he) + # Omit some internal or obsolete options to make the list less imposing. + # This message is too long to be a string in the A/UX 3.1 sh. + cat << EOF +Usage: configure [options] [host] +Options: [defaults in brackets after descriptions] +Configuration: + --cache-file=FILE cache test results in FILE + --help print this message + --no-create do not create output files + --quiet, --silent do not print \`checking...' messages + --version print the version of autoconf that created configure +Directory and file names: + --prefix=PREFIX install architecture-independent files in PREFIX + [$ac_default_prefix] + --exec-prefix=PREFIX install architecture-dependent files in PREFIX + [same as prefix] + --srcdir=DIR find the sources in DIR [configure dir or ..] + --program-prefix=PREFIX prepend PREFIX to installed program names + --program-suffix=SUFFIX append SUFFIX to installed program names + --program-transform-name=PROGRAM run sed PROGRAM on installed program names +Host type: + --build=BUILD configure for building on BUILD [BUILD=HOST] + --host=HOST configure for HOST [guessed] + --target=TARGET configure for TARGET [TARGET=HOST] +Features and packages: + --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) + --enable-FEATURE[=ARG] include FEATURE [ARG=yes] + --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] + --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) + --x-includes=DIR X include files are in DIR + --x-libraries=DIR X library files are in DIR +--enable and --with options recognized:$ac_help +EOF + exit 0 ;; + + -host | --host | --hos | --ho) + ac_prev=host ;; + -host=* | --host=* | --hos=* | --ho=*) + host="$ac_optarg" ;; + + -nfp | --nfp | --nf) + # Obsolete; use --without-fp. + with_fp=no ;; + + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c) + no_create=yes ;; + + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) + no_recursion=yes ;; + + -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) + ac_prev=prefix ;; + -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) + prefix="$ac_optarg" ;; + + -program-prefix | --program-prefix | --program-prefi | --program-pref \ + | --program-pre | --program-pr | --program-p) + ac_prev=program_prefix ;; + -program-prefix=* | --program-prefix=* | --program-prefi=* \ + | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) + program_prefix="$ac_optarg" ;; + + -program-suffix | --program-suffix | --program-suffi | --program-suff \ + | --program-suf | --program-su | --program-s) + ac_prev=program_suffix ;; + -program-suffix=* | --program-suffix=* | --program-suffi=* \ + | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) + program_suffix="$ac_optarg" ;; + + -program-transform-name | --program-transform-name \ + | --program-transform-nam | --program-transform-na \ + | --program-transform-n | --program-transform- \ + | --program-transform | --program-transfor \ + | --program-transfo | --program-transf \ + | --program-trans | --program-tran \ + | --progr-tra | --program-tr | --program-t) + ac_prev=program_transform_name ;; + -program-transform-name=* | --program-transform-name=* \ + | --program-transform-nam=* | --program-transform-na=* \ + | --program-transform-n=* | --program-transform-=* \ + | --program-transform=* | --program-transfor=* \ + | --program-transfo=* | --program-transf=* \ + | --program-trans=* | --program-tran=* \ + | --progr-tra=* | --program-tr=* | --program-t=*) + program_transform_name="$ac_optarg" ;; + + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + silent=yes ;; + + -site | --site | --sit) + ac_prev=site ;; + -site=* | --site=* | --sit=*) + site="$ac_optarg" ;; + + -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) + ac_prev=srcdir ;; + -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) + srcdir="$ac_optarg" ;; + + -target | --target | --targe | --targ | --tar | --ta | --t) + ac_prev=target ;; + -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) + target="$ac_optarg" ;; + + -v | -verbose | --verbose | --verbos | --verbo | --verb) + verbose=yes ;; + + -version | --version | --versio | --versi | --vers) + echo "configure generated by autoconf version 2.4" + exit 0 ;; + + -with-* | --with-*) + ac_package=`echo $ac_option|sed -e 's/-*with-//' -e 's/=.*//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_package| sed 's/[-_a-zA-Z0-9]//g'`"; then + { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } + fi + ac_package=`echo $ac_package| sed 's/-/_/g'` + case "$ac_option" in + *=*) ;; + *) ac_optarg=yes ;; + esac + eval "with_${ac_package}='$ac_optarg'" ;; + + -without-* | --without-*) + ac_package=`echo $ac_option|sed -e 's/-*without-//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_package| sed 's/[-a-zA-Z0-9_]//g'`"; then + { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } + fi + ac_package=`echo $ac_package| sed 's/-/_/g'` + eval "with_${ac_package}=no" ;; + + --x) + # Obsolete; use --with-x. + with_x=yes ;; + + -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ + | --x-incl | --x-inc | --x-in | --x-i) + ac_prev=x_includes ;; + -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ + | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) + x_includes="$ac_optarg" ;; + + -x-libraries | --x-libraries | --x-librarie | --x-librari \ + | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) + ac_prev=x_libraries ;; + -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ + | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) + x_libraries="$ac_optarg" ;; + + -*) { echo "configure: error: $ac_option: invalid option; use --help to show usage" 1>&2; exit 1; } + ;; + + *) + if test -n "`echo $ac_option| sed 's/[-a-z0-9.]//g'`"; then + echo "configure: warning: $ac_option: invalid host type" 1>&2 + fi + if test "x$nonopt" != xNONE; then + { echo "configure: error: can only configure for one host and one target at a time" 1>&2; exit 1; } + fi + nonopt="$ac_option" + ;; + + esac +done + +if test -n "$ac_prev"; then + { echo "configure: error: missing argument to --`echo $ac_prev | sed 's/_/-/g'`" 1>&2; exit 1; } +fi + +trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 + +# File descriptor usage: +# 0 standard input +# 1 file creation +# 2 errors and warnings +# 3 some systems may open it to /dev/tty +# 4 used on the Kubota Titan +# 6 checking for... messages and results +# 5 compiler messages saved in config.log +if test "$silent" = yes; then + exec 6>/dev/null +else + exec 6>&1 +fi +exec 5>./config.log + +echo "\ +This file contains any messages produced by compilers while +running configure, to aid debugging if configure makes a mistake. +" 1>&5 + +# Strip out --no-create and --no-recursion so they do not pile up. +# Also quote any args containing shell metacharacters. +ac_configure_args= +for ac_arg +do + case "$ac_arg" in + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c) ;; + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) ;; + *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?]*) + ac_configure_args="$ac_configure_args '$ac_arg'" ;; + *) ac_configure_args="$ac_configure_args $ac_arg" ;; + esac +done + +# NLS nuisances. +# Only set LANG and LC_ALL to C if already set. +# 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 + +# confdefs.h avoids OS command line length limits that DEFS can exceed. +rm -rf conftest* confdefs.h +# AIX cpp loses on an empty file, so make sure it contains at least a newline. +echo > confdefs.h + +# 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. +ac_unique_file=pkga.c + +# Find the source files, if location was not specified. +if test -z "$srcdir"; then + ac_srcdir_defaulted=yes + # Try the directory containing this script, then its parent. + ac_prog=$0 + ac_confdir=`echo $ac_prog|sed 's%/[^/][^/]*$%%'` + test "x$ac_confdir" = "x$ac_prog" && ac_confdir=. + srcdir=$ac_confdir + if test ! -r $srcdir/$ac_unique_file; then + srcdir=.. + fi +else + ac_srcdir_defaulted=no +fi +if test ! -r $srcdir/$ac_unique_file; then + if test "$ac_srcdir_defaulted" = yes; then + { echo "configure: error: can not find sources in $ac_confdir or .." 1>&2; exit 1; } + else + { echo "configure: error: can not find sources in $srcdir" 1>&2; exit 1; } + fi +fi +srcdir=`echo "${srcdir}" | sed 's%\([^/]\)/*$%\1%'` + +# Prefer explicitly selected file to automatically selected ones. +if test -z "$CONFIG_SITE"; then + if test "x$prefix" != xNONE; then + CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site" + else + CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" + fi +fi +for ac_site_file in $CONFIG_SITE; do + if test -r "$ac_site_file"; then + echo "loading site script $ac_site_file" + . "$ac_site_file" + fi +done + +if test -r "$cache_file"; then + echo "loading cache $cache_file" + . $cache_file +else + echo "creating cache $cache_file" + > $cache_file +fi + +ac_ext=c +# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. +ac_cpp='$CPP $CPPFLAGS' +ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5 2>&5' +ac_link='${CC-cc} -o conftest $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5 2>&5' + +if (echo "testing\c"; echo 1,2,3) | grep c >/dev/null; then + # Stardent Vistra SVR4 grep lacks -e, says ghazi@caip.rutgers.edu. + if (echo -n testing; echo 1,2,3) | sed s/-n/xn/ | grep xn >/dev/null; then + ac_n= ac_c=' +' ac_t=' ' + else + ac_n=-n ac_c= ac_t= + fi +else + ac_n= ac_c='\c' ac_t= +fi + + +# SCCS: @(#) configure.in 1.9 96/04/15 09:50:20 + +# Recover information that Tcl computed with its configure script. + +. ../tclConfig.sh + +CC=$TCL_CC + +SHLIB_CFLAGS=$TCL_SHLIB_CFLAGS + +SHLIB_LD=$TCL_SHLIB_LD + +SHLIB_LD_LIBS=$TCL_SHLIB_LD_LIBS + +SHLIB_SUFFIX=$TCL_SHLIB_SUFFIX + +SHLIB_VERSION=$TCL_SHLIB_VERSION + + +TCL_LIBS=$TCL_LIBS + +TCL_VERSION=$TCL_VERSION + + +trap '' 1 2 15 +cat > confcache <<\EOF +# This file is a shell script that caches the results of configure +# tests run on this system so they can be shared between configure +# scripts and configure runs. It is not useful on other systems. +# If it contains results you don't want to keep, you may remove or edit it. +# +# By default, configure uses ./config.cache as the cache file, +# creating it if it does not exist already. You can give configure +# the --cache-file=FILE option to use a different cache file; that is +# what configure does when it calls configure scripts in +# subdirectories, so they share the cache. +# Giving --cache-file=/dev/null disables caching, for debugging configure. +# config.status only pays attention to the cache file if you give it the +# --recheck option to rerun configure. +# +EOF +# Ultrix sh set writes to stderr and can't be redirected directly, +# and sets the high bit in the cache file unless we assign to the vars. +(set) 2>&1 | + sed -n "s/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=\${\1='\2'}/p" \ + >> confcache +if cmp -s $cache_file confcache; then + : +else + if test -w $cache_file; then + echo "updating cache $cache_file" + cat confcache > $cache_file + else + echo "not updating unwritable cache $cache_file" + fi +fi +rm -f confcache + +trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 + +test "x$prefix" = xNONE && prefix=$ac_default_prefix +# Let make expand exec_prefix. +test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' + +# Any assignment to VPATH causes Sun make to only execute +# the first set of double-colon rules, so remove it if not needed. +# If there is a colon in the path, we need to keep it. +if test "x$srcdir" = x.; then + ac_vpsub='/^[ ]*VPATH[ ]*=[^:]*$/d' +fi + +trap 'rm -f $CONFIG_STATUS conftest*; exit 1' 1 2 15 + +# Transform confdefs.h into DEFS. +# Protect against shell expansion while executing Makefile rules. +# Protect against Makefile macro expansion. +cat > conftest.defs <<\EOF +s%#define \([A-Za-z_][A-Za-z0-9_]*\) \(.*\)%-D\1=\2%g +s%[ `~#$^&*(){}\\|;'"<>?]%\\&%g +s%\[%\\&%g +s%\]%\\&%g +s%\$%$$%g +EOF +DEFS=`sed -f conftest.defs confdefs.h | tr '\012' ' '` +rm -f conftest.defs + + +# Without the "./", some shells look in PATH for config.status. +: ${CONFIG_STATUS=./config.status} + +echo creating $CONFIG_STATUS +rm -f $CONFIG_STATUS +cat > $CONFIG_STATUS </dev/null | sed 1q`: +# +# $0 $ac_configure_args +# +# Compiler output produced by configure, useful for debugging +# configure, is in ./config.log if it exists. + +ac_cs_usage="Usage: $CONFIG_STATUS [--recheck] [--version] [--help]" +for ac_option +do + case "\$ac_option" in + -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) + echo "running \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion" + exec \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion ;; + -version | --version | --versio | --versi | --vers | --ver | --ve | --v) + echo "$CONFIG_STATUS generated by autoconf version 2.4" + exit 0 ;; + -help | --help | --hel | --he | --h) + echo "\$ac_cs_usage"; exit 0 ;; + *) echo "\$ac_cs_usage"; exit 1 ;; + esac +done + +ac_given_srcdir=$srcdir + +trap 'rm -fr `echo "Makefile" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15 + +# Protect against being on the right side of a sed subst in config.status. +sed 's/%@/@@/; s/@%/@@/; s/%g$/@g/; /@g$/s/[\\\\&%]/\\\\&/g; + s/@@/%@/; s/@@/@%/; s/@g$/%g/' > conftest.subs <<\CEOF +$ac_vpsub +$extrasub +s%@CFLAGS@%$CFLAGS%g +s%@CPPFLAGS@%$CPPFLAGS%g +s%@CXXFLAGS@%$CXXFLAGS%g +s%@DEFS@%$DEFS%g +s%@LDFLAGS@%$LDFLAGS%g +s%@LIBS@%$LIBS%g +s%@exec_prefix@%$exec_prefix%g +s%@prefix@%$prefix%g +s%@program_transform_name@%$program_transform_name%g +s%@CC@%$CC%g +s%@SHLIB_CFLAGS@%$SHLIB_CFLAGS%g +s%@SHLIB_LD@%$SHLIB_LD%g +s%@SHLIB_LD_LIBS@%$SHLIB_LD_LIBS%g +s%@SHLIB_SUFFIX@%$SHLIB_SUFFIX%g +s%@SHLIB_VERSION@%$SHLIB_VERSION%g +s%@TCL_BUILD_LIB_SPEC@%$TCL_BUILD_LIB_SPEC%g +s%@TCL_LIBS@%$TCL_LIBS%g +s%@TCL_VERSION@%$TCL_VERSION%g + +CEOF +EOF +cat >> $CONFIG_STATUS <> $CONFIG_STATUS <<\EOF +for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then + # Support "outfile[:infile]", defaulting infile="outfile.in". + case "$ac_file" in + *:*) ac_file_in=`echo "$ac_file"|sed 's%.*:%%'` + ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;; + *) ac_file_in="${ac_file}.in" ;; + esac + + # Adjust relative srcdir, etc. for subdirectories. + + # Remove last slash and all that follows it. Not all systems have dirname. + ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'` + if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then + # The file is in a subdirectory. + test ! -d "$ac_dir" && mkdir "$ac_dir" + ac_dir_suffix="/`echo $ac_dir|sed 's%^\./%%'`" + # A "../" for each directory in $ac_dir_suffix. + ac_dots=`echo $ac_dir_suffix|sed 's%/[^/]*%../%g'` + else + ac_dir_suffix= ac_dots= + fi + + case "$ac_given_srcdir" in + .) srcdir=. + if test -z "$ac_dots"; then top_srcdir=. + else top_srcdir=`echo $ac_dots|sed 's%/$%%'`; fi ;; + /*) srcdir="$ac_given_srcdir$ac_dir_suffix"; top_srcdir="$ac_given_srcdir" ;; + *) # Relative path. + srcdir="$ac_dots$ac_given_srcdir$ac_dir_suffix" + top_srcdir="$ac_dots$ac_given_srcdir" ;; + esac + + echo creating "$ac_file" + rm -f "$ac_file" + configure_input="Generated automatically from `echo $ac_file_in|sed 's%.*/%%'` by configure." + case "$ac_file" in + *Makefile*) ac_comsub="1i\\ +# $configure_input" ;; + *) ac_comsub= ;; + esac + sed -e "$ac_comsub +s%@configure_input@%$configure_input%g +s%@srcdir@%$srcdir%g +s%@top_srcdir@%$top_srcdir%g +" -f conftest.subs $ac_given_srcdir/$ac_file_in > $ac_file +fi; done +rm -f conftest.subs + + + +exit 0 +EOF +chmod +x $CONFIG_STATUS +rm -fr confdefs* $ac_clean_files +test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1 + diff --git a/tcl7.6/unix/dltest/configure.in b/tcl7.6/unix/dltest/configure.in new file mode 100644 index 0000000..29924e9 --- /dev/null +++ b/tcl7.6/unix/dltest/configure.in @@ -0,0 +1,29 @@ +dnl This file is an input file used by the GNU "autoconf" program to +dnl generate the file "configure", which is run to configure the +dnl Makefile in this directory. +AC_INIT(pkga.c) +# SCCS: @(#) configure.in 1.9 96/04/15 09:50:20 + +# Recover information that Tcl computed with its configure script. + +. ../tclConfig.sh + +CC=$TCL_CC +AC_SUBST(CC) +SHLIB_CFLAGS=$TCL_SHLIB_CFLAGS +AC_SUBST(SHLIB_CFLAGS) +SHLIB_LD=$TCL_SHLIB_LD +AC_SUBST(SHLIB_LD) +SHLIB_LD_LIBS=$TCL_SHLIB_LD_LIBS +AC_SUBST(SHLIB_LD_LIBS) +SHLIB_SUFFIX=$TCL_SHLIB_SUFFIX +AC_SUBST(SHLIB_SUFFIX) +SHLIB_VERSION=$TCL_SHLIB_VERSION +AC_SUBST(SHLIB_VERSION) +AC_SUBST(TCL_BUILD_LIB_SPEC) +TCL_LIBS=$TCL_LIBS +AC_SUBST(TCL_LIBS) +TCL_VERSION=$TCL_VERSION +AC_SUBST(TCL_VERSION) + +AC_OUTPUT(Makefile) diff --git a/tcl7.6/unix/dltest/pkga.c b/tcl7.6/unix/dltest/pkga.c new file mode 100644 index 0000000..ab48522 --- /dev/null +++ b/tcl7.6/unix/dltest/pkga.c @@ -0,0 +1,130 @@ +/* + * pkga.c -- + * + * This file contains a simple Tcl package "pkga" that is intended + * for testing the Tcl dynamic loading facilities. + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) pkga.c 1.4 96/02/15 12:30:35 + */ +#include "tcl.h" + +/* + * Prototypes for procedures defined later in this file: + */ + +static int Pkga_EqCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static int Pkga_QuoteCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +/* + *---------------------------------------------------------------------- + * + * Pkga_EqCmd -- + * + * This procedure is invoked to process the "pkga_eq" Tcl command. + * It expects two arguments and returns 1 if they are the same, + * 0 if they are different. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +Pkga_EqCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " string1 string2\"", (char *) NULL); + return TCL_ERROR; + } + + if (strcmp(argv[1], argv[2]) == 0) { + interp->result = "1"; + } else { + interp->result = "0"; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkga_quoteCmd -- + * + * This procedure is invoked to process the "pkga_quote" Tcl command. + * It expects one argument, which it returns as result. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +Pkga_QuoteCmd(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], + " value\"", (char *) NULL); + return TCL_ERROR; + } + strcpy(interp->result, argv[1]); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkga_Init -- + * + * This is a package initialization procedure, which is called + * by Tcl when this package is to be added to an interpreter. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Pkga_Init(interp) + Tcl_Interp *interp; /* Interpreter in which the package is + * to be made available. */ +{ + int code; + + code = Tcl_PkgProvide(interp, "Pkga", "1.0"); + if (code != TCL_OK) { + return code; + } + Tcl_CreateCommand(interp, "pkga_eq", Pkga_EqCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "pkga_quote", Pkga_QuoteCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + return TCL_OK; +} diff --git a/tcl7.6/unix/dltest/pkgb.c b/tcl7.6/unix/dltest/pkgb.c new file mode 100644 index 0000000..1da9575 --- /dev/null +++ b/tcl7.6/unix/dltest/pkgb.c @@ -0,0 +1,153 @@ +/* + * pkgb.c -- + * + * This file contains a simple Tcl package "pkgb" that is intended + * for testing the Tcl dynamic loading facilities. It can be used + * in both safe and unsafe interpreters. + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) pkgb.c 1.4 96/02/15 12:30:34 + */ +#include "tcl.h" + +/* + * Prototypes for procedures defined later in this file: + */ + +static int Pkgb_SubCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static int Pkgb_UnsafeCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +/* + *---------------------------------------------------------------------- + * + * Pkgb_SubCmd -- + * + * This procedure is invoked to process the "pkgb_sub" Tcl command. + * It expects two arguments and returns their difference. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +Pkgb_SubCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int first, second; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " num num\"", (char *) NULL); + return TCL_ERROR; + } + if ((Tcl_GetInt(interp, argv[1], &first) != TCL_OK) + || (Tcl_GetInt(interp, argv[2], &second) != TCL_OK)) { + return TCL_ERROR; + } + sprintf(interp->result, "%d", first - second); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkgb_UnsafeCmd -- + * + * This procedure is invoked to process the "pkgb_unsafe" Tcl command. + * It just returns a constant string. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +Pkgb_UnsafeCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + interp->result = "unsafe command invoked"; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkgb_Init -- + * + * This is a package initialization procedure, which is called + * by Tcl when this package is to be added to an interpreter. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Pkgb_Init(interp) + Tcl_Interp *interp; /* Interpreter in which the package is + * to be made available. */ +{ + int code; + + code = Tcl_PkgProvide(interp, "Pkgb", "2.3"); + if (code != TCL_OK) { + return code; + } + Tcl_CreateCommand(interp, "pkgb_sub", Pkgb_SubCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "pkgb_unsafe", Pkgb_UnsafeCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkgb_SafeInit -- + * + * This is a package initialization procedure, which is called + * by Tcl when this package is to be added to an unsafe interpreter. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Pkgb_SafeInit(interp) + Tcl_Interp *interp; /* Interpreter in which the package is + * to be made available. */ +{ + Tcl_CreateCommand(interp, "pkgb_sub", Pkgb_SubCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + return TCL_OK; +} diff --git a/tcl7.6/unix/dltest/pkgc.c b/tcl7.6/unix/dltest/pkgc.c new file mode 100644 index 0000000..c35189a --- /dev/null +++ b/tcl7.6/unix/dltest/pkgc.c @@ -0,0 +1,153 @@ +/* + * pkgc.c -- + * + * This file contains a simple Tcl package "pkgc" that is intended + * for testing the Tcl dynamic loading facilities. It can be used + * in both safe and unsafe interpreters. + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) pkgc.c 1.4 96/02/15 12:30:35 + */ +#include "tcl.h" + +/* + * Prototypes for procedures defined later in this file: + */ + +static int Pkgc_SubCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static int Pkgc_UnsafeCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +/* + *---------------------------------------------------------------------- + * + * Pkgc_SubCmd -- + * + * This procedure is invoked to process the "pkgc_sub" Tcl command. + * It expects two arguments and returns their difference. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +Pkgc_SubCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int first, second; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " num num\"", (char *) NULL); + return TCL_ERROR; + } + if ((Tcl_GetInt(interp, argv[1], &first) != TCL_OK) + || (Tcl_GetInt(interp, argv[2], &second) != TCL_OK)) { + return TCL_ERROR; + } + sprintf(interp->result, "%d", first - second); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkgc_UnsafeCmd -- + * + * This procedure is invoked to process the "pkgc_unsafe" Tcl command. + * It just returns a constant string. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +Pkgc_UnsafeCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + interp->result = "unsafe command invoked"; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkgc_Init -- + * + * This is a package initialization procedure, which is called + * by Tcl when this package is to be added to an interpreter. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Pkgc_Init(interp) + Tcl_Interp *interp; /* Interpreter in which the package is + * to be made available. */ +{ + int code; + + code = Tcl_PkgProvide(interp, "Pkgc", "1.7.2"); + if (code != TCL_OK) { + return code; + } + Tcl_CreateCommand(interp, "pkgc_sub", Pkgc_SubCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "pkgc_unsafe", Pkgc_UnsafeCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkgc_SafeInit -- + * + * This is a package initialization procedure, which is called + * by Tcl when this package is to be added to an unsafe interpreter. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Pkgc_SafeInit(interp) + Tcl_Interp *interp; /* Interpreter in which the package is + * to be made available. */ +{ + Tcl_CreateCommand(interp, "pkgc_sub", Pkgc_SubCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + return TCL_OK; +} diff --git a/tcl7.6/unix/dltest/pkgd.c b/tcl7.6/unix/dltest/pkgd.c new file mode 100644 index 0000000..56821cc --- /dev/null +++ b/tcl7.6/unix/dltest/pkgd.c @@ -0,0 +1,154 @@ +/* + * pkgd.c -- + * + * This file contains a simple Tcl package "pkgd" that is intended + * for testing the Tcl dynamic loading facilities. It can be used + * in both safe and unsafe interpreters. + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) pkgd.c 1.4 96/02/15 12:30:32 + */ + +#include "tcl.h" + +/* + * Prototypes for procedures defined later in this file: + */ + +static int Pkgd_SubCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static int Pkgd_UnsafeCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +/* + *---------------------------------------------------------------------- + * + * Pkgd_SubCmd -- + * + * This procedure is invoked to process the "pkgd_sub" Tcl command. + * It expects two arguments and returns their difference. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +Pkgd_SubCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int first, second; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " num num\"", (char *) NULL); + return TCL_ERROR; + } + if ((Tcl_GetInt(interp, argv[1], &first) != TCL_OK) + || (Tcl_GetInt(interp, argv[2], &second) != TCL_OK)) { + return TCL_ERROR; + } + sprintf(interp->result, "%d", first - second); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkgd_UnsafeCmd -- + * + * This procedure is invoked to process the "pkgd_unsafe" Tcl command. + * It just returns a constant string. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +Pkgd_UnsafeCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + interp->result = "unsafe command invoked"; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkgd_Init -- + * + * This is a package initialization procedure, which is called + * by Tcl when this package is to be added to an interpreter. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Pkgd_Init(interp) + Tcl_Interp *interp; /* Interpreter in which the package is + * to be made available. */ +{ + int code; + + code = Tcl_PkgProvide(interp, "Pkgd", "7.3"); + if (code != TCL_OK) { + return code; + } + Tcl_CreateCommand(interp, "pkgd_sub", Pkgd_SubCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "pkgd_unsafe", Pkgd_UnsafeCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkgd_SafeInit -- + * + * This is a package initialization procedure, which is called + * by Tcl when this package is to be added to an unsafe interpreter. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Pkgd_SafeInit(interp) + Tcl_Interp *interp; /* Interpreter in which the package is + * to be made available. */ +{ + Tcl_CreateCommand(interp, "pkgd_sub", Pkgd_SubCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + return TCL_OK; +} diff --git a/tcl7.6/unix/dltest/pkge.c b/tcl7.6/unix/dltest/pkge.c new file mode 100644 index 0000000..1d585ca --- /dev/null +++ b/tcl7.6/unix/dltest/pkge.c @@ -0,0 +1,49 @@ +/* + * pkge.c -- + * + * This file contains a simple Tcl package "pkge" that is intended + * for testing the Tcl dynamic loading facilities. Its Init + * procedure returns an error in order to test how this is handled. + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) pkge.c 1.5 96/03/07 09:34:27 + */ +#include "tcl.h" + +/* + * Prototypes for procedures defined later in this file: + */ + +static int Pkgd_SubCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static int Pkgd_UnsafeCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +/* + *---------------------------------------------------------------------- + * + * Pkge_Init -- + * + * This is a package initialization procedure, which is called + * by Tcl when this package is to be added to an interpreter. + * + * Results: + * Returns TCL_ERROR and leaves an error message in interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Pkge_Init(interp) + Tcl_Interp *interp; /* Interpreter in which the package is + * to be made available. */ +{ + return Tcl_Eval(interp, "if 44 {open non_existent}"); +} diff --git a/tcl7.6/unix/dltest/pkgf.c b/tcl7.6/unix/dltest/pkgf.c new file mode 100644 index 0000000..d7c641a --- /dev/null +++ b/tcl7.6/unix/dltest/pkgf.c @@ -0,0 +1,49 @@ +/* + * pkgf.c -- + * + * This file contains a simple Tcl package "pkgf" that is intended + * for testing the Tcl dynamic loading facilities. Its Init + * procedure returns an error in order to test how this is handled. + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) pkgf.c 1.2 96/02/15 12:30:32 + */ +#include "tcl.h" + +/* + * Prototypes for procedures defined later in this file: + */ + +static int Pkgd_SubCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static int Pkgd_UnsafeCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +/* + *---------------------------------------------------------------------- + * + * Pkgf_Init -- + * + * This is a package initialization procedure, which is called + * by Tcl when this package is to be added to an interpreter. + * + * Results: + * Returns TCL_ERROR and leaves an error message in interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Pkgf_Init(interp) + Tcl_Interp *interp; /* Interpreter in which the package is + * to be made available. */ +{ + return Tcl_Eval(interp, "if 44 {open non_existent}"); +} diff --git a/tcl7.6/unix/install-sh b/tcl7.6/unix/install-sh new file mode 100755 index 0000000..0ff4b6a --- /dev/null +++ b/tcl7.6/unix/install-sh @@ -0,0 +1,119 @@ +#!/bin/sh + +# +# install - install a program, script, or datafile +# This comes from X11R5; it is not part of GNU. +# +# $XConsortium: install.sh,v 1.2 89/12/18 14:47:22 jim Exp $ +# +# This script is compatible with the BSD install script, but was written +# from scratch. +# + + +# set DOITPROG to echo to test this script + +# Don't use :- since 4.3BSD and earlier shells don't like it. +doit="${DOITPROG-}" + + +# put in absolute paths if you don't have them in your path; or use env. vars. + +mvprog="${MVPROG-mv}" +cpprog="${CPPROG-cp}" +chmodprog="${CHMODPROG-chmod}" +chownprog="${CHOWNPROG-chown}" +chgrpprog="${CHGRPPROG-chgrp}" +stripprog="${STRIPPROG-strip}" +rmprog="${RMPROG-rm}" + +instcmd="$mvprog" +chmodcmd="" +chowncmd="" +chgrpcmd="" +stripcmd="" +rmcmd="$rmprog -f" +mvcmd="$mvprog" +src="" +dst="" + +while [ x"$1" != x ]; do + case $1 in + -c) instcmd="$cpprog" + shift + continue;; + + -m) chmodcmd="$chmodprog $2" + shift + shift + continue;; + + -o) chowncmd="$chownprog $2" + shift + shift + continue;; + + -g) chgrpcmd="$chgrpprog $2" + shift + shift + continue;; + + -s) stripcmd="$stripprog" + shift + continue;; + + *) if [ x"$src" = x ] + then + src=$1 + else + dst=$1 + fi + shift + continue;; + esac +done + +if [ x"$src" = x ] +then + echo "install: no input file specified" + exit 1 +fi + +if [ x"$dst" = x ] +then + echo "install: no destination specified" + exit 1 +fi + + +# If destination is a directory, append the input filename; if your system +# does not like double slashes in filenames, you may need to add some logic + +if [ -d $dst ] +then + dst="$dst"/`basename $src` +fi + +# Make a temp file name in the proper directory. + +dstdir=`dirname $dst` +dsttmp=$dstdir/#inst.$$# + +# Move or copy the file name to the temp name + +$doit $instcmd $src $dsttmp + +# and set any options; do chmod last to preserve setuid bits + +if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; fi +if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; fi +if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; fi +if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; fi + +# Now rename the file to the real destination. + +$doit $rmcmd $dst +$doit $mvcmd $dsttmp $dst + + +exit 0 diff --git a/tcl7.6/unix/ldAix b/tcl7.6/unix/ldAix new file mode 100755 index 0000000..d7f0275 --- /dev/null +++ b/tcl7.6/unix/ldAix @@ -0,0 +1,72 @@ +#!/bin/sh +# +# ldAix ldCmd ldArg ldArg ... +# +# This shell script provides a wrapper for ld under AIX in order to +# create the .exp file required for linking. Its arguments consist +# of the name and arguments that would normally be provided to the +# ld command. This script extracts the names of the object files +# from the argument list, creates a .exp file describing all of the +# symbols exported by those files, and then invokes "ldCmd" to +# perform the real link. +# +# SCCS: @(#) ldAix 1.7 96/03/27 09:45:03 + +# Extract from the arguments the names of all of the object files. + +args=$* +ofiles="" +for i do + x=`echo $i | grep '[^.].o$'` + if test "$x" != ""; then + ofiles="$ofiles $i" + fi +done + +# Create the export file from all of the object files, using nm followed +# by sed editing. Here are some tricky aspects of this: +# +# 1. Nm produces different output under AIX 4.1 than under AIX 3.2.5; +# the following statements handle both versions. +# 2. Use the -g switch to nm instead of -e under 4.1 (this shows just +# externals, not statics; -g isn't available under 3.2.5, though). +# 3. Eliminate lines that end in ":": these are the names of object +# files (relevant in 4.1 only). +# 4. Eliminate entries with the "U" key letter; these are undefined +# symbols (relevant in 4.1 only). +# 5. Eliminate lines that contain the string "0|extern" preceded by space; +# in 3.2.5, these are undefined symbols (address 0). +# 6. Eliminate lines containing the "unamex" symbol. In 3.2.5, these +# are also undefined symbols. +# 7. If a line starts with ".", delete the leading ".", since this will +# just cause confusion later. +# 8. Eliminate everything after the first field in a line, so that we're +# left with just the symbol name. + +nmopts="-g" +osver=`uname -v` +if test $osver -eq 3; then + nmopts="-e" +fi +rm -f lib.exp +echo "#! " >lib.exp +/usr/ccs/bin/nm $nmopts -h $ofiles | sed -e '/:$/d' -e '/ U /d' -e '/[ ]0|extern/d' -e '/unamex/d' -e 's/^\.//' -e 's/[ |].*//' | sort | uniq >>lib.exp + +# Extract the name of the object file that we're linking. If it's a .a +# file, then link all the objects together into a single file "shr.o" +# and then put that into the archive. Otherwise link the object files +# directly into the .a file. + +outputFile=`echo $args | sed -e 's/.*-o \([^ ]*\).*/\1/'` +noDotA=`echo $outputFile | sed -e '/\.a$/d'` +echo "noDotA=\"$noDotA\"" +if test "$noDotA" = "" ; then + linkArgs=`echo $args | sed -e 's/-o .*\.a /-o shr.o /'` + echo $linkArgs + eval $linkArgs + echo ar cr $outputFile shr.o + ar cr $outputFile shr.o + rm -f shr.o +else + eval $args +fi diff --git a/tcl7.6/unix/mkLinks b/tcl7.6/unix/mkLinks new file mode 100755 index 0000000..7b036df --- /dev/null +++ b/tcl7.6/unix/mkLinks @@ -0,0 +1,738 @@ +#!/bin/sh +# This script is invoked when installing manual entries. It generates +# additional links to manual entries, corresponding to the procedure +# and command names described by the manual entry. For example, the +# Tcl manual entry Hash.3 describes procedures Tcl_InitHashTable, +# Tcl_CreateHashEntry, and many more. This script will make hard +# links so that Tcl_InitHashTable.3, Tcl_CreateHashEntry.3, and so +# on all refer to Hash.3 in the installed directory. +# +# Because of the length of command and procedure names, this mechanism +# only works on machines that support file names longer than 14 characters. +# This script checks to see if long file names are supported, and it +# doesn't make any links if they are not. +# +# The script takes one argument, which is the name of the directory +# where the manual entries have been installed. + +if test $# != 1; then + echo "Usage: mkLinks dir" + exit 1 +fi + +cd $1 +echo foo > xyzzyTestingAVeryLongFileName.foo +x=`echo xyzzyTe*` +rm xyzzyTe* +if test "$x" != "xyzzyTestingAVeryLongFileName.foo"; then + exit +fi +if test -r AddErrInfo.3; then + rm -f Tcl_AddErrorInfo.3 + ln AddErrInfo.3 Tcl_AddErrorInfo.3 +fi +if test -r Alloc.3; then + rm -f Tcl_Alloc.3 + ln Alloc.3 Tcl_Alloc.3 +fi +if test -r AllowExc.3; then + rm -f Tcl_AllowExceptions.3 + ln AllowExc.3 Tcl_AllowExceptions.3 +fi +if test -r AppInit.3; then + rm -f Tcl_AppInit.3 + ln AppInit.3 Tcl_AppInit.3 +fi +if test -r SetResult.3; then + rm -f Tcl_AppendElement.3 + ln SetResult.3 Tcl_AppendElement.3 +fi +if test -r SetResult.3; then + rm -f Tcl_AppendResult.3 + ln SetResult.3 Tcl_AppendResult.3 +fi +if test -r Async.3; then + rm -f Tcl_AsyncCreate.3 + ln Async.3 Tcl_AsyncCreate.3 +fi +if test -r Async.3; then + rm -f Tcl_AsyncDelete.3 + ln Async.3 Tcl_AsyncDelete.3 +fi +if test -r Async.3; then + rm -f Tcl_AsyncInvoke.3 + ln Async.3 Tcl_AsyncInvoke.3 +fi +if test -r Async.3; then + rm -f Tcl_AsyncMark.3 + ln Async.3 Tcl_AsyncMark.3 +fi +if test -r BackgdErr.3; then + rm -f Tcl_BackgroundError.3 + ln BackgdErr.3 Tcl_BackgroundError.3 +fi +if test -r Backslash.3; then + rm -f Tcl_Backslash.3 + ln Backslash.3 Tcl_Backslash.3 +fi +if test -r CallDel.3; then + rm -f Tcl_CallWhenDeleted.3 + ln CallDel.3 Tcl_CallWhenDeleted.3 +fi +if test -r DoWhenIdle.3; then + rm -f Tcl_CancelIdleCall.3 + ln DoWhenIdle.3 Tcl_CancelIdleCall.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_Close.3 + ln OpenFileChnl.3 Tcl_Close.3 +fi +if test -r CmdCmplt.3; then + rm -f Tcl_CommandComplete.3 + ln CmdCmplt.3 Tcl_CommandComplete.3 +fi +if test -r Concat.3; then + rm -f Tcl_Concat.3 + ln Concat.3 Tcl_Concat.3 +fi +if test -r SplitList.3; then + rm -f Tcl_ConvertElement.3 + ln SplitList.3 Tcl_ConvertElement.3 +fi +if test -r CrtSlave.3; then + rm -f Tcl_CreateAlias.3 + ln CrtSlave.3 Tcl_CreateAlias.3 +fi +if test -r CrtChannel.3; then + rm -f Tcl_CreateChannel.3 + ln CrtChannel.3 Tcl_CreateChannel.3 +fi +if test -r CrtChnlHdlr.3; then + rm -f Tcl_CreateChannelHandler.3 + ln CrtChnlHdlr.3 Tcl_CreateChannelHandler.3 +fi +if test -r CrtCloseHdlr.3; then + rm -f Tcl_CreateCloseHandler.3 + ln CrtCloseHdlr.3 Tcl_CreateCloseHandler.3 +fi +if test -r CrtCommand.3; then + rm -f Tcl_CreateCommand.3 + ln CrtCommand.3 Tcl_CreateCommand.3 +fi +if test -r Notifier.3; then + rm -f Tcl_CreateEventSource.3 + ln Notifier.3 Tcl_CreateEventSource.3 +fi +if test -r Exit.3; then + rm -f Tcl_CreateExitHandler.3 + ln Exit.3 Tcl_CreateExitHandler.3 +fi +if test -r CrtFileHdlr.3; then + rm -f Tcl_CreateFileHandler.3 + ln CrtFileHdlr.3 Tcl_CreateFileHandler.3 +fi +if test -r Hash.3; then + rm -f Tcl_CreateHashEntry.3 + ln Hash.3 Tcl_CreateHashEntry.3 +fi +if test -r CrtInterp.3; then + rm -f Tcl_CreateInterp.3 + ln CrtInterp.3 Tcl_CreateInterp.3 +fi +if test -r CrtMathFnc.3; then + rm -f Tcl_CreateMathFunc.3 + ln CrtMathFnc.3 Tcl_CreateMathFunc.3 +fi +if test -r CrtModalTmt.3; then + rm -f Tcl_CreateModalTimeout.3 + ln CrtModalTmt.3 Tcl_CreateModalTimeout.3 +fi +if test -r CrtSlave.3; then + rm -f Tcl_CreateSlave.3 + ln CrtSlave.3 Tcl_CreateSlave.3 +fi +if test -r CrtTimerHdlr.3; then + rm -f Tcl_CreateTimerHandler.3 + ln CrtTimerHdlr.3 Tcl_CreateTimerHandler.3 +fi +if test -r CrtTrace.3; then + rm -f Tcl_CreateTrace.3 + ln CrtTrace.3 Tcl_CreateTrace.3 +fi +if test -r DString.3; then + rm -f Tcl_DStringAppend.3 + ln DString.3 Tcl_DStringAppend.3 +fi +if test -r DString.3; then + rm -f Tcl_DStringAppendElement.3 + ln DString.3 Tcl_DStringAppendElement.3 +fi +if test -r DString.3; then + rm -f Tcl_DStringEndSublist.3 + ln DString.3 Tcl_DStringEndSublist.3 +fi +if test -r DString.3; then + rm -f Tcl_DStringFree.3 + ln DString.3 Tcl_DStringFree.3 +fi +if test -r DString.3; then + rm -f Tcl_DStringGetResult.3 + ln DString.3 Tcl_DStringGetResult.3 +fi +if test -r DString.3; then + rm -f Tcl_DStringInit.3 + ln DString.3 Tcl_DStringInit.3 +fi +if test -r DString.3; then + rm -f Tcl_DStringLength.3 + ln DString.3 Tcl_DStringLength.3 +fi +if test -r DString.3; then + rm -f Tcl_DStringResult.3 + ln DString.3 Tcl_DStringResult.3 +fi +if test -r DString.3; then + rm -f Tcl_DStringSetLength.3 + ln DString.3 Tcl_DStringSetLength.3 +fi +if test -r DString.3; then + rm -f Tcl_DStringStartSublist.3 + ln DString.3 Tcl_DStringStartSublist.3 +fi +if test -r DString.3; then + rm -f Tcl_DStringValue.3 + ln DString.3 Tcl_DStringValue.3 +fi +if test -r AssocData.3; then + rm -f Tcl_DeleteAssocData.3 + ln AssocData.3 Tcl_DeleteAssocData.3 +fi +if test -r CrtChnlHdlr.3; then + rm -f Tcl_DeleteChannelHandler.3 + ln CrtChnlHdlr.3 Tcl_DeleteChannelHandler.3 +fi +if test -r CrtCloseHdlr.3; then + rm -f Tcl_DeleteCloseHandler.3 + ln CrtCloseHdlr.3 Tcl_DeleteCloseHandler.3 +fi +if test -r CrtCommand.3; then + rm -f Tcl_DeleteCommand.3 + ln CrtCommand.3 Tcl_DeleteCommand.3 +fi +if test -r Notifier.3; then + rm -f Tcl_DeleteEventSource.3 + ln Notifier.3 Tcl_DeleteEventSource.3 +fi +if test -r Exit.3; then + rm -f Tcl_DeleteExitHandler.3 + ln Exit.3 Tcl_DeleteExitHandler.3 +fi +if test -r CrtFileHdlr.3; then + rm -f Tcl_DeleteFileHandler.3 + ln CrtFileHdlr.3 Tcl_DeleteFileHandler.3 +fi +if test -r Hash.3; then + rm -f Tcl_DeleteHashEntry.3 + ln Hash.3 Tcl_DeleteHashEntry.3 +fi +if test -r Hash.3; then + rm -f Tcl_DeleteHashTable.3 + ln Hash.3 Tcl_DeleteHashTable.3 +fi +if test -r CrtInterp.3; then + rm -f Tcl_DeleteInterp.3 + ln CrtInterp.3 Tcl_DeleteInterp.3 +fi +if test -r CrtModalTmt.3; then + rm -f Tcl_DeleteModalTimeout.3 + ln CrtModalTmt.3 Tcl_DeleteModalTimeout.3 +fi +if test -r CrtTimerHdlr.3; then + rm -f Tcl_DeleteTimerHandler.3 + ln CrtTimerHdlr.3 Tcl_DeleteTimerHandler.3 +fi +if test -r CrtTrace.3; then + rm -f Tcl_DeleteTrace.3 + ln CrtTrace.3 Tcl_DeleteTrace.3 +fi +if test -r DetachPids.3; then + rm -f Tcl_DetachPids.3 + ln DetachPids.3 Tcl_DetachPids.3 +fi +if test -r DoOneEvent.3; then + rm -f Tcl_DoOneEvent.3 + ln DoOneEvent.3 Tcl_DoOneEvent.3 +fi +if test -r DoWhenIdle.3; then + rm -f Tcl_DoWhenIdle.3 + ln DoWhenIdle.3 Tcl_DoWhenIdle.3 +fi +if test -r CallDel.3; then + rm -f Tcl_DontCallWhenDeleted.3 + ln CallDel.3 Tcl_DontCallWhenDeleted.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_Eof.3 + ln OpenFileChnl.3 Tcl_Eof.3 +fi +if test -r Eval.3; then + rm -f Tcl_Eval.3 + ln Eval.3 Tcl_Eval.3 +fi +if test -r Eval.3; then + rm -f Tcl_EvalFile.3 + ln Eval.3 Tcl_EvalFile.3 +fi +if test -r Preserve.3; then + rm -f Tcl_EventuallyFree.3 + ln Preserve.3 Tcl_EventuallyFree.3 +fi +if test -r Exit.3; then + rm -f Tcl_Exit.3 + ln Exit.3 Tcl_Exit.3 +fi +if test -r ExprLong.3; then + rm -f Tcl_ExprBoolean.3 + ln ExprLong.3 Tcl_ExprBoolean.3 +fi +if test -r ExprLong.3; then + rm -f Tcl_ExprDouble.3 + ln ExprLong.3 Tcl_ExprDouble.3 +fi +if test -r ExprLong.3; then + rm -f Tcl_ExprLong.3 + ln ExprLong.3 Tcl_ExprLong.3 +fi +if test -r ExprLong.3; then + rm -f Tcl_ExprString.3 + ln ExprLong.3 Tcl_ExprString.3 +fi +if test -r Notifier.3; then + rm -f Tcl_FileReady.3 + ln Notifier.3 Tcl_FileReady.3 +fi +if test -r FindExec.3; then + rm -f Tcl_FindExecutable.3 + ln FindExec.3 Tcl_FindExecutable.3 +fi +if test -r Hash.3; then + rm -f Tcl_FindHashEntry.3 + ln Hash.3 Tcl_FindHashEntry.3 +fi +if test -r Hash.3; then + rm -f Tcl_FirstHashEntry.3 + ln Hash.3 Tcl_FirstHashEntry.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_Flush.3 + ln OpenFileChnl.3 Tcl_Flush.3 +fi +if test -r Alloc.3; then + rm -f Tcl_Free.3 + ln Alloc.3 Tcl_Free.3 +fi +if test -r GetFile.3; then + rm -f Tcl_FreeFile.3 + ln GetFile.3 Tcl_FreeFile.3 +fi +if test -r CrtSlave.3; then + rm -f Tcl_GetAlias.3 + ln CrtSlave.3 Tcl_GetAlias.3 +fi +if test -r CrtSlave.3; then + rm -f Tcl_GetAliases.3 + ln CrtSlave.3 Tcl_GetAliases.3 +fi +if test -r AssocData.3; then + rm -f Tcl_GetAssocData.3 + ln AssocData.3 Tcl_GetAssocData.3 +fi +if test -r GetInt.3; then + rm -f Tcl_GetBoolean.3 + ln GetInt.3 Tcl_GetBoolean.3 +fi +if test -r CrtChannel.3; then + rm -f Tcl_GetChannelBufferSize.3 + ln CrtChannel.3 Tcl_GetChannelBufferSize.3 +fi +if test -r CrtChannel.3; then + rm -f Tcl_GetChannelFile.3 + ln CrtChannel.3 Tcl_GetChannelFile.3 +fi +if test -r CrtChannel.3; then + rm -f Tcl_GetChannelInstanceData.3 + ln CrtChannel.3 Tcl_GetChannelInstanceData.3 +fi +if test -r CrtChannel.3; then + rm -f Tcl_GetChannelMode.3 + ln CrtChannel.3 Tcl_GetChannelMode.3 +fi +if test -r CrtChannel.3; then + rm -f Tcl_GetChannelName.3 + ln CrtChannel.3 Tcl_GetChannelName.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_GetChannelOption.3 + ln OpenFileChnl.3 Tcl_GetChannelOption.3 +fi +if test -r CrtChannel.3; then + rm -f Tcl_GetChannelType.3 + ln CrtChannel.3 Tcl_GetChannelType.3 +fi +if test -r CrtCommand.3; then + rm -f Tcl_GetCommandInfo.3 + ln CrtCommand.3 Tcl_GetCommandInfo.3 +fi +if test -r GetInt.3; then + rm -f Tcl_GetDouble.3 + ln GetInt.3 Tcl_GetDouble.3 +fi +if test -r SetErrno.3; then + rm -f Tcl_GetErrno.3 + ln SetErrno.3 Tcl_GetErrno.3 +fi +if test -r GetFile.3; then + rm -f Tcl_GetFile.3 + ln GetFile.3 Tcl_GetFile.3 +fi +if test -r GetFile.3; then + rm -f Tcl_GetFileInfo.3 + ln GetFile.3 Tcl_GetFileInfo.3 +fi +if test -r Hash.3; then + rm -f Tcl_GetHashKey.3 + ln Hash.3 Tcl_GetHashKey.3 +fi +if test -r Hash.3; then + rm -f Tcl_GetHashValue.3 + ln Hash.3 Tcl_GetHashValue.3 +fi +if test -r GetInt.3; then + rm -f Tcl_GetInt.3 + ln GetInt.3 Tcl_GetInt.3 +fi +if test -r CrtSlave.3; then + rm -f Tcl_GetMaster.3 + ln CrtSlave.3 Tcl_GetMaster.3 +fi +if test -r GetOpnFl.3; then + rm -f Tcl_GetOpenFile.3 + ln GetOpnFl.3 Tcl_GetOpenFile.3 +fi +if test -r SplitPath.3; then + rm -f Tcl_GetPathType.3 + ln SplitPath.3 Tcl_GetPathType.3 +fi +if test -r CrtSlave.3; then + rm -f Tcl_GetSlave.3 + ln CrtSlave.3 Tcl_GetSlave.3 +fi +if test -r CrtSlave.3; then + rm -f Tcl_GetSlaves.3 + ln CrtSlave.3 Tcl_GetSlaves.3 +fi +if test -r GetStdChan.3; then + rm -f Tcl_GetStdChannel.3 + ln GetStdChan.3 Tcl_GetStdChannel.3 +fi +if test -r SetVar.3; then + rm -f Tcl_GetVar.3 + ln SetVar.3 Tcl_GetVar.3 +fi +if test -r SetVar.3; then + rm -f Tcl_GetVar2.3 + ln SetVar.3 Tcl_GetVar2.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_Gets.3 + ln OpenFileChnl.3 Tcl_Gets.3 +fi +if test -r Eval.3; then + rm -f Tcl_GlobalEval.3 + ln Eval.3 Tcl_GlobalEval.3 +fi +if test -r Hash.3; then + rm -f Tcl_HashStats.3 + ln Hash.3 Tcl_HashStats.3 +fi +if test -r Hash.3; then + rm -f Tcl_InitHashTable.3 + ln Hash.3 Tcl_InitHashTable.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_InputBlocked.3 + ln OpenFileChnl.3 Tcl_InputBlocked.3 +fi +if test -r Interp.3; then + rm -f Tcl_Interp.3 + ln Interp.3 Tcl_Interp.3 +fi +if test -r CrtInterp.3; then + rm -f Tcl_InterpDeleted.3 + ln CrtInterp.3 Tcl_InterpDeleted.3 +fi +if test -r CrtSlave.3; then + rm -f Tcl_IsSafe.3 + ln CrtSlave.3 Tcl_IsSafe.3 +fi +if test -r SplitPath.3; then + rm -f Tcl_JoinPath.3 + ln SplitPath.3 Tcl_JoinPath.3 +fi +if test -r LinkVar.3; then + rm -f Tcl_LinkVar.3 + ln LinkVar.3 Tcl_LinkVar.3 +fi +if test -r CrtSlave.3; then + rm -f Tcl_MakeSafe.3 + ln CrtSlave.3 Tcl_MakeSafe.3 +fi +if test -r SplitList.3; then + rm -f Tcl_Merge.3 + ln SplitList.3 Tcl_Merge.3 +fi +if test -r Hash.3; then + rm -f Tcl_NextHashEntry.3 + ln Hash.3 Tcl_NextHashEntry.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_OpenCommandChannel.3 + ln OpenFileChnl.3 Tcl_OpenCommandChannel.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_OpenFileChannel.3 + ln OpenFileChnl.3 Tcl_OpenFileChannel.3 +fi +if test -r OpenTcp.3; then + rm -f Tcl_OpenTcpClient.3 + ln OpenTcp.3 Tcl_OpenTcpClient.3 +fi +if test -r OpenTcp.3; then + rm -f Tcl_OpenTcpServer.3 + ln OpenTcp.3 Tcl_OpenTcpServer.3 +fi +if test -r PkgRequire.3; then + rm -f Tcl_PkgProvide.3 + ln PkgRequire.3 Tcl_PkgProvide.3 +fi +if test -r PkgRequire.3; then + rm -f Tcl_PkgRequire.3 + ln PkgRequire.3 Tcl_PkgRequire.3 +fi +if test -r AddErrInfo.3; then + rm -f Tcl_PosixError.3 + ln AddErrInfo.3 Tcl_PosixError.3 +fi +if test -r Preserve.3; then + rm -f Tcl_Preserve.3 + ln Preserve.3 Tcl_Preserve.3 +fi +if test -r PrintDbl.3; then + rm -f Tcl_PrintDouble.3 + ln PrintDbl.3 Tcl_PrintDouble.3 +fi +if test -r Notifier.3; then + rm -f Tcl_QueueEvent.3 + ln Notifier.3 Tcl_QueueEvent.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_Read.3 + ln OpenFileChnl.3 Tcl_Read.3 +fi +if test -r Alloc.3; then + rm -f Tcl_Realloc.3 + ln Alloc.3 Tcl_Realloc.3 +fi +if test -r DetachPids.3; then + rm -f Tcl_ReapDetachedProcs.3 + ln DetachPids.3 Tcl_ReapDetachedProcs.3 +fi +if test -r RecordEval.3; then + rm -f Tcl_RecordAndEval.3 + ln RecordEval.3 Tcl_RecordAndEval.3 +fi +if test -r RegExp.3; then + rm -f Tcl_RegExpCompile.3 + ln RegExp.3 Tcl_RegExpCompile.3 +fi +if test -r RegExp.3; then + rm -f Tcl_RegExpExec.3 + ln RegExp.3 Tcl_RegExpExec.3 +fi +if test -r RegExp.3; then + rm -f Tcl_RegExpMatch.3 + ln RegExp.3 Tcl_RegExpMatch.3 +fi +if test -r RegExp.3; then + rm -f Tcl_RegExpRange.3 + ln RegExp.3 Tcl_RegExpRange.3 +fi +if test -r Preserve.3; then + rm -f Tcl_Release.3 + ln Preserve.3 Tcl_Release.3 +fi +if test -r SetResult.3; then + rm -f Tcl_ResetResult.3 + ln SetResult.3 Tcl_ResetResult.3 +fi +if test -r SplitList.3; then + rm -f Tcl_ScanElement.3 + ln SplitList.3 Tcl_ScanElement.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_Seek.3 + ln OpenFileChnl.3 Tcl_Seek.3 +fi +if test -r AssocData.3; then + rm -f Tcl_SetAssocData.3 + ln AssocData.3 Tcl_SetAssocData.3 +fi +if test -r CrtChannel.3; then + rm -f Tcl_SetChannelBufferSize.3 + ln CrtChannel.3 Tcl_SetChannelBufferSize.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_SetChannelOption.3 + ln OpenFileChnl.3 Tcl_SetChannelOption.3 +fi +if test -r CrtCommand.3; then + rm -f Tcl_SetCommandInfo.3 + ln CrtCommand.3 Tcl_SetCommandInfo.3 +fi +if test -r CrtChannel.3; then + rm -f Tcl_SetDefaultTranslation.3 + ln CrtChannel.3 Tcl_SetDefaultTranslation.3 +fi +if test -r SetErrno.3; then + rm -f Tcl_SetErrno.3 + ln SetErrno.3 Tcl_SetErrno.3 +fi +if test -r AddErrInfo.3; then + rm -f Tcl_SetErrorCode.3 + ln AddErrInfo.3 Tcl_SetErrorCode.3 +fi +if test -r Hash.3; then + rm -f Tcl_SetHashValue.3 + ln Hash.3 Tcl_SetHashValue.3 +fi +if test -r Notifier.3; then + rm -f Tcl_SetMaxBlockTime.3 + ln Notifier.3 Tcl_SetMaxBlockTime.3 +fi +if test -r SetRecLmt.3; then + rm -f Tcl_SetRecursionLimit.3 + ln SetRecLmt.3 Tcl_SetRecursionLimit.3 +fi +if test -r SetResult.3; then + rm -f Tcl_SetResult.3 + ln SetResult.3 Tcl_SetResult.3 +fi +if test -r GetStdChan.3; then + rm -f Tcl_SetStdChannel.3 + ln GetStdChan.3 Tcl_SetStdChannel.3 +fi +if test -r SetVar.3; then + rm -f Tcl_SetVar.3 + ln SetVar.3 Tcl_SetVar.3 +fi +if test -r SetVar.3; then + rm -f Tcl_SetVar2.3 + ln SetVar.3 Tcl_SetVar2.3 +fi +if test -r Sleep.3; then + rm -f Tcl_Sleep.3 + ln Sleep.3 Tcl_Sleep.3 +fi +if test -r SplitList.3; then + rm -f Tcl_SplitList.3 + ln SplitList.3 Tcl_SplitList.3 +fi +if test -r SplitPath.3; then + rm -f Tcl_SplitPath.3 + ln SplitPath.3 Tcl_SplitPath.3 +fi +if test -r StaticPkg.3; then + rm -f Tcl_StaticPackage.3 + ln StaticPkg.3 Tcl_StaticPackage.3 +fi +if test -r StrMatch.3; then + rm -f Tcl_StringMatch.3 + ln StrMatch.3 Tcl_StringMatch.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_Tell.3 + ln OpenFileChnl.3 Tcl_Tell.3 +fi +if test -r TraceVar.3; then + rm -f Tcl_TraceVar.3 + ln TraceVar.3 Tcl_TraceVar.3 +fi +if test -r TraceVar.3; then + rm -f Tcl_TraceVar2.3 + ln TraceVar.3 Tcl_TraceVar2.3 +fi +if test -r Translate.3; then + rm -f Tcl_TranslateFileName.3 + ln Translate.3 Tcl_TranslateFileName.3 +fi +if test -r LinkVar.3; then + rm -f Tcl_UnlinkVar.3 + ln LinkVar.3 Tcl_UnlinkVar.3 +fi +if test -r SetVar.3; then + rm -f Tcl_UnsetVar.3 + ln SetVar.3 Tcl_UnsetVar.3 +fi +if test -r SetVar.3; then + rm -f Tcl_UnsetVar2.3 + ln SetVar.3 Tcl_UnsetVar2.3 +fi +if test -r TraceVar.3; then + rm -f Tcl_UntraceVar.3 + ln TraceVar.3 Tcl_UntraceVar.3 +fi +if test -r TraceVar.3; then + rm -f Tcl_UntraceVar2.3 + ln TraceVar.3 Tcl_UntraceVar2.3 +fi +if test -r UpVar.3; then + rm -f Tcl_UpVar.3 + ln UpVar.3 Tcl_UpVar.3 +fi +if test -r UpVar.3; then + rm -f Tcl_UpVar2.3 + ln UpVar.3 Tcl_UpVar2.3 +fi +if test -r LinkVar.3; then + rm -f Tcl_UpdateLinkedVar.3 + ln LinkVar.3 Tcl_UpdateLinkedVar.3 +fi +if test -r Eval.3; then + rm -f Tcl_VarEval.3 + ln Eval.3 Tcl_VarEval.3 +fi +if test -r TraceVar.3; then + rm -f Tcl_VarTraceInfo.3 + ln TraceVar.3 Tcl_VarTraceInfo.3 +fi +if test -r TraceVar.3; then + rm -f Tcl_VarTraceInfo2.3 + ln TraceVar.3 Tcl_VarTraceInfo2.3 +fi +if test -r Notifier.3; then + rm -f Tcl_WaitForEvent.3 + ln Notifier.3 Tcl_WaitForEvent.3 +fi +if test -r Notifier.3; then + rm -f Tcl_WatchFile.3 + ln Notifier.3 Tcl_WatchFile.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_Write.3 + ln OpenFileChnl.3 Tcl_Write.3 +fi +if test -r pkgMkIndex.n; then + rm -f pkg_mkIndex.n + ln pkgMkIndex.n pkg_mkIndex.n +fi +exit 0 diff --git a/tcl7.6/unix/porting.notes b/tcl7.6/unix/porting.notes new file mode 100644 index 0000000..e018b9d --- /dev/null +++ b/tcl7.6/unix/porting.notes @@ -0,0 +1,392 @@ +This file contains a collection of notes that various people have +provided about porting Tcl to various machines and operating systems. +I don't have personal access to any of these machines, so I make +no guarantees that the notes are correct, complete, or up-to-date. +If you see the word "I" in any explanations, it refers to the person +who contributed the information, not to me; this means that I +probably can't answer any questions about any of this stuff. In +some cases, a person has volunteered to act as a contact point for +questions about porting Tcl to a particular machine; in these +cases the person's name and e-mail address are listed. I'm +interested in getting new porting information to add to the file; +please mail updates to "john.ousterhout@eng.sun.com". + +This file reflects information provided for Tcl 7.4 and later releases. +If there is no information for your configuration in this file, check +the file "porting.old" too; it contains information that was +submitted for Tcl 7.3 and earlier releases, and some of that information +may still be valid. + +A new porting database has recently become available on the Web at +the following URL: + http://www.sunlabs.com/cgi-bin/tcl/info.4.0 +This page provides information about the platforms on which Tcl 7.4 +and Tk 4.0 have been compiled and what changes were needed to get Tcl +and Tk to compile. You can also add new entries to that database +when you install Tcl and Tk on a new platform. The Web database is +likely to be more up-to-date than this file. + +sccsid = SCCS: @(#) porting.notes 1.17 96/05/18 16:49:24 + +-------------------------------------------- +Solaris, various versions +-------------------------------------------- + +1. If typing "make test" results in an error message saying that +there are no "*.test" files, or you get lots of globbing errors, +it's probably because your system doesn't have cc installed and +you used gcc. In order for this to work, you have to set your +CC environment variable to gcc and your CPP environment variable +to "gcc -E" before running the configure script. + +2. Make sure that /usr/ucb is not in your PATH or LD_LIBRARY_PATH +environment variables; this will cause confusion between the new +Solaris libraries and older UCB versions (Tcl will expect one version +and get another). + +3. There have been several reports of problems with the "glob" command. +So far these reports have all been for older versions of Tcl, but +if you run into problems, edit the Makefile after "configure" is +run and add "-DNO_DIRENT_H=1" to the definitions of DEFS. Do this +before compiling. + +-------------------------------------------- +Pyramid DC/OSx SVr4, DC/OSx version 94c079 +-------------------------------------------- + +Tcl seems to dump core in cmdinfo.test when compiled with the +optimiser turned on in TclEval which calls 'free'. To get around +this, turn the optimiser off. + +-------------------------------------------- +SGI machines, IRIX 5.2, 5.3, IRIX64 6.0.1 +-------------------------------------------- + +1. If you compile with gcc-2.6.3 under some versions of IRIX (e.g. + 4.0.5), DBL_MAX is defined too large for gcc and Tcl complains + about all floating-point values being too large to represent. + If this happens, redefining DBL_MAX to 9.99e299. + +2. Add "-D_BSD_TIME" to CFLAGS in Makefile. This avoids type conflicts +in the prototype for the gettimeofday procedure. + +2. If you're running under Irix 6.x and tclsh dumps core, try +removing -O from the CFLAGS in Makefile and recompiling; compiler +optimizations seem to cause problems on some machines. + +-------------------------------------------- +IBM RTs, AOS +-------------------------------------------- + +1. Steal fmod from 4.4BSD +2. Add a #define to tclExpr such that: +extern double fmod(); +is defined conditionally on ibm032 + +-------------------------------------------- +QNX 4.22 +-------------------------------------------- + +tclPort.h + - commented out 2 lines containing #include + +tcl.h + - changed #define VARARGS () + - to #ifndef __QNX__ + #define VARARGS () + #else + #define VARARGS (void *, ...) + #endif + +-------------------------------------------- +Interactive UNIX +-------------------------------------------- + +Add the switch -Xp to LIBS in Makefile; otherwise strftime will not +be found when linking. + +-------------------------------------------- +Motorola SVR4 V4.2 (m88k) +-------------------------------------------- + +For Motorola Unix R40V4.2 (m88k architechure), use /usr/ucb/cc instead of +/usr/bin/cc. Otherwise, the compile will fail because of conflicts over +the gettimeofday() call. + +Also, -DNO_DIRENT_H=1 is required for the "glob" command to work. + +-------------------------------------------- +NeXTSTEP 3.x +-------------------------------------------- + +Here's the set of changes I made to make 7.5b3 compile cleanly on +NeXTSTEP3.x. + +Here are a couple lines from unix/Makefile: + +# Added utsname.o, which implements a uname() emulation for NeXTSTEP. +COMPAT_OBJS = getcwd.o strtod.o tmpnam.o utsname.o + +TCL_NAMES=\ + -Dstrtod=tcl_strtod -Dtmpnam=tcl_tmpnam -Dgetcwd=tcl_getcwd \ + -Dpanic=tcl_panic -Dmatherr=tcl_matherr \ + -Duname=tcl_uname -Dutsname=tcl_utsname + +# Added mode_t, pid_t, and O_NONBLOCK definitions. +AC_FLAGS = -DNO_DIRENT_H=1 -DHAVE_UNISTD_H=1 -DHAVE_SYS_TIME_H=1 +-DTIME_WITH_SYS_TIME=1 -DHAVE_TM_ZONE=1 -DHAVE_TM_GMTOFF=1 -DHAVE_TIMEZONE_VAR=1 +-DSTDC_HEADERS=1 -Dmode_t=int -Dpid_t=int -DO_NONBLOCK=O_NDELAY ${TCL_NAMES} + + +Here are diffs for other files. utsname.[hc] are a couple files I added +to compat/ I'm not clear whether that's where they legitimately belong +- I considered stashing them in tclLoadNext.c instead. The tclIO.c +change was a bug, I believe, which I reported on comp.lang.tcl and +has apparently been noted and fixed. The objc_loadModules() change +allows "load" to load object code containing Objective-C code in +addition to plain C code. + +--- +scott hess (WWW to "http://www.winternet.com/~shess/") +Work: 12550 Portland Avenue South #121, Burnsville, MN 55337 (612)895-1208 + + +diff -rc tcl7.5b3.orig/compat/utsname.c tcl7.5b3/compat/utsname.c +*** tcl7.5b3.orig/compat/utsname.c Tue Apr 2 13:57:23 1996 +--- tcl7.5b3/compat/utsname.c Mon Mar 18 11:05:54 1996 +*************** +*** 0 **** +--- 1,27 ---- ++ /* ++ * utsname.c -- ++ * ++ * This file is an emulation of the POSIX uname() function ++ * under NeXTSTEP 3.x. ++ * ++ */ ++ + ++ #include "utsname.h" ++ #include ++ #include ++ + ++ int uname( struct utsname *name) ++ { ++ const NXArchInfo *arch; ++ if( gethostname( name->nodename, sizeof( name->nodename))==-1) { ++ return -1; ++ } ++ if( (arch=NXGetLocalArchInfo())==NULL) { ++ return -1; ++ } ++ strncpy( name->machine, arch->description, sizeof( name->machine)); ++ strcpy( name->sysname, "NEXTSTEP"); ++ strcpy( name->release, "0"); ++ strcpy( name->version, "3"); ++ return 0; ++ } +diff -rc tcl7.5b3.orig/compat/utsname.h tcl7.5b3/compat/utsname.h +*** tcl7.5b3.orig/compat/utsname.h Tue Apr 2 13:57:26 1996 +--- tcl7.5b3/compat/utsname.h Mon Mar 18 10:34:05 1996 +*************** +*** 0 **** +--- 1,22 ---- ++ /* ++ * utsname.h -- ++ * ++ * This file is an emulation of the POSIX uname() function ++ * under NeXTSTEP. ++ * ++ */ ++ + ++ #ifndef _UTSNAME ++ #define _UTSNAME ++ + ++ struct utsname { ++ char sysname[ 32]; ++ char nodename[ 32]; ++ char release[ 32]; ++ char version[ 32]; ++ char machine[ 32]; ++ }; ++ + ++ extern int uname( struct utsname *name); ++ + ++ #endif /* _UTSNAME */ +diff -rc tcl7.5b3.orig/generic/tclIO.c tcl7.5b3/generic/tclIO.c +*** tcl7.5b3.orig/generic/tclIO.c Fri Mar 8 12:59:53 1996 +--- tcl7.5b3/generic/tclIO.c Mon Mar 18 11:38:57 1996 +*************** +*** 2542,2548 **** + } + result = GetInput(chanPtr); + if (result != 0) { +! if (result == EWOULDBLOCK) { + chanPtr->flags |= CHANNEL_BLOCKED; + return copied; + } +--- 2542,2548 ---- + } + result = GetInput(chanPtr); + if (result != 0) { +! if (result == EAGAIN) { + chanPtr->flags |= CHANNEL_BLOCKED; + return copied; + } +diff -rc tcl7.5b3.orig/unix/tclLoadNext.c tcl7.5b3/unix/tclLoadNext.c +*** tcl7.5b3.orig/unix/tclLoadNext.c Sat Feb 17 16:16:42 1996 +--- tcl7.5b3/unix/tclLoadNext.c Mon Mar 18 10:02:36 1996 +*************** +*** 55,61 **** + char *files[]={fileName,NULL}; + NXStream *errorStream=NXOpenMemory(0,0,NX_READWRITE); + + +! if(!rld_load(errorStream,&header,files,NULL)) { + NXGetMemoryBuffer(errorStream,&data,&len,&maxlen); + Tcl_AppendResult(interp,"couldn't load file \"",fileName,"\": ",data,NULL); + NXCloseMemory(errorStream,NX_FREEBUFFER); +--- 55,61 ---- + char *files[]={fileName,NULL}; + NXStream *errorStream=NXOpenMemory(0,0,NX_READWRITE); + + +! if(objc_loadModules(files,errorStream,NULL,&header,NULL)) { + NXGetMemoryBuffer(errorStream,&data,&len,&maxlen); + Tcl_AppendResult(interp,"couldn't load file \"",fileName,"\": ",data,NULL); + NXCloseMemory(errorStream,NX_FREEBUFFER); +diff -rc tcl7.5b3.orig/unix/tclUnixFile.c tcl7.5b3/unix/tclUnixFile.c +*** tcl7.5b3.orig/unix/tclUnixFile.c Thu Mar 7 18:16:34 1996 +--- tcl7.5b3/unix/tclUnixFile.c Mon Mar 18 11:10:03 1996 +*************** +*** 31,37 **** +--- 31,41 ---- + + + static int executableNameExitHandlerSet = 0; + + ++ #if NeXT ++ #define waitpid( p, s, o) wait4( p, s, o, NULL) ++ #else + extern pid_t waitpid _ANSI_ARGS_((pid_t pid, int *stat_loc, int options)); ++ #endif + + + /* + * Static routines for this file: +diff -rc tcl7.5b3.orig/unix/tclUnixInit.c tcl7.5b3/unix/tclUnixInit.c +*** tcl7.5b3.orig/unix/tclUnixInit.c Sat Feb 17 16:16:39 1996 +--- tcl7.5b3/unix/tclUnixInit.c Mon Mar 18 11:50:28 1996 +*************** +*** 14,20 **** + #include "tclInt.h" + #include "tclPort.h" + #ifndef NO_UNAME +! # include + #endif + #if defined(__FreeBSD__) + #include +--- 14,24 ---- + #include "tclInt.h" + #include "tclPort.h" + #ifndef NO_UNAME +! # if NeXT +! # include "../compat/utsname.h" +! # else +! # include +! # endif + #endif + #if defined(__FreeBSD__) + #include +diff -rc tcl7.5b3.orig/unix/tclUnixPort.h tcl7.5b3/unix/tclUnixPort.h +*** tcl7.5b3.orig/unix/tclUnixPort.h Thu Mar 7 18:16:31 1996 +--- tcl7.5b3/unix/tclUnixPort.h Mon Mar 18 11:53:14 1996 +*************** +*** 76,82 **** + */ + + + #include /* struct sockaddr, SOCK_STREAM, ... */ +! #include /* uname system call. */ + #include /* struct in_addr, struct sockaddr_in */ + #include /* inet_ntoa() */ + #include /* gethostbyname() */ +--- 76,88 ---- + */ + + + #include /* struct sockaddr, SOCK_STREAM, ... */ +! #ifndef NO_UNAME +! # if NeXT +! # include "../compat/utsname.h" +! # else +! # include /* uname system call. */ +! # endif +! #endif + #include /* struct in_addr, struct sockaddr_in */ + #include /* inet_ntoa() */ + #include /* gethostbyname() */ + +-------------------------------------------- +SCO Unix 3.2.4 (ODT 3.0) +-------------------------------------------- + +The macro va_start in /usr/include/stdarg.h is incorrectly terminated by +a semi-colon. This causes compile of generic/tclBasic.c to fail. The +best solution is to edit the definition of va_start to remove the `;'. +This will fix this file for anything you want to compile. If you don't have +permission to edit /usr/include/stdarg.h in place, copy it to the tcl unix +directory and change it there. + +Contact me directly if you have problems on SCO systems. +Mark Diekhans + +-------------------------------------------- +SCO Unix 3.2.5 (ODT 5.0) +-------------------------------------------- + +Expect failures from socket tests 2.9 and 3.1. + +Contact me directly if you have problems on SCO systems. +Mark Diekhans + +-------------------------------------------- +Linux 1.2.13 (gcc 2.7.0, libc.so.5.0.9) +-------------------------------------------- + +Symptoms: + +* Some extensions could not be loaded dynamically, most + prominently Blt 2.0 + + The given error message essentially said: + Could not resolve symbol '__eprintf'. + + (This procedure is used by the macro 'assert') + +Cause + +* '__eprintf' is defined in 'libgcc.a', not 'libc.so.x.y'. + It is therefore impossible to load it dynamically. + +* Neither tcl nor tk make use of 'assert', thereby + preventing a static linkage. + +Workaround + +* I included in 'tclAppInit.c' / 'tkAppInit.c' + and then executed 'assert (argc)' just before the call + to Tcl_Main / Tk_Main. + + This forced the static linkage of '__eprintf' and + everything went fine from then on. + + (Something like 'assert (1)', 'assert (a==a)' is not + sufficient, it will be optimized away). + diff --git a/tcl7.3/porting.notes b/tcl7.6/unix/porting.old similarity index 52% rename from tcl7.3/porting.notes rename to tcl7.6/unix/porting.old index 5e33875..e312de0 100644 --- a/tcl7.3/porting.notes +++ b/tcl7.6/unix/porting.old @@ -1,11 +1,20 @@ -This file contains a collection of notes that various people have -provided about porting Tcl to various machines and operating systems. +This is an old version of the file "porting.notes". It contains +porting information that people submitted for Tcl releases numbered +7.3 and earlier. You may find information in this file useful if +there is no information available for your machine in the current +version of "porting.notes". + 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 +If you see the word "I" in any explanations, it refers to the person +who contributed the information, not to me; this means that I +probably can't answer any questions about any of this stuff. In +some cases, a person has volunteered to act as a contact point for +questions about porting Tcl to a particular machine; in these cases the person's name and e-mail address are listed. +sccsid = SCCS: @(#) porting.old 1.3 96/02/16 08:56:07 + --------------------------------------------- Cray machines running UNICOS: Contact: John Freeman (jlf@cray.com) @@ -97,26 +106,73 @@ routines. 4. Add a "-lsun" switch in the targets for tclsh and tcltest, just before ${MATH_LIBS}. +5. Rumor has it that you also need to add the "-lmalloc" library switch +in the targets for tclsh and tcltest. + +6. In IRIX 5.2 you'll have to modify Makefile to fix the following problems: + - The "-c" option is illegal with this version of install, but + the "-F" switch is needed instead. Change this in the "INSTALL =" + definition line. + - The order of file and directory have to be changed in all the + invocations of INSTALL_DATA or INSTALL_PROGRAM. + --------------------------------------------- NeXT machines running NeXTStep 3.1: --------------------------------------------- 1. Run configure with predefined CPP: CPP='cc -E' ./configure + (If your shell is [t]csh, do a "setenv CPP 'cc -E' ") 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 + -add the following to AC_FLAGS: + -Dstrtod=tcl_strtod -3. Edit compat/tmpnam.o and replace "/usr/tmp" with "/tmp" +3. Edit compat/tmpnam.c 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. +4. Additional information that may apply to NeXTStep 3.2 only: + + The problem on NEXTSTEP 3.2 is that the configure script makes some + bad assumptions about the uid_t and gid_t types. Actually, the may + have been valid for NEXTSTEP 3.0, or it may be NEXTSTEP's rudimentary + attempt at POSIX support under 3.2, but no matter what the reason, the + configure script sets up the Makefile with CFLAGS '-Duid_t=int' and + '-Dgid_t=int', which are, unfortunately, incorrect, since they shoudl + actually be (I think) unsigned shorts. This causes problems when the + 'stat' structure is included, since it throws off the field offsets + from what the 'fstat' function thinks they should be. + + Anyway, the quick fix is to run configure and then edit the Makefile + to remove the uid_t and gid_t defines. This will allow tcl and Tk to + compile and run. There are some other problems on NEXTSTEP, + specifically with %g in the printf family of functions, but making the + uid_t and gid_t change will get it up and running. + +--------------------------------------------- +NeXT machines running NeXTStep 3.2: +--------------------------------------------- + +1. Run configure with predefined CPP: + CPP='cc -E' ./configure + (If your shell is [t]csh, do a "setenv CPP 'cc -E' ") + +2. Edit Makefile: + -add tmpnam.o to COMPAT_OBJS: + COMPAT_OBJS = getcwd.o waitpid.o strtod.o tmpnam.o + -add the following to AC_FLAGS: + -Dstrtod=tcl_strtod + -add '-m' to MATH_LIBS: + MATH_LIBS = -m -lm + -add '-O2 -arch m68k -arch i386' to CFLAGS: + CFLAGS = -O2 -arch m68k -arch i386 + ------------------------------------------------- ISC 2.2 UNIX (using standard ATT SYSV compiler): ------------------------------------------------- @@ -142,7 +198,7 @@ switch). The problem appears to have been fixed in the 1.3-4 version of the compiler. --------------------------------------------- -CDC 4680MNP, EP/IX 1.4.3: +CDC 4680MP, EP/IX 1.4.3: --------------------------------------------- The installation was done in the System V environment (-systype sysv) @@ -157,7 +213,8 @@ 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. +status to be returned to the shell (but see the comments about "-non_shared" +below in the 2.1.1 notes). There is a bug in the include file that mis-defines the structure fields and causes WIFEXITED and WIFSIGNALED to return incorrect @@ -179,16 +236,64 @@ After running configure, I made the following changes to Makefile: 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: + 2) 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 + 3) Add "-lbsd" to the commands that create tclsh and tcltest (look for "-o"). +--------------------------------------------- +CDC 4680MP, EP/IX 2.1.1: +--------------------------------------------- + +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 3.11 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. The 2.20 compiler does not have this +problem. + +To make the configure script find the BSD extensions, I set environment +variable DEFS to: + + "-I/usr/include/bsd -D__STDC__=0 -non_shared" + +and LIBS to: + + "-lbsd" + +before running it. The "-non_shared" is needed because with shared +libraries, the compiler (actually, the loader) does not report an +error for "missing" routines. The configuration script depends on this +error to know what routines are available. This is the real problem +I reported above for EP/IX 1.4.3 that I incorrectly attributed to a +compiler driver bug. I don't have 1.4.3 available any more, but it's +possible using "-non_shared" on it would have solved the problem. + +The same bug exists at 2.1.1 (yes, I have reported it to +CDC), and the same fix as described in the 1.4.3 porting notes works. + +In addition to the three Makefile changes described in the 1.4.3 notes, +you can remove the "-non_shared" flag from AC_FLAGS. It is only needed +for the configuration step, not the build. + +You will get duplicate definition compilation warnings of: + + DBL_MIN + DBL_MAX + FLT_MIN + FLT_MAX + +during tclExpr.c. These can be ignored. + +During expr.test, you will get a failure for one of the "fmod" tests +unless you have CDC patch CC40038311 installed. + --------------------------------------------- Convex systems, OS 10.1 and 10.2: Contact: Lennart Sorth (ls@dmi.min.dk) @@ -212,3 +317,68 @@ 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. + +------------------------------------------------- +Encore 91, UMAX V 3.0.9.3: +------------------------------------------------- + +1. Modify the CFLAGS assignment in file Makefile.in to include the +-DENCORE flag in Makefile: + + CFLAGS = -O -DENCORE + +2. "mkdir" does not by default create the parent directories. The mkdir +directives should be modified to "midir -p". + +------------------------------------------------- +Sequent machines running Dynix: +Contact: Andrew Swan (aswan@soda.berkeley.edu) +------------------------------------------------- + +1. Use gcc instead of the cc distributed by Sequent + +2. The distributed math library does not include the fmod + function. Source for fmod can be retrieved from a BSD + source archive (such as ftp.uu.net) and included in the + compat directory. Add fmod.o to the COMPAT_OBJS variable + in the Makefile. You may need to comment out references + to 'isnan' and 'finite' in fmod.c + +3. If the linker complains that there are two copies of the + 'tanh' function, use the ar command to extract the objects + from the math library and build a new one without tanh.o + +4. The *scanf functions in the Sequent libraries are apparently + broken, which will cause the scanning tests to fail. The + cases that fail are fairly obscure. Using GNU libc apparently + solves this problem. + +------------------------------------------------- +Systems running Interactive 4.0: +------------------------------------------------- + +1. Add "-posix -D_SYSV3" to CFLAGS in Makefile (or Makefile.in). + +------------------------------------------------- +Systems running FreeBSD 1.1.5.1: +------------------------------------------------- + +The following changes comprise the entire porting effort of tcl7.3 to +FreeBSD (i.e. these were the changes to tclTest.c) and should probably +be made part of the tcl distribution. The changes only effect the way that +floating point exceptions are reported. I've choosen to move the changes +out of tclTest.c and into tclBasic.c. + +in tclBasic.c at top-of-file: + +#ifdef BSD_NET2 +#include +#endif + +in tclBasic.c in Tcl_Init(): + +#ifdef BSD_NET2 + fpsetround(FP_RN); + fpsetmask(0L); +#endif + diff --git a/tcl7.6/unix/tclAppInit.c b/tcl7.6/unix/tclAppInit.c new file mode 100644 index 0000000..a9479b3 --- /dev/null +++ b/tcl7.6/unix/tclAppInit.c @@ -0,0 +1,116 @@ +/* + * tclAppInit.c -- + * + * Provides a default version of the main program and Tcl_AppInit + * procedure for Tcl applications (without Tk). + * + * Copyright (c) 1993 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclAppInit.c 1.17 96/03/26 12:45:29 + */ + +#include "tcl.h" + +/* + * The following variable is a special hack that is needed in order for + * Sun shared libraries to be used for Tcl. + */ + +extern int matherr(); +int *tclDummyMathPtr = (int *) matherr; + +#ifdef TCL_TEST +EXTERN int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +#endif /* TCL_TEST */ + +/* + *---------------------------------------------------------------------- + * + * main -- + * + * This is the main program for the application. + * + * Results: + * None: Tcl_Main never returns here, so this procedure never + * returns either. + * + * Side effects: + * Whatever the application does. + * + *---------------------------------------------------------------------- + */ + +int +main(argc, argv) + int argc; /* Number of command-line arguments. */ + char **argv; /* Values of command-line arguments. */ +{ + Tcl_Main(argc, argv, Tcl_AppInit); + return 0; /* Needed only to prevent compiler warning. */ +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppInit -- + * + * This procedure performs application-specific initialization. + * Most applications, especially those that incorporate additional + * packages, will have their own version of this procedure. + * + * Results: + * Returns a standard Tcl completion code, and leaves an error + * message in interp->result if an error occurs. + * + * Side effects: + * Depends on the startup script. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_AppInit(interp) + Tcl_Interp *interp; /* Interpreter for application. */ +{ + if (Tcl_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + +#ifdef TCL_TEST + if (Tcltest_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, + (Tcl_PackageInitProc *) NULL); +#endif /* TCL_TEST */ + + /* + * 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. + */ + + /* + * Call Tcl_CreateCommand for application-specific commands, if + * they weren't already created by the init procedures called above. + */ + + /* + * Specify a user-specific startup file to invoke if the application + * is run interactively. Typically the startup file is "~/.apprc" + * where "app" is the name of the application. If this line is deleted + * then no user-specific startup file will be run under any conditions. + */ + + Tcl_SetVar(interp, "tcl_rcFileName", "~/.tclshrc", TCL_GLOBAL_ONLY); + return TCL_OK; +} diff --git a/tcl7.6/unix/tclConfig.sh.in b/tcl7.6/unix/tclConfig.sh.in new file mode 100644 index 0000000..a19296c --- /dev/null +++ b/tcl7.6/unix/tclConfig.sh.in @@ -0,0 +1,112 @@ +# tclConfig.sh -- +# +# This shell script (for sh) is generated automatically by Tcl's +# configure script. It will create shell variables for most of +# the configuration options discovered by the configure script. +# This script is intended to be included by the configure scripts +# for Tcl extensions so that they don't have to figure this all +# out for themselves. +# +# The information in this file is specific to a single platform. +# +# SCCS: @(#) tclConfig.sh.in 1.18 96/10/04 10:28:46 + +# Tcl's version number. +TCL_VERSION='@TCL_VERSION@' +TCL_MAJOR_VERSION='@TCL_MAJOR_VERSION@' +TCL_MINOR_VERSION='@TCL_MINOR_VERSION@' + +# C compiler to use for compilation. +TCL_CC='@CC@' + +# -D flags for use with the C compiler. +TCL_DEFS='@DEFS@' + +# The name of the Tcl library (may be either a .a file or a shared library): +TCL_LIB_FILE=@TCL_LIB_FILE@ + +# Additional libraries to use when linking Tcl. +TCL_LIBS='@DL_LIBS@ @LIBS@ @MATH_LIBS@' + +# Top-level directory in which Tcl's platform-independent files are +# installed. +TCL_PREFIX='@prefix@' + +# Top-level directory in which Tcl's platform-specific files (e.g. +# executables) are installed. +TCL_EXEC_PREFIX='@exec_prefix@' + +# Flags to pass to cc when compiling the components of a shared library: +TCL_SHLIB_CFLAGS='@SHLIB_CFLAGS@' + +# Base command to use for combining object files into a shared library: +TCL_SHLIB_LD='@SHLIB_LD@' + +# Either '$LIBS' (if dependent libraries should be included when linking +# shared libraries) or an empty string. See Tcl's configure.in for more +# explanation. +TCL_SHLIB_LD_LIBS='@SHLIB_LD_LIBS@' + +# Suffix to use for the name of a shared library. +TCL_SHLIB_SUFFIX='@SHLIB_SUFFIX@' + +# Library file(s) to include in tclsh and other base applications +# in order to provide facilities needed by DLOBJ above. +TCL_DL_LIBS='@DL_LIBS@' + +# Flags to pass to the compiler when linking object files into +# an executable tclsh or tcltest binary. +TCL_LD_FLAGS='@LD_FLAGS@' + +# Flags to pass to ld, such as "-R /usr/local/tcl/lib", that tell the +# run-time dynamic linker where to look for shared libraries such as +# libtcl.so. Used when linking applications. Only works if there +# is a variable "LIB_RUNTIME_DIR" defined in the Makefile. +TCL_LD_SEARCH_FLAGS='@TCL_LD_SEARCH_FLAGS@' + +# Additional object files linked with Tcl to provide compatibility +# with standard facilities from ANSI C or POSIX. +TCL_COMPAT_OBJS='@LIBOBJS@' + +# Name of the ranlib program to use. +TCL_RANLIB='@RANLIB@' + +# String to pass to linker to pick up the Tcl library from its +# build directory. +TCL_BUILD_LIB_SPEC='@TCL_BUILD_LIB_SPEC@' + +# String to pass to linker to pick up the Tcl library from its +# installed directory. +TCL_LIB_SPEC='@TCL_LIB_SPEC@' + +# Indicates whether a version numbers should be used in -l switches +# ("ok" means it's safe to use switches like -ltcl7.5; "nodots" means +# use switches like -ltcl75). SunOS and FreeBSD require "nodots", for +# example. +TCL_LIB_VERSIONS_OK='@TCL_LIB_VERSIONS_OK@' + +# String that can be evaluated to generate the part of a shared library +# name that comes after the "libxxx" (includes version number, if any, +# extension, and anything else needed). May depend on the variables +# VERSION and SHLIB_SUFFIX. On most UNIX systems this is +# ${VERSION}${SHLIB_SUFFIX}. +TCL_SHARED_LIB_SUFFIX='@TCL_SHARED_LIB_SUFFIX@' + +# String that can be evaluated to generate the part of an unshared library +# name that comes after the "libxxx" (includes version number, if any, +# extension, and anything else needed). May depend on the variable +# VERSION. On most UNIX systems this is ${VERSION}.a. +TCL_UNSHARED_LIB_SUFFIX='@TCL_UNSHARED_LIB_SUFFIX@' + +# Location of the top-level source directory from which Tcl was built. +# This is the directory that contains a README file as well as +# subdirectories such as generic, unix, etc. If Tcl was compiled in a +# different place than the directory containing the source files, this +# points to the location of the sources, not the location where Tcl was +# compiled. +TCL_SRC_DIR='@TCL_SRC_DIR@' + +# List of standard directories in which to look for packages during +# "package require" commands. Contains the "prefix" directory plus also +# the "exec_prefix" directory, if it is different. +TCL_PACKAGE_PATH='@TCL_PACKAGE_PATH@' diff --git a/tcl7.6/unix/tclLoadAix.c b/tcl7.6/unix/tclLoadAix.c new file mode 100644 index 0000000..edf33d6 --- /dev/null +++ b/tcl7.6/unix/tclLoadAix.c @@ -0,0 +1,549 @@ +/* + * tclLoadAix.c -- + * + * This file implements the dlopen and dlsym APIs under the + * AIX operating system, to enable the Tcl "load" command to + * work. This code was provided by Jens-Uwe Mager. + * + * This file is subject to the following copyright notice, which is + * different from the notice used elsewhere in Tcl. The file has + * been modified to incorporate the file dlfcn.h in-line. + * + * Copyright (c) 1992,1993,1995,1996, Jens-Uwe Mager, Helios Software GmbH + * Not derived from licensed software. + + * Permission is granted to freely use, copy, modify, and redistribute + * this software, provided that the author is not construed to be liable + * for any results of using the software, alterations are clearly marked + * as such, and this notice is not modified. + * + * SCCS: @(#) tclLoadAix.c 1.11 96/10/07 10:41:24 + * + * Note: this file has been altered from the original in a few + * ways in order to work properly with Tcl. + */ + +/* + * @(#)dlfcn.c 1.7 revision of 95/08/14 19:08:38 + * This is an unpublished work copyright (c) 1992 HELIOS Software GmbH + * 30159 Hannover, Germany + */ + +#include +#include +#include +#include +#include +#include +#include +#include +#include "../compat/dlfcn.h" + +/* + * We simulate dlopen() et al. through a call to load. Because AIX has + * no call to find an exported symbol we read the loader section of the + * loaded module and build a list of exported symbols and their virtual + * address. + */ + +typedef struct { + char *name; /* the symbols's name */ + void *addr; /* its relocated virtual address */ +} Export, *ExportPtr; + +/* + * xlC uses the following structure to list its constructors and + * destructors. This is gleaned from the output of munch. + */ +typedef struct { + void (*init)(void); /* call static constructors */ + void (*term)(void); /* call static destructors */ +} Cdtor, *CdtorPtr; + +/* + * The void * handle returned from dlopen is actually a ModulePtr. + */ +typedef struct Module { + struct Module *next; + char *name; /* module name for refcounting */ + int refCnt; /* the number of references */ + void *entry; /* entry point from load */ + struct dl_info *info; /* optional init/terminate functions */ + CdtorPtr cdtors; /* optional C++ constructors */ + int nExports; /* the number of exports found */ + ExportPtr exports; /* the array of exports */ +} Module, *ModulePtr; + +/* + * We keep a list of all loaded modules to be able to call the fini + * handlers and destructors at atexit() time. + */ +static ModulePtr modList; + +/* + * The last error from one of the dl* routines is kept in static + * variables here. Each error is returned only once to the caller. + */ +static char errbuf[BUFSIZ]; +static int errvalid; + +static void caterr(char *); +static int readExports(ModulePtr); +static void terminate(void); +static void *findMain(void); + +VOID *dlopen(const char *path, int mode) +{ + register ModulePtr mp; + static void *mainModule; + + /* + * Upon the first call register a terminate handler that will + * close all libraries. Also get a reference to the main module + * for use with loadbind. + */ + if (!mainModule) { + if ((mainModule = findMain()) == NULL) + return NULL; + atexit(terminate); + } + /* + * Scan the list of modules if we have the module already loaded. + */ + for (mp = modList; mp; mp = mp->next) + if (strcmp(mp->name, path) == 0) { + mp->refCnt++; + return (VOID *) mp; + } + if ((mp = (ModulePtr)calloc(1, sizeof(*mp))) == NULL) { + errvalid++; + strcpy(errbuf, "calloc: "); + strcat(errbuf, strerror(errno)); + return (VOID *) NULL; + } + mp->name = malloc((unsigned) (strlen(path) + 1)); + strcpy(mp->name, path); + /* + * load should be declared load(const char *...). Thus we + * cast the path to a normal char *. Ugly. + */ + if ((mp->entry = (void *)load((char *)path, L_NOAUTODEFER, NULL)) == NULL) { + free(mp->name); + free(mp); + errvalid++; + strcpy(errbuf, "dlopen: "); + strcat(errbuf, path); + strcat(errbuf, ": "); + /* + * If AIX says the file is not executable, the error + * can be further described by querying the loader about + * the last error. + */ + if (errno == ENOEXEC) { + char *tmp[BUFSIZ/sizeof(char *)]; + if (loadquery(L_GETMESSAGES, tmp, sizeof(tmp)) == -1) + strcpy(errbuf, strerror(errno)); + else { + char **p; + for (p = tmp; *p; p++) + caterr(*p); + } + } else + strcat(errbuf, strerror(errno)); + return (VOID *) NULL; + } + mp->refCnt = 1; + mp->next = modList; + modList = mp; + if (loadbind(0, mainModule, mp->entry) == -1) { + dlclose(mp); + errvalid++; + strcpy(errbuf, "loadbind: "); + strcat(errbuf, strerror(errno)); + return (VOID *) NULL; + } + /* + * If the user wants global binding, loadbind against all other + * loaded modules. + */ + if (mode & RTLD_GLOBAL) { + register ModulePtr mp1; + for (mp1 = mp->next; mp1; mp1 = mp1->next) + if (loadbind(0, mp1->entry, mp->entry) == -1) { + dlclose(mp); + errvalid++; + strcpy(errbuf, "loadbind: "); + strcat(errbuf, strerror(errno)); + return (VOID *) NULL; + } + } + if (readExports(mp) == -1) { + dlclose(mp); + return (VOID *) NULL; + } + /* + * If there is a dl_info structure, call the init function. + */ + if (mp->info = (struct dl_info *)dlsym(mp, "dl_info")) { + if (mp->info->init) + (*mp->info->init)(); + } else + errvalid = 0; + /* + * If the shared object was compiled using xlC we will need + * to call static constructors (and later on dlclose destructors). + */ + if (mp->cdtors = (CdtorPtr)dlsym(mp, "__cdtors")) { + while (mp->cdtors->init) { + (*mp->cdtors->init)(); + mp->cdtors++; + } + } else + errvalid = 0; + return (VOID *) mp; +} + +/* + * Attempt to decipher an AIX loader error message and append it + * to our static error message buffer. + */ +static void caterr(char *s) +{ + register char *p = s; + + while (*p >= '0' && *p <= '9') + p++; + switch(atoi(s)) { + case L_ERROR_TOOMANY: + strcat(errbuf, "to many errors"); + break; + case L_ERROR_NOLIB: + strcat(errbuf, "can't load library"); + strcat(errbuf, p); + break; + case L_ERROR_UNDEF: + strcat(errbuf, "can't find symbol"); + strcat(errbuf, p); + break; + case L_ERROR_RLDBAD: + strcat(errbuf, "bad RLD"); + strcat(errbuf, p); + break; + case L_ERROR_FORMAT: + strcat(errbuf, "bad exec format in"); + strcat(errbuf, p); + break; + case L_ERROR_ERRNO: + strcat(errbuf, strerror(atoi(++p))); + break; + default: + strcat(errbuf, s); + break; + } +} + +VOID *dlsym(void *handle, const char *symbol) +{ + register ModulePtr mp = (ModulePtr)handle; + register ExportPtr ep; + register int i; + + /* + * Could speed up the search, but I assume that one assigns + * the result to function pointers anyways. + */ + for (ep = mp->exports, i = mp->nExports; i; i--, ep++) + if (strcmp(ep->name, symbol) == 0) + return ep->addr; + errvalid++; + strcpy(errbuf, "dlsym: undefined symbol "); + strcat(errbuf, symbol); + return NULL; +} + +char *dlerror(void) +{ + if (errvalid) { + errvalid = 0; + return errbuf; + } + return NULL; +} + +int dlclose(void *handle) +{ + register ModulePtr mp = (ModulePtr)handle; + int result; + register ModulePtr mp1; + + if (--mp->refCnt > 0) + return 0; + if (mp->info && mp->info->fini) + (*mp->info->fini)(); + if (mp->cdtors) + while (mp->cdtors->term) { + (*mp->cdtors->term)(); + mp->cdtors++; + } + result = unload(mp->entry); + if (result == -1) { + errvalid++; + strcpy(errbuf, strerror(errno)); + } + if (mp->exports) { + register ExportPtr ep; + register int i; + for (ep = mp->exports, i = mp->nExports; i; i--, ep++) + if (ep->name) + free(ep->name); + free(mp->exports); + } + if (mp == modList) + modList = mp->next; + else { + for (mp1 = modList; mp1; mp1 = mp1->next) + if (mp1->next == mp) { + mp1->next = mp->next; + break; + } + } + free(mp->name); + free(mp); + return result; +} + +static void terminate(void) +{ + while (modList) + dlclose(modList); +} + +/* + * Build the export table from the XCOFF .loader section. + */ +static int readExports(ModulePtr mp) +{ + LDFILE *ldp = NULL; + SCNHDR sh, shdata; + LDHDR *lhp; + char *ldbuf; + LDSYM *ls; + int i; + ExportPtr ep; + + if ((ldp = ldopen(mp->name, ldp)) == NULL) { + struct ld_info *lp; + char *buf; + int size = 4*1024; + if (errno != ENOENT) { + errvalid++; + strcpy(errbuf, "readExports: "); + strcat(errbuf, strerror(errno)); + return -1; + } + /* + * The module might be loaded due to the LIBPATH + * environment variable. Search for the loaded + * module using L_GETINFO. + */ + if ((buf = malloc(size)) == NULL) { + errvalid++; + strcpy(errbuf, "readExports: "); + strcat(errbuf, strerror(errno)); + return -1; + } + while ((i = loadquery(L_GETINFO, buf, size)) == -1 && errno == ENOMEM) { + free(buf); + size += 4*1024; + if ((buf = malloc(size)) == NULL) { + errvalid++; + strcpy(errbuf, "readExports: "); + strcat(errbuf, strerror(errno)); + return -1; + } + } + if (i == -1) { + errvalid++; + strcpy(errbuf, "readExports: "); + strcat(errbuf, strerror(errno)); + free(buf); + return -1; + } + /* + * Traverse the list of loaded modules. The entry point + * returned by load() does actually point to the data + * segment origin. + */ + lp = (struct ld_info *)buf; + while (lp) { + if (lp->ldinfo_dataorg == mp->entry) { + ldp = ldopen(lp->ldinfo_filename, ldp); + break; + } + if (lp->ldinfo_next == 0) + lp = NULL; + else + lp = (struct ld_info *)((char *)lp + lp->ldinfo_next); + } + free(buf); + if (!ldp) { + errvalid++; + strcpy(errbuf, "readExports: "); + strcat(errbuf, strerror(errno)); + return -1; + } + } + if (TYPE(ldp) != U802TOCMAGIC) { + errvalid++; + strcpy(errbuf, "readExports: bad magic"); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + /* + * Get the padding for the data section. This is needed for + * AIX 4.1 compilers. This is used when building the final + * function pointer to the exported symbol. + */ + if (ldnshread(ldp, _DATA, &shdata) != SUCCESS) { + errvalid++; + strcpy(errbuf, "readExports: cannot read data section header"); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + if (ldnshread(ldp, _LOADER, &sh) != SUCCESS) { + errvalid++; + strcpy(errbuf, "readExports: cannot read loader section header"); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + /* + * We read the complete loader section in one chunk, this makes + * finding long symbol names residing in the string table easier. + */ + if ((ldbuf = (char *)malloc(sh.s_size)) == NULL) { + errvalid++; + strcpy(errbuf, "readExports: "); + strcat(errbuf, strerror(errno)); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + if (FSEEK(ldp, sh.s_scnptr, BEGINNING) != OKFSEEK) { + errvalid++; + strcpy(errbuf, "readExports: cannot seek to loader section"); + free(ldbuf); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + if (FREAD(ldbuf, sh.s_size, 1, ldp) != 1) { + errvalid++; + strcpy(errbuf, "readExports: cannot read loader section"); + free(ldbuf); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + lhp = (LDHDR *)ldbuf; + ls = (LDSYM *)(ldbuf+LDHDRSZ); + /* + * Count the number of exports to include in our export table. + */ + for (i = lhp->l_nsyms; i; i--, ls++) { + if (!LDR_EXPORT(*ls)) + continue; + mp->nExports++; + } + if ((mp->exports = (ExportPtr)calloc(mp->nExports, sizeof(*mp->exports))) == NULL) { + errvalid++; + strcpy(errbuf, "readExports: "); + strcat(errbuf, strerror(errno)); + free(ldbuf); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + /* + * Fill in the export table. All entries are relative to + * the entry point we got from load. + */ + ep = mp->exports; + ls = (LDSYM *)(ldbuf+LDHDRSZ); + for (i = lhp->l_nsyms; i; i--, ls++) { + char *symname; + char tmpsym[SYMNMLEN+1]; + if (!LDR_EXPORT(*ls)) + continue; + if (ls->l_zeroes == 0) + symname = ls->l_offset+lhp->l_stoff+ldbuf; + else { + /* + * The l_name member is not zero terminated, we + * must copy the first SYMNMLEN chars and make + * sure we have a zero byte at the end. + */ + strncpy(tmpsym, ls->l_name, SYMNMLEN); + tmpsym[SYMNMLEN] = '\0'; + symname = tmpsym; + } + ep->name = malloc((unsigned) (strlen(symname) + 1)); + strcpy(ep->name, symname); + ep->addr = (void *)((unsigned long)mp->entry + + ls->l_value - shdata.s_vaddr); + ep++; + } + free(ldbuf); + while(ldclose(ldp) == FAILURE) + ; + return 0; +} + +/* + * Find the main modules entry point. This is used as export pointer + * for loadbind() to be able to resolve references to the main part. + */ +static void * findMain(void) +{ + struct ld_info *lp; + char *buf; + int size = 4*1024; + int i; + void *ret; + + if ((buf = malloc(size)) == NULL) { + errvalid++; + strcpy(errbuf, "findMain: "); + strcat(errbuf, strerror(errno)); + return NULL; + } + while ((i = loadquery(L_GETINFO, buf, size)) == -1 && errno == ENOMEM) { + free(buf); + size += 4*1024; + if ((buf = malloc(size)) == NULL) { + errvalid++; + strcpy(errbuf, "findMain: "); + strcat(errbuf, strerror(errno)); + return NULL; + } + } + if (i == -1) { + errvalid++; + strcpy(errbuf, "findMain: "); + strcat(errbuf, strerror(errno)); + free(buf); + return NULL; + } + /* + * The first entry is the main module. The entry point + * returned by load() does actually point to the data + * segment origin. + */ + lp = (struct ld_info *)buf; + ret = lp->ldinfo_dataorg; + free(buf); + return ret; +} + diff --git a/tcl7.6/unix/tclLoadAout.c b/tcl7.6/unix/tclLoadAout.c new file mode 100644 index 0000000..29859a0 --- /dev/null +++ b/tcl7.6/unix/tclLoadAout.c @@ -0,0 +1,433 @@ +/* + * tclLoadAout.c -- + * + * This procedure provides a version of the TclLoadFile that + * provides pseudo-static linking using version-7 compatible + * a.out files described in either sys/exec.h or sys/a.out.h. + * + * Copyright (c) 1995, by General Electric Company. All rights reserved. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * This work was supported in part by the ARPA Manufacturing Automation + * and Design Engineering (MADE) Initiative through ARPA contract + * F33615-94-C-4400. + * + * SCCS: @(#) tclLoadAout.c 1.7 96/02/15 11:58:53 + */ + +#include "tclInt.h" +#include +#ifdef HAVE_EXEC_AOUT_H +# include +#endif + +/* + * Some systems describe the a.out header in sys/exec.h, and some in + * a.out.h. + */ + +#ifdef USE_SYS_EXEC_H +#include +#endif +#ifdef USE_A_OUT_H +#include +#endif +#ifdef USE_SYS_EXEC_AOUT_H +#include +#define a_magic a_midmag +#endif + +/* + * TCL_LOADSHIM is the amount by which to shim the break when loading + */ + +#ifndef TCL_LOADSHIM +#define TCL_LOADSHIM 0x4000L +#endif + +/* + * TCL_LOADALIGN must be a power of 2, and is the alignment to which + * to force the origin of load modules + */ + +#ifndef TCL_LOADALIGN +#define TCL_LOADALIGN 0x4000L +#endif + +/* + * TCL_LOADMAX is the maximum size of a load module, and is used as + * a sanity check when loading + */ + +#ifndef TCL_LOADMAX +#define TCL_LOADMAX 2000000L +#endif + +/* + * Kernel calls that appear to be missing from the system .h files: + */ + +extern char * brk _ANSI_ARGS_((char *)); +extern char * sbrk _ANSI_ARGS_((size_t)); + +/* + * The static variable SymbolTableFile contains the file name where the + * result of the last link was stored. The file is kept because doing so + * allows one load module to use the symbols defined in another. + */ + +static char * SymbolTableFile = NULL; + +/* + * Type of the dictionary function that begins each load module. + */ + +typedef Tcl_PackageInitProc * (* DictFn) _ANSI_ARGS_ ((char * symbol)); + +/* + * Prototypes for procedures referenced only in this file: + */ + +static int FindLibraries _ANSI_ARGS_((Tcl_Interp * interp, char * fileName, + Tcl_DString * buf)); +static void UnlinkSymbolTable _ANSI_ARGS_((void)); + +/* + *---------------------------------------------------------------------- + * + * TclLoadFile -- + * + * Dynamically loads a binary code file into memory and returns + * the addresses of two procedures within that file, if they + * are defined. + * + * Results: + * A standard Tcl completion code. If an error occurs, an error + * message is left in interp->result. *proc1Ptr and *proc2Ptr + * are filled in with the addresses of the symbols given by + * *sym1 and *sym2, or NULL if those symbols can't be found. + * + * Side effects: + * New code suddenly appears in memory. + * + * + * Bugs: + * This function does not attempt to handle the case where the + * BSS segment is not executable. It will therefore fail on + * Encore Multimax, Pyramid 90x, and similar machines. The + * reason is that the mprotect() kernel call, which would + * otherwise be employed to mark the newly-loaded text segment + * executable, results in a system crash on BSD/386. + * + * In an effort to make it fast, this function eschews the + * technique of linking the load module once, reading its header + * to determine its size, allocating memory for it, and linking + * it again. Instead, it `shims out' memory allocation by + * placing the module TCL_LOADSHIM bytes beyond the break, + * and assuming that any malloc() calls required to run the + * linker will not advance the break beyond that point. If + * the break is advanced beyonnd that point, the load will + * fail with an `inconsistent memory allocation' error. + * It perhaps ought to retry the link, but the failure has + * not been observed in two years of daily use of this function. + *---------------------------------------------------------------------- + */ + +int +TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *fileName; /* Name of the file containing the desired + * code. */ + char *sym1, *sym2; /* Names of two procedures to look up in + * the file's symbol table. */ + Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; + /* Where to return the addresses corresponding + * to sym1 and sym2. */ +{ + char * inputSymbolTable; /* Name of the file containing the + * symbol table from the last link. */ + Tcl_DString linkCommandBuf; /* Command to do the run-time relocation + * of the module.*/ + char * linkCommand; + char relocatedFileName [L_tmpnam]; + /* Name of the file holding the relocated */ + /* text of the module */ + int relocatedFd; /* File descriptor of the file holding + * relocated text */ + struct exec relocatedHead; /* Header of the relocated text */ + unsigned long relocatedSize; /* Size of the relocated text */ + char * startAddress; /* Starting address of the module */ + DictFn dictionary; /* Dictionary function in the load module */ + int status; /* Status return from Tcl_ calls */ + char * p; + + /* Find the file that contains the symbols for the run-time link. */ + + if (SymbolTableFile != NULL) { + inputSymbolTable = SymbolTableFile; + } else if (tclExecutableName == NULL) { + Tcl_SetResult (interp, "can't find the tclsh executable", TCL_STATIC); + return TCL_ERROR; + } else { + inputSymbolTable = tclExecutableName; + } + + /* Construct the `ld' command that builds the relocated module */ + + tmpnam (relocatedFileName); + Tcl_DStringInit (&linkCommandBuf); + Tcl_DStringAppend (&linkCommandBuf, "exec ld -o ", -1); + Tcl_DStringAppend (&linkCommandBuf, relocatedFileName, -1); +#if defined(__mips) || defined(mips) + Tcl_DStringAppend (&linkCommandBuf, " -G 0 ", -1); +#endif + Tcl_DStringAppend (&linkCommandBuf, " -A ", -1); + Tcl_DStringAppend (&linkCommandBuf, inputSymbolTable, -1); + Tcl_DStringAppend (&linkCommandBuf, " -N -T XXXXXXXX ", -1); + Tcl_DStringAppend (&linkCommandBuf, fileName, -1); + Tcl_DStringAppend (&linkCommandBuf, " ", -1); + if (FindLibraries (interp, fileName, &linkCommandBuf) != TCL_OK) { + Tcl_DStringFree (&linkCommandBuf); + return TCL_ERROR; + } + linkCommand = Tcl_DStringValue (&linkCommandBuf); + + /* Determine the starting address, and plug it into the command */ + + startAddress = (char *) (((unsigned long) sbrk (0) + + TCL_LOADSHIM + TCL_LOADALIGN - 1) + & (- TCL_LOADALIGN)); + p = strstr (linkCommand, "-T") + 3; + sprintf (p, "%08lx", (long) startAddress); + p [8] = ' '; + + /* Run the linker */ + + status = Tcl_Eval (interp, linkCommand); + Tcl_DStringFree (&linkCommandBuf); + if (status != 0) { + return TCL_ERROR; + } + + /* Open the linker's result file and read the header */ + + relocatedFd = open (relocatedFileName, O_RDONLY); + if (relocatedFd < 0) { + goto ioError; + } + status= read (relocatedFd, (char *) & relocatedHead, sizeof relocatedHead); + if (status < sizeof relocatedHead) { + goto ioError; + } + + /* Check the magic number */ + + if (relocatedHead.a_magic != OMAGIC) { + Tcl_AppendResult (interp, "bad magic number in intermediate file \"", + relocatedFileName, "\"", (char *) NULL); + goto failure; + } + + /* Make sure that memory allocation is still consistent */ + + if ((unsigned long) sbrk (0) > (unsigned long) startAddress) { + Tcl_SetResult (interp, "can't load, memory allocation is inconsistent.", + TCL_STATIC); + goto failure; + } + + /* Make sure that the relocated module's size is reasonable */ + + relocatedSize = relocatedHead.a_text + relocatedHead.a_data + + relocatedHead.a_bss; + if (relocatedSize > TCL_LOADMAX) { + Tcl_SetResult (interp, "module too big to load", TCL_STATIC); + goto failure; + } + + /* Advance the break to protect the loaded module */ + + (void) brk (startAddress + relocatedSize); + + /* Seek to the start of the module's text */ + +#if defined(__mips) || defined(mips) + status = lseek (relocatedFd, + N_TXTOFF (relocatedHead.ex_f, relocatedHead.ex_o), + SEEK_SET); +#else + status = lseek (relocatedFd, N_TXTOFF (relocatedHead), SEEK_SET); +#endif + if (status < 0) { + goto ioError; + } + + /* Read in the module's text and data */ + + relocatedSize = relocatedHead.a_text + relocatedHead.a_data; + if (read (relocatedFd, startAddress, relocatedSize) < relocatedSize) { + brk (startAddress); + ioError: + Tcl_AppendResult (interp, "error on intermediate file \"", + relocatedFileName, "\": ", Tcl_PosixError (interp), + (char *) NULL); + failure: + (void) unlink (relocatedFileName); + return TCL_ERROR; + } + + /* Close the intermediate file. */ + + (void) close (relocatedFd); + + /* Arrange things so that intermediate symbol tables eventually get + * deleted. */ + + if (SymbolTableFile != NULL) { + UnlinkSymbolTable (); + } else { + atexit (UnlinkSymbolTable); + } + SymbolTableFile = ckalloc (strlen (relocatedFileName) + 1); + strcpy (SymbolTableFile, relocatedFileName); + + /* Look up the entry points in the load module's dictionary. */ + + dictionary = (DictFn) startAddress; + *proc1Ptr = dictionary (sym1); + *proc2Ptr = dictionary (sym2); + + return TCL_OK; +} + +/* + *------------------------------------------------------------------------ + * + * FindLibraries -- + * + * Find the libraries needed to link a load module at run time. + * + * Results: + * A standard Tcl completion code. If an error occurs, + * an error message is left in interp->result. The -l and -L flags + * are concatenated onto the dynamic string `buf'. + * + *------------------------------------------------------------------------ + */ + +static int +FindLibraries (interp, fileName, buf) + Tcl_Interp * interp; /* Used for error reporting */ + char * fileName; /* Name of the load module */ + Tcl_DString * buf; /* Buffer where the -l an -L flags */ +{ + FILE * f; /* The load module */ + int c; /* Byte from the load module */ + char * p; + + /* Open the load module */ + + if ((f = fopen (fileName, "rb")) == NULL) { + Tcl_AppendResult (interp, "couldn't open \"", fileName, "\": ", + Tcl_PosixError (interp), (char *) NULL); + return TCL_ERROR; + } + + /* Search for the library list in the load module */ + + p = "@LIBS: "; + while (*p != '\0' && (c = getc (f)) != EOF) { + if (c == *p) { + ++p; + } + else { + p = "@LIBS: "; + if (c == *p) { + ++p; + } + } + } + + /* No library list -- this must be an ill-formed module */ + + if (c == EOF) { + Tcl_AppendResult (interp, "File \"", fileName, + "\" is not a Tcl load module.", (char *) NULL); + (void) fclose (f); + return TCL_ERROR; + } + + /* Accumulate the library list */ + + while ((c = getc (f)) != '\0' && c != EOF) { + char cc = c; + Tcl_DStringAppend (buf, &cc, 1); + } + (void) fclose (f); + + if (c == EOF) { + Tcl_AppendResult (interp, "Library directory in \"", fileName, + "\" ends prematurely.", (char *) NULL); + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + *------------------------------------------------------------------------ + * + * UnlinkSymbolTable -- + * + * Remove the symbol table file from the last dynamic link. + * + * Results: + * None. + * + * Side effects: + * The symbol table file from the last dynamic link is removed. + * This function is called when (a) a new symbol table is present + * because another dynamic link is complete, or (b) the process + * is exiting. + *------------------------------------------------------------------------ + */ + +static void +UnlinkSymbolTable () +{ + (void) unlink (SymbolTableFile); + ckfree (SymbolTableFile); + SymbolTableFile = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TclGuessPackageName -- + * + * If the "load" command is invoked without providing a package + * name, this procedure is invoked to try to figure it out. + * + * Results: + * Always returns 0 to indicate that we couldn't figure out a + * package name; generic code will then try to guess the package + * from the file name. A return value of 1 would have meant that + * we figured out the package name and put it in bufPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclGuessPackageName(fileName, bufPtr) + char *fileName; /* Name of file containing package (already + * translated to local form if needed). */ + Tcl_DString *bufPtr; /* Initialized empty dstring. Append + * package name to this if possible. */ +{ + return 0; +} diff --git a/tcl7.6/unix/tclLoadDl.c b/tcl7.6/unix/tclLoadDl.c new file mode 100644 index 0000000..4f07363 --- /dev/null +++ b/tcl7.6/unix/tclLoadDl.c @@ -0,0 +1,111 @@ +/* + * tclLoadDl.c -- + * + * This procedure provides a version of the TclLoadFile that + * works with the "dlopen" and "dlsym" library procedures for + * dynamic loading. + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclLoadDl.c 1.7 96/03/14 09:03:33 + */ + +#include "tclInt.h" +#ifdef NO_DLFCN_H +# include "../compat/dlfcn.h" +#else +# include +#endif + +/* + * In some systems, like SunOS 4.1.3, the RTLD_NOW flag isn't defined + * and this argument to dlopen must always be 1. The RTLD_GLOBAL + * flag is needed on some systems (e.g. SCO and UnixWare) but doesn't + * exist on others; if it doesn't exist, set it to 0 so it has no effect. + */ + +#ifndef RTLD_NOW +# define RTLD_NOW 1 +#endif + +#ifndef RTLD_GLOBAL +# define RTLD_GLOBAL 0 +#endif + +/* + *---------------------------------------------------------------------- + * + * TclLoadFile -- + * + * Dynamically loads a binary code file into memory and returns + * the addresses of two procedures within that file, if they + * are defined. + * + * Results: + * A standard Tcl completion code. If an error occurs, an error + * message is left in interp->result. *proc1Ptr and *proc2Ptr + * are filled in with the addresses of the symbols given by + * *sym1 and *sym2, or NULL if those symbols can't be found. + * + * Side effects: + * New code suddenly appears in memory. + * + *---------------------------------------------------------------------- + */ + +int +TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *fileName; /* Name of the file containing the desired + * code. */ + char *sym1, *sym2; /* Names of two procedures to look up in + * the file's symbol table. */ + Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; + /* Where to return the addresses corresponding + * to sym1 and sym2. */ +{ + VOID *handle; + + handle = dlopen(fileName, RTLD_NOW | RTLD_GLOBAL); + if (handle == NULL) { + Tcl_AppendResult(interp, "couldn't load file \"", fileName, + "\": ", dlerror(), (char *) NULL); + return TCL_ERROR; + } + *proc1Ptr = (Tcl_PackageInitProc *) dlsym(handle, sym1); + *proc2Ptr = (Tcl_PackageInitProc *) dlsym(handle, sym2); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclGuessPackageName -- + * + * If the "load" command is invoked without providing a package + * name, this procedure is invoked to try to figure it out. + * + * Results: + * Always returns 0 to indicate that we couldn't figure out a + * package name; generic code will then try to guess the package + * from the file name. A return value of 1 would have meant that + * we figured out the package name and put it in bufPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclGuessPackageName(fileName, bufPtr) + char *fileName; /* Name of file containing package (already + * translated to local form if needed). */ + Tcl_DString *bufPtr; /* Initialized empty dstring. Append + * package name to this if possible. */ +{ + return 0; +} diff --git a/tcl7.6/unix/tclLoadDl2.c b/tcl7.6/unix/tclLoadDl2.c new file mode 100644 index 0000000..ad18537 --- /dev/null +++ b/tcl7.6/unix/tclLoadDl2.c @@ -0,0 +1,113 @@ +/* + * tclLoadDl2.c -- + * + * This procedure provides a version of the TclLoadFile that + * works with the "dlopen" and "dlsym" library procedures for + * dynamic loading. It is identical to tclLoadDl.c except that + * it adds a "_" character to symbol names before looking them + * up. + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclLoadDl2.c 1.3 96/02/15 11:58:45 + */ + +#include "tcl.h" +#include "dlfcn.h" + +/* + * In some systems, like SunOS 4.1.3, the RTLD_NOW flag isn't defined + * and this argument to dlopen must always be 1. + */ + +#ifndef RTLD_NOW +# define RTLD_NOW 1 +#endif + +/* + *---------------------------------------------------------------------- + * + * TclLoadFile -- + * + * Dynamically loads a binary code file into memory and returns + * the addresses of two procedures within that file, if they + * are defined. + * + * Results: + * A standard Tcl completion code. If an error occurs, an error + * message is left in interp->result. *proc1Ptr and *proc2Ptr + * are filled in with the addresses of the symbols given by + * *sym1 and *sym2, or NULL if those symbols can't be found. + * + * Side effects: + * New code suddenly appears in memory. + * + *---------------------------------------------------------------------- + */ + +int +TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *fileName; /* Name of the file containing the desired + * code. */ + char *sym1, *sym2; /* Names of two procedures to look up in + * the file's symbol table. */ + Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; + /* Where to return the addresses corresponding + * to sym1 and sym2. */ +{ + VOID *handle; + Tcl_DString newName; + + handle = dlopen(fileName, RTLD_NOW); + if (handle == NULL) { + Tcl_AppendResult(interp, "couldn't load file \"", fileName, + "\": ", dlerror(), (char *) NULL); + return TCL_ERROR; + } + Tcl_DStringInit(&newName); + Tcl_DStringAppend(&newName, "_", 1); + Tcl_DStringAppend(&newName, sym1, -1); + *proc1Ptr = (Tcl_PackageInitProc *) dlsym(handle, + Tcl_DStringValue(&newName)); + Tcl_DStringSetLength(&newName, 0); + Tcl_DStringAppend(&newName, "_", 1); + Tcl_DStringAppend(&newName, sym2, -1); + *proc2Ptr = (Tcl_PackageInitProc *) dlsym(handle, + Tcl_DStringValue(&newName)); + Tcl_DStringFree(&newName); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclGuessPackageName -- + * + * If the "load" command is invoked without providing a package + * name, this procedure is invoked to try to figure it out. + * + * Results: + * Always returns 0 to indicate that we couldn't figure out a + * package name; generic code will then try to guess the package + * from the file name. A return value of 1 would have meant that + * we figured out the package name and put it in bufPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclGuessPackageName(fileName, bufPtr) + char *fileName; /* Name of file containing package (already + * translated to local form if needed). */ + Tcl_DString *bufPtr; /* Initialized empty dstring. Append + * package name to this if possible. */ +{ + return 0; +} diff --git a/tcl7.6/unix/tclLoadDld.c b/tcl7.6/unix/tclLoadDld.c new file mode 100644 index 0000000..f2f949e --- /dev/null +++ b/tcl7.6/unix/tclLoadDld.c @@ -0,0 +1,123 @@ +/* + * tclLoadDld.c -- + * + * This procedure provides a version of the TclLoadFile that + * works with the "dld_link" and "dld_get_func" library procedures + * for dynamic loading. It has been tested on Linux 1.1.95 and + * dld-3.2.7. This file probably isn't needed anymore, since it + * makes more sense to use "dl_open" etc. + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclLoadDld.c 1.4 96/02/15 11:58:46 + */ + +#include "tclInt.h" +#include "dld.h" + +/* + * In some systems, like SunOS 4.1.3, the RTLD_NOW flag isn't defined + * and this argument to dlopen must always be 1. + */ + +#ifndef RTLD_NOW +# define RTLD_NOW 1 +#endif + +/* + *---------------------------------------------------------------------- + * + * TclLoadFile -- + * + * Dynamically loads a binary code file into memory and returns + * the addresses of two procedures within that file, if they + * are defined. + * + * Results: + * A standard Tcl completion code. If an error occurs, an error + * message is left in interp->result. *proc1Ptr and *proc2Ptr + * are filled in with the addresses of the symbols given by + * *sym1 and *sym2, or NULL if those symbols can't be found. + * + * Side effects: + * New code suddenly appears in memory. + * + *---------------------------------------------------------------------- + */ + +int +TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *fileName; /* Name of the file containing the desired + * code. */ + char *sym1, *sym2; /* Names of two procedures to look up in + * the file's symbol table. */ + Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; + /* Where to return the addresses corresponding + * to sym1 and sym2. */ +{ + static int firstTime = 1; + int returnCode; + + /* + * The dld package needs to know the pathname to the tcl binary. + * If that's not know, return an error. + */ + + if (firstTime) { + if (tclExecutableName == NULL) { + interp->result = "don't know name of application binary file, so can't initialize dynamic loader"; + return TCL_ERROR; + } + returnCode = dld_init(tclExecutableName); + if (returnCode != 0) { + Tcl_AppendResult(interp, + "initialization failed for dynamic loader: ", + dld_strerror(returnCode), (char *) NULL); + return TCL_ERROR; + } + firstTime = 0; + } + + if ((returnCode = dld_link(fileName)) != 0) { + Tcl_AppendResult(interp, "couldn't load file \"", fileName, + "\": ", dld_strerror(returnCode), (char *) NULL); + return TCL_ERROR; + } + *proc1Ptr = (Tcl_PackageInitProc *) dld_get_func(sym1); + *proc2Ptr = (Tcl_PackageInitProc *) dld_get_func(sym2); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclGuessPackageName -- + * + * If the "load" command is invoked without providing a package + * name, this procedure is invoked to try to figure it out. + * + * Results: + * Always returns 0 to indicate that we couldn't figure out a + * package name; generic code will then try to guess the package + * from the file name. A return value of 1 would have meant that + * we figured out the package name and put it in bufPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclGuessPackageName(fileName, bufPtr) + char *fileName; /* Name of file containing package (already + * translated to local form if needed). */ + Tcl_DString *bufPtr; /* Initialized empty dstring. Append + * package name to this if possible. */ +{ + return 0; +} diff --git a/tcl7.6/unix/tclLoadNext.c b/tcl7.6/unix/tclLoadNext.c new file mode 100644 index 0000000..ed4b823 --- /dev/null +++ b/tcl7.6/unix/tclLoadNext.c @@ -0,0 +1,111 @@ +/* + * tclLoadNext.c -- + * + * This procedure provides a version of the TclLoadFile that + * works with NeXTs rld_* dynamic loading. This file provided + * by Pedja Bogdanovich. + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclLoadNext.c 1.4 96/02/15 11:58:55 + */ + +#include "tclInt.h" +#include +#include + +/* + *---------------------------------------------------------------------- + * + * TclLoadFile -- + * + * Dynamically loads a binary code file into memory and returns + * the addresses of two procedures within that file, if they + * are defined. + * + * Results: + * A standard Tcl completion code. If an error occurs, an error + * message is left in interp->result. *proc1Ptr and *proc2Ptr + * are filled in with the addresses of the symbols given by + * *sym1 and *sym2, or NULL if those symbols can't be found. + * + * Side effects: + * New code suddenly appears in memory. + * + *---------------------------------------------------------------------- + */ + +int +TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *fileName; /* Name of the file containing the desired + * code. */ + char *sym1, *sym2; /* Names of two procedures to look up in + * the file's symbol table. */ + Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; + /* Where to return the addresses corresponding + * to sym1 and sym2. */ +{ + struct mach_header *header; + char *data; + int len, maxlen; + char *files[]={fileName,NULL}; + NXStream *errorStream=NXOpenMemory(0,0,NX_READWRITE); + + if(!rld_load(errorStream,&header,files,NULL)) { + NXGetMemoryBuffer(errorStream,&data,&len,&maxlen); + Tcl_AppendResult(interp,"couldn't load file \"",fileName,"\": ",data,NULL); + NXCloseMemory(errorStream,NX_FREEBUFFER); + return TCL_ERROR; + } + NXCloseMemory(errorStream,NX_FREEBUFFER); + + *proc1Ptr=NULL; + if(sym1) { + char sym[strlen(sym1)+2]; + sym[0]='_'; sym[1]=0; strcat(sym,sym1); + rld_lookup(NULL,sym,(unsigned long *)proc1Ptr); + } + + *proc2Ptr=NULL; + if(sym2) { + char sym[strlen(sym2)+2]; + sym[0]='_'; sym[1]=0; strcat(sym,sym2); + rld_lookup(NULL,sym,(unsigned long *)proc2Ptr); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclGuessPackageName -- + * + * If the "load" command is invoked without providing a package + * name, this procedure is invoked to try to figure it out. + * + * Results: + * Always returns 0 to indicate that we couldn't figure out a + * package name; generic code will then try to guess the package + * from the file name. A return value of 1 would have meant that + * we figured out the package name and put it in bufPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclGuessPackageName(fileName, bufPtr) + char *fileName; /* Name of file containing package (already + * translated to local form if needed). */ + Tcl_DString *bufPtr; /* Initialized empty dstring. Append + * package name to this if possible. */ +{ + return 0; +} diff --git a/tcl7.6/unix/tclLoadOSF.c b/tcl7.6/unix/tclLoadOSF.c new file mode 100644 index 0000000..ca8c8fc --- /dev/null +++ b/tcl7.6/unix/tclLoadOSF.c @@ -0,0 +1,128 @@ +/* + * tclLoadOSF.c -- + * + * This procedure provides a version of the TclLoadFile that works + * under OSF/1 1.0/1.1/1.2 and related systems, utilizing the old OSF/1 + * /sbin/loader and /usr/include/loader.h. OSF/1 versions from 1.3 and + * on use ELF, rtld, and dlopen()[/usr/include/ldfcn.h]. + * + * This is useful for: + * OSF/1 1.0, 1.1, 1.2 (from OSF) + * includes: MK4 and AD1 (from OSF RI) + * OSF/1 1.3 (from OSF) using ROSE + * HP OSF/1 1.0 ("Acorn") using COFF + * + * This is likely to be useful for: + * Paragon OSF/1 (from Intel) + * HI-OSF/1 (from Hitachi) + * + * This is NOT to be used on: + * Digitial Alpha OSF/1 systems + * OSF/1 1.3 or later (from OSF) using ELF + * includes: MK6, MK7, AD2, AD3 (from OSF RI) + * + * This approach to things was utter @&^#; thankfully, + * OSF/1 eventually supported dlopen(). + * + * John Robert LoVerso + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclLoadOSF.c 1.2 96/02/15 11:58:40 + */ + +#include "tclInt.h" +#include +#include + +/* + *---------------------------------------------------------------------- + * + * TclLoadFile -- + * + * Dynamically loads a binary code file into memory and returns + * the addresses of two procedures within that file, if they + * are defined. + * + * Results: + * A standard Tcl completion code. If an error occurs, an error + * message is left in interp->result. *proc1Ptr and *proc2Ptr + * are filled in with the addresses of the symbols given by + * *sym1 and *sym2, or NULL if those symbols can't be found. + * + * Side effects: + * New code suddenly appears in memory. + * + *---------------------------------------------------------------------- + */ + +int +TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *fileName; /* Name of the file containing the desired + * code. */ + char *sym1, *sym2; /* Names of two procedures to look up in + * the file's symbol table. */ + Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; + /* Where to return the addresses corresponding + * to sym1 and sym2. */ +{ + ldr_module_t lm; + char *pkg; + + lm = (Tcl_PackageInitProc *) load(fileName, LDR_NOFLAGS); + if (lm == LDR_NULL_MODULE) { + Tcl_AppendResult(interp, "couldn't load file \"", fileName, + "\": ", Tcl_PosixError (interp), (char *) NULL); + return TCL_ERROR; + } + + /* + * My convention is to use a [OSF loader] package name the same as shlib, + * since the idiots never implemented ldr_lookup() and it is otherwise + * impossible to get a package name given a module. + * + * I build loadable modules with a makefile rule like + * ld ... -export $@: -o $@ $(OBJS) + */ + if ((pkg = strrchr(fileName, '/')) == NULL) + pkg = fileName; + else + pkg++; + *proc1Ptr = ldr_lookup_package(pkg, sym1); + *proc2Ptr = ldr_lookup_package(pkg, sym2); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclGuessPackageName -- + * + * If the "load" command is invoked without providing a package + * name, this procedure is invoked to try to figure it out. + * + * Results: + * Always returns 0 to indicate that we couldn't figure out a + * package name; generic code will then try to guess the package + * from the file name. A return value of 1 would have meant that + * we figured out the package name and put it in bufPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclGuessPackageName(fileName, bufPtr) + char *fileName; /* Name of file containing package (already + * translated to local form if needed). */ + Tcl_DString *bufPtr; /* Initialized empty dstring. Append + * package name to this if possible. */ +{ + return 0; +} diff --git a/tcl7.6/unix/tclLoadShl.c b/tcl7.6/unix/tclLoadShl.c new file mode 100644 index 0000000..2f290ab --- /dev/null +++ b/tcl7.6/unix/tclLoadShl.c @@ -0,0 +1,129 @@ +/* + * tclLoadShl.c -- + * + * This procedure provides a version of the TclLoadFile that works + * with the "shl_load" and "shl_findsym" library procedures for + * dynamic loading (e.g. for HP machines). + * + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclLoadShl.c 1.5 96/03/15 15:01:44 + */ + +#include + +/* + * On some HP machines, dl.h defines EXTERN; remove that definition. + */ + +#ifdef EXTERN +# undef EXTERN +#endif + +#include "tcl.h" + +/* + *---------------------------------------------------------------------- + * + * TclLoadFile -- + * + * Dynamically loads a binary code file into memory and returns + * the addresses of two procedures within that file, if they + * are defined. + * + * Results: + * A standard Tcl completion code. If an error occurs, an error + * message is left in interp->result. *proc1Ptr and *proc2Ptr + * are filled in with the addresses of the symbols given by + * *sym1 and *sym2, or NULL if those symbols can't be found. + * + * Side effects: + * New code suddenly appears in memory. + * + *---------------------------------------------------------------------- + */ + +int +TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *fileName; /* Name of the file containing the desired + * code. */ + char *sym1, *sym2; /* Names of two procedures to look up in + * the file's symbol table. */ + Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; + /* Where to return the addresses corresponding + * to sym1 and sym2. */ +{ + shl_t handle; + Tcl_DString newName; + + handle = shl_load(fileName, BIND_IMMEDIATE, 0L); + if (handle == NULL) { + Tcl_AppendResult(interp, "couldn't load file \"", fileName, + "\": ", Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + + /* + * Some versions of the HP system software still use "_" at the + * beginning of exported symbols while others don't; try both + * forms of each name. + */ + + if (shl_findsym(&handle, sym1, (short) TYPE_PROCEDURE, (void *) proc1Ptr) + != 0) { + Tcl_DStringInit(&newName); + Tcl_DStringAppend(&newName, "_", 1); + Tcl_DStringAppend(&newName, sym1, -1); + if (shl_findsym(&handle, Tcl_DStringValue(&newName), + (short) TYPE_PROCEDURE, (void *) proc1Ptr) != 0) { + *proc1Ptr = NULL; + } + Tcl_DStringFree(&newName); + } + if (shl_findsym(&handle, sym2, (short) TYPE_PROCEDURE, (void *) proc2Ptr) + != 0) { + Tcl_DStringInit(&newName); + Tcl_DStringAppend(&newName, "_", 1); + Tcl_DStringAppend(&newName, sym2, -1); + if (shl_findsym(&handle, Tcl_DStringValue(&newName), + (short) TYPE_PROCEDURE, (void *) proc2Ptr) != 0) { + *proc2Ptr = NULL; + } + Tcl_DStringFree(&newName); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclGuessPackageName -- + * + * If the "load" command is invoked without providing a package + * name, this procedure is invoked to try to figure it out. + * + * Results: + * Always returns 0 to indicate that we couldn't figure out a + * package name; generic code will then try to guess the package + * from the file name. A return value of 1 would have meant that + * we figured out the package name and put it in bufPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclGuessPackageName(fileName, bufPtr) + char *fileName; /* Name of file containing package (already + * translated to local form if needed). */ + Tcl_DString *bufPtr; /* Initialized empty dstring. Append + * package name to this if possible. */ +{ + return 0; +} diff --git a/tcl7.3/tclMtherr.c b/tcl7.6/unix/tclMtherr.c similarity index 51% rename from tcl7.3/tclMtherr.c rename to tcl7.6/unix/tclMtherr.c index 81c14ac..2f56e00 100644 --- a/tcl7.3/tclMtherr.c +++ b/tcl7.6/unix/tclMtherr.c @@ -4,36 +4,20 @@ * 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. + * Copyright (c) 1993-1994 The Regents of the University of California. + * Copyright (c) 1994 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tclMtherr.c 1.11 96/02/15 11:58:36 */ -#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 #ifndef TCL_GENERIC_ONLY -#include "tclUnix.h" +#include "tclPort.h" #else #define NO_ERRNO_H #endif @@ -53,6 +37,19 @@ extern int errno; /* Use errno from tclExpr.c. */ extern int tcl_MathInProgress; +/* + * The following definitions allow matherr to compile on systems + * that don't really support it. The compiled procedure is bogus, + * but it will never be executed on these systems anyway. + */ + +#ifndef NEED_MATHERR +struct exception { + int type; +}; +#define DOMAIN 0 +#define SING 0 +#endif /* *---------------------------------------------------------------------- diff --git a/tcl7.6/unix/tclUnixChan.c b/tcl7.6/unix/tclUnixChan.c new file mode 100644 index 0000000..3393452 --- /dev/null +++ b/tcl7.6/unix/tclUnixChan.c @@ -0,0 +1,2531 @@ +/* + * tclUnixChan.c + * + * Common channel driver for Unix channels based on files, command + * pipes and TCP sockets. + * + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclUnixChan.c 1.182 96/09/07 21:59:43 + */ + +#include "tclInt.h" /* Internal definitions for Tcl. */ +#include "tclPort.h" /* Portability features for Tcl. */ + +/* + * This structure describes per-instance state of a file based channel. + */ + +typedef struct FileState { + Tcl_File inFile; /* Input from file. */ + Tcl_File outFile; /* Output to file. */ +} FileState; + +/* + * This structure describes per-instance state of a pipe based channel. + */ + +typedef struct PipeState { + Tcl_File inFile; /* Output from pipe. */ + Tcl_File outFile; /* Input to pipe. */ + Tcl_File errorFile; /* Error output from pipe. */ + int numPids; /* How many processes are attached to this pipe? */ + int *pidPtr; /* The process IDs themselves. Allocated by + * the creator of the pipe. */ + int isNonBlocking; /* Nonzero when the pipe is in nonblocking mode. + * Used to decide whether to wait for the children + * at close time. */ +} PipeState; + +/* + * This structure describes per-instance state of a tcp based channel. + */ + +typedef struct TcpState { + int flags; /* ORed combination of the + * bitfields defined below. */ + Tcl_File sock; /* The socket itself. */ + Tcl_TcpAcceptProc *acceptProc; /* Proc to call on accept. */ + ClientData acceptProcData; /* The data for the accept proc. */ +} TcpState; + +/* + * These bits may be ORed together into the "flags" field of a TcpState + * structure. + */ + +#define TCP_ASYNC_SOCKET (1<<0) /* Asynchronous socket. */ +#define TCP_ASYNC_CONNECT (1<<1) /* Async connect in progress. */ + +/* + * The following defines the maximum length of the listen queue. This is + * the number of outstanding yet-to-be-serviced requests for a connection + * on a server socket, more than this number of outstanding requests and + * the connection request will fail. + */ + +#define TCL_LISTEN_LIMIT 100 + +/* + * The following defines how much buffer space the kernel should maintain + * for a socket. + */ + +#define SOCKET_BUFSIZE 4096 + +/* + * Static routines for this file: + */ + +static TcpState * CreateSocket _ANSI_ARGS_((Tcl_Interp *interp, + int port, char *host, int server, + char *myaddr, int myport, int async)); +static int CreateSocketAddress _ANSI_ARGS_( + (struct sockaddr_in *sockaddrPtr, + char *host, int port)); +static int FileBlockModeProc _ANSI_ARGS_(( + ClientData instanceData, int mode)); +static int FileCloseProc _ANSI_ARGS_((ClientData instanceData, + Tcl_Interp *interp)); +static Tcl_File FileGetProc _ANSI_ARGS_((ClientData instanceData, + int direction)); +static int FileInputProc _ANSI_ARGS_((ClientData instanceData, + char *buf, int toRead, int *errorCode)); +static int FileOutputProc _ANSI_ARGS_(( + ClientData instanceData, char *buf, int toWrite, + int *errorCode)); +static int FileReadyProc _ANSI_ARGS_((ClientData instanceData, + int mask)); +static int FileSeekProc _ANSI_ARGS_((ClientData instanceData, + long offset, int mode, int *errorCode)); +static void FileWatchProc _ANSI_ARGS_((ClientData instanceData, + int mask)); +static int PipeBlockModeProc _ANSI_ARGS_(( + ClientData instanceData, int mode)); +static int PipeCloseProc _ANSI_ARGS_((ClientData instanceData, + Tcl_Interp *interp)); +static Tcl_File PipeGetProc _ANSI_ARGS_((ClientData instanceData, + int direction)); +static int PipeInputProc _ANSI_ARGS_((ClientData instanceData, + char *buf, int toRead, int *errorCode)); +static int PipeOutputProc _ANSI_ARGS_(( + ClientData instanceData, char *buf, int toWrite, + int *errorCode)); +static int PipeReadyProc _ANSI_ARGS_((ClientData instanceData, + int mask)); +static void PipeWatchProc _ANSI_ARGS_((ClientData instanceData, + int mask)); +static void TcpAccept _ANSI_ARGS_((ClientData data, int mask)); +static int TcpBlockModeProc _ANSI_ARGS_((ClientData data, + int mode)); +static int TcpCloseProc _ANSI_ARGS_((ClientData instanceData, + Tcl_Interp *interp)); +static Tcl_File TcpGetProc _ANSI_ARGS_((ClientData instanceData, + int direction)); +static int TcpGetOptionProc _ANSI_ARGS_((ClientData instanceData, + char *optionName, Tcl_DString *dsPtr)); +static int TcpInputProc _ANSI_ARGS_((ClientData instanceData, + char *buf, int toRead, int *errorCode)); +static int TcpOutputProc _ANSI_ARGS_((ClientData instanceData, + char *buf, int toWrite, int *errorCode)); +static int TcpReadyProc _ANSI_ARGS_((ClientData instanceData, + int mask)); +static void TcpWatchProc _ANSI_ARGS_((ClientData instanceData, + int mask)); +static int WaitForConnect _ANSI_ARGS_((TcpState *statePtr, + int *errorCodePtr)); + +/* + * This structure describes the channel type structure for file based IO: + */ + +static Tcl_ChannelType fileChannelType = { + "file", /* Type name. */ + FileBlockModeProc, /* Set blocking/nonblocking mode.*/ + FileCloseProc, /* Close proc. */ + FileInputProc, /* Input proc. */ + FileOutputProc, /* Output proc. */ + FileSeekProc, /* Seek proc. */ + NULL, /* Set option proc. */ + NULL, /* Get option proc. */ + FileWatchProc, /* Initialize notifier. */ + FileReadyProc, /* Are there events? */ + FileGetProc, /* Get Tcl_Files out of channel. */ +}; + +/* + * This structure describes the channel type structure for command pipe + * based IO: + */ + +static Tcl_ChannelType pipeChannelType = { + "pipe", /* Type name. */ + PipeBlockModeProc, /* Set blocking/nonblocking mode.*/ + PipeCloseProc, /* Close proc. */ + PipeInputProc, /* Input proc. */ + PipeOutputProc, /* Output proc. */ + NULL, /* Seek proc. */ + NULL, /* Set option proc. */ + NULL, /* Get option proc. */ + PipeWatchProc, /* Initialize notifier. */ + PipeReadyProc, /* Are there events? */ + PipeGetProc, /* Get Tcl_Files out of channel. */ +}; + +/* + * This structure describes the channel type structure for TCP socket + * based IO: + */ + +static Tcl_ChannelType tcpChannelType = { + "tcp", /* Type name. */ + TcpBlockModeProc, /* Set blocking/nonblocking mode.*/ + TcpCloseProc, /* Close proc. */ + TcpInputProc, /* Input proc. */ + TcpOutputProc, /* Output proc. */ + NULL, /* Seek proc. */ + NULL, /* Set option proc. */ + TcpGetOptionProc, /* Get option proc. */ + TcpWatchProc, /* Initialize notifier. */ + TcpReadyProc, /* Are there events? */ + TcpGetProc, /* Get Tcl_Files out of channel. */ +}; + +/* + *---------------------------------------------------------------------- + * + * FileBlockModeProc -- + * + * Helper procedure to set blocking and nonblocking modes on a + * file based channel. Invoked by generic IO level code. + * + * Results: + * 0 if successful, errno when failed. + * + * Side effects: + * Sets the device into blocking or non-blocking mode. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +FileBlockModeProc(instanceData, mode) + ClientData instanceData; /* File state. */ + int mode; /* The mode to set. Can be one of + * TCL_MODE_BLOCKING or + * TCL_MODE_NONBLOCKING. */ +{ + FileState *fsPtr = (FileState *) instanceData; + int curStatus; + int fd; + +#ifndef USE_FIONBIO + if (fsPtr->inFile != NULL) { + fd = (int) Tcl_GetFileInfo(fsPtr->inFile, NULL); + curStatus = fcntl(fd, F_GETFL); + if (mode == TCL_MODE_BLOCKING) { + curStatus &= (~(O_NONBLOCK)); + } else { + curStatus |= O_NONBLOCK; + } + if (fcntl(fd, F_SETFL, curStatus) < 0) { + return errno; + } + curStatus = fcntl(fd, F_GETFL); + } + if (fsPtr->outFile != NULL) { + fd = (int) Tcl_GetFileInfo(fsPtr->outFile, NULL); + curStatus = fcntl(fd, F_GETFL); + if (mode == TCL_MODE_BLOCKING) { + curStatus &= (~(O_NONBLOCK)); + } else { + curStatus |= O_NONBLOCK; + } + if (fcntl(fd, F_SETFL, curStatus) < 0) { + return errno; + } + } +#endif + +#ifdef USE_FIONBIO + if (fsPtr->inFile != NULL) { + fd = (int) Tcl_GetFileInfo(fsPtr->inFile, NULL); + if (mode == TCL_MODE_BLOCKING) { + curStatus = 0; + } else { + curStatus = 1; + } + if (ioctl(fd, (int) FIONBIO, &curStatus) < 0) { + return errno; + } + } + if (fsPtr->outFile != NULL) { + fd = (int) Tcl_GetFileInfo(fsPtr->outFile, NULL); + if (mode == TCL_MODE_BLOCKING) { + curStatus = 0; + } else { + curStatus = 1; + } + if (ioctl(fd, (int) FIONBIO, &curStatus) < 0) { + return errno; + } + } +#endif + + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * FileInputProc -- + * + * This procedure is invoked from the generic IO level to read + * input from a file based channel. + * + * Results: + * The number of bytes read is returned or -1 on error. An output + * argument contains a POSIX error code if an error occurs, or zero. + * + * Side effects: + * Reads input from the input device of the channel. + * + *---------------------------------------------------------------------- + */ + +static int +FileInputProc(instanceData, buf, toRead, errorCodePtr) + ClientData instanceData; /* File state. */ + char *buf; /* Where to store data read. */ + int toRead; /* How much space is available + * in the buffer? */ + int *errorCodePtr; /* Where to store error code. */ +{ + FileState *fsPtr = (FileState *) instanceData; + int fd; /* The OS handle for reading. */ + int bytesRead; /* How many bytes were actually + * read from the input device? */ + + *errorCodePtr = 0; + fd = (int) Tcl_GetFileInfo(fsPtr->inFile, NULL); + + /* + * Assume there is always enough input available. This will block + * appropriately, and read will unblock as soon as a short read is + * possible, if the channel is in blocking mode. If the channel is + * nonblocking, the read will never block. + */ + + bytesRead = read(fd, buf, (size_t) toRead); + if (bytesRead > -1) { + return bytesRead; + } + *errorCodePtr = errno; + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * FileOutputProc-- + * + * This procedure is invoked from the generic IO level to write + * output to a file channel. + * + * Results: + * The number of bytes written is returned or -1 on error. An + * output argument contains a POSIX error code if an error occurred, + * or zero. + * + * Side effects: + * Writes output on the output device of the channel. + * + *---------------------------------------------------------------------- + */ + +static int +FileOutputProc(instanceData, buf, toWrite, errorCodePtr) + ClientData instanceData; /* File state. */ + char *buf; /* The data buffer. */ + int toWrite; /* How many bytes to write? */ + int *errorCodePtr; /* Where to store error code. */ +{ + FileState *fsPtr = (FileState *) instanceData; + int written; + int fd; + + *errorCodePtr = 0; + fd = (int) Tcl_GetFileInfo(fsPtr->outFile, NULL); + written = write(fd, buf, (size_t) toWrite); + if (written > -1) { + return written; + } + *errorCodePtr = errno; + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * FileCloseProc -- + * + * This procedure is called from the generic IO level to perform + * channel-type-specific cleanup when a file based channel is closed. + * + * Results: + * 0 if successful, errno if failed. + * + * Side effects: + * Closes the device of the channel. + * + *---------------------------------------------------------------------- + */ + +static int +FileCloseProc(instanceData, interp) + ClientData instanceData; /* File state. */ + Tcl_Interp *interp; /* For error reporting - unused. */ +{ + FileState *fsPtr = (FileState *) instanceData; + int fd, errorCode = 0; + + if (fsPtr->inFile != NULL) { + + /* + * Check for read/write file so we only close it once. + */ + + if (fsPtr->inFile == fsPtr->outFile) { + fsPtr->outFile = NULL; + } + fd = (int) Tcl_GetFileInfo(fsPtr->inFile, NULL); + Tcl_FreeFile(fsPtr->inFile); + if (close(fd) < 0) { + errorCode = errno; + } + } + + if (fsPtr->outFile != NULL) { + fd = (int) Tcl_GetFileInfo(fsPtr->outFile, NULL); + Tcl_FreeFile(fsPtr->outFile); + if ((close(fd) < 0) && (errorCode == 0)) { + errorCode = errno; + } + } + + ckfree((char *) fsPtr); + + return errorCode; +} + +/* + *---------------------------------------------------------------------- + * + * FileSeekProc -- + * + * This procedure is called by the generic IO level to move the + * access point in a file based channel. + * + * Results: + * -1 if failed, the new position if successful. An output + * argument contains the POSIX error code if an error occurred, + * or zero. + * + * Side effects: + * Moves the location at which the channel will be accessed in + * future operations. + * + *---------------------------------------------------------------------- + */ + +static int +FileSeekProc(instanceData, offset, mode, errorCodePtr) + ClientData instanceData; /* File state. */ + long offset; /* Offset to seek to. */ + int mode; /* Relative to where + * should we seek? Can be + * one of SEEK_START, + * SEEK_SET or SEEK_END. */ + int *errorCodePtr; /* To store error code. */ +{ + FileState *fsPtr = (FileState *) instanceData; + int newLoc; + int fd; + + *errorCodePtr = 0; + if (fsPtr->inFile != (Tcl_File) NULL) { + fd = (int) Tcl_GetFileInfo(fsPtr->inFile, NULL); + } else if (fsPtr->outFile != (Tcl_File) NULL) { + fd = (int) Tcl_GetFileInfo(fsPtr->outFile, NULL); + } else { + *errorCodePtr = EFAULT; + return -1; + } + newLoc = lseek(fd, offset, mode); + if (newLoc > -1) { + return newLoc; + } + *errorCodePtr = errno; + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * FileWatchProc -- + * + * Initialize the notifier to watch Tcl_Files from this channel. + * + * Results: + * None. + * + * Side effects: + * Sets up the notifier so that a future event on the channel will + * be seen by Tcl. + * + *---------------------------------------------------------------------- + */ + +static void +FileWatchProc(instanceData, mask) + ClientData instanceData; /* The file state. */ + int mask; /* Events of interest; an OR-ed + * combination of TCL_READABLE, + * TCL_WRITABLE and TCL_EXCEPTION. */ +{ + FileState *fsPtr = (FileState *) instanceData; + + if ((mask & TCL_READABLE) && (fsPtr->inFile != (Tcl_File) NULL)) { + Tcl_WatchFile(fsPtr->inFile, TCL_READABLE); + } + if ((mask & TCL_WRITABLE) && (fsPtr->outFile != (Tcl_File) NULL)) { + Tcl_WatchFile(fsPtr->outFile, TCL_WRITABLE); + } + + if (mask & TCL_EXCEPTION) { + if (fsPtr->inFile != (Tcl_File) NULL) { + Tcl_WatchFile(fsPtr->inFile, TCL_EXCEPTION); + } + if (fsPtr->outFile != (Tcl_File) NULL) { + Tcl_WatchFile(fsPtr->outFile, TCL_EXCEPTION); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * FileReadyProc -- + * + * Called by the notifier to check whether events of interest are + * present on the channel. + * + * Results: + * Returns OR-ed combination of TCL_READABLE, TCL_WRITABLE and + * TCL_EXCEPTION to indicate which events of interest are present. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +FileReadyProc(instanceData, mask) + ClientData instanceData; /* The file state. */ + int mask; /* Events of interest; an OR-ed + * combination of TCL_READABLE, + * TCL_WRITABLE and TCL_EXCEPTION. */ +{ + FileState *fsPtr = (FileState *) instanceData; + int present = 0; + + if ((mask & TCL_READABLE) && (fsPtr->inFile != (Tcl_File) NULL)) { + present |= Tcl_FileReady(fsPtr->inFile, TCL_READABLE); + } + if ((mask & TCL_WRITABLE) && (fsPtr->outFile != (Tcl_File) NULL)) { + present |= Tcl_FileReady(fsPtr->outFile, TCL_WRITABLE); + } + if (mask & TCL_EXCEPTION) { + if (fsPtr->inFile != (Tcl_File) NULL) { + present |= Tcl_FileReady(fsPtr->inFile, TCL_EXCEPTION); + } + if (fsPtr->outFile != (Tcl_File) NULL) { + present |= Tcl_FileReady(fsPtr->outFile, TCL_EXCEPTION); + } + } + return present; +} + +/* + *---------------------------------------------------------------------- + * + * FileGetProc -- + * + * Called from Tcl_GetChannelFile to retrieve Tcl_Files from inside + * a file based channel. + * + * Results: + * The appropriate Tcl_File or NULL if not present. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tcl_File +FileGetProc(instanceData, direction) + ClientData instanceData; /* The file state. */ + int direction; /* Which Tcl_File to retrieve? */ +{ + FileState *fsPtr = (FileState *) instanceData; + + if (direction == TCL_READABLE) { + return fsPtr->inFile; + } + if (direction == TCL_WRITABLE) { + return fsPtr->outFile; + } + return (Tcl_File) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetAndDetachPids -- + * + * This procedure is invoked in the generic implementation of a + * background "exec" (An exec when invoked with a terminating "&") + * to store a list of the PIDs for processes in a command pipeline + * in interp->result and to detach the processes. + * + * Results: + * None. + * + * Side effects: + * Modifies interp->result. Detaches processes. + * + *---------------------------------------------------------------------- + */ + +void +TclGetAndDetachPids(interp, chan) + Tcl_Interp *interp; + Tcl_Channel chan; +{ + PipeState *pipePtr; + Tcl_ChannelType *chanTypePtr; + int i; + char buf[20]; + + /* + * Punt if the channel is not a command channel. + */ + + chanTypePtr = Tcl_GetChannelType(chan); + if (chanTypePtr != &pipeChannelType) { + return; + } + + pipePtr = (PipeState *) Tcl_GetChannelInstanceData(chan); + for (i = 0; i < pipePtr->numPids; i++) { + sprintf(buf, "%d", pipePtr->pidPtr[i]); + Tcl_AppendElement(interp, buf); + Tcl_DetachPids(1, &(pipePtr->pidPtr[i])); + } + if (pipePtr->numPids > 0) { + ckfree((char *) pipePtr->pidPtr); + pipePtr->numPids = 0; + } +} + +/* + *---------------------------------------------------------------------- + * + * PipeBlockModeProc -- + * + * Helper procedure to set blocking and nonblocking modes on a + * pipe based channel. Invoked by generic IO level code. + * + * Results: + * 0 if successful, errno when failed. + * + * Side effects: + * Sets the device into blocking or non-blocking mode. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +PipeBlockModeProc(instanceData, mode) + ClientData instanceData; /* Pipe state. */ + int mode; /* The mode to set. Can be one of + * TCL_MODE_BLOCKING or + * TCL_MODE_NONBLOCKING. */ +{ + PipeState *psPtr = (PipeState *) instanceData; + int curStatus; + int fd; + +#ifndef USE_FIONBIO + if (psPtr->inFile != NULL) { + fd = (int) Tcl_GetFileInfo(psPtr->inFile, NULL); + curStatus = fcntl(fd, F_GETFL); + if (mode == TCL_MODE_BLOCKING) { + curStatus &= (~(O_NONBLOCK)); + } else { + curStatus |= O_NONBLOCK; + } + if (fcntl(fd, F_SETFL, curStatus) < 0) { + return errno; + } + curStatus = fcntl(fd, F_GETFL); + } + if (psPtr->outFile != NULL) { + fd = (int) Tcl_GetFileInfo(psPtr->outFile, NULL); + curStatus = fcntl(fd, F_GETFL); + if (mode == TCL_MODE_BLOCKING) { + curStatus &= (~(O_NONBLOCK)); + } else { + curStatus |= O_NONBLOCK; + } + if (fcntl(fd, F_SETFL, curStatus) < 0) { + return errno; + } + } +#endif /* !FIONBIO */ + +#ifdef USE_FIONBIO + if (psPtr->inFile != NULL) { + fd = (int) Tcl_GetFileInfo(psPtr->inFile, NULL); + if (mode == TCL_MODE_BLOCKING) { + curStatus = 0; + } else { + curStatus = 1; + } + if (ioctl(fd, (int) FIONBIO, &curStatus) < 0) { + return errno; + } + } + if (psPtr->outFile != NULL) { + fd = (int) Tcl_GetFileInfo(psPtr->outFile, NULL); + if (mode == TCL_MODE_BLOCKING) { + curStatus = 0; + } else { + curStatus = 1; + } + if (ioctl(fd, (int) FIONBIO, &curStatus) < 0) { + return errno; + } + } +#endif /* USE_FIONBIO */ + + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * PipeCloseProc -- + * + * This procedure is invoked by the generic IO level to perform + * channel-type-specific cleanup when a command pipeline channel + * is closed. + * + * Results: + * 0 on success, errno otherwise. + * + * Side effects: + * Closes the command pipeline channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +PipeCloseProc(instanceData, interp) + ClientData instanceData; /* The pipe to close. */ + Tcl_Interp *interp; /* For error reporting. */ +{ + PipeState *pipePtr; + FileState *fsPtr; + Tcl_Channel errChan; + int fd, errorCode, result; + + errorCode = 0; + result = 0; + pipePtr = (PipeState *) instanceData; + if (pipePtr->inFile != NULL) { + fd = (int) Tcl_GetFileInfo(pipePtr->inFile, NULL); + Tcl_FreeFile(pipePtr->inFile); + if (close(fd) < 0) { + errorCode = errno; + } + } + if (pipePtr->outFile != NULL) { + fd = (int) Tcl_GetFileInfo(pipePtr->outFile, NULL); + Tcl_FreeFile(pipePtr->outFile); + if ((close(fd) < 0) && (errorCode == 0)) { + errorCode = errno; + } + } + + if (pipePtr->isNonBlocking) { + + /* + * If the channel is non-blocking, just detach the children PIDs + * and discard the errorFile. + */ + + Tcl_DetachPids(pipePtr->numPids, pipePtr->pidPtr); + if (pipePtr->errorFile != NULL) { + Tcl_FreeFile(pipePtr->errorFile); + } + } else { + + /* + * Wrap the error file into a channel and give it to the cleanup + * routine. + */ + + if (pipePtr->errorFile != NULL) { + fsPtr = (FileState *) ckalloc((unsigned) sizeof(FileState)); + fsPtr->inFile = pipePtr->errorFile; + fsPtr->outFile = (Tcl_File) NULL; + errChan = Tcl_CreateChannel(&fileChannelType, "pipeError", + (ClientData) fsPtr, TCL_READABLE); + } else { + errChan = NULL; + } + result = TclCleanupChildren(interp, pipePtr->numPids, pipePtr->pidPtr, + errChan); + } + + if (pipePtr->numPids != 0) { + ckfree((char *) pipePtr->pidPtr); + } + ckfree((char *) pipePtr); + if (errorCode == 0) { + return result; + } + return errorCode; +} + +/* + *---------------------------------------------------------------------- + * + * PipeInputProc -- + * + * This procedure is invoked from the generic IO level to read + * input from a command pipeline based channel. + * + * Results: + * The number of bytes read is returned or -1 on error. An output + * argument contains a POSIX error code if an error occurs, or zero. + * + * Side effects: + * Reads input from the input device of the channel. + * + *---------------------------------------------------------------------- + */ + +static int +PipeInputProc(instanceData, buf, toRead, errorCodePtr) + ClientData instanceData; /* Pipe state. */ + char *buf; /* Where to store data read. */ + int toRead; /* How much space is available + * in the buffer? */ + int *errorCodePtr; /* Where to store error code. */ +{ + PipeState *psPtr = (PipeState *) instanceData; + int fd; /* The OS handle for reading. */ + int bytesRead; /* How many bytes were actually + * read from the input device? */ + + *errorCodePtr = 0; + fd = (int) Tcl_GetFileInfo(psPtr->inFile, NULL); + + /* + * Assume there is always enough input available. This will block + * appropriately, and read will unblock as soon as a short read is + * possible, if the channel is in blocking mode. If the channel is + * nonblocking, the read will never block. + */ + + bytesRead = read(fd, buf, (size_t) toRead); + if (bytesRead > -1) { + return bytesRead; + } + *errorCodePtr = errno; + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * PipeOutputProc-- + * + * This procedure is invoked from the generic IO level to write + * output to a command pipeline based channel. + * + * Results: + * The number of bytes written is returned or -1 on error. An + * output argument contains a POSIX error code if an error occurred, + * or zero. + * + * Side effects: + * Writes output on the output device of the channel. + * + *---------------------------------------------------------------------- + */ + +static int +PipeOutputProc(instanceData, buf, toWrite, errorCodePtr) + ClientData instanceData; /* Pipe state. */ + char *buf; /* The data buffer. */ + int toWrite; /* How many bytes to write? */ + int *errorCodePtr; /* Where to store error code. */ +{ + PipeState *psPtr = (PipeState *) instanceData; + int written; + int fd; + + *errorCodePtr = 0; + fd = (int) Tcl_GetFileInfo(psPtr->outFile, NULL); + written = write(fd, buf, (size_t) toWrite); + if (written > -1) { + return written; + } + *errorCodePtr = errno; + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * PipeWatchProc -- + * + * Initialize the notifier to watch Tcl_Files from this channel. + * + * Results: + * None. + * + * Side effects: + * Sets up the notifier so that a future event on the channel will + * be seen by Tcl. + * + *---------------------------------------------------------------------- + */ + +static void +PipeWatchProc(instanceData, mask) + ClientData instanceData; /* The pipe state. */ + int mask; /* Events of interest; an OR-ed + * combination of TCL_READABLE, + * TCL_WRITABEL and TCL_EXCEPTION. */ +{ + PipeState *psPtr = (PipeState *) instanceData; + + if ((mask & TCL_READABLE) && (psPtr->inFile != (Tcl_File) NULL)) { + Tcl_WatchFile(psPtr->inFile, TCL_READABLE); + } + if ((mask & TCL_WRITABLE) && (psPtr->outFile != (Tcl_File) NULL)) { + Tcl_WatchFile(psPtr->outFile, TCL_WRITABLE); + } + + if (mask & TCL_EXCEPTION) { + if (psPtr->inFile != (Tcl_File) NULL) { + Tcl_WatchFile(psPtr->inFile, TCL_EXCEPTION); + } + if (psPtr->outFile != (Tcl_File) NULL) { + Tcl_WatchFile(psPtr->outFile, TCL_EXCEPTION); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * PipeReadyProc -- + * + * Called by the notifier to check whether events of interest are + * present on the channel. + * + * Results: + * Returns OR-ed combination of TCL_READABLE, TCL_WRITABLE and + * TCL_EXCEPTION to indicate which events of interest are present. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +PipeReadyProc(instanceData, mask) + ClientData instanceData; /* The pipe state. */ + int mask; /* Events of interest; an OR-ed + * combination of TCL_READABLE, + * TCL_WRITABLE and TCL_EXCEPTION. */ +{ + PipeState *psPtr = (PipeState *) instanceData; + int present = 0; + + if ((mask & TCL_READABLE) && (psPtr->inFile != (Tcl_File) NULL)) { + present |= Tcl_FileReady(psPtr->inFile, TCL_READABLE); + } + if ((mask & TCL_WRITABLE) && (psPtr->outFile != (Tcl_File) NULL)) { + present |= Tcl_FileReady(psPtr->outFile, TCL_WRITABLE); + } + if (mask & TCL_EXCEPTION) { + if (psPtr->inFile != (Tcl_File) NULL) { + present |= Tcl_FileReady(psPtr->inFile, TCL_EXCEPTION); + } + if (psPtr->outFile != (Tcl_File) NULL) { + present |= Tcl_FileReady(psPtr->outFile, TCL_EXCEPTION); + } + } + return present; +} + +/* + *---------------------------------------------------------------------- + * + * PipeGetProc -- + * + * Called from Tcl_GetChannelFile to retrieve Tcl_Files from inside + * a command pipeline based channel. + * + * Results: + * The appropriate Tcl_File or NULL if not present. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tcl_File +PipeGetProc(instanceData, direction) + ClientData instanceData; /* The pipe state. */ + int direction; /* Which Tcl_File to retrieve? */ +{ + PipeState *psPtr = (PipeState *) instanceData; + + if (direction == TCL_READABLE) { + return psPtr->inFile; + } + if (direction == TCL_WRITABLE) { + return psPtr->outFile; + } + return (Tcl_File) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_OpenFileChannel -- + * + * Open an file based channel on Unix systems. + * + * Results: + * The new channel or NULL. If NULL, the output argument + * errorCodePtr is set to a POSIX error and an error message is + * left in interp->result if interp is not NULL. + * + * Side effects: + * May open the channel and may cause creation of a file on the + * file system. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_OpenFileChannel(interp, fileName, modeString, permissions) + Tcl_Interp *interp; /* Interpreter for error reporting; + * can be NULL. */ + char *fileName; /* Name of file to open. */ + char *modeString; /* A list of POSIX open modes or + * a string such as "rw". */ + int permissions; /* If the open involves creating a + * file, with what modes to create + * it? */ +{ + int fd, seekFlag, mode, channelPermissions; + Tcl_File file; + FileState *fsPtr; + Tcl_Channel chan; + char *nativeName, channelName[20]; + Tcl_DString buffer; + + mode = TclGetOpenMode(interp, modeString, &seekFlag); + if (mode == -1) { + return NULL; + } + switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) { + case O_RDONLY: + channelPermissions = TCL_READABLE; + break; + case O_WRONLY: + channelPermissions = TCL_WRITABLE; + break; + case O_RDWR: + channelPermissions = (TCL_READABLE | TCL_WRITABLE); + break; + default: + /* + * This may occurr if modeString was "", for example. + */ + panic("Tcl_OpenFileChannel: invalid mode value"); + return NULL; + } + + nativeName = Tcl_TranslateFileName(interp, fileName, &buffer); + if (nativeName == NULL) { + return NULL; + } + fd = open(nativeName, mode, permissions); + + /* + * If nativeName is not NULL, the buffer is valid and we must free + * the storage. + */ + + Tcl_DStringFree(&buffer); + + if (fd < 0) { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "couldn't open \"", fileName, "\": ", + Tcl_PosixError(interp), (char *) NULL); + } + return NULL; + } + + /* + * Set close-on-exec flag on the fd so that child processes will not + * inherit this fd. + */ + + fcntl(fd, F_SETFD, FD_CLOEXEC); + + sprintf(channelName, "file%d", fd); + file = Tcl_GetFile((ClientData) fd, TCL_UNIX_FD); + + fsPtr = (FileState *) ckalloc((unsigned) sizeof(FileState)); + if (channelPermissions & TCL_READABLE) { + fsPtr->inFile = file; + } else { + fsPtr->inFile = (Tcl_File) NULL; + } + if (channelPermissions & TCL_WRITABLE) { + fsPtr->outFile = file; + } else { + fsPtr->outFile = (Tcl_File) NULL; + } + chan = Tcl_CreateChannel(&fileChannelType, channelName, + (ClientData) fsPtr, channelPermissions); + + /* + * The channel may not be open now, for example if we tried to + * open a file with permissions that cannot be satisfied. + */ + + if (chan == (Tcl_Channel) NULL) { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "couldn't create channel \"", + channelName, "\": ", Tcl_PosixError(interp), + (char *) NULL); + } + Tcl_FreeFile(file); + close(fd); + return NULL; + } + + if (seekFlag) { + if (Tcl_Seek(chan, 0, SEEK_END) < 0) { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "couldn't seek to end of file on \"", + channelName, "\": ", Tcl_PosixError(interp), + (char *) NULL); + } + Tcl_Close(NULL, chan); + return NULL; + } + } + return chan; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_MakeFileChannel -- + * + * Makes a Tcl_Channel from an existing OS level file handle. + * + * Results: + * The Tcl_Channel created around the preexisting OS level file handle. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_MakeFileChannel(inFd, outFd, mode) + ClientData inFd; /* OS level handle used for input. */ + ClientData outFd; /* OS level handle used for output. */ + int mode; /* ORed combination of TCL_READABLE and + * TCL_WRITABLE to indicate whether inFile + * and/or outFile are valid. */ +{ + Tcl_Channel chan; + int fileUsed; + Tcl_File inFile, outFile; + FileState *fsPtr; + char channelName[20]; + + if (mode == 0) { + return (Tcl_Channel) NULL; + } + + inFile = (Tcl_File) NULL; + outFile = (Tcl_File) NULL; + + if (mode & TCL_READABLE) { + sprintf(channelName, "file%d", (int) inFd); + inFile = Tcl_GetFile(inFd, TCL_UNIX_FD); + } + + if (mode & TCL_WRITABLE) { + sprintf(channelName, "file%d", (int) outFd); + outFile = Tcl_GetFile(outFd, TCL_UNIX_FD); + } + + /* + * Look to see if a channel with those two Tcl_Files already exists. + * If so, return it. + */ + + chan = TclFindFileChannel(inFile, outFile, &fileUsed); + if (chan != (Tcl_Channel) NULL) { + return chan; + } + + /* + * If one of the Tcl_Files is used in another channel, do not + * create a new channel containing it; this avoids core dumps + * later, when the Tcl_File would be freed twice. + */ + + if (fileUsed) { + return (Tcl_Channel) NULL; + } + fsPtr = (FileState *) ckalloc((unsigned) sizeof(FileState)); + fsPtr->inFile = inFile; + fsPtr->outFile = outFile; + + return Tcl_CreateChannel(&fileChannelType, channelName, + (ClientData) fsPtr, mode); +} + +/* + *---------------------------------------------------------------------- + * + * TclCreateCommandChannel -- + * + * This function is called by the generic IO level to perform + * the platform specific channel initialization for a command + * channel. + * + * Results: + * Returns a new channel or NULL on failure. + * + * Side effects: + * Allocates a new channel. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +TclCreateCommandChannel(readFile, writeFile, errorFile, numPids, pidPtr) + Tcl_File readFile; /* If non-null, gives the file for reading. */ + Tcl_File writeFile; /* If non-null, gives the file for writing. */ + Tcl_File errorFile; /* If non-null, gives the file where errors + * can be read. */ + int numPids; /* The number of pids in the pid array. */ + int *pidPtr; /* An array of process identifiers. + * Allocated by the caller, freed when + * the channel is closed or the processes + * are detached (in a background exec). */ +{ + Tcl_Channel channel; + char channelName[20]; + int channelId; + PipeState *statePtr = (PipeState *) ckalloc((unsigned) sizeof(PipeState)); + int mode; + + statePtr->inFile = readFile; + statePtr->outFile = writeFile; + statePtr->errorFile = errorFile; + statePtr->numPids = numPids; + statePtr->pidPtr = pidPtr; + statePtr->isNonBlocking = 0; + + mode = 0; + if (readFile != (Tcl_File) NULL) { + mode |= TCL_READABLE; + } + if (writeFile != (Tcl_File) NULL) { + mode |= TCL_WRITABLE; + } + + /* + * Use one of the fds associated with the channel as the + * channel id. + */ + + if (readFile) { + channelId = (int) Tcl_GetFileInfo(readFile, NULL); + } else if (writeFile) { + channelId = (int) Tcl_GetFileInfo(writeFile, NULL); + } else if (errorFile) { + channelId = (int) Tcl_GetFileInfo(errorFile, NULL); + } else { + channelId = 0; + } + + /* + * For backward compatibility with previous versions of Tcl, we + * use "file%d" as the base name for pipes even though it would + * be more natural to use "pipe%d". + */ + + sprintf(channelName, "file%d", channelId); + channel = Tcl_CreateChannel(&pipeChannelType, channelName, + (ClientData) statePtr, mode); + + if (channel == NULL) { + + /* + * pidPtr will be freed by the caller if the return value is NULL. + */ + + ckfree((char *)statePtr); + } + return channel; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PidCmd -- + * + * This procedure is invoked to process the "pid" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_PidCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Channel chan; /* The channel to get pids for. */ + Tcl_ChannelType *chanTypePtr; /* The type of that channel. */ + PipeState *pipePtr; /* The pipe state. */ + int i; /* Loops over PIDs attached to the + * pipe. */ + char string[50]; /* Temp buffer for string rep. of + * PIDs attached to the pipe. */ + + if (argc > 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " ?channelId?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 1) { + sprintf(interp->result, "%ld", (long) getpid()); + } else { + chan = Tcl_GetChannel(interp, argv[1], NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + chanTypePtr = Tcl_GetChannelType(chan); + if (chanTypePtr != &pipeChannelType) { + return TCL_OK; + } + pipePtr = (PipeState *) Tcl_GetChannelInstanceData(chan); + for (i = 0; i < pipePtr->numPids; i++) { + sprintf(string, "%d", pipePtr->pidPtr[i]); + Tcl_AppendElement(interp, string); + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TcpBlockModeProc -- + * + * This procedure is invoked by the generic IO level to set blocking + * and nonblocking mode on a TCP socket based channel. + * + * Results: + * 0 if successful, errno when failed. + * + * Side effects: + * Sets the device into blocking or nonblocking mode. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TcpBlockModeProc(instanceData, mode) + ClientData instanceData; /* Socket state. */ + int mode; /* The mode to set. Can be one of + * TCL_MODE_BLOCKING or + * TCL_MODE_NONBLOCKING. */ +{ + TcpState *statePtr; + int sock; + int setting; + + statePtr = (TcpState *) instanceData; + sock = (int) Tcl_GetFileInfo(statePtr->sock, NULL); +#ifndef USE_FIONBIO + setting = fcntl(sock, F_GETFL); + if (mode == TCL_MODE_BLOCKING) { + statePtr->flags &= (~(TCP_ASYNC_SOCKET)); + setting &= (~(O_NONBLOCK)); + } else { + statePtr->flags |= TCP_ASYNC_SOCKET; + setting |= O_NONBLOCK; + } + if (fcntl(sock, F_SETFL, setting) < 0) { + return errno; + } +#endif + +#ifdef USE_FIONBIO + if (mode == TCL_MODE_BLOCKING) { + statePtr->flags &= (~(TCP_ASYNC_SOCKET)); + setting = 0; + if (ioctl(sock, (int) FIONBIO, &setting) == -1) { + return errno; + } + } else { + statePtr->flags |= TCP_ASYNC_SOCKET; + setting = 1; + if (ioctl(sock, (int) FIONBIO, &setting) == -1) { + return errno; + } + } +#endif + + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * WaitForConnect -- + * + * Waits for a connection on an asynchronously opened socket to + * be completed. + * + * Results: + * None. + * + * Side effects: + * The socket is connected after this function returns. + * + *---------------------------------------------------------------------- + */ + +static int +WaitForConnect(statePtr, errorCodePtr) + TcpState *statePtr; /* State of the socket. */ + int *errorCodePtr; /* Where to store errors? */ +{ + int sock; /* The socket itself. */ + int timeOut; /* How long to wait. */ + int state; /* Of calling TclWaitForFile. */ + int flags; /* fcntl flags for the socket. */ + + /* + * If an asynchronous connect is in progress, attempt to wait for it + * to complete before reading. + */ + + if (statePtr->flags & TCP_ASYNC_CONNECT) { + if (statePtr->flags & TCP_ASYNC_SOCKET) { + timeOut = 0; + } else { + timeOut = -1; + } + errno = 0; + state = TclWaitForFile(statePtr->sock, TCL_WRITABLE | TCL_EXCEPTION, + timeOut); + if (!(statePtr->flags & TCP_ASYNC_SOCKET)) { + sock = (int) Tcl_GetFileInfo(statePtr->sock, NULL); +#ifndef USE_FIONBIO + flags = fcntl(sock, F_GETFL); + flags &= (~(O_NONBLOCK)); + (void) fcntl(sock, F_SETFL, flags); +#endif + +#ifdef USE_FIONBIO + flags = 0; + (void) ioctl(sock, FIONBIO, &flags); +#endif + } + if (state & TCL_EXCEPTION) { + return -1; + } + if (state & TCL_WRITABLE) { + statePtr->flags &= (~(TCP_ASYNC_CONNECT)); + } else if (timeOut == 0) { + *errorCodePtr = errno = EWOULDBLOCK; + return -1; + } + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * TcpInputProc -- + * + * This procedure is invoked by the generic IO level to read input + * from a TCP socket based channel. + * + * NOTE: We cannot share code with FilePipeInputProc because here + * we must use recv to obtain the input from the channel, not read. + * + * Results: + * The number of bytes read is returned or -1 on error. An output + * argument contains the POSIX error code on error, or zero if no + * error occurred. + * + * Side effects: + * Reads input from the input device of the channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TcpInputProc(instanceData, buf, bufSize, errorCodePtr) + ClientData instanceData; /* Socket state. */ + char *buf; /* Where to store data read. */ + int bufSize; /* How much space is available + * in the buffer? */ + int *errorCodePtr; /* Where to store error code. */ +{ + TcpState *statePtr; /* The state of the socket. */ + int sock; /* The OS handle. */ + int bytesRead; /* How many bytes were read? */ + int state; /* Of waiting for connection. */ + + *errorCodePtr = 0; + statePtr = (TcpState *) instanceData; + sock = (int) Tcl_GetFileInfo(statePtr->sock, NULL); + + state = WaitForConnect(statePtr, errorCodePtr); + if (state != 0) { + return -1; + } + bytesRead = recv(sock, buf, bufSize, 0); + if (bytesRead > -1) { + return bytesRead; + } + if (errno == ECONNRESET) { + + /* + * Turn ECONNRESET into a soft EOF condition. + */ + + return 0; + } + *errorCodePtr = errno; + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * TcpOutputProc -- + * + * This procedure is invoked by the generic IO level to write output + * to a TCP socket based channel. + * + * NOTE: We cannot share code with FilePipeOutputProc because here + * we must use send, not write, to get reliable error reporting. + * + * Results: + * The number of bytes written is returned. An output argument is + * set to a POSIX error code if an error occurred, or zero. + * + * Side effects: + * Writes output on the output device of the channel. + * + *---------------------------------------------------------------------- + */ + +static int +TcpOutputProc(instanceData, buf, toWrite, errorCodePtr) + ClientData instanceData; /* Socket state. */ + char *buf; /* The data buffer. */ + int toWrite; /* How many bytes to write? */ + int *errorCodePtr; /* Where to store error code. */ +{ + TcpState *statePtr; + int written; + int sock; /* OS level socket. */ + int state; /* Of waiting for connection. */ + + *errorCodePtr = 0; + statePtr = (TcpState *) instanceData; + sock = (int) Tcl_GetFileInfo(statePtr->sock, NULL); + state = WaitForConnect(statePtr, errorCodePtr); + if (state != 0) { + return -1; + } + written = send(sock, buf, toWrite, 0); + if (written > -1) { + return written; + } + *errorCodePtr = errno; + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * TcpCloseProc -- + * + * This procedure is invoked by the generic IO level to perform + * channel-type-specific cleanup when a TCP socket based channel + * is closed. + * + * Results: + * 0 if successful, the value of errno if failed. + * + * Side effects: + * Closes the socket of the channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TcpCloseProc(instanceData, interp) + ClientData instanceData; /* The socket to close. */ + Tcl_Interp *interp; /* For error reporting - unused. */ +{ + TcpState *statePtr; + Tcl_File sockFile; + int sock; + int errorCode = 0; + + statePtr = (TcpState *) instanceData; + sockFile = statePtr->sock; + sock = (int) Tcl_GetFileInfo(sockFile, NULL); + + /* + * Delete a file handler that may be active for this socket if this + * is a server socket - the file handler was created automatically + * by Tcl as part of the mechanism to accept new client connections. + * Channel handlers are already deleted in the generic IO channel + * closing code that called this function, so we do not have to + * delete them here. + */ + + Tcl_DeleteFileHandler(sockFile); + + ckfree((char *) statePtr); + + /* + * We assume that inFile==outFile==sockFile and so + * we only clean up sockFile. + */ + + Tcl_FreeFile(sockFile); + + if (close(sock) < 0) { + errorCode = errno; + } + + return errorCode; +} + +/* + *---------------------------------------------------------------------- + * + * TcpGetOptionProc -- + * + * Computes an option value for a TCP socket based channel, or a + * list of all options and their values. + * + * Note: This code is based on code contributed by John Haxby. + * + * Results: + * A standard Tcl result. The value of the specified option or a + * list of all options and their values is returned in the + * supplied DString. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TcpGetOptionProc(instanceData, optionName, dsPtr) + ClientData instanceData; /* Socket state. */ + char *optionName; /* Name of the option to + * retrieve the value for, or + * NULL to get all options and + * their values. */ + Tcl_DString *dsPtr; /* Where to store the computed + * value; initialized by caller. */ +{ + TcpState *statePtr; + struct sockaddr_in sockname; + struct sockaddr_in peername; + struct hostent *hostEntPtr; + int sock; + size_t size = sizeof(struct sockaddr_in); + size_t len = 0; + char buf[128]; + + statePtr = (TcpState *) instanceData; + sock = (int) Tcl_GetFileInfo(statePtr->sock, NULL); + if (optionName != (char *) NULL) { + len = strlen(optionName); + } + + if ((len == 0) || + ((len > 1) && (optionName[1] == 'p') && + (strncmp(optionName, "-peername", len) == 0))) { + if (getpeername(sock, (struct sockaddr *) &peername, &size) >= 0) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-peername"); + Tcl_DStringStartSublist(dsPtr); + } + Tcl_DStringAppendElement(dsPtr, inet_ntoa(peername.sin_addr)); + hostEntPtr = gethostbyaddr((char *) &(peername.sin_addr), + sizeof(peername.sin_addr), AF_INET); + if (hostEntPtr != (struct hostent *) NULL) { + Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name); + } else { + Tcl_DStringAppendElement(dsPtr, inet_ntoa(peername.sin_addr)); + } + sprintf(buf, "%d", ntohs(peername.sin_port)); + Tcl_DStringAppendElement(dsPtr, buf); + if (len == 0) { + Tcl_DStringEndSublist(dsPtr); + } else { + return TCL_OK; + } + } + } + + if ((len == 0) || + ((len > 1) && (optionName[1] == 's') && + (strncmp(optionName, "-sockname", len) == 0))) { + if (getsockname(sock, (struct sockaddr *) &sockname, &size) >= 0) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-sockname"); + Tcl_DStringStartSublist(dsPtr); + } + Tcl_DStringAppendElement(dsPtr, inet_ntoa(sockname.sin_addr)); + hostEntPtr = gethostbyaddr((char *) &(sockname.sin_addr), + sizeof(peername.sin_addr), AF_INET); + if (hostEntPtr != (struct hostent *) NULL) { + Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name); + } else { + Tcl_DStringAppendElement(dsPtr, inet_ntoa(sockname.sin_addr)); + } + sprintf(buf, "%d", ntohs(sockname.sin_port)); + Tcl_DStringAppendElement(dsPtr, buf); + if (len == 0) { + Tcl_DStringEndSublist(dsPtr); + } else { + return TCL_OK; + } + } + } + + if (len > 0) { + Tcl_SetErrno(EINVAL); + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TcpWatchProc -- + * + * Initialize the notifier to watch Tcl_Files from this channel. + * + * Results: + * None. + * + * Side effects: + * Sets up the notifier so that a future event on the channel will + * be seen by Tcl. + * + *---------------------------------------------------------------------- + */ + +static void +TcpWatchProc(instanceData, mask) + ClientData instanceData; /* The socket state. */ + int mask; /* Events of interest; an OR-ed + * combination of TCL_READABLE, + * TCL_WRITABEL and TCL_EXCEPTION. */ +{ + TcpState *statePtr = (TcpState *) instanceData; + + Tcl_WatchFile(statePtr->sock, mask); +} + +/* + *---------------------------------------------------------------------- + * + * TcpReadyProc -- + * + * Called by the notifier to check whether events of interest are + * present on the channel. + * + * Results: + * Returns OR-ed combination of TCL_READABLE, TCL_WRITABLE and + * TCL_EXCEPTION to indicate which events of interest are present. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TcpReadyProc(instanceData, mask) + ClientData instanceData; /* The socket state. */ + int mask; /* Events of interest; an OR-ed + * combination of TCL_READABLE, + * TCL_WRITABLE and TCL_EXCEPTION. */ +{ + TcpState *statePtr = (TcpState *) instanceData; + + return Tcl_FileReady(statePtr->sock, mask); +} + +/* + *---------------------------------------------------------------------- + * + * TcpGetProc -- + * + * Called from Tcl_GetChannelFile to retrieve Tcl_Files from inside + * a TCP socket based channel. + * + * Results: + * The appropriate Tcl_File or NULL if not present. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static Tcl_File +TcpGetProc(instanceData, direction) + ClientData instanceData; /* The socket state. */ + int direction; /* Which Tcl_File to retrieve? */ +{ + TcpState *statePtr = (TcpState *) instanceData; + + return statePtr->sock; +} + +/* + *---------------------------------------------------------------------- + * + * CreateSocket -- + * + * This function opens a new socket in client or server mode + * and initializes the TcpState structure. + * + * Results: + * Returns a new TcpState, or NULL with an error in interp->result, + * if interp is not NULL. + * + * Side effects: + * Opens a socket. + * + *---------------------------------------------------------------------- + */ + +static TcpState * +CreateSocket(interp, port, host, server, myaddr, myport, async) + Tcl_Interp *interp; /* For error reporting; can be NULL. */ + int port; /* Port number to open. */ + char *host; /* Name of host on which to open port. + * NULL implies INADDR_ANY */ + int server; /* 1 if socket should be a server socket, + * else 0 for a client socket. */ + char *myaddr; /* Optional client-side address */ + int myport; /* Optional client-side port */ + int async; /* If nonzero and creating a client socket, + * attempt to do an async connect. Otherwise + * do a synchronous connect or bind. */ +{ + int status, sock, asyncConnect, curState, origState; + struct sockaddr_in sockaddr; /* socket address */ + struct sockaddr_in mysockaddr; /* Socket address for client */ + TcpState *statePtr; + + sock = -1; + origState = 0; + if (! CreateSocketAddress(&sockaddr, host, port)) { + goto addressError; + } + if ((myaddr != NULL || myport != 0) && + ! CreateSocketAddress(&mysockaddr, myaddr, myport)) { + goto addressError; + } + + sock = socket(AF_INET, SOCK_STREAM, 0); + if (sock < 0) { + goto addressError; + } + + /* + * Set the close-on-exec flag so that the socket will not get + * inherited by child processes. + */ + + fcntl(sock, F_SETFD, FD_CLOEXEC); + + /* + * Set kernel space buffering + */ + + TclSockMinimumBuffers(sock, SOCKET_BUFSIZE); + + asyncConnect = 0; + status = 0; + if (server) { + + /* + * Set up to reuse server addresses automatically and bind to the + * specified port. + */ + + status = 1; + (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, (char *) &status, + sizeof(status)); + status = bind(sock, (struct sockaddr *) &sockaddr, + sizeof(struct sockaddr)); + if (status != -1) { + status = listen(sock, TCL_LISTEN_LIMIT); + } + } else { + if (myaddr != NULL || myport != 0) { + curState = 1; + (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, + (char *) &curState, sizeof(curState)); + status = bind(sock, (struct sockaddr *) &mysockaddr, + sizeof(struct sockaddr)); + if (status < 0) { + goto bindError; + } + } + + /* + * Attempt to connect. The connect may fail at present with an + * EINPROGRESS but at a later time it will complete. The caller + * will set up a file handler on the socket if she is interested in + * being informed when the connect completes. + */ + + if (async) { +#ifndef USE_FIONBIO + origState = fcntl(sock, F_GETFL); + curState = origState | O_NONBLOCK; + status = fcntl(sock, F_SETFL, curState); +#endif + +#ifdef USE_FIONBIO + curState = 1; + status = ioctl(sock, FIONBIO, &curState); +#endif + } else { + status = 0; + } + if (status > -1) { + status = connect(sock, (struct sockaddr *) &sockaddr, + sizeof(sockaddr)); + if (status < 0) { + if (errno == EINPROGRESS) { + asyncConnect = 1; + status = 0; + } + } + } + } + +bindError: + if (status < 0) { + if (interp != NULL) { + Tcl_AppendResult(interp, "couldn't open socket: ", + Tcl_PosixError(interp), (char *) NULL); + } + if (sock != -1) { + close(sock); + } + return NULL; + } + + /* + * Allocate a new TcpState for this socket. + */ + + statePtr = (TcpState *) ckalloc((unsigned) sizeof(TcpState)); + statePtr->flags = 0; + if (asyncConnect) { + statePtr->flags = TCP_ASYNC_CONNECT; + } + statePtr->sock = Tcl_GetFile((ClientData) sock, TCL_UNIX_FD); + + return statePtr; + +addressError: + if (sock != -1) { + close(sock); + } + if (interp != NULL) { + Tcl_AppendResult(interp, "couldn't open socket: ", + Tcl_PosixError(interp), (char *) NULL); + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * CreateSocketAddress -- + * + * This function initializes a sockaddr structure for a host and port. + * + * Results: + * 1 if the host was valid, 0 if the host could not be converted to + * an IP address. + * + * Side effects: + * Fills in the *sockaddrPtr structure. + * + *---------------------------------------------------------------------- + */ + +static int +CreateSocketAddress(sockaddrPtr, host, port) + struct sockaddr_in *sockaddrPtr; /* Socket address */ + char *host; /* Host. NULL implies INADDR_ANY */ + int port; /* Port number */ +{ + struct hostent *hostent; /* Host database entry */ + struct in_addr addr; /* For 64/32 bit madness */ + + (void) memset((VOID *) sockaddrPtr, '\0', sizeof(struct sockaddr_in)); + sockaddrPtr->sin_family = AF_INET; + sockaddrPtr->sin_port = htons((unsigned short) (port & 0xFFFF)); + if (host == NULL) { + addr.s_addr = INADDR_ANY; + } else { + addr.s_addr = inet_addr(host); + if (addr.s_addr == -1) { + hostent = gethostbyname(host); + if (hostent != NULL) { + memcpy((VOID *) &addr, + (VOID *) hostent->h_addr_list[0], + (size_t) hostent->h_length); + } else { +#ifdef EHOSTUNREACH + errno = EHOSTUNREACH; +#else +#ifdef ENXIO + errno = ENXIO; +#endif +#endif + return 0; /* error */ + } + } + } + + /* + * NOTE: On 64 bit machines the assignment below is rumored to not + * do the right thing. Please report errors related to this if you + * observe incorrect behavior on 64 bit machines such as DEC Alphas. + * Should we modify this code to do an explicit memcpy? + */ + + sockaddrPtr->sin_addr.s_addr = addr.s_addr; + return 1; /* Success. */ +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_OpenTcpClient -- + * + * Opens a TCP client socket and creates a channel around it. + * + * Results: + * The channel or NULL if failed. An error message is returned + * in the interpreter on failure. + * + * Side effects: + * Opens a client socket and creates a new channel. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async) + Tcl_Interp *interp; /* For error reporting; can be NULL. */ + int port; /* Port number to open. */ + char *host; /* Host on which to open port. */ + char *myaddr; /* Client-side address */ + int myport; /* Client-side port */ + int async; /* If nonzero, attempt to do an + * asynchronous connect. Otherwise + * we do a blocking connect. */ +{ + Tcl_Channel chan; + TcpState *statePtr; + char channelName[20]; + + /* + * Create a new client socket and wrap it in a channel. + */ + + statePtr = CreateSocket(interp, port, host, 0, myaddr, myport, async); + if (statePtr == NULL) { + return NULL; + } + + statePtr->acceptProc = NULL; + statePtr->acceptProcData = (ClientData) NULL; + + sprintf(channelName, "sock%d", + (int) Tcl_GetFileInfo(statePtr->sock, NULL)); + + chan = Tcl_CreateChannel(&tcpChannelType, channelName, + (ClientData) statePtr, (TCL_READABLE | TCL_WRITABLE)); + if (Tcl_SetChannelOption(interp, chan, "-translation", "auto crlf") == + TCL_ERROR) { + Tcl_Close((Tcl_Interp *) NULL, chan); + return NULL; + } + return chan; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_MakeTcpClientChannel -- + * + * Creates a Tcl_Channel from an existing client TCP socket. + * + * Results: + * The Tcl_Channel wrapped around the preexisting TCP socket. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_MakeTcpClientChannel(sock) + ClientData sock; /* The socket to wrap up into a channel. */ +{ + TcpState *statePtr; + Tcl_File sockFile; + char channelName[20]; + Tcl_Channel chan; + + sockFile = Tcl_GetFile(sock, TCL_UNIX_FD); + statePtr = (TcpState *) ckalloc((unsigned) sizeof(TcpState)); + statePtr->sock = sockFile; + statePtr->acceptProc = NULL; + statePtr->acceptProcData = (ClientData) NULL; + + sprintf(channelName, "sock%d", (int) sock); + + chan = Tcl_CreateChannel(&tcpChannelType, channelName, + (ClientData) statePtr, (TCL_READABLE | TCL_WRITABLE)); + if (Tcl_SetChannelOption((Tcl_Interp *) NULL, chan, "-translation", + "auto crlf") == TCL_ERROR) { + Tcl_Close((Tcl_Interp *) NULL, chan); + return NULL; + } + return chan; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_OpenTcpServer -- + * + * Opens a TCP server socket and creates a channel around it. + * + * Results: + * The channel or NULL if failed. If an error occurred, an + * error message is left in interp->result if interp is + * not NULL. + * + * Side effects: + * Opens a server socket and creates a new channel. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_OpenTcpServer(interp, port, myHost, acceptProc, acceptProcData) + Tcl_Interp *interp; /* For error reporting - may be + * NULL. */ + int port; /* Port number to open. */ + char *myHost; /* Name of local host. */ + Tcl_TcpAcceptProc *acceptProc; /* Callback for accepting connections + * from new clients. */ + ClientData acceptProcData; /* Data for the callback. */ +{ + Tcl_Channel chan; + TcpState *statePtr; + char channelName[20]; + + /* + * Create a new client socket and wrap it in a channel. + */ + + statePtr = CreateSocket(interp, port, myHost, 1, NULL, 0, 0); + if (statePtr == NULL) { + return NULL; + } + + statePtr->acceptProc = acceptProc; + statePtr->acceptProcData = acceptProcData; + + /* + * Set up the callback mechanism for accepting connections + * from new clients. + */ + + Tcl_CreateFileHandler(statePtr->sock, TCL_READABLE, TcpAccept, + (ClientData) statePtr); + sprintf(channelName, "sock%d", + (int) Tcl_GetFileInfo(statePtr->sock, NULL)); + chan = Tcl_CreateChannel(&tcpChannelType, channelName, + (ClientData) statePtr, 0); + return chan; +} + +/* + *---------------------------------------------------------------------- + * + * TcpAccept -- + * Accept a TCP socket connection. This is called by the event loop. + * + * Results: + * None. + * + * Side effects: + * Creates a new connection socket. Calls the registered callback + * for the connection acceptance mechanism. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +TcpAccept(data, mask) + ClientData data; /* Callback token. */ + int mask; /* Not used. */ +{ + TcpState *sockState; /* Client data of server socket. */ + int newsock; /* The new client socket */ + Tcl_File newFile; /* Its file. */ + TcpState *newSockState; /* State for new socket. */ + struct sockaddr_in addr; /* The remote address */ + int len; /* For accept interface */ + Tcl_Channel chan; /* Channel instance created. */ + char channelName[20]; + + sockState = (TcpState *) data; + + len = sizeof(struct sockaddr_in); + newsock = accept((int) Tcl_GetFileInfo(sockState->sock, NULL), + (struct sockaddr *)&addr, &len); + if (newsock < 0) { + return; + } + + /* + * Set close-on-exec flag to prevent the newly accepted socket from + * being inherited by child processes. + */ + + (void) fcntl(newsock, F_SETFD, FD_CLOEXEC); + + newFile = Tcl_GetFile((ClientData) newsock, TCL_UNIX_FD); + if (newFile) { + newSockState = (TcpState *) ckalloc((unsigned) sizeof(TcpState)); + + newSockState->flags = 0; + newSockState->sock = newFile; + newSockState->acceptProc = (Tcl_TcpAcceptProc *) NULL; + newSockState->acceptProcData = (ClientData) NULL; + + sprintf(channelName, "sock%d", (int) newsock); + chan = Tcl_CreateChannel(&tcpChannelType, channelName, + (ClientData) newSockState, (TCL_READABLE | TCL_WRITABLE)); + if (chan == (Tcl_Channel) NULL) { + ckfree((char *) newSockState); + close(newsock); + Tcl_FreeFile(newFile); + } else { + if (Tcl_SetChannelOption((Tcl_Interp *) NULL, chan, "-translation", + "auto crlf") == TCL_ERROR) { + Tcl_Close((Tcl_Interp *) NULL, chan); + } + if (sockState->acceptProc != (Tcl_TcpAcceptProc *) NULL) { + (sockState->acceptProc) (sockState->acceptProcData, chan, + inet_ntoa(addr.sin_addr), ntohs(addr.sin_port)); + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TclGetDefaultStdChannel -- + * + * Creates channels for standard input, standard output or standard + * error output if they do not already exist. + * + * Results: + * Returns the specified default standard channel, or NULL. + * + * Side effects: + * May cause the creation of a standard channel and the underlying + * file. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +TclGetDefaultStdChannel(type) + int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */ +{ + Tcl_Channel channel = NULL; + int fd = 0; /* Initializations needed to prevent */ + int mode = 0; /* compiler warning (used before set). */ + char *bufMode = NULL; + + switch (type) { + case TCL_STDIN: + if ((lseek(0, (off_t) 0, SEEK_CUR) == -1) && + (errno == EBADF)) { + return (Tcl_Channel) NULL; + } + fd = 0; + mode = TCL_READABLE; + bufMode = "line"; + break; + case TCL_STDOUT: + if ((lseek(1, (off_t) 0, SEEK_CUR) == -1) && + (errno == EBADF)) { + return (Tcl_Channel) NULL; + } + fd = 1; + mode = TCL_WRITABLE; + bufMode = "line"; + break; + case TCL_STDERR: + if ((lseek(2, (off_t) 0, SEEK_CUR) == -1) && + (errno == EBADF)) { + return (Tcl_Channel) NULL; + } + fd = 2; + mode = TCL_WRITABLE; + bufMode = "none"; + break; + default: + panic("TclGetDefaultStdChannel: Unexpected channel type"); + break; + } + + channel = Tcl_MakeFileChannel((ClientData) fd, (ClientData) fd, mode); + + /* + * Set up the normal channel options for stdio handles. + */ + + if (Tcl_SetChannelOption(NULL, channel, "-translation", "auto") == + TCL_ERROR) { + Tcl_Close((Tcl_Interp *) NULL, channel); + return NULL; + } + if (Tcl_SetChannelOption(NULL, channel, "-buffering", bufMode) == + TCL_ERROR) { + Tcl_Close((Tcl_Interp *) NULL, channel); + return NULL; + } + return channel; +} + +/* + *---------------------------------------------------------------------- + * + * TclClosePipeFile -- + * + * This function is a simple wrapper for close on a file or + * pipe handle. Called in the generic command pipeline cleanup + * code to do platform specific closing of the files associated + * with the command channel. + * + * Results: + * None. + * + * Side effects: + * Closes the fd and frees the Tcl_File. + * + *---------------------------------------------------------------------- + */ + +void +TclClosePipeFile(file) + Tcl_File file; +{ + int fd = (int) Tcl_GetFileInfo(file, NULL); + close(fd); + Tcl_FreeFile(file); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetOpenFile -- + * + * Given a name of a channel registered in the given interpreter, + * returns a FILE * for it. + * + * Results: + * A standard Tcl result. If the channel is registered in the given + * interpreter and it is managed by the "file" channel driver, and + * it is open for the requested mode, then the output parameter + * filePtr is set to a FILE * for the underlying file. On error, the + * filePtr is not set, TCL_ERROR is returned and an error message is + * left in interp->result. + * + * Side effects: + * May invoke fdopen to create the FILE * for the requested file. + * + *---------------------------------------------------------------------- + */ + +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". Ignored, we always + * check that the channel is open for the + * requested mode. */ + ClientData *filePtr; /* Store pointer to FILE structure here. */ +{ + Tcl_Channel chan; + int chanMode; + Tcl_ChannelType *chanTypePtr; + Tcl_File tf; + int fd; + FILE *f; + + chan = Tcl_GetChannel(interp, string, &chanMode); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if ((forWriting) && ((chanMode & TCL_WRITABLE) == 0)) { + Tcl_AppendResult(interp, + "\"", string, "\" wasn't opened for writing", (char *) NULL); + return TCL_ERROR; + } else if ((!(forWriting)) && ((chanMode & TCL_READABLE) == 0)) { + Tcl_AppendResult(interp, + "\"", string, "\" wasn't opened for reading", (char *) NULL); + return TCL_ERROR; + } + + /* + * We allow creating a FILE * out of file based, pipe based and socket + * based channels. We currently do not allow any other channel types, + * because it is likely that stdio will not know what to do with them. + */ + + chanTypePtr = Tcl_GetChannelType(chan); + if ((chanTypePtr == &fileChannelType) || (chanTypePtr == &pipeChannelType) + || (chanTypePtr == &tcpChannelType)) { + tf = Tcl_GetChannelFile(chan, + (forWriting ? TCL_WRITABLE : TCL_READABLE)); + fd = (int) Tcl_GetFileInfo(tf, NULL); + + /* + * The call to fdopen below is probably dangerous, since it will + * truncate an existing file if the file is being opened + * for writing.... + */ + + f = fdopen(fd, (forWriting ? "w" : "r")); + if (f == NULL) { + Tcl_AppendResult(interp, "cannot get a FILE * for \"", string, + "\"", (char *) NULL); + return TCL_ERROR; + } + *filePtr = (ClientData) f; + return TCL_OK; + } + + Tcl_AppendResult(interp, "\"", string, + "\" cannot be used to get a FILE * - unsupported type", + (char *) NULL); + return TCL_ERROR; +} diff --git a/tcl7.6/unix/tclUnixFCmd.c b/tcl7.6/unix/tclUnixFCmd.c new file mode 100644 index 0000000..5083d39 --- /dev/null +++ b/tcl7.6/unix/tclUnixFCmd.c @@ -0,0 +1,866 @@ +/* + * tclUnixFCmd.c + * + * This file implements the unix specific portion of file manipulation + * subcommands of the "file" command. All filename arguments should + * already be translated to native format. + * + * Copyright (c) 1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclUnixFCmd.c 1.15 96/10/10 10:16:39 + * + * Portions of this code were derived from NetBSD source code which has + * the following copyright notice: + * + * Copyright (c) 1988, 1993, 1994 + * The Regents of the University of California. All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * 3. All advertising materials mentioning features or use of this software + * must display the following acknowledgement: + * This product includes software developed by the University of + * California, Berkeley and its contributors. + * 4. Neither the name of the University nor the names of its contributors + * may be used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE + * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + * SUCH DAMAGE. + */ + +#include "tclInt.h" +#include "tclPort.h" +#include + +/* + * The following constants specify the type of callback when + * TraverseUnixTree() calls the traverseProc() + */ + +#define DOTREE_PRED 1 /* pre-order directory */ +#define DOTREE_POSTD 2 /* post-order directory */ +#define DOTREE_F 3 /* regular file */ + +/* + * Prototype for the TraverseUnixTree callback function. + */ + +typedef int (TraversalProc) _ANSI_ARGS_((char *src, char *dst, + struct stat *sb, int type, Tcl_DString *errorPtr)); + +/* + * Declarations for local procedures defined in this file: + */ + +static int CopyFile _ANSI_ARGS_((char *src, char *dst, + struct stat *srcStatBufPtr)); +static int CopyFileAtts _ANSI_ARGS_((char *src, char *dst, + struct stat *srcStatBufPtr)); +static int TraversalCopy _ANSI_ARGS_((char *src, char *dst, + struct stat *sbPtr, int type, + Tcl_DString *errorPtr)); +static int TraversalDelete _ANSI_ARGS_((char *src, char *dst, + struct stat *sbPtr, int type, + Tcl_DString *errorPtr)); +static int TraverseUnixTree _ANSI_ARGS_(( + TraversalProc *traversalProc, + Tcl_DString *sourcePath, Tcl_DString *destPath, + Tcl_DString *errorPtr)); + +/* + *--------------------------------------------------------------------------- + * + * TclpRenameFile -- + * + * Changes the name of an existing file or directory, from src to dst. + * If src and dst refer to the same file or directory, does nothing + * and returns success. Otherwise if dst already exists, it will be + * deleted and replaced by src subject to the following conditions: + * If src is a directory, dst may be an empty directory. + * If src is a file, dst may be a file. + * In any other situation where dst already exists, the rename will + * fail. + * + * Results: + * If the directory was successfully created, returns TCL_OK. + * Otherwise the return value is TCL_ERROR and errno is set to + * indicate the error. Some possible values for errno are: + * + * EACCES: src or dst parent directory can't be read and/or written. + * EEXIST: dst is a non-empty directory. + * EINVAL: src is a root directory or dst is a subdirectory of src. + * EISDIR: dst is a directory, but src is not. + * ENOENT: src doesn't exist, or src or dst is "". + * ENOTDIR: src is a directory, but dst is not. + * EXDEV: src and dst are on different filesystems. + * + * Side effects: + * The implementation of rename may allow cross-filesystem renames, + * but the caller should be prepared to emulate it with copy and + * delete if errno is EXDEV. + * + *--------------------------------------------------------------------------- + */ + +int +TclpRenameFile(src, dst) + char *src; /* Pathname of file or dir to be renamed. */ + char *dst; /* New pathname of file or directory. */ +{ + if (rename(src, dst) == 0) { + return TCL_OK; + } + if (errno == ENOTEMPTY) { + errno = EEXIST; + } + +#ifdef sparc + /* + * SunOS 4.1.4 reports overwriting a non-empty directory with a + * directory as EINVAL instead of EEXIST (first rule out the correct + * EINVAL result code for moving a directory into itself). Must be + * conditionally compiled because realpath() is only defined on SunOS. + */ + + if (errno == EINVAL) { + char srcPath[MAXPATHLEN], dstPath[MAXPATHLEN]; + DIR *dirPtr; + struct dirent *dirEntPtr; + + if ((realpath(src, srcPath) != NULL) + && (realpath(dst, dstPath) != NULL) + && (strncmp(srcPath, dstPath, strlen(srcPath)) != 0)) { + dirPtr = opendir(dst); + if (dirPtr != NULL) { + while ((dirEntPtr = readdir(dirPtr)) != NULL) { + if ((strcmp(dirEntPtr->d_name, ".") != 0) && + (strcmp(dirEntPtr->d_name, "..") != 0)) { + errno = EEXIST; + closedir(dirPtr); + return TCL_ERROR; + } + } + closedir(dirPtr); + } + } + errno = EINVAL; + } +#endif /* sparc */ + + if (strcmp(src, "/") == 0) { + /* + * Alpha reports renaming / as EBUSY and Linux reports it as EACCES, + * instead of EINVAL. + */ + + errno = EINVAL; + } + + /* + * DEC Alpha OSF1 V3.0 returns EACCES when attempting to move a + * file across filesystems and the parent directory of that file is + * not writable. Most other systems return EXDEV. Does nothing to + * correct this behavior. + */ + + return TCL_ERROR; +} + + +/* + *--------------------------------------------------------------------------- + * + * TclpCopyFile -- + * + * Copy a single file (not a directory). If dst already exists and + * is not a directory, it is removed. + * + * Results: + * If the file was successfully copied, returns TCL_OK. Otherwise + * the return value is TCL_ERROR and errno is set to indicate the + * error. Some possible values for errno are: + * + * EACCES: src or dst parent directory can't be read and/or written. + * EISDIR: src or dst is a directory. + * ENOENT: src doesn't exist. src or dst is "". + * + * Side effects: + * This procedure will also copy symbolic links, block, and + * character devices, and fifos. For symbolic links, the links + * themselves will be copied and not what they point to. For the + * other special file types, the directory entry will be copied and + * not the contents of the device that it refers to. + * + *--------------------------------------------------------------------------- + */ + +int +TclpCopyFile(src, dst) + char *src; /* Pathname of file to be copied. */ + char *dst; /* Pathname of file to copy to. */ +{ + struct stat srcStatBuf, dstStatBuf; + char link[MAXPATHLEN]; + int length; + + /* + * Have to do a stat() to determine the filetype. + */ + + if (lstat(src, &srcStatBuf) != 0) { + return TCL_ERROR; + } + if (S_ISDIR(srcStatBuf.st_mode)) { + errno = EISDIR; + return TCL_ERROR; + } + + /* + * symlink, and some of the other calls will fail if the target + * exists, so we remove it first + */ + + if (lstat(dst, &dstStatBuf) == 0) { + if (S_ISDIR(dstStatBuf.st_mode)) { + errno = EISDIR; + return TCL_ERROR; + } + } + if (unlink(dst) != 0) { + if (errno != ENOENT) { + return TCL_ERROR; + } + } + + switch ((int) (srcStatBuf.st_mode & S_IFMT)) { + case S_IFLNK: + length = readlink(src, link, sizeof(link)); + if (length == -1) { + return TCL_ERROR; + } + link[length] = '\0'; + if (symlink(link, dst) < 0) { + return TCL_ERROR; + } + return TCL_OK; + + case S_IFBLK: + case S_IFCHR: + if (mknod(dst, srcStatBuf.st_mode, srcStatBuf.st_rdev) < 0) { + return TCL_ERROR; + } + return CopyFileAtts(src, dst, &srcStatBuf); + + case S_IFIFO: + if (mkfifo(dst, srcStatBuf.st_mode) < 0) { + return TCL_ERROR; + } + return CopyFileAtts(src, dst, &srcStatBuf); + + default: + return CopyFile(src, dst, &srcStatBuf); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * CopyFile - + * + * Helper function for TclpCopyFile. Copies one regular file, + * using read() and write(). + * + * Results: + * A standard Tcl result. + * + * Side effects: + * A file is copied. Dst will be overwritten if it exists. + * + *---------------------------------------------------------------------- + */ + +static int +CopyFile(src, dst, srcStatBufPtr) + char *src; /* Pathname of file to copy. */ + char *dst; /* Pathname of file to create/overwrite. */ + struct stat *srcStatBufPtr; /* Used to determine mode and blocksize */ +{ + int srcFd; + int dstFd; + u_int blockSize; /* Optimal I/O blocksize for filesystem */ + char *buffer; /* Data buffer for copy */ + size_t nread; + + if ((srcFd = open(src, O_RDONLY, 0)) < 0) { + return TCL_ERROR; + } + + dstFd = open(dst, O_CREAT | O_TRUNC | O_WRONLY, srcStatBufPtr->st_mode); + if (dstFd < 0) { + close(srcFd); + return TCL_ERROR; + } + + blockSize = srcStatBufPtr->st_blksize; + buffer = ckalloc(blockSize); + while (1) { + nread = read(srcFd, buffer, blockSize); + if ((nread == -1) || (nread == 0)) { + break; + } + if (write(dstFd, buffer, nread) != nread) { + nread = (size_t) -1; + break; + } + } + + ckfree(buffer); + close(srcFd); + if ((close(dstFd) != 0) || (nread == -1)) { + unlink(dst); + return TCL_ERROR; + } + if (CopyFileAtts(src, dst, srcStatBufPtr) == TCL_ERROR) { + /* + * The copy succeeded, but setting the permissions failed, so be in + * a consistent state, we remove the file that was created by the + * copy. + */ + + unlink(dst); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpDeleteFile -- + * + * Removes a single file (not a directory). + * + * Results: + * If the file was successfully deleted, returns TCL_OK. Otherwise + * the return value is TCL_ERROR and errno is set to indicate the + * error. Some possible values for errno are: + * + * EACCES: a parent directory can't be read and/or written. + * EISDIR: path is a directory. + * ENOENT: path doesn't exist or is "". + * + * Side effects: + * The file is deleted, even if it is read-only. + * + *--------------------------------------------------------------------------- + */ + +int +TclpDeleteFile(path) + char *path; /* Pathname of file to be removed. */ +{ + if (unlink(path) != 0) { + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpCreateDirectory -- + * + * Creates the specified directory. All parent directories of the + * specified directory must already exist. The directory is + * automatically created with permissions so that user can access + * the new directory and create new files or subdirectories in it. + * + * Results: + * If the directory was successfully created, returns TCL_OK. + * Otherwise the return value is TCL_ERROR and errno is set to + * indicate the error. Some possible values for errno are: + * + * EACCES: a parent directory can't be read and/or written. + * EEXIST: path already exists. + * ENOENT: a parent directory doesn't exist. + * + * Side effects: + * A directory is created with the current umask, except that + * permission for u+rwx will always be added. + * + *--------------------------------------------------------------------------- + */ + +int +TclpCreateDirectory(path) + char *path; /* Pathname of directory to create. */ +{ + mode_t mode; + + mode = umask(0); + umask(mode); + + /* + * umask return value is actually the inverse of the permissions. + */ + + mode = (0777 & ~mode); + + if (mkdir(path, mode | S_IRUSR | S_IWUSR | S_IXUSR) != 0) { + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpCopyDirectory -- + * + * Recursively copies a directory. The target directory dst must + * not already exist. Note that this function does not merge two + * directory hierarchies, even if the target directory is an an + * empty directory. + * + * Results: + * If the directory was successfully copied, returns TCL_OK. + * Otherwise the return value is TCL_ERROR, errno is set to indicate + * the error, and the pathname of the file that caused the error + * is stored in errorPtr. See TclpCreateDirectory and TclpCopyFile + * for a description of possible values for errno. + * + * Side effects: + * An exact copy of the directory hierarchy src will be created + * with the name dst. If an error occurs, the error will + * be returned immediately, and remaining files will not be + * processed. + * + *--------------------------------------------------------------------------- + */ + +int +TclpCopyDirectory(src, dst, errorPtr) + char *src; /* Pathname of directory to be copied. */ + char *dst; /* Pathname of target directory. */ + Tcl_DString *errorPtr; /* If non-NULL, initialized DString for + * error reporting. */ +{ + int result; + Tcl_DString srcBuffer; + Tcl_DString dstBuffer; + + Tcl_DStringInit(&srcBuffer); + Tcl_DStringInit(&dstBuffer); + Tcl_DStringAppend(&srcBuffer, src, -1); + Tcl_DStringAppend(&dstBuffer, dst, -1); + result = TraverseUnixTree(TraversalCopy, &srcBuffer, &dstBuffer, + errorPtr); + Tcl_DStringFree(&srcBuffer); + Tcl_DStringFree(&dstBuffer); + return result; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpRemoveDirectory -- + * + * Removes directory (and its contents, if the recursive flag is set). + * + * Results: + * If the directory was successfully removed, returns TCL_OK. + * Otherwise the return value is TCL_ERROR, errno is set to indicate + * the error, and the pathname of the file that caused the error + * is stored in errorPtr. Some possible values for errno are: + * + * EACCES: path directory can't be read and/or written. + * EEXIST: path is a non-empty directory. + * EINVAL: path is a root directory. + * ENOENT: path doesn't exist or is "". + * ENOTDIR: path is not a directory. + * + * Side effects: + * Directory removed. If an error occurs, the error will be returned + * immediately, and remaining files will not be deleted. + * + *--------------------------------------------------------------------------- + */ + +int +TclpRemoveDirectory(path, recursive, errorPtr) + char *path; /* Pathname of directory to be removed. */ + int recursive; /* If non-zero, removes directories that + * are nonempty. Otherwise, will only remove + * empty directories. */ + Tcl_DString *errorPtr; /* If non-NULL, initialized DString for + * error reporting. */ +{ + int result; + Tcl_DString buffer; + + if (rmdir(path) == 0) { + return TCL_OK; + } + if (((errno != EEXIST) && (errno != ENOTEMPTY)) || (recursive == 0)) { + if (errorPtr != NULL) { + Tcl_DStringAppend(errorPtr, path, -1); + } + return TCL_ERROR; + } + + /* + * The directory is nonempty, but the recursive flag has been + * specified, so we recursively remove all the files in the directory. + */ + + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, path, -1); + result = TraverseUnixTree(TraversalDelete, &buffer, NULL, errorPtr); + Tcl_DStringFree(&buffer); + return result; +} + +/* + *--------------------------------------------------------------------------- + * + * TraverseUnixTree -- + * + * Traverse directory tree specified by sourcePtr, calling the function + * traverseProc for each file and directory encountered. If destPtr + * is non-null, each of name in the sourcePtr directory is appended to + * the directory specified by destPtr and passed as the second argument + * to traverseProc() . + * + * Results: + * Standard Tcl result. + * + * Side effects: + * None caused by TraverseUnixTree, however the user specified + * traverseProc() may change state. If an error occurs, the error will + * be returned immediately, and remaining files will not be processed. + * + *--------------------------------------------------------------------------- + */ + +static int +TraverseUnixTree(traverseProc, sourcePtr, targetPtr, errorPtr) + TraversalProc *traverseProc;/* Function to call for every file and + * directory in source hierarchy. */ + Tcl_DString *sourcePtr; /* Pathname of source directory to be + * traversed. */ + Tcl_DString *targetPtr; /* Pathname of directory to traverse in + * parallel with source directory. */ + Tcl_DString *errorPtr; /* If non-NULL, an initialized DString for + * error reporting. */ +{ + struct stat statbuf; + char *source, *target, *errfile; + int result, sourceLen; + int targetLen = 0; /* Initialization needed only to prevent + * warning in gcc. */ + struct dirent *dirp; + DIR *dp; + + result = TCL_OK; + source = Tcl_DStringValue(sourcePtr); + if (targetPtr != NULL) { + target = Tcl_DStringValue(targetPtr); + } else { + target = NULL; + } + + errfile = NULL; + if (lstat(source, &statbuf) != 0) { + errfile = source; + goto end; + } + if (!S_ISDIR(statbuf.st_mode)) { + /* + * Process the regular file + */ + + return (*traverseProc)(source, target, &statbuf, DOTREE_F, errorPtr); + } + + dp = opendir(source); + if (dp == NULL) { + /* + * Can't read directory + */ + + errfile = source; + goto end; + } + result = (*traverseProc)(source, target, &statbuf, DOTREE_PRED, errorPtr); + if (result != TCL_OK) { + closedir(dp); + return result; + } + + Tcl_DStringAppend(sourcePtr, "/", 1); + source = Tcl_DStringValue(sourcePtr); + sourceLen = Tcl_DStringLength(sourcePtr); + + if (targetPtr != NULL) { + Tcl_DStringAppend(targetPtr, "/", 1); + target = Tcl_DStringValue(targetPtr); + targetLen = Tcl_DStringLength(targetPtr); + } + + while ((dirp = readdir(dp)) != NULL) { + if ((strcmp(dirp->d_name, ".") == 0) + || (strcmp(dirp->d_name, "..") == 0)) { + continue; + } + + /* + * Append name after slash, and recurse on the file. + */ + + Tcl_DStringAppend(sourcePtr, dirp->d_name, -1); + if (targetPtr != NULL) { + Tcl_DStringAppend(targetPtr, dirp->d_name, -1); + } + result = TraverseUnixTree(traverseProc, sourcePtr, targetPtr, + errorPtr); + if (result != TCL_OK) { + break; + } + + /* + * Remove name after slash. + */ + + Tcl_DStringSetLength(sourcePtr, sourceLen); + if (targetPtr != NULL) { + Tcl_DStringSetLength(targetPtr, targetLen); + } + } + closedir(dp); + + /* + * Strip off the trailing slash we added + */ + + Tcl_DStringSetLength(sourcePtr, sourceLen - 1); + if (targetPtr != NULL) { + Tcl_DStringSetLength(targetPtr, targetLen - 1); + } + + if (result == TCL_OK) { + /* + * Call traverseProc() on a directory after visiting all the + * files in that directory. + */ + + result = (*traverseProc)(source, target, &statbuf, DOTREE_POSTD, + errorPtr); + } + end: + if (errfile != NULL) { + if (errorPtr != NULL) { + Tcl_DStringAppend(errorPtr, errfile, -1); + } + result = TCL_ERROR; + } + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TraversalCopy + * + * Called from TraverseUnixTree in order to execute a recursive copy of a + * directory. + * + * Results: + * Standard Tcl result. + * + * Side effects: + * The file or directory src may be copied to dst, depending on + * the value of type. + * + *---------------------------------------------------------------------- + */ + +static int +TraversalCopy(src, dst, sbPtr, type, errorPtr) + char *src; /* Source pathname to copy. */ + char *dst; /* Destination pathname of copy. */ + struct stat *sbPtr; /* Stat info for file specified by src. */ + int type; /* Reason for call - see TraverseUnixTree(). */ + Tcl_DString *errorPtr; /* If non-NULL, initialized DString for + * error return. */ +{ + switch (type) { + case DOTREE_F: + if (TclpCopyFile(src, dst) == TCL_OK) { + return TCL_OK; + } + break; + + case DOTREE_PRED: + if (TclpCreateDirectory(dst) == TCL_OK) { + return TCL_OK; + } + break; + + case DOTREE_POSTD: + if (CopyFileAtts(src, dst, sbPtr) == TCL_OK) { + return TCL_OK; + } + break; + + } + + /* + * There shouldn't be a problem with src, because we already + * checked it to get here. + */ + + if (errorPtr != NULL) { + Tcl_DStringAppend(errorPtr, dst, -1); + } + return TCL_ERROR; +} + +/* + *--------------------------------------------------------------------------- + * + * TraversalDelete -- + * + * Called by procedure TraverseUnixTree for every file and directory + * that it encounters in a directory hierarchy. This procedure unlinks + * files, and removes directories after all the containing files + * have been processed. + * + * Results: + * Standard Tcl result. + * + * Side effects: + * Files or directory specified by src will be deleted. + * + *---------------------------------------------------------------------- + */ + +static int +TraversalDelete(src, ignore, sbPtr, type, errorPtr) + char *src; /* Source pathname. */ + char *ignore; /* Destination pathname (not used). */ + struct stat *sbPtr; /* Stat info for file specified by src. */ + int type; /* Reason for call - see TraverseUnixTree(). */ + Tcl_DString *errorPtr; /* If non-NULL, initialized DString for + * error return. */ +{ + switch (type) { + case DOTREE_F: + if (unlink(src) == 0) { + return TCL_OK; + } + break; + + case DOTREE_PRED: + return TCL_OK; + + case DOTREE_POSTD: + if (rmdir(src) == 0) { + return TCL_OK; + } + break; + + } + + if (errorPtr != NULL) { + Tcl_DStringAppend(errorPtr, src, -1); + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * CopyFileAtts + * + * Copy the file attributes such as owner, group, permissions, and + * modification date from one file to another. + * + * Results: + * Standard Tcl result. + * + * Side effects: + * user id, group id, permission bits, last modification time, and + * last access time are updated in the new file to reflect the old + * file. + * + *---------------------------------------------------------------------- + */ +static int +CopyFileAtts(src, dst, statBufPtr) + char *src; /* Path name of source file */ + char *dst; /* Path name of target file */ + struct stat *statBufPtr; /* ptr to stat info for source file */ +{ + struct utimbuf tval; + mode_t newMode; + + newMode = statBufPtr->st_mode & (S_ISUID | S_ISGID | S_IRWXU | S_IRWXG | S_IRWXO); + + /* + * On some systems chown will always fail for a non-root user unless + * POSIX_CHOWN_RESTRICTED is not set. Others will succeed as long as + * you don't try to chown a file to someone besides youself. + */ + + if (chown(dst, statBufPtr->st_uid, statBufPtr->st_gid)) { + if (errno != EPERM) { + return TCL_ERROR; + } + } + + /* + * Note that if you copy a setuid file that is owned by someone + * else, and you are not root, then the copy will be setuid to you. + * The most correct implementation would probably be to have the + * copy not setuid to anyone if the original file was owned by + * someone else, but this corner case isn't currently handled. + * It would require another lstat(), or getuid(). + */ + + if (chmod(dst, newMode)) { + newMode &= ~(S_ISUID | S_ISGID); + if (chmod(dst, newMode)) { + return TCL_ERROR; + } + } + + tval.actime = statBufPtr->st_atime; + tval.modtime = statBufPtr->st_mtime; + + if (utime(dst, &tval)) { + return TCL_ERROR; + } + return TCL_OK; +} diff --git a/tcl7.6/unix/tclUnixFile.c b/tcl7.6/unix/tclUnixFile.c new file mode 100644 index 0000000..b99fab0 --- /dev/null +++ b/tcl7.6/unix/tclUnixFile.c @@ -0,0 +1,768 @@ +/* + * tclUnixFile.c -- + * + * This file contains wrappers around UNIX file handling functions. + * These wrappers mask differences between Windows and UNIX. + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclUnixFile.c 1.39 96/09/12 14:57:31 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * The variable below caches the name of the current working directory + * in order to avoid repeated calls to getcwd. The string is malloc-ed. + * NULL means the cache needs to be refreshed. + */ + +static char *currentDir = NULL; +static int currentDirExitHandlerSet = 0; + +/* + * The variable below is set if the exit routine for deleting the string + * containing the executable name has been registered. + */ + +static int executableNameExitHandlerSet = 0; + +extern pid_t waitpid _ANSI_ARGS_((pid_t pid, int *stat_loc, int options)); + +/* + * Static routines for this file: + */ + +static void FreeCurrentDir _ANSI_ARGS_((ClientData clientData)); +static void FreeExecutableName _ANSI_ARGS_((ClientData clientData)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_WaitPid -- + * + * Implements the waitpid system call on Unix systems. + * + * Results: + * Result of calling waitpid. + * + * Side effects: + * Waits for a process to terminate. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_WaitPid(pid, statPtr, options) + int pid; + int *statPtr; + int options; +{ + int result; + pid_t real_pid; + + real_pid = (pid_t) pid; + while (1) { + result = (int) waitpid(real_pid, statPtr, options); + if ((result != -1) || (errno != EINTR)) { + return result; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * FreeCurrentDir -- + * + * Frees the string stored in the currentDir variable. This routine + * is registered as an exit handler and will be called during shutdown. + * + * Results: + * None. + * + * Side effects: + * Frees the memory occuppied by the currentDir value. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +FreeCurrentDir(clientData) + ClientData clientData; /* Not used. */ +{ + if (currentDir != (char *) NULL) { + ckfree(currentDir); + currentDir = (char *) NULL; + } +} + +/* + *---------------------------------------------------------------------- + * + * FreeExecutableName -- + * + * Frees the string stored in the tclExecutableName variable. This + * routine is registered as an exit handler and will be called + * during shutdown. + * + * Results: + * None. + * + * Side effects: + * Frees the memory occuppied by the tclExecutableName value. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +FreeExecutableName(clientData) + ClientData clientData; /* Not used. */ +{ + if (tclExecutableName != (char *) NULL) { + ckfree(tclExecutableName); + tclExecutableName = (char *) NULL; + } +} + +/* + *---------------------------------------------------------------------- + * + * TclChdir -- + * + * Change the current working directory. + * + * Results: + * The result is a standard Tcl result. If an error occurs and + * interp isn't NULL, an error message is left in interp->result. + * + * Side effects: + * The working directory for this application is changed. Also + * the cache maintained used by TclGetCwd is deallocated and + * set to NULL. + * + *---------------------------------------------------------------------- + */ + +int +TclChdir(interp, dirName) + Tcl_Interp *interp; /* If non NULL, used for error reporting. */ + char *dirName; /* Path to new working directory. */ +{ + if (currentDir != NULL) { + ckfree(currentDir); + currentDir = NULL; + } + if (chdir(dirName) != 0) { + if (interp != NULL) { + Tcl_AppendResult(interp, "couldn't change working directory to \"", + dirName, "\": ", Tcl_PosixError(interp), (char *) NULL); + } + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetCwd -- + * + * Return the path name of the current working directory. + * + * Results: + * The result is the full path name of the current working + * directory, or NULL if an error occurred while figuring it out. + * The returned string is owned by the TclGetCwd routine and must + * not be freed by the caller. If an error occurs and interp + * isn't NULL, an error message is left in interp->result. + * + * Side effects: + * The path name is cached to avoid having to recompute it + * on future calls; if it is already cached, the cached + * value is returned. + * + *---------------------------------------------------------------------- + */ + +char * +TclGetCwd(interp) + Tcl_Interp *interp; /* If non NULL, used for error reporting. */ +{ + char buffer[MAXPATHLEN+1]; + + if (currentDir == NULL) { + if (!currentDirExitHandlerSet) { + currentDirExitHandlerSet = 1; + Tcl_CreateExitHandler(FreeCurrentDir, (ClientData) NULL); + } + if (getcwd(buffer, MAXPATHLEN+1) == NULL) { + if (interp != 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 NULL; + } + currentDir = (char *) ckalloc((unsigned) (strlen(buffer) + 1)); + strcpy(currentDir, buffer); + } + return currentDir; +} + +/* + *---------------------------------------------------------------------- + * + * TclOpenFile -- + * + * Implements a mechanism to open files on Unix systems. + * + * Results: + * The opened file. + * + * Side effects: + * May cause a file to be created on the file system. + * + *---------------------------------------------------------------------- + */ + +Tcl_File +TclOpenFile(fname, mode) + char *fname; /* The name of the file to open. */ + int mode; /* In what mode to open the file? */ +{ + int fd; + + fd = open(fname, mode, 0600); + if (fd != -1) { + fcntl(fd, F_SETFD, FD_CLOEXEC); + return Tcl_GetFile((ClientData)fd, TCL_UNIX_FD); + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TclCloseFile -- + * + * Implements a mechanism to close a UNIX file. + * + * Results: + * Returns 0 on success, or -1 on error, setting errno. + * + * Side effects: + * The file is closed. + * + *---------------------------------------------------------------------- + */ + +int +TclCloseFile(file) + Tcl_File file; /* The file to close. */ +{ + int type; + int fd; + int result; + + fd = (int) Tcl_GetFileInfo(file, &type); + if (type != TCL_UNIX_FD) { + panic("Tcl_CloseFile: unexpected file type"); + } + + /* + * Refuse to close the fds for stdin, stdout and stderr. + */ + + if ((fd == 0) || (fd == 1) || (fd == 2)) { + return 0; + } + + result = close(fd); + Tcl_DeleteFileHandler(file); + Tcl_FreeFile(file); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclReadFile -- + * + * Implements a mechanism to read from files on Unix systems. Also + * simulates blocking behavior on non-blocking files when asked to. + * + * Results: + * The number of characters read from the specified file. + * + * Side effects: + * May consume characters from the file. + * + *---------------------------------------------------------------------- + */ + /* ARGSUSED */ +int +TclReadFile(file, shouldBlock, buf, toRead) + Tcl_File file; /* The file to read from. */ + int shouldBlock; /* Not used. */ + char *buf; /* The buffer to store input in. */ + int toRead; /* Number of characters to read. */ +{ + int type, fd; + + fd = (int) Tcl_GetFileInfo(file, &type); + if (type != TCL_UNIX_FD) { + panic("Tcl_ReadFile: unexpected file type"); + } + + return read(fd, buf, (size_t) toRead); +} + +/* + *---------------------------------------------------------------------- + * + * TclWriteFile -- + * + * Implements a mechanism to write to files on Unix systems. + * + * Results: + * The number of characters written to the specified file. + * + * Side effects: + * May produce characters on the file. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +TclWriteFile(file, shouldBlock, buf, toWrite) + Tcl_File file; /* The file to write to. */ + int shouldBlock; /* Not used. */ + char *buf; /* Where output is stored. */ + int toWrite; /* Number of characters to write. */ +{ + int type, fd; + + fd = (int) Tcl_GetFileInfo(file, &type); + if (type != TCL_UNIX_FD) { + panic("Tcl_WriteFile: unexpected file type"); + } + return write(fd, buf, (size_t) toWrite); +} + +/* + *---------------------------------------------------------------------- + * + * TclSeekFile -- + * + * Sets the file pointer on the indicated UNIX file. + * + * Results: + * The new position at which the file will be accessed, or -1 on + * failure. + * + * Side effects: + * May change the position at which subsequent operations access the + * file designated by the file. + * + *---------------------------------------------------------------------- + */ + +int +TclSeekFile(file, offset, whence) + Tcl_File file; /* The file to seek on. */ + int offset; /* How far to seek? */ + int whence; /* And from where to seek? */ +{ + int type, fd; + + fd = (int) Tcl_GetFileInfo(file, &type); + if (type != TCL_UNIX_FD) { + panic("Tcl_SeekFile: unexpected file type"); + } + + return lseek(fd, offset, whence); +} + +/* + *---------------------------------------------------------------------- + * + * TclCreateTempFile -- + * + * This function creates a temporary file initialized with an + * optional string, and returns a file handle with the file pointer + * at the beginning of the file. + * + * Results: + * A handle to a file. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_File +TclCreateTempFile(contents, namePtr) + char *contents; /* String to write into temp file, or NULL. */ + Tcl_DString *namePtr; /* If non-NULL, pointer to initialized + * DString that is filled with the name of + * the temp file that was created. */ +{ + char fileName[L_tmpnam]; + Tcl_File file; + size_t length = (contents == NULL) ? 0 : strlen(contents); + + tmpnam(fileName); + file = TclOpenFile(fileName, O_RDWR|O_CREAT|O_TRUNC); + unlink(fileName); + + if ((file != NULL) && (length > 0)) { + int fd = (int)Tcl_GetFileInfo(file, NULL); + while (1) { + if (write(fd, contents, length) != -1) { + break; + } else if (errno != EINTR) { + close(fd); + Tcl_FreeFile(file); + return NULL; + } + } + lseek(fd, 0, SEEK_SET); + } + if (namePtr != NULL) { + Tcl_DStringAppend(namePtr, fileName, -1); + } + return file; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FindExecutable -- + * + * This procedure computes the absolute path name of the current + * application, given its argv[0] value. + * + * Results: + * None. + * + * Side effects: + * The variable tclExecutableName gets filled in with the file + * name for the application, if we figured it out. If we couldn't + * figure it out, Tcl_FindExecutable is set to NULL. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_FindExecutable(argv0) + char *argv0; /* The value of the application's argv[0]. */ +{ + char *name, *p, *cwd; + Tcl_DString buffer; + int length; + + Tcl_DStringInit(&buffer); + if (tclExecutableName != NULL) { + ckfree(tclExecutableName); + tclExecutableName = NULL; + } + + name = argv0; + for (p = name; *p != 0; p++) { + if (*p == '/') { + /* + * The name contains a slash, so use the name directly + * without doing a path search. + */ + + goto gotName; + } + } + + p = getenv("PATH"); + if (p == NULL) { + /* + * There's no PATH environment variable; use the default that + * is used by sh. + */ + + p = ":/bin:/usr/bin"; + } + + /* + * Search through all the directories named in the PATH variable + * to see if argv[0] is in one of them. If so, use that file + * name. + */ + + while (*p != 0) { + while (isspace(UCHAR(*p))) { + p++; + } + name = p; + while ((*p != ':') && (*p != 0)) { + p++; + } + Tcl_DStringSetLength(&buffer, 0); + if (p != name) { + Tcl_DStringAppend(&buffer, name, p-name); + if (p[-1] != '/') { + Tcl_DStringAppend(&buffer, "/", 1); + } + } + Tcl_DStringAppend(&buffer, argv0, -1); + if (access(Tcl_DStringValue(&buffer), X_OK) == 0) { + name = Tcl_DStringValue(&buffer); + goto gotName; + } + p++; + } + goto done; + + /* + * If the name starts with "/" then just copy it to tclExecutableName. + */ + + gotName: + if (name[0] == '/') { + tclExecutableName = (char *) ckalloc((unsigned) (strlen(name) + 1)); + strcpy(tclExecutableName, name); + goto done; + } + + /* + * The name is relative to the current working directory. First + * strip off a leading "./", if any, then add the full path name of + * the current working directory. + */ + + if ((name[0] == '.') && (name[1] == '/')) { + name += 2; + } + cwd = TclGetCwd((Tcl_Interp *) NULL); + if (cwd == NULL) { + tclExecutableName = NULL; + goto done; + } + length = strlen(cwd); + tclExecutableName = (char *) ckalloc((unsigned) + (length + strlen(name) + 2)); + strcpy(tclExecutableName, cwd); + tclExecutableName[length] = '/'; + strcpy(tclExecutableName + length + 1, name); + + done: + Tcl_DStringFree(&buffer); + + if (!executableNameExitHandlerSet) { + executableNameExitHandlerSet = 1; + Tcl_CreateExitHandler(FreeExecutableName, (ClientData) NULL); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclGetUserHome -- + * + * This function takes the passed in user name and finds the + * corresponding home directory specified in the password file. + * + * Results: + * The result is a pointer to a static string containing + * the new name. If there was an error in processing the + * user name then the return value is NULL. Otherwise the + * result is stored in bufferPtr, and the caller must call + * Tcl_DStringFree(bufferPtr) to free the result. + * + * Side effects: + * Information may be left in bufferPtr. + * + *---------------------------------------------------------------------- + */ + +char * +TclGetUserHome(name, bufferPtr) + char *name; /* User name to use to find home directory. */ + Tcl_DString *bufferPtr; /* May be used to hold result. Must not hold + * anything at the time of the call, and need + * not even be initialized. */ +{ + struct passwd *pwPtr; + + pwPtr = getpwnam(name); + if (pwPtr == NULL) { + endpwent(); + return NULL; + } + Tcl_DStringInit(bufferPtr); + Tcl_DStringAppend(bufferPtr, pwPtr->pw_dir, -1); + endpwent(); + return bufferPtr->string; +} + +/* + *---------------------------------------------------------------------- + * + * TclMatchFiles -- + * + * This routine is used by the globbing code to search a + * directory for all files which match a given pattern. + * + * Results: + * If the tail argument is NULL, then the matching files are + * added to the interp->result. Otherwise, TclDoGlob is called + * recursively for each matching subdirectory. The return value + * is a standard Tcl result indicating whether an error occurred + * in globbing. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- */ + +int +TclMatchFiles(interp, separators, dirPtr, pattern, tail) + Tcl_Interp *interp; /* Interpreter to receive results. */ + char *separators; /* Path separators to pass to TclDoGlob. */ + Tcl_DString *dirPtr; /* Contains path to directory to search. */ + char *pattern; /* Pattern to match against. */ + char *tail; /* Pointer to end of pattern. */ +{ + char *dirName, *patternEnd = tail; + char savedChar = 0; /* Initialization needed only to prevent + * compiler warning from gcc. */ + DIR *d; + struct stat statBuf; + struct dirent *entryPtr; + int matchHidden; + int result = TCL_OK; + int baseLength = Tcl_DStringLength(dirPtr); + + /* + * 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 (dirPtr->string[0] == '\0') { + dirName = "."; + } else { + dirName = dirPtr->string; + } + if ((stat(dirName, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) { + return TCL_OK; + } + + /* + * Check to see if the pattern needs to compare with hidden files. + */ + + if ((pattern[0] == '.') + || ((pattern[0] == '\\') && (pattern[1] == '.'))) { + matchHidden = 1; + } else { + matchHidden = 0; + } + + /* + * Now open the directory for reading and iterate over the contents. + */ + + d = opendir(dirName); + if (d == NULL) { + Tcl_ResetResult(interp); + + /* + * Strip off a trailing '/' if necessary, before reporting the error. + */ + + if (baseLength > 0) { + savedChar = dirPtr->string[baseLength-1]; + if (savedChar == '/') { + dirPtr->string[baseLength-1] = '\0'; + } + } + Tcl_AppendResult(interp, "couldn't read directory \"", + dirPtr->string, "\": ", Tcl_PosixError(interp), (char *) NULL); + if (baseLength > 0) { + dirPtr->string[baseLength-1] = savedChar; + } + return TCL_ERROR; + } + + /* + * Clean up the end of the pattern and the tail pointer. Leave + * the tail pointing to the first character after the path separator + * following the pattern, or NULL. Also, ensure that the pattern + * is null-terminated. + */ + + if (*tail == '\\') { + tail++; + } + if (*tail == '\0') { + tail = NULL; + } else { + tail++; + } + savedChar = *patternEnd; + *patternEnd = '\0'; + + while (1) { + entryPtr = readdir(d); + if (entryPtr == NULL) { + break; + } + + /* + * Don't match names starting with "." unless the "." is + * present in the pattern. + */ + + if (!matchHidden && (*entryPtr->d_name == '.')) { + continue; + } + + /* + * Now check to see if the file matches. If there are more + * characters to be processed, then ensure matching files are + * directories before calling TclDoGlob. Otherwise, just add + * the file to the result. + */ + + if (Tcl_StringMatch(entryPtr->d_name, pattern)) { + Tcl_DStringSetLength(dirPtr, baseLength); + Tcl_DStringAppend(dirPtr, entryPtr->d_name, -1); + if (tail == NULL) { + Tcl_AppendElement(interp, dirPtr->string); + } else if ((stat(dirPtr->string, &statBuf) == 0) + && S_ISDIR(statBuf.st_mode)) { + Tcl_DStringAppend(dirPtr, "/", 1); + result = TclDoGlob(interp, separators, dirPtr, tail); + if (result != TCL_OK) { + break; + } + } + } + } + *patternEnd = savedChar; + + closedir(d); + return result; +} diff --git a/tcl7.6/unix/tclUnixInit.c b/tcl7.6/unix/tclUnixInit.c new file mode 100644 index 0000000..8940182 --- /dev/null +++ b/tcl7.6/unix/tclUnixInit.c @@ -0,0 +1,246 @@ +/* + * tclUnixInit.c -- + * + * Contains the Unix-specific interpreter initialization functions. + * + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclUnixInit.c 1.19 96/10/04 10:28:56 + */ + +#include "tclInt.h" +#include "tclPort.h" +#if defined(__FreeBSD__) +# include +#endif +#if defined(__bsdi__) +# include +# if _BSDI_VERSION > 199501 +# include +# endif +#endif + +/* + * Default directory in which to look for Tcl library scripts. The + * symbol is defined by Makefile. + */ + +static char defaultLibraryDir[200] = TCL_LIBRARY; + +/* + * Directory in which to look for packages (each package is typically + * installed as a subdirectory of this directory). The symbol is + * defined by Makefile. + */ + +static char pkgPath[200] = TCL_PACKAGE_PATH; + +/* + * The following string is the startup script executed in new + * interpreters. It looks on disk in several different directories + * for a script "init.tcl" that is compatible with this version + * of Tcl. The init.tcl script does all of the real work of + * initialization. + */ + +static char initScript[] = +"proc tclInit {} {\n\ + global tcl_library tcl_version tcl_patchLevel env\n\ + rename tclInit {}\n\ + set dirs {}\n\ + if [info exists env(TCL_LIBRARY)] {\n\ + lappend dirs $env(TCL_LIBRARY)\n\ + }\n\ + lappend dirs [info library]\n\ + set parentDir [file dirname [file dirname [info nameofexecutable]]]\n\ + lappend dirs $parentDir/lib/tcl$tcl_version\n\ + if [string match {*[ab]*} $tcl_patchLevel] {\n\ + set lib tcl$tcl_patchLevel\n\ + } else {\n\ + set lib tcl$tcl_version\n\ + }\n\ + lappend dirs [file dirname $parentDir]/$lib/library\n\ + lappend dirs $parentDir/library\n\ + foreach i $dirs {\n\ + set tcl_library $i\n\ + if ![catch {uplevel #0 source $i/init.tcl}] {\n\ + return\n\ + }\n\ + }\n\ + set msg \"Can't find a usable init.tcl in the following directories: \n\"\n\ + append msg \" $dirs\n\"\n\ + append msg \"This probably means that Tcl wasn't installed properly.\n\"\n\ + error $msg\n\ +}\n\ +tclInit"; + +/* + *---------------------------------------------------------------------- + * + * TclPlatformInit -- + * + * Performs Unix-specific interpreter initialization related to the + * tcl_library and tcl_platform variables, and other platform- + * specific things. + * + * Results: + * None. + * + * Side effects: + * Sets "tcl_library" and "tcl_platform" Tcl variables. + * + *---------------------------------------------------------------------- + */ + +void +TclPlatformInit(interp) + Tcl_Interp *interp; +{ +#ifndef NO_UNAME + struct utsname name; +#endif + int unameOK; + static int initialized = 0; + + tclPlatform = TCL_PLATFORM_UNIX; + Tcl_SetVar(interp, "tcl_library", defaultLibraryDir, TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "tcl_pkgPath", pkgPath, TCL_GLOBAL_ONLY); + Tcl_SetVar2(interp, "tcl_platform", "platform", "unix", TCL_GLOBAL_ONLY); + unameOK = 0; +#ifndef NO_UNAME + if (uname(&name) >= 0) { + unameOK = 1; + Tcl_SetVar2(interp, "tcl_platform", "os", name.sysname, + TCL_GLOBAL_ONLY); + Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.release, + TCL_GLOBAL_ONLY); + Tcl_SetVar2(interp, "tcl_platform", "machine", name.machine, + TCL_GLOBAL_ONLY); + } +#endif + if (!unameOK) { + Tcl_SetVar2(interp, "tcl_platform", "os", "", TCL_GLOBAL_ONLY); + Tcl_SetVar2(interp, "tcl_platform", "osVersion", "", TCL_GLOBAL_ONLY); + Tcl_SetVar2(interp, "tcl_platform", "machine", "", TCL_GLOBAL_ONLY); + } + + if (!initialized) { + /* + * The code below causes SIGPIPE (broken pipe) errors to + * be ignored. This is needed so that Tcl processes don't + * die if they create child processes (e.g. using "exec" or + * "open") that terminate prematurely. The signal handler + * is only set up when the first interpreter is created; + * after this the application can override the handler with + * a different one of its own, if it wants. + */ + +#ifdef SIGPIPE + (void) signal(SIGPIPE, SIG_IGN); +#endif /* SIGPIPE */ + +#ifdef __FreeBSD__ + fpsetround(FP_RN); + fpsetmask(0L); +#endif + +#if defined(__bsdi__) && (_BSDI_VERSION > 199501) + /* + * Find local symbols. Don't report an error if we fail. + */ + (void) dlopen (NULL, RTLD_NOW); +#endif + initialized = 1; + } +} + +/* + *---------------------------------------------------------------------- + * + * 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. */ +{ + return Tcl_Eval(interp, initScript); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SourceRCFile -- + * + * This procedure is typically invoked by Tcl_Main of Tk_Main + * procedure to source an application specific rc file into the + * interpreter at startup time. + * + * Results: + * None. + * + * Side effects: + * Depends on what's in the rc script. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SourceRCFile(interp) + Tcl_Interp *interp; /* Interpreter to source rc file into. */ +{ + Tcl_DString temp; + char *fileName; + Tcl_Channel errChannel; + + fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY); + + if (fileName != NULL) { + Tcl_Channel c; + char *fullName; + + Tcl_DStringInit(&temp); + fullName = Tcl_TranslateFileName(interp, fileName, &temp); + if (fullName == NULL) { + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel) { + Tcl_Write(errChannel, interp->result, -1); + Tcl_Write(errChannel, "\n", 1); + } + } else { + + /* + * Test for the existence of the rc file before trying to read it. + */ + + c = Tcl_OpenFileChannel(NULL, fullName, "r", 0); + if (c != (Tcl_Channel) NULL) { + Tcl_Close(NULL, c); + if (Tcl_EvalFile(interp, fullName) != TCL_OK) { + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel) { + Tcl_Write(errChannel, interp->result, -1); + Tcl_Write(errChannel, "\n", 1); + } + } + } + } + Tcl_DStringFree(&temp); + } +} diff --git a/tcl7.6/unix/tclUnixNotfy.c b/tcl7.6/unix/tclUnixNotfy.c new file mode 100644 index 0000000..7dce634 --- /dev/null +++ b/tcl7.6/unix/tclUnixNotfy.c @@ -0,0 +1,322 @@ +/* + * tclUnixNotify.c -- + * + * This file contains Unix-specific procedures for the notifier, + * which is the lowest-level part of the Tcl event loop. This file + * works together with ../generic/tclNotify.c. + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclUnixNotfy.c 1.31 96/07/23 16:17:29 + */ + +#include "tclInt.h" +#include "tclPort.h" +#include + +/* + * The information below is used to provide read, write, and + * exception masks to select during calls to Tcl_DoOneEvent. + */ + +static fd_mask checkMasks[3*MASK_SIZE]; + /* This array is used to build up the masks + * to be used in the next call to select. + * Bits are set in response to calls to + * Tcl_WatchFile. */ +static fd_mask readyMasks[3*MASK_SIZE]; + /* This array reflects the readable/writable + * conditions that were found to exist by the + * last call to select. */ +static int numFdBits; /* Number of valid bits in checkMasks + * (one more than highest fd for which + * Tcl_WatchFile has been called). */ + +/* + * Static routines in this file: + */ + +static int MaskEmpty _ANSI_ARGS_((long *maskPtr)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_WatchFile -- + * + * Arrange for Tcl_DoOneEvent to include this file in the masks + * for the next call to select. This procedure is invoked by + * event sources, which are in turn invoked by Tcl_DoOneEvent + * before it invokes select. + * + * Results: + * None. + * + * Side effects: + * + * The notifier will generate a file event when the I/O channel + * given by fd next becomes ready in the way indicated by mask. + * If fd is already registered then the old mask will be replaced + * with the new one. Once the event is sent, the notifier will + * not send any more events about the fd until the next call to + * Tcl_NotifyFile. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_WatchFile(file, mask) + Tcl_File file; /* Generic file handle for a stream. */ + int mask; /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, and TCL_EXCEPTION: + * indicates conditions to wait for + * in select. */ +{ + int fd, type, index; + fd_mask bit; + + fd = (int) Tcl_GetFileInfo(file, &type); + + if (type != TCL_UNIX_FD) { + panic("Tcl_WatchFile: unexpected file type"); + } + + if (fd >= FD_SETSIZE) { + panic("Tcl_WatchFile can't handle file id %d", fd); + } + + index = fd/(NBBY*sizeof(fd_mask)); + bit = 1 << (fd%(NBBY*sizeof(fd_mask))); + if (mask & TCL_READABLE) { + checkMasks[index] |= bit; + } + if (mask & TCL_WRITABLE) { + (checkMasks+MASK_SIZE)[index] |= bit; + } + if (mask & TCL_EXCEPTION) { + (checkMasks+2*(MASK_SIZE))[index] |= bit; + } + if (numFdBits <= fd) { + numFdBits = fd+1; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FileReady -- + * + * Indicates what conditions (readable, writable, etc.) were + * present on a file the last time the notifier invoked select. + * This procedure is typically invoked by event sources to see + * if they should queue events. + * + * Results: + * The return value is 0 if none of the conditions specified by mask + * was true for fd the last time the system checked. If any of the + * conditions were true, then the return value is a mask of those + * that were true. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_FileReady(file, mask) + Tcl_File file; /* Generic file handle for a stream. */ + int mask; /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, and TCL_EXCEPTION: + * indicates conditions caller cares about. */ +{ + int index, result, type, fd; + fd_mask bit; + + fd = (int) Tcl_GetFileInfo(file, &type); + if (type != TCL_UNIX_FD) { + panic("Tcl_FileReady: unexpected file type"); + } + + index = fd/(NBBY*sizeof(fd_mask)); + bit = 1 << (fd%(NBBY*sizeof(fd_mask))); + result = 0; + if ((mask & TCL_READABLE) && (readyMasks[index] & bit)) { + result |= TCL_READABLE; + } + if ((mask & TCL_WRITABLE) && ((readyMasks+MASK_SIZE)[index] & bit)) { + result |= TCL_WRITABLE; + } + if ((mask & TCL_EXCEPTION) && ((readyMasks+(2*MASK_SIZE))[index] & bit)) { + result |= TCL_EXCEPTION; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * MaskEmpty -- + * + * Returns nonzero if mask is empty (has no bits set). + * + * Results: + * Nonzero if the mask is empty, zero otherwise. + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +static int +MaskEmpty(maskPtr) + long *maskPtr; +{ + long *runPtr, *tailPtr; + int found, sz; + + sz = 3 * ((MASK_SIZE) / sizeof(long)) * sizeof(fd_mask); + for (runPtr = maskPtr, tailPtr = maskPtr + sz, found = 0; + runPtr < tailPtr; + runPtr++) { + if (*runPtr != 0) { + found = 1; + break; + } + } + return !found; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_WaitForEvent -- + * + * This procedure does the lowest level wait for events in a + * platform-specific manner. It uses information provided by + * previous calls to Tcl_WatchFile, plus the timePtr argument, + * to determine what to wait for and how long to wait. + * + * Results: + * The return value is normally TCL_OK. However, if there are + * no events to wait for (e.g. no files and no timers) so that + * the procedure would block forever, then it returns TCL_ERROR. + * + * Side effects: + * May put the process to sleep for a while, depending on timePtr. + * When this procedure returns, an event of interest to the application + * has probably, but not necessarily, occurred. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_WaitForEvent(timePtr) + Tcl_Time *timePtr; /* Specifies the maximum amount of time + * that this procedure should block before + * returning. The time is given as an + * interval, not an absolute wakeup time. + * NULL means block forever. */ +{ + struct timeval timeout, *timeoutPtr; + int numFound; + + memcpy((VOID *) readyMasks, (VOID *) checkMasks, + 3*MASK_SIZE*sizeof(fd_mask)); + if (timePtr == NULL) { + if ((numFdBits == 0) || (MaskEmpty((long *) readyMasks))) { + return TCL_ERROR; + } + timeoutPtr = NULL; + } else { + timeoutPtr = &timeout; + timeout.tv_sec = timePtr->sec; + timeout.tv_usec = timePtr->usec; + } + numFound = select(numFdBits, (SELECT_MASK *) &readyMasks[0], + (SELECT_MASK *) &readyMasks[MASK_SIZE], + (SELECT_MASK *) &readyMasks[2*MASK_SIZE], timeoutPtr); + + /* + * Some systems don't clear the masks after an error, so + * we have to do it here. + */ + + if (numFound == -1) { + memset((VOID *) readyMasks, 0, 3*MASK_SIZE*sizeof(fd_mask)); + } + + /* + * Reset the check masks in preparation for the next call to + * select. + */ + + numFdBits = 0; + memset((VOID *) checkMasks, 0, 3*MASK_SIZE*sizeof(fd_mask)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Sleep -- + * + * Delay execution for the specified number of milliseconds. + * + * Results: + * None. + * + * Side effects: + * Time passes. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_Sleep(ms) + int ms; /* Number of milliseconds to sleep. */ +{ + static struct timeval delay; + Tcl_Time before, after; + + /* + * The only trick here is that select appears to return early + * under some conditions, so we have to check to make sure that + * the right amount of time really has elapsed. If it's too + * early, go back to sleep again. + */ + + TclpGetTime(&before); + after = before; + after.sec += ms/1000; + after.usec += (ms%1000)*1000; + if (after.usec > 1000000) { + after.usec -= 1000000; + after.sec += 1; + } + while (1) { + delay.tv_sec = after.sec - before.sec; + delay.tv_usec = after.usec - before.usec; + if (delay.tv_usec < 0) { + delay.tv_usec += 1000000; + delay.tv_sec -= 1; + } + + /* + * Special note: must convert delay.tv_sec to int before comparing + * to zero, since delay.tv_usec is unsigned on some platforms. + */ + + if ((((int) delay.tv_sec) < 0) + || ((delay.tv_usec == 0) && (delay.tv_sec == 0))) { + break; + } + (void) select(0, (SELECT_MASK *) 0, (SELECT_MASK *) 0, + (SELECT_MASK *) 0, &delay); + TclpGetTime(&before); + } +} + diff --git a/tcl7.6/unix/tclUnixPipe.c b/tcl7.6/unix/tclUnixPipe.c new file mode 100644 index 0000000..8516667 --- /dev/null +++ b/tcl7.6/unix/tclUnixPipe.c @@ -0,0 +1,378 @@ +/* + * tclUnixPipe.c -- This file implements the UNIX-specific exec pipeline + * functions. + * + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclUnixPipe.c 1.30 96/09/12 14:57:15 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * Declarations for local procedures defined in this file: + */ + +static void RestoreSignals _ANSI_ARGS_((void)); +static int SetupStdFile _ANSI_ARGS_((Tcl_File file, int type)); + +/* + *---------------------------------------------------------------------- + * + * TclpCreateProcess -- + * + * Create a child process that has the specified files as its + * standard input, output, and error. The child process runs + * asynchronously and runs with the same environment variables + * as the creating process. + * + * The path is searched to find the specified executable. + * + * Results: + * The return value is TCL_ERROR and an error message is left in + * interp->result if there was a problem creating the child + * process. Otherwise, the return value is TCL_OK and *pidPtr is + * filled with the process id of the child process. + * + * Side effects: + * A process is created. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile, + inputFileName, outputFileName, errorFileName, pidPtr) + Tcl_Interp *interp; /* Interpreter in which to leave errors that + * occurred when creating the child process. + * Error messages from the child process + * itself are sent to errorFile. */ + int argc; /* Number of arguments in following array. */ + char **argv; /* Array of argument strings. argv[0] + * contains the name of the executable + * converted to native format (using the + * Tcl_TranslateFileName call). Additional + * arguments have not been converted. */ + Tcl_File inputFile; /* If non-NULL, gives the file to use as + * input for the child process. If inputFile + * file is not readable or is NULL, the child + * will receive no standard input. */ + Tcl_File outputFile; /* If non-NULL, gives the file that + * receives output from the child process. If + * outputFile file is not writeable or is + * NULL, output from the child will be + * discarded. */ + Tcl_File errorFile; /* If non-NULL, gives the file that + * receives errors from the child process. If + * errorFile file is not writeable or is NULL, + * errors from the child will be discarded. + * errorFile may be the same as outputFile. */ + char *inputFileName; /* If non-NULL, gives the name of the disk + * file that corresponds to inputFile + * (unused). */ + char *outputFileName; /* If non-NULL, gives the name of the disk + * file that corresponds to outputFile + * (unused). */ + char *errorFileName; /* If non-NULL, gives the name of the disk + * file that corresponds to errorFile + * (unused). */ + int *pidPtr; /* If this procedure is successful, pidPtr + * is filled with the process id of the child + * process. */ +{ + Tcl_File errPipeIn, errPipeOut; + int pid, joinThisError, count, status; + char errSpace[200]; + + errPipeIn = NULL; + errPipeOut = NULL; + pid = -1; + + /* + * Create a pipe that the child can use to return error + * information if anything goes wrong. + */ + + if (TclCreatePipe(&errPipeIn, &errPipeOut) == 0) { + Tcl_AppendResult(interp, "couldn't create pipe: ", + Tcl_PosixError(interp), (char *) NULL); + goto error; + } + + joinThisError = (errorFile == outputFile); + pid = vfork(); + if (pid == 0) { + + /* + * Set up stdio file handles for the child process. + */ + + if (!SetupStdFile(inputFile, TCL_STDIN) + || !SetupStdFile(outputFile, TCL_STDOUT) + || (!joinThisError && !SetupStdFile(errorFile, TCL_STDERR)) + || (joinThisError && + ((dup2(1,2) == -1) || + (fcntl(2, F_SETFD, 0) != 0)))) { + sprintf(errSpace, + "%dforked process couldn't set up input/output: ", + errno); + TclWriteFile(errPipeOut, 1, errSpace, (int) strlen(errSpace)); + _exit(1); + } + + /* + * Close the input side of the error pipe. + */ + + RestoreSignals(); + execvp(argv[0], &argv[0]); + sprintf(errSpace, "%dcouldn't execute \"%.150s\": ", errno, + argv[0]); + TclWriteFile(errPipeOut, 1, errSpace, (int) strlen(errSpace)); + _exit(1); + } + if (pid == -1) { + Tcl_AppendResult(interp, "couldn't fork child process: ", + Tcl_PosixError(interp), (char *) NULL); + goto error; + } + + /* + * Read back from the error pipe to see if the child startup + * up OK. The info in the pipe (if any) consists of a decimal + * errno value followed by an error message. + */ + + TclCloseFile(errPipeOut); + errPipeOut = NULL; + + count = TclReadFile(errPipeIn, 1, errSpace, + (size_t) (sizeof(errSpace) - 1)); + if (count > 0) { + char *end; + errSpace[count] = 0; + errno = strtol(errSpace, &end, 10); + Tcl_AppendResult(interp, end, Tcl_PosixError(interp), + (char *) NULL); + goto error; + } + + TclCloseFile(errPipeIn); + *pidPtr = pid; + return TCL_OK; + + error: + if (pid != -1) { + /* + * Reap the child process now if an error occurred during its + * startup. + */ + + Tcl_WaitPid(pid, &status, WNOHANG); + } + + if (errPipeIn) { + TclCloseFile(errPipeIn); + } + if (errPipeOut) { + TclCloseFile(errPipeOut); + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * 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 +} + +/* + *---------------------------------------------------------------------- + * + * SetupStdFile -- + * + * Set up stdio file handles for the child process, using the + * current standard channels if no other files are specified. + * If no standard channel is defined, or if no file is associated + * with the channel, then the corresponding standard fd is closed. + * + * Results: + * Returns 1 on success, or 0 on failure. + * + * Side effects: + * Replaces stdio fds. + * + *---------------------------------------------------------------------- + */ + +static int +SetupStdFile(file, type) + Tcl_File file; /* File to dup, or NULL. */ + int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR */ +{ + Tcl_Channel channel; + int fd; + int targetFd = 0; /* Initializations here needed only to */ + int direction = 0; /* prevent warnings about using uninitialized + * variables. */ + + switch (type) { + case TCL_STDIN: + targetFd = 0; + direction = TCL_READABLE; + break; + case TCL_STDOUT: + targetFd = 1; + direction = TCL_WRITABLE; + break; + case TCL_STDERR: + targetFd = 2; + direction = TCL_WRITABLE; + break; + } + + if (!file) { + channel = Tcl_GetStdChannel(type); + if (channel) { + file = Tcl_GetChannelFile(channel, direction); + } + } + if (file) { + fd = (int)Tcl_GetFileInfo(file, NULL); + if (fd != targetFd) { + if (dup2(fd, targetFd) == -1) { + return 0; + } + + /* + * Must clear the close-on-exec flag for the target FD, since + * some systems (e.g. Ultrix) do not clear the CLOEXEC flag on + * the target FD. + */ + + fcntl(targetFd, F_SETFD, 0); + } else { + int result; + + /* + * Since we aren't dup'ing the file, we need to explicitly clear + * the close-on-exec flag. + */ + + result = fcntl(fd, F_SETFD, 0); + } + } else { + close(targetFd); + } + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * TclCreatePipe -- + * + * Creates a pipe - simply calls the pipe() function. + * + * Results: + * Returns 1 on success, 0 on failure. + * + * Side effects: + * Creates a pipe. + * + *---------------------------------------------------------------------- + */ +int +TclCreatePipe(readPipe, writePipe) + Tcl_File *readPipe; /* Location to store file handle for + * read side of pipe. */ + Tcl_File *writePipe; /* Location to store file handle for + * write side of pipe. */ +{ + int pipeIds[2]; + + if (pipe(pipeIds) != 0) { + return 0; + } + + fcntl(pipeIds[0], F_SETFD, FD_CLOEXEC); + fcntl(pipeIds[1], F_SETFD, FD_CLOEXEC); + + *readPipe = Tcl_GetFile((ClientData)pipeIds[0], TCL_UNIX_FD); + *writePipe = Tcl_GetFile((ClientData)pipeIds[1], TCL_UNIX_FD); + return 1; +} diff --git a/tcl7.6/unix/tclUnixPort.h b/tcl7.6/unix/tclUnixPort.h new file mode 100644 index 0000000..58fc49c --- /dev/null +++ b/tcl7.6/unix/tclUnixPort.h @@ -0,0 +1,448 @@ +/* + * tclUnixPort.h -- + * + * This header file handles porting issues that occur because + * of differences between systems. It 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 such + * as NO_DIRENT_H that are set up by the "configure" script. + * + * Much of the material in this file was originally contributed + * by Karl Lehenbauer, Mark Diekhans and Peter da Silva. + * + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclUnixPort.h 1.43 96/10/08 17:13:28 + */ + +#ifndef _TCLUNIXPORT +#define _TCLUNIXPORT + +#ifndef _TCLINT +# include "tclInt.h" +#endif +#include +#include +#ifdef HAVE_NET_ERRNO_H +# include +#endif +#include +#include +#include +#include +#ifdef USE_DIRENT2_H +# include "../compat/dirent2.h" +#else +# ifdef NO_DIRENT_H +# include "../compat/dirent.h" +# else +# include +# endif +#endif +#include +#ifdef HAVE_SYS_SELECT_H +# include +#endif +#include +#if TIME_WITH_SYS_TIME +# include +# include +#else +# if HAVE_SYS_TIME_H +# include +# else +# include +# endif +#endif +#ifndef NO_SYS_WAIT_H +# include +#endif +#ifdef HAVE_UNISTD_H +# include +#else +# include "../compat/unistd.h" +#endif +#ifdef USE_FIONBIO + + /* + * Not using the Posix fcntl(...,O_NONBLOCK,...) interface, instead + * we are using ioctl(..,FIONBIO,..). + */ + +# ifdef HAVE_SYS_FILIO_H +# include /* For FIONBIO. */ +# endif + +# ifdef HAVE_SYS_IOCTL_H +# include /* For FIONBIO. */ +# endif +#endif /* USE_FIONBIO */ + +/* + * Socket support stuff: This likely needs more work to parameterize for + * each system. + */ + +#include /* struct sockaddr, SOCK_STREAM, ... */ +#ifndef NO_UNAME +# include /* uname system call. */ +#endif +#include /* struct in_addr, struct sockaddr_in */ +#include /* inet_ntoa() */ +#include /* gethostbyname() */ + +/* + * NeXT doesn't define O_NONBLOCK, so #define it here if necessary. + */ + +#ifndef O_NONBLOCK +# define O_NONBLOCK 0x80 +#endif + +/* + * HPUX needs the flag O_NONBLOCK to get the right non-blocking I/O + * semantics, while most other systems need O_NDELAY. Define the + * constant NBIO_FLAG to be one of these + */ + +#ifdef HPUX +# define NBIO_FLAG O_NONBLOCK +#else +# define NBIO_FLAG O_NDELAY +#endif + +/* + * The following defines denote malloc and free as the system calls + * used to allocate new memory. These defines are only used in the + * file tclCkalloc.c. + */ + +#define TclpAlloc(size) malloc(size) +#define TclpFree(ptr) free(ptr) +#define TclpRealloc(ptr, size) realloc(ptr, size) + +/* + * The default platform eol translation on Unix is TCL_TRANSLATE_LF: + */ + +#define TCL_PLATFORM_TRANSLATION TCL_TRANSLATE_LF + +/* + * Not all systems declare the errno variable in errno.h. so this + * file does it explicitly. The list of system error messages also + * isn't generally declared in a header file anywhere. + */ + +extern int errno; + +/* + * The type of the status returned by wait varies from UNIX system + * to UNIX system. The macro below defines it: + */ + +#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 + +/* + * Define constants for waitpid() system call if they aren't defined + * by a system header file. + */ + +#ifndef WNOHANG +# define WNOHANG 1 +#endif +#ifndef WUNTRACED +# define WUNTRACED 2 +#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 +# include +# ifndef CLK_TCK +# ifdef HZ +# define CLK_TCK HZ +# else +# define CLK_TCK 60 +# endif +# endif +#else +# ifdef HAVE_BSDGETTIMEOFDAY +# define gettimeofday BSDgettimeofday +# endif +#endif + +#ifdef GETTOD_NOT_DECLARED +EXTERN int gettimeofday _ANSI_ARGS_((struct timeval *tp, + struct timezone *tzp)); +#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 + +/* + * Define FD_CLOEEXEC (the close-on-exec flag bit) if it isn't + * already defined. + */ + +#ifndef FD_CLOEXEC +# define FD_CLOEXEC 1 +#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 + +/* + * The following macro defines the type of the mask arguments to + * select: + */ + +#ifndef NO_FD_SET +# define SELECT_MASK fd_set +#else +# ifndef _AIX + typedef long fd_mask; +# endif +# if defined(_IBMR2) +# define SELECT_MASK void +# else +# define SELECT_MASK int +# endif +#endif + +/* + * Define "NBBY" (number of bits per byte) if it's not already defined. + */ + +#ifndef NBBY +# define NBBY 8 +#endif + +/* + * The following macro defines the number of fd_masks in an fd_set: + */ + +#ifndef FD_SETSIZE +# ifdef OPEN_MAX +# define FD_SETSIZE OPEN_MAX +# else +# define FD_SETSIZE 256 +# endif +#endif +#if !defined(howmany) +# define howmany(x, y) (((x)+((y)-1))/(y)) +#endif +#ifndef NFDBITS +# define NFDBITS NBBY*sizeof(fd_mask) +#endif +#define MASK_SIZE howmany(FD_SETSIZE, NFDBITS) + +/* + * The following function is declared in tclInt.h but doesn't do anything + * on Unix systems. + */ + +#define TclSetSystemEnv(a,b) + +/* + * The following implements the Unix method for exiting the process. + */ +#define TclPlatformExit(status) exit(status) + +/* + * The following functions always succeeds under Unix. + */ + +#define TclHasSockets(interp) (TCL_OK) +#define TclHasPipes() (1) + +/* + * Variables provided by the C library: + */ + +#if defined(_sgi) || defined(__sgi) +#define environ _environ +#endif +extern char **environ; + +/* + * 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(); + +/* + * The following macros define time related functions in terms of + * standard Unix routines. + */ + +#define TclpGetDate(t,u) ((u) ? gmtime((t)) : localtime((t))) +#define TclStrftime(s,m,f,t) (strftime((s),(m),(f),(t))) + +#endif /* _TCLUNIXPORT */ diff --git a/tcl7.6/unix/tclUnixSock.c b/tcl7.6/unix/tclUnixSock.c new file mode 100644 index 0000000..4301889 --- /dev/null +++ b/tcl7.6/unix/tclUnixSock.c @@ -0,0 +1,81 @@ +/* + * tclUnixSock.c -- + * + * This file contains Unix-specific socket related code. + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclUnixSock.c 1.6 96/08/08 08:48:51 + */ + +#include "tcl.h" +#include "tclPort.h" + +/* + * The following variable holds the network name of this host. + */ + +#ifndef SYS_NMLN +# define SYS_NMLN 100 +#endif + +static char hostname[SYS_NMLN + 1]; +static int hostnameInited = 0; + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetHostName -- + * + * Get the network name for this machine, in a system dependent way. + * + * Results: + * A string containing the network name for this machine, or + * an empty string if we can't figure out the name. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_GetHostName() +{ +#ifndef NO_UNAME + struct utsname u; + struct hostent *hp; +#endif + + if (hostnameInited) { + return hostname; + } + +#ifndef NO_UNAME + if (uname(&u) > -1) { + hp = gethostbyname(u.nodename); + if (hp != NULL) { + strcpy(hostname, hp->h_name); + } else { + strcpy(hostname, u.nodename); + } + hostnameInited = 1; + return hostname; + } +#else + /* + * Uname doesn't exist; try gethostname instead. + */ + + if (gethostname(hostname, sizeof(hostname)) > -1) { + hostnameInited = 1; + return hostname; + } +#endif + + hostname[0] = 0; + return hostname; +} diff --git a/tcl7.6/unix/tclUnixTest.c b/tcl7.6/unix/tclUnixTest.c new file mode 100644 index 0000000..1fc95e6 --- /dev/null +++ b/tcl7.6/unix/tclUnixTest.c @@ -0,0 +1,378 @@ +/* + * tclUnixTest.c -- + * + * Contains platform specific test commands for the Unix platform. + * + * Copyright (c) 1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclUnixTest.c 1.1 96/03/26 12:44:30 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * The stuff below is used to keep track of file handlers created and + * exercised by the "testfilehandler" command. + */ + +typedef struct Pipe { + Tcl_File readFile; /* File handle for reading from the + * pipe. NULL means pipe doesn't exist yet. */ + Tcl_File writeFile; /* File handle for writing from the + * pipe. */ + int readCount; /* Number of times the file handler for + * this file has triggered and the file + * was readable. */ + int writeCount; /* Number of times the file handler for + * this file has triggered and the file + * was writable. */ +} Pipe; + +#define MAX_PIPES 10 +static Pipe testPipes[MAX_PIPES]; + +/* + * Forward declarations of procedures defined later in this file: + */ + +static void TestFileHandlerProc _ANSI_ARGS_((ClientData clientData, + int mask)); +static int TestfilehandlerCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestgetopenfileCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +int TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp)); + +/* + *---------------------------------------------------------------------- + * + * TclplatformtestInit -- + * + * Defines commands that test platform specific functionality for + * Unix platforms. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Defines new commands. + * + *---------------------------------------------------------------------- + */ + +int +TclplatformtestInit(interp) + Tcl_Interp *interp; /* Interpreter to add commands to. */ +{ + Tcl_CreateCommand(interp, "testfilehandler", TestfilehandlerCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testgetopenfile", TestgetopenfileCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestfilehandlerCmd -- + * + * This procedure implements the "testfilehandler" command. It is + * used to test Tcl_CreateFileHandler, Tcl_DeleteFileHandler, and + * TclWaitForFile. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestfilehandlerCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Pipe *pipePtr; + int i, mask, timeout; + static int initialized = 0; + char buffer[4000]; + Tcl_File file; + + /* + * NOTE: When we make this code work on Windows also, the following + * variable needs to be made Unix-only. + */ + + int fd; + + if (!initialized) { + for (i = 0; i < MAX_PIPES; i++) { + testPipes[i].readFile = NULL; + } + initialized = 1; + } + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " option ... \"", (char *) NULL); + return TCL_ERROR; + } + pipePtr = NULL; + if (argc >= 3) { + if (Tcl_GetInt(interp, argv[2], &i) != TCL_OK) { + return TCL_ERROR; + } + if (i >= MAX_PIPES) { + Tcl_AppendResult(interp, "bad index ", argv[2], (char *) NULL); + return TCL_ERROR; + } + pipePtr = &testPipes[i]; + } + + if (strcmp(argv[1], "close") == 0) { + for (i = 0; i < MAX_PIPES; i++) { + if (testPipes[i].readFile != NULL) { + Tcl_DeleteFileHandler(testPipes[i].readFile); + + /* + * NOTE: Unix specific code below. + */ + + fd = (int) Tcl_GetFileInfo(testPipes[i].readFile, NULL); + close(fd); + Tcl_FreeFile(testPipes[i].readFile); + + testPipes[i].readFile = NULL; + Tcl_DeleteFileHandler(testPipes[i].writeFile); + + /* + * NOTE: Unix specific code below. + */ + + fd = (int) Tcl_GetFileInfo(testPipes[i].writeFile, NULL); + Tcl_FreeFile(testPipes[i].writeFile); + close(fd); + } + } + } else if (strcmp(argv[1], "clear") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " clear index\"", (char *) NULL); + return TCL_ERROR; + } + pipePtr->readCount = pipePtr->writeCount = 0; + } else if (strcmp(argv[1], "counts") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " counts index\"", (char *) NULL); + return TCL_ERROR; + } + sprintf(interp->result, "%d %d", pipePtr->readCount, + pipePtr->writeCount); + } else if (strcmp(argv[1], "create") == 0) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " create index readMode writeMode\"", + (char *) NULL); + return TCL_ERROR; + } + if (pipePtr->readFile == NULL) { + if (!TclCreatePipe(&pipePtr->readFile, &pipePtr->writeFile)) { + Tcl_AppendResult(interp, "couldn't open pipe: ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } +#ifdef O_NONBLOCK + fcntl((int)Tcl_GetFileInfo(pipePtr->readFile, NULL), + F_SETFL, O_NONBLOCK); + fcntl((int)Tcl_GetFileInfo(pipePtr->writeFile, NULL), + F_SETFL, O_NONBLOCK); +#else + interp->result = "can't make pipes non-blocking"; + return TCL_ERROR; +#endif + } + pipePtr->readCount = 0; + pipePtr->writeCount = 0; + + if (strcmp(argv[3], "readable") == 0) { + Tcl_CreateFileHandler(pipePtr->readFile, TCL_READABLE, + TestFileHandlerProc, (ClientData) pipePtr); + } else if (strcmp(argv[3], "off") == 0) { + Tcl_DeleteFileHandler(pipePtr->readFile); + } else if (strcmp(argv[3], "disabled") == 0) { + Tcl_CreateFileHandler(pipePtr->readFile, 0, + TestFileHandlerProc, (ClientData) pipePtr); + } else { + Tcl_AppendResult(interp, "bad read mode \"", argv[3], "\"", + (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[4], "writable") == 0) { + Tcl_CreateFileHandler(pipePtr->writeFile, TCL_WRITABLE, + TestFileHandlerProc, (ClientData) pipePtr); + } else if (strcmp(argv[4], "off") == 0) { + Tcl_DeleteFileHandler(pipePtr->writeFile); + } else if (strcmp(argv[4], "disabled") == 0) { + Tcl_CreateFileHandler(pipePtr->writeFile, 0, + TestFileHandlerProc, (ClientData) pipePtr); + } else { + Tcl_AppendResult(interp, "bad read mode \"", argv[4], "\"", + (char *) NULL); + return TCL_ERROR; + } + } else if (strcmp(argv[1], "empty") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " empty index\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * NOTE: Unix specific code below. + */ + + fd = (int) Tcl_GetFileInfo(pipePtr->readFile, NULL); + while (read(fd, buffer, 4000) > 0) { + /* Empty loop body. */ + } + } else if (strcmp(argv[1], "fill") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " empty index\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * NOTE: Unix specific code below. + */ + + fd = (int) Tcl_GetFileInfo(pipePtr->writeFile, NULL); + memset((VOID *) buffer, 'a', 4000); + while (write(fd, buffer, 4000) > 0) { + /* Empty loop body. */ + } + } else if (strcmp(argv[1], "fillpartial") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " empty index\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * NOTE: Unix specific code below. + */ + + fd = (int) Tcl_GetFileInfo(pipePtr->writeFile, NULL); + memset((VOID *) buffer, 'b', 10); + sprintf(interp->result, "%d", write(fd, buffer, 10)); + } else if (strcmp(argv[1], "oneevent") == 0) { + Tcl_DoOneEvent(TCL_FILE_EVENTS|TCL_DONT_WAIT); + } else if (strcmp(argv[1], "wait") == 0) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " wait index readable/writable timeout\"", + (char *) NULL); + return TCL_ERROR; + } + if (pipePtr->readFile == NULL) { + Tcl_AppendResult(interp, "pipe ", argv[2], " doesn't exist", + (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[3], "readable") == 0) { + mask = TCL_READABLE; + file = pipePtr->readFile; + } else { + mask = TCL_WRITABLE; + file = pipePtr->writeFile; + } + if (Tcl_GetInt(interp, argv[4], &timeout) != TCL_OK) { + return TCL_ERROR; + } + i = TclWaitForFile(file, mask, timeout); + if (i & TCL_READABLE) { + Tcl_AppendElement(interp, "readable"); + } + if (i & TCL_WRITABLE) { + Tcl_AppendElement(interp, "writable"); + } + } else if (strcmp(argv[1], "windowevent") == 0) { + Tcl_DoOneEvent(TCL_WINDOW_EVENTS|TCL_DONT_WAIT); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be close, clear, counts, create, empty, fill, ", + "fillpartial, oneevent, wait, or windowevent", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +static void TestFileHandlerProc(clientData, mask) + ClientData clientData; /* Points to a Pipe structure. */ + int mask; /* Indicates which events happened: + * TCL_READABLE or TCL_WRITABLE. */ +{ + Pipe *pipePtr = (Pipe *) clientData; + + if (mask & TCL_READABLE) { + pipePtr->readCount++; + } + if (mask & TCL_WRITABLE) { + pipePtr->writeCount++; + } +} + +/* + *---------------------------------------------------------------------- + * + * TestgetopenfileCmd -- + * + * This procedure implements the "testgetopenfile" command. It is + * used to get a FILE * value from a registered channel. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestgetopenfileCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + ClientData filePtr; + + if (argc != 3) { + Tcl_AppendResult(interp, + "wrong # args: should be \"", argv[0], + " channelName forWriting\"", + (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetOpenFile(interp, argv[1], atoi(argv[2]), 1, &filePtr) + == TCL_ERROR) { + return TCL_ERROR; + } + if (filePtr == (ClientData) NULL) { + Tcl_AppendResult(interp, + "Tcl_GetOpenFile succeeded but FILE * NULL!", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} diff --git a/tcl7.6/unix/tclUnixTime.c b/tcl7.6/unix/tclUnixTime.c new file mode 100644 index 0000000..6c9d5af --- /dev/null +++ b/tcl7.6/unix/tclUnixTime.c @@ -0,0 +1,217 @@ +/* + * tclUnixTime.c -- + * + * Contains Unix specific versions of Tcl functions that + * obtain time values from the operating system. + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclUnixTime.c 1.11 96/07/23 16:17:21 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + *----------------------------------------------------------------------------- + * + * TclpGetSeconds -- + * + * This procedure returns the number of seconds from the epoch. On + * most Unix systems the epoch is Midnight Jan 1, 1970 GMT. + * + * Results: + * Number of seconds from the epoch. + * + * Side effects: + * None. + * + *----------------------------------------------------------------------------- + */ + +unsigned long +TclpGetSeconds() +{ + return time((time_t *) NULL); +} + +/* + *----------------------------------------------------------------------------- + * + * TclpGetClicks -- + * + * This procedure returns a value that represents the highest resolution + * clock available on the system. There are no garantees on what the + * resolution will be. In Tcl we will call this value a "click". The + * start time is also system dependant. + * + * Results: + * Number of clicks from some start time. + * + * Side effects: + * None. + * + *----------------------------------------------------------------------------- + */ + +unsigned long +TclpGetClicks() +{ + unsigned long now; +#ifdef NO_GETTOD + struct tms dummy; +#else + struct timeval date; + struct timezone tz; +#endif + +#ifdef NO_GETTOD + now = (unsigned long) times(&dummy); +#else + gettimeofday(&date, &tz); + now = date.tv_sec*1000000 + date.tv_usec; +#endif + + return now; +} + +/* + *---------------------------------------------------------------------- + * + * TclpGetTimeZone -- + * + * Determines the current timezone. The method varies wildly + * between different platform implementations, so its hidden in + * this function. + * + * Results: + * Hours east of GMT. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclpGetTimeZone (currentTime) + unsigned long currentTime; +{ + /* + * Determine how a timezone is obtained from "struct tm". If there is no + * time zone in this struct (very lame) then use the timezone variable. + * This is done in a way to make the timezone variable the method of last + * resort, as some systems have it in addition to a field in "struct tm". + * The gettimeofday system call can also be used to determine the time + * zone. + */ + +#if defined(HAVE_TM_TZADJ) +# define TCL_GOT_TIMEZONE + time_t curTime = (time_t) currentTime; + struct tm *timeDataPtr = localtime(&curTime); + int timeZone; + + timeZone = timeDataPtr->tm_tzadj / 60; + if (timeDataPtr->tm_isdst) { + timeZone += 60; + } + + return timeZone; +#endif + +#if defined(HAVE_TM_GMTOFF) && !defined (TCL_GOT_TIMEZONE) +# define TCL_GOT_TIMEZONE + time_t curTime = (time_t) currentTime; + struct tm *timeDataPtr = localtime(¤tTime); + int timeZone; + + timeZone = -(timeDataPtr->tm_gmtoff / 60); + if (timeDataPtr->tm_isdst) { + timeZone += 60; + } + + return timeZone; +#endif + + /* + * Must prefer timezone variable over gettimeofday, as gettimeofday does + * not return timezone information on many systems that have moved this + * information outside of the kernel. + */ + +#if defined(HAVE_TIMEZONE_VAR) && !defined (TCL_GOT_TIMEZONE) +# define TCL_GOT_TIMEZONE + static int setTZ = 0; + int timeZone; + + if (!setTZ) { + tzset(); + setTZ = 1; + } + + /* + * Note: this is not a typo in "timezone" below! See tzset + * documentation for details. + */ + + timeZone = timezone / 60; + + return timeZone; +#endif + +#if defined(HAVE_GETTIMEOFDAY) && !defined (TCL_GOT_TIMEZONE) +# define TCL_GOT_TIMEZONE + struct timeval tv; + struct timezone tz; + int timeZone; + + gettimeofday(&tv, &tz); + timeZone = tz.tz_minuteswest; + if (tz.tz_dsttime) { + timeZone += 60; + } + + return timeZone; +#endif + +#ifndef TCL_GOT_TIMEZONE + /* + * Cause compile error, we don't know how to get timezone. + */ + error: autoconf did not figure out how to determine the timezone. +#endif + +} + +/* + *---------------------------------------------------------------------- + * + * TclpGetTime -- + * + * Gets the current system time in seconds and microseconds + * since the beginning of the epoch: 00:00 UCT, January 1, 1970. + * + * Results: + * Returns the current time in timePtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclpGetTime(timePtr) + Tcl_Time *timePtr; /* Location to store time information. */ +{ + struct timeval tv; + struct timezone tz; + + (void) gettimeofday(&tv, &tz); + timePtr->sec = tv.tv_sec; + timePtr->usec = tv.tv_usec; +} diff --git a/tcl7.6/win/README b/tcl7.6/win/README new file mode 100644 index 0000000..2da7f26 --- /dev/null +++ b/tcl7.6/win/README @@ -0,0 +1,105 @@ +Tcl 7.6 for Windows + +by Scott Stanton +Sun Microsystems Laboratories +scott.stanton@eng.sun.com + +SCCS: @(#) README 1.18 96/10/15 18:35:40 + +1. Introduction +--------------- + +This is the directory where you configure and compile the Windows +version of Tcl. This directory also contains source files for Tcl +that are specific to Microsoft Windows. The rest of this file +contains information specific to the Windows version of Tcl. + +2. Distribution notes +--------------------- + +Tcl 7.6 for Windows is distributed in binary form in addition to the +common source release. The binary distribution is a self-extracting +archive with a built-in installation script. + +Look for the binary release in the same location as the source release +(ftp.smli.com:/pub/tcl or any of the mirror sites). For most users, +the binary release will be much easier to install and use. You only +need the source release if you plan to modify the core of Tcl, or if +you need to compile with a different compiler. With the addition of +the dynamic loading interface, it is no longer necessary to have the +source distribution in order to build and use extensions. + +3. Compiling Tcl +---------------- + +In order to compile Tcl for Windows, you need the following items: + + Tcl 7.6 Source Distribution (plus any patches) + + Borland C++ 4.52/5.0 (both 16-bit and 32-bit compilers) + or + Visual C++ 2.x/4.x + Visual C++ 1.5 (to build tcl1676.dll for Win32s support of exec) + +In the "win" subdirectory of the source release, you will find two +files called "makefile.bc" and "makefile.vc". These are the makefiles +for the Borland and Visual C++ compilers respectively. You should +copy the appropriate one to "makefile" and update the paths at the +top of the file to reflect your system configuration. Now you can use +"make" (or "nmake" for VC++) to build the tcl libraries and the tclsh +executable. + +In order to use the binaries generated by these makefiles, you will +need to place the Tcl script library files someplace where Tcl can +find them. Tcl looks in one of three places for the library files: + + 1) The path specified in the environment variable "TCL_LIBRARY". + + 2) In the lib\tcl7.6 directory under the installation directory + as specified in the registry: + + For Windows NT & 95: + HKEY_LOCAL_MACHINE\SOFTWARE\Sun\Tcl\7.6 + Value Name is "Root" + + For Win32s: + HKEY_CLASSES_ROOT\SOFTWARE\Sun\Tcl\7.6\ + + 3) Relative to the directory containing the current .exe. + Tcl will look for a directory "..\lib\tcl7.6" relative to the + directory containing the currently running .exe. + +Note that in order to run tclsh76.exe, you must ensure that tcl76.dll +and tclpip76.dll (plus tcl1676.dll under Win32s) are on your path, in +the system directory, or in the directory containing tclsh76.exe. + +4. Test suite +------------- + +This distribution contains an extensive test suite for Tcl. Some of +the tests are timing dependent and will fail from time to time. If a +test is failing consistently, please send us a bug report with as much +detail as you can manage. + +In order to run the test suite, you build the "test" target using the +appropriate makefile for your compiler. + + +5. Known Bugs +------------- + +Here is the current list of known bugs/missing features for the +Windows beta version of Tcl: + +- Non-blocking connect for sockets does not work yet. +- File events only work on sockets. +- The library cannot be used by two processes at the same time under + Win32s (i.e. Tcl still isn't thread-safe). + +If you have comments or bug reports for the Windows version of Tcl, +please direct them to: + +Scott Stanton +scott.stanton@eng.sun.com + +or post them to the newsgroup comp.lang.tcl. diff --git a/tcl7.6/win/cat.c b/tcl7.6/win/cat.c new file mode 100644 index 0000000..0ce550f --- /dev/null +++ b/tcl7.6/win/cat.c @@ -0,0 +1,37 @@ +/* + * cat.c -- + * + * Program used when testing tclWinPipe.c + * + * Copyright (c) 1996 by Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) cat.c 1.3 96/09/18 15:15:32 + */ + +#include +#include +#include + +int +main() +{ + char buf[1024]; + int n; + char *err; + + while (1) { + n = read(0, buf, sizeof(buf)); + if (n <= 0) { + break; + } + write(1, buf, n); + } + err = (sizeof(int) == 2) ? "stderr16" : "stderr32"; + write(2, err, strlen(err)); + + return 0; +} + diff --git a/tcl7.6/win/license.terms b/tcl7.6/win/license.terms new file mode 100644 index 0000000..96ad966 --- /dev/null +++ b/tcl7.6/win/license.terms @@ -0,0 +1,39 @@ +This software is copyrighted by the Regents of the University of +California, Sun Microsystems, Inc., and other parties. The following +terms apply to all files associated with the software unless explicitly +disclaimed in individual files. + +The authors hereby grant permission to use, copy, modify, distribute, +and license this software and its documentation for any purpose, provided +that existing copyright notices are retained in all copies and that this +notice is included verbatim in any distributions. No written agreement, +license, or royalty fee is required for any of the authorized uses. +Modifications to this software may be copyrighted by their authors +and need not follow the licensing terms described here, provided that +the new terms are clearly indicated on the first page of each file where +they apply. + +IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY +FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES +ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY +DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + +THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE +IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE +NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR +MODIFICATIONS. + +GOVERNMENT USE: If you are acquiring this software on behalf of the +U.S. government, the Government shall have only "Restricted Rights" +in the software and related documentation as defined in the Federal +Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you +are acquiring the software on behalf of the Department of Defense, the +software shall be classified as "Commercial Computer Software" and the +Government shall have only "Restricted Rights" as defined in Clause +252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the +authors grant the U.S. Government and others acting in its behalf +permission to use and distribute the software in accordance with the +terms specified in this license. diff --git a/tcl7.6/win/makefile.bc b/tcl7.6/win/makefile.bc new file mode 100644 index 0000000..23f94f5 --- /dev/null +++ b/tcl7.6/win/makefile.bc @@ -0,0 +1,335 @@ +# Copyright (c) 1995-1996 Sun Microsystems, Inc. +# SCCS: @(#) makefile.bc 1.64 96/10/11 17:38:55 +# +# Borland C++ 4.5 makefile +# + +# +# Project directories +# +# ROOT = top of source tree +# TMPDIR = location where .obj files should be stored during build +# TOOLS = location of compiler and other development tools +# + +ROOT = .. +TMPDIR = . +TOOLS = c:\bc45 + +# uncomment the following line to compile with symbols +#DEBUG=1 + +# uncomment the following two lines to compile with TCL_MEM_DEBUG +#DEBUGDEFINES =TCL_MEM_DEBUG + +# +# Borland C++ tools +# + +BORLAND = $(TOOLS) +IMPLIB = $(BORLAND)\bin\Implib +BCC32 = $(BORLAND)\bin\Bcc32 +TLINK32 = $(BORLAND)\bin\tlink32 +RC = $(BORLAND)\bin\brcc32 +BCC = $(BORLAND)\bin\Bcc +TLINK = $(BORLAND)\bin\tlink +RC16 = $(BORLAND)\bin\brcc32 -31 +CP = copy +RM = del + +INCLUDES = $(BORLAND)\include;$(ROOT)\generic;$(ROOT)\win +LIBDIRS = $(BORLAND)\lib;$(ROOT)\win + + +!ifndef DEBUG + +# these macros cause maximum optimization and no symbols +DEBUGLDFLAGS = +DEBUGCCFLAGS = -v- -vi- -O2 +DEBUGLDFLAGS16 = -Oc -Oi -Oa -Or +!else + +# these macros enable debugging +DEBUGLDFLAGS = -v +DEBUGCCFLAGS = -k -Od -v +DEBUGLDFLAGS16 = + +!endif + +DEFINES = _RTLDLL;USE_TCLALLOC=0;$(DEBUGDEFINES) +PROJECTCCFLAGS= $(DEBUGCCFLAGS) -w-par -w-stu + +CFLAGS16_dll = $(PROJECTCCFLAGS) -I$(INCLUDES) -D$(DEFINES) -WD -ml -c -3 -d -w + +LNFLAGS_exe = -Tpe -aa -c $(DEBUGLDFLAGS) $(BORLAND)\lib\c0w32 +LNFLAGS_CONSOLE_exe = -Tpe -ap -c $(DEBUGLDFLAGS) $(BORLAND)\lib\c0x32 +LNFLAGS_dll = -Tpd -aa -c $(DEBUGLDFLAGS) $(BORLAND)\lib\c0d32 +LNFLAGS16_dll = -Twd -c -C -A=16 $(DEBUGLDFLAGS16) $(BORLAND)\lib\c0dl.obj +LNLIBS_exe = $(TCLLIB) import32 cw32i +LNLIBS_dll = import32 cw32i +LNLIBS16_dll = import cwl + +# +# Global makefile settings +# + +.AUTODEPEND +.CACHEAUTODEPEND + +.suffixes: .c .dll .lib .obj .exe + +.path.c=$(ROOT)\win;$(ROOT)\generic;$(ROOT)\compat +.path.obj=$(TMPDIR) +.path.dll=$(ROOT)\win;$(WINDIR);$(WINDIR)\SYSTEM32;$(WINDIR)\SYSTEM + +TCLSHOBJS = \ + $(TMPDIR)\tclAppInit.obj + +TCLTESTOBJS = \ + $(TMPDIR)\tclTest.obj \ + $(TMPDIR)\tclWinTest.obj \ + $(TMPDIR)\testMain.obj + +TCLOBJS = \ + $(TMPDIR)\panic.obj \ + $(TMPDIR)\regexp.obj \ + $(TMPDIR)\strftime.obj \ + $(TMPDIR)\tclAsync.obj \ + $(TMPDIR)\tclBasic.obj \ + $(TMPDIR)\tclCkalloc.obj \ + $(TMPDIR)\tclClock.obj \ + $(TMPDIR)\tclCmdAH.obj \ + $(TMPDIR)\tclCmdIL.obj \ + $(TMPDIR)\tclCmdMZ.obj \ + $(TMPDIR)\tclDate.obj \ + $(TMPDIR)\tclEnv.obj \ + $(TMPDIR)\tclEvent.obj \ + $(TMPDIR)\tclExpr.obj \ + $(TMPDIR)\tclFCmd.obj \ + $(TMPDIR)\tclFHandle.obj \ + $(TMPDIR)\tclFileName.obj \ + $(TMPDIR)\tclGet.obj \ + $(TMPDIR)\tclHash.obj \ + $(TMPDIR)\tclHistory.obj \ + $(TMPDIR)\tclIO.obj \ + $(TMPDIR)\tclIOCmd.obj \ + $(TMPDIR)\tclIOSock.obj \ + $(TMPDIR)\tclIOUtil.obj \ + $(TMPDIR)\tclInterp.obj \ + $(TMPDIR)\tclLink.obj \ + $(TMPDIR)\tclLoad.obj \ + $(TMPDIR)\tclMain.obj \ + $(TMPDIR)\tclNotify.obj \ + $(TMPDIR)\tclParse.obj \ + $(TMPDIR)\tclPkg.obj \ + $(TMPDIR)\tclPosixStr.obj \ + $(TMPDIR)\tclPreserve.obj \ + $(TMPDIR)\tclProc.obj \ + $(TMPDIR)\tclUtil.obj \ + $(TMPDIR)\tclVar.obj \ + $(TMPDIR)\tclWin32Dll.obj \ + $(TMPDIR)\tclWinChan.obj \ + $(TMPDIR)\tclWinError.obj \ + $(TMPDIR)\tclWinFCmd.obj \ + $(TMPDIR)\tclWinFile.obj \ + $(TMPDIR)\tclWinInit.obj \ + $(TMPDIR)\tclWinLoad.obj \ + $(TMPDIR)\tclWinMtherr.obj \ + $(TMPDIR)\tclWinNotify.obj \ + $(TMPDIR)\tclWinPipe.obj \ + $(TMPDIR)\tclWinSock.obj \ + $(TMPDIR)\tclWinTime.obj + +TCLLIB = tcl76.lib +TCLDLL = tcl76.dll +TCL16DLL = tcl1676.dll +TCLSH = tclsh76.exe +TCLTEST = tcltest.exe +DUMPEXTS = dumpexts.exe +TCLPIPEDLL = tclpip76.dll +CAT16 = cat16.exe +CAT32 = cat32.exe + +# +# Targets +# + +all: cfgcln $(DUMPEXTS) $(TCLPIPEDLL) $(TCL16DLL) cfgdll $(TCLDLL) cfgexe $(TCLSH) cfgcln + +test: cfgcln $(DUMPEXTS) $(TCLPIPEDLL) $(TCL16DLL) $(CAT16) $(CAT32) cfgdll $(TCLDLL) cfgtest $(TCLTEST) cfgcln + $(TCLTEST) &&| + cd ../tests + source all +| + + + +# Implicit Targets + +.c.obj: + @$(BCC32) {$< } + +.dll.lib: + $(IMPLIB) -c $@ $< + +.rc.res: + $(RC) -i$(INCLUDES) -d__WIN32__;$(DEFINES) $< + +# +# Special case object file targets +# + +$(TMPDIR)\testMain.obj : $(ROOT)\win\tclAppInit.c + $(BCC32) -c -o$@ $(ROOT)\win\tclAppInit.c + +$(TMPDIR)\tclWin16.obj : $(ROOT)\win\tclWin16.c + $(BCC) -c -o$@ $(ROOT)\win\tclWin16.c + +# +# Configuration file targets - these files are implicitly used by the compiler +# + +cfgdll: + @$(CP) &&| + -n$(TMPDIR) -I$(INCLUDES) -c -WD + -D$(DEFINES) -3 -d -w $(PROJECTCCFLAGS) +| bcc32.cfg >NUL + +cfgexe: + @$(CP) &&| + -n$(TMPDIR) -I$(INCLUDES) -c -W + -D$(DEFINES) -3 -d -w $(PROJECTCCFLAGS) +| bcc32.cfg >NUL + +cfgtest: + @$(CP) &&| + -n$(TMPDIR) -I$(INCLUDES) -c -W + -D$(DEFINES);TCL_TEST -3 -d -w $(PROJECTCCFLAGS) +| bcc32.cfg >NUL + +cfgcln: + -@$(RM) *.cfg + +# +# Executable targets +# + +dumpexts.exe: winDumpExts.c + $(BCC32) -WC -c winDumpExts.c + $(TLINK32) $(LNFLAGS_CONSOLE_exe) \ + winDumpExts.obj,$@,,import32 cw32,, + +$(TCLPIPEDLL): stub16.c + $(BCC32) -c -tWC stub16.c + $(TLINK32) $(LNFLAGS_CONSOLE_exe) -L$(BORLAND)\lib \ + stub16.obj,$@,,import32 cw32,, + +$(CAT32): cat.c + $(BCC32) -c -Ox -tWC -ocat32.obj cat.c + $(TLINK32) $(LNFLAGS_CONSOLE_exe) -L$(BORLAND)\lib \ + cat32.obj,$@,,import32 cw32,, + +$(CAT16): cat.c + $(BCC) -W- -ml -Ox -c -ocat16.obj cat.c + $(TLINK) -Tde -c -L$(BORLAND)\lib $(BORLAND)\lib\c0l.obj cat16.obj,cat16.exe,,cl.lib,, + +$(TCLDLL): $(TCLOBJS) tcl.def tcl.res + $(TLINK32) $(LNFLAGS_dll) @&&| + $(TCLOBJS) +$@ +-x +$(LNLIBS_dll) +|, tcl.def, tcl.res + +$(TCL16DLL): tcl16.rc $(ROOT)\win\tclWin16.c + $(BCC) @&&| +$(CFLAGS16_dll) -n$(TMPDIR) +| $(ROOT)\win\tclWin16.c + $(RC16) -i$(INCLUDES) -d__WIN32__;$(DEFINES) tcl16.rc + @copy >nul &&| +LIBRARY $&;dll +EXETYPE WINDOWS +CODE PRELOAD MOVEABLE DISCARDABLE +DATA PRELOAD MOVEABLE SINGLE +HEAPSIZE 1024 +EXPORTS + WEP @1 RESIDENTNAME + UTPROC @2 +| $(TMPDIR)\tclWin16.def + $(TLINK) $(LNFLAGS16_dll) @&&| +$(TMPDIR)\tclWin16.obj +$@ +nul +$(LNLIBS16_dll) +$(TMPDIR)\tclWin16.def +| + $(BORLAND)\bin\rlink tcl16.res $@ + + + +$(TCLSH): $(TCLSHOBJS) $(ROOT)\win\$(TCLLIB) tclsh.res + $(TLINK32) $(LNFLAGS_CONSOLE_exe) @&&| + $(TCLSHOBJS) +$@ +-x +$(LNLIBS_exe) +|, &&| +EXETYPE WINDOWS +CODE PRELOAD MOVEABLE DISCARDABLE +DATA PRELOAD MOVEABLE MULTIPLE +|, tclsh.res + +$(TCLTEST): $(TCLTESTOBJS) $(ROOT)\win\$(TCLLIB) + $(TLINK32) $(LNFLAGS_CONSOLE_exe) @&&| + $(TCLTESTOBJS) +$@ +-x +$(LNLIBS_exe) +|, &&| +EXETYPE WINDOWS +CODE PRELOAD MOVEABLE DISCARDABLE +DATA PRELOAD MOVEABLE MULTIPLE +|, + +# The following rule automatically generates a tcl.def file containing +# an export entry for every public symbol in the tcl.dll library. + +tcl.def: $(TCLOBJS) + $(DUMPEXTS) -o tcl.def $(TCLDLL) @&&| + $(TCLOBJS) +| + +# the following two rules are a hack to get around the fact that the +# 16-bit compiler doesn't handle long file names :-( + +$(ROOT)\win\tclWinIn.h: $(ROOT)\win\tclWinInt.h + $(CP) $(ROOT)\win\tclWinInt.h $(ROOT)\win\tclWinIn.h + +$(ROOT)\win\tclWin16.c: $(ROOT)\win\tclWinIn.h + +# debugging rules, the .dll and .exe files must be in the same +# directory as the object files for debugging purposes + +$(TMPDIR)\$(TCLDLL): $(TCLDLL) + $(CP) $(TCLDLL) $(TMPDIR) + +$(TMPDIR)\$(TCLSH): $(TCLSH) + $(CP) $(TCLSH) $(TMPDIR) + +$(TMPDIR)\$(TCLTEST): $(TCLTEST) + $(CP) $(TCLTEST) $(TMPDIR) + +debug: $(TMPDIR)\$(TCLDLL) $(TMPDIR)\$(TCLTEST) + + +# remove all generated files + +clean: + -@$(RM) *.exe + -@$(RM) *.lib + -@$(RM) *.dll + -@$(RM) *.res + -@$(RM) $(ROOT)\win\tclWinIn.h + -@$(RM) tcl.def + -@$(RM) $(TMPDIR)\*.obj + -@$(RM) *.cfg diff --git a/tcl7.6/win/makefile.vc b/tcl7.6/win/makefile.vc new file mode 100644 index 0000000..54ec87f --- /dev/null +++ b/tcl7.6/win/makefile.vc @@ -0,0 +1,247 @@ +# Copyright (c) 1995-1996 Sun Microsystems, Inc. +# SCCS: @(#) makefile.vc 1.56 96/10/11 17:39:36 + +# +# Visual C++ 2.x and 4.0 makefile +# +# Does not depend on the presence of any environment variables in +# order to compile tcl; all needed information is derived from +# location of the compiler directories. + +# +# Project directories +# +# ROOT = top of source tree +# +# TMPDIR = location where .obj files should be stored during build +# +# TOOLS32 = location of VC++ 32-bit development tools. Note that the +# VC++ 2.0 header files are broken, so you need to use the +# ones that come with the developer network CD's, or later +# versions of VC++. +# +# TOOLS16 = location of VC++ 1.5 16-bit tools, needed to build thunking +# library. This information is optional; if the 16-bit compiler +# is not available, then the 16-bit code will not be built. +# Tcl will still run without the 16-bit code, but... +# A. Under Windows 3.X you will any calls to the exec command +# will return an error. +# B. A 16-bit program to test the behavior of the exec +# command under NT and 95 will not be built. +# + +ROOT = .. +TMPDIR = . +TOOLS32 = c:\msdev +TOOLS16 = c:\msvc + +# Comment the following line to compile with symbols +NODEBUG=1 + +# uncomment the following two lines to compile with TCL_MEM_DEBUG +#DEBUGDEFINES = -DTCL_MEM_DEBUG + +WINDIR = $(ROOT)\win +GENERICDIR = $(ROOT)\generic + +cc32 = $(TOOLS32)\bin\cl.exe +link32 = $(TOOLS32)\bin\link.exe +rc32 = $(TOOLS32)\bin\rc.exe +include32 = -I$(TOOLS32)\include + +cc16 = $(TOOLS16)\bin\cl.exe +link16 = $(TOOLS16)\bin\link.exe +rc16 = $(TOOLS16)\bin\rc.exe +include16 = -I$(TOOLS16)\include + +TCL_INCLUDES = -I$(WINDIR) -I$(GENERICDIR) + +TCL_DEFINES = -D__WIN32__ -DUSE_TCLALLOC=0 $(DEBUGDEFINES) -Dtry=__try \ + -Dexcept=__except + +TCLSHOBJS = \ + $(TMPDIR)\tclAppInit.obj + +TCLTESTOBJS = \ + $(TMPDIR)\tclTest.obj \ + $(TMPDIR)\tclWinTest.obj \ + $(TMPDIR)\testMain.obj + +TCLOBJS = \ + $(TMPDIR)\panic.obj \ + $(TMPDIR)\regexp.obj \ + $(TMPDIR)\strftime.obj \ + $(TMPDIR)\tclAsync.obj \ + $(TMPDIR)\tclBasic.obj \ + $(TMPDIR)\tclCkalloc.obj \ + $(TMPDIR)\tclClock.obj \ + $(TMPDIR)\tclCmdAH.obj \ + $(TMPDIR)\tclCmdIL.obj \ + $(TMPDIR)\tclCmdMZ.obj \ + $(TMPDIR)\tclDate.obj \ + $(TMPDIR)\tclEnv.obj \ + $(TMPDIR)\tclEvent.obj \ + $(TMPDIR)\tclExpr.obj \ + $(TMPDIR)\tclFCmd.obj \ + $(TMPDIR)\tclFHandle.obj \ + $(TMPDIR)\tclFileName.obj \ + $(TMPDIR)\tclGet.obj \ + $(TMPDIR)\tclHash.obj \ + $(TMPDIR)\tclHistory.obj \ + $(TMPDIR)\tclIO.obj \ + $(TMPDIR)\tclIOCmd.obj \ + $(TMPDIR)\tclIOSock.obj \ + $(TMPDIR)\tclIOUtil.obj \ + $(TMPDIR)\tclInterp.obj \ + $(TMPDIR)\tclLink.obj \ + $(TMPDIR)\tclLoad.obj \ + $(TMPDIR)\tclMain.obj \ + $(TMPDIR)\tclNotify.obj \ + $(TMPDIR)\tclParse.obj \ + $(TMPDIR)\tclPkg.obj \ + $(TMPDIR)\tclPosixStr.obj \ + $(TMPDIR)\tclPreserve.obj \ + $(TMPDIR)\tclProc.obj \ + $(TMPDIR)\tclUtil.obj \ + $(TMPDIR)\tclVar.obj \ + $(TMPDIR)\tclWin32Dll.obj \ + $(TMPDIR)\tclWinChan.obj \ + $(TMPDIR)\tclWinError.obj \ + $(TMPDIR)\tclWinFCmd.obj \ + $(TMPDIR)\tclWinFile.obj \ + $(TMPDIR)\tclWinInit.obj \ + $(TMPDIR)\tclWinLoad.obj \ + $(TMPDIR)\tclWinMtherr.obj \ + $(TMPDIR)\tclWinNotify.obj \ + $(TMPDIR)\tclWinPipe.obj \ + $(TMPDIR)\tclWinSock.obj \ + $(TMPDIR)\tclWinTime.obj + +TCLLIB = tcl76.lib +TCLDLL = tcl76.dll +TCL16DLL = tcl1676.dll +TCLSH = tclsh76.exe +TCLTEST = tcltest.exe +DUMPEXTS = dumpexts.exe +TCLPIPEDLL = tclpip76.dll +CAT16 = cat16.exe +CAT32 = cat32.exe + +CPU = i386 +INCLUDE = $(TOOLS32)\include +!include + +TCL_CFLAGS = $(cdebug) $(cflags) $(cvarsdll) $(include32) $(TCL_INCLUDES) $(TCL_DEFINES) +CON_CFLAGS = $(cdebug) $(cflags) $(cvars) $(include32) -DCONSOLE +DOS_CFLAGS = $(cdebug) $(cflags) $(include16) -AL +DLL16_CFLAGS = $(cdebug) $(cflags) $(include16) -ALw + +# +# Targets +# + +release: $(DUMPEXTS) $(TCLDLL) $(TCLSH) $(TCL16DLL) $(TCLPIPEDLL) +all: $(DUMPEXTS) $(TCLDLL) $(TCLSH) $(TCL16DLL) $(TCLPIPEDLL) $(CAT16) $(CAT32) +test: $(DUMPEXTS) $(TCLDLL) $(TCLTEST) $(TCL16DLL) $(TCLPIPEDLL) $(CAT16) $(CAT32) + $(TCLTEST) << + cd ../tests + source all +<< + +$(DUMPEXTS): $(WINDIR)\winDumpExts.c + $(cc32) $(CON_CFLAGS) -Fo$(TMPDIR)\ $? + set LIB=$(TOOLS32)\lib + $(link32) $(linkdebug) $(conlflags) -out:$@ $(TMPDIR)\winDumpExts.obj $(guilibs) + +$(TCLDLL): $(TCLOBJS) $(TMPDIR)\tclvc.def $(TMPDIR)\tcl.res + set LIB=$(TOOLS32)\lib + $(link32) $(linkdebug) $(dlllflags) -def:$(TMPDIR)\tclvc.def \ + -out:$@ $(TMPDIR)\tcl.res $(guilibsdll) @<< +$(TCLOBJS) +<< + +$(TCLSH): $(TCLSHOBJS) $(TCLLIB) $(TMPDIR)\tclsh.res + set LIB=$(TOOLS32)\lib + $(link32) $(linkdebug) $(conlflags) $(TMPDIR)\tclsh.res \ + -out:$@ $(conlibsdll) $(TCLLIB) $(TCLSHOBJS) + +$(TCLTEST): $(TCLTESTOBJS) $(TCLLIB) $(TMPDIR)\tclsh.res + set LIB=$(TOOLS32)\lib + $(link32) $(linkdebug) $(conlflags) $(TMPDIR)\tclsh.res \ + -out:$@ $(conlibsdll) $(TCLLIB) $(TCLTESTOBJS) + +$(TCL16DLL): $(WINDIR)\tcl16.rc $(WINDIR)\tclWin16.c + if exist $(cc16) $(cc16) @<< +$(DLL16_CFLAGS) -Fo$(TMPDIR)\ $(WINDIR)\tclWin16.c +<< + @copy << $(TMPDIR)\tclWin16.def > nul +LIBRARY $(@B);dll +EXETYPE WINDOWS +CODE PRELOAD MOVEABLE DISCARDABLE +DATA PRELOAD MOVEABLE SINGLE +HEAPSIZE 1024 +EXPORTS + WEP @1 RESIDENTNAME + UTPROC @2 +<< + if exist $(cc16) $(link16) /NOLOGO /ONERROR:NOEXE /NOE @<< +$(TMPDIR)\tclWin16.obj +$@ +nul +$(TOOLS16)\lib\ ldllcew oldnames libw toolhelp +$(TMPDIR)\tclWin16.def +<< + if exist $(cc16) $(rc16) -i $(GENERICDIR) $(TCL_DEFINES) $(WINDIR)\tcl16.rc $@ + +$(TCLPIPEDLL): $(WINDIR)\stub16.c + $(cc32) $(CON_CFLAGS) -Fo$(TMPDIR)\ $(WINDIR)\stub16.c + set LIB=$(TOOLS32)\lib + $(link32) $(linkdebug) $(conlflags) -out:$@ $(TMPDIR)\stub16.obj $(guilibs) + +$(CAT32): $(WINDIR)\cat.c + $(cc32) $(CON_CFLAGS) -Fo$(TMPDIR)\ $? + set LIB=$(TOOLS32)\lib + $(link32) $(conlflags) -out:$@ -stack:16384 $(TMPDIR)\cat.obj $(conlibs) + +$(CAT16): $(WINDIR)\cat.c + if exist $(cc16) $(cc16) $(DOS_CFLAGS) -Fo$(TMPDIR)\ $? + set LIB=$(TOOLS16)\lib + if exist $(cc16) $(link16) /NOLOGO /ONERROR:NOEXE /NOI /STACK:16384 \ + $(TMPDIR)\cat.obj,$@,nul,llibce.lib,nul + + +# +# Special case object file targets +# + +$(TMPDIR)\tclvc.def: $(DUMPEXTS) $(TCLOBJS) + $(DUMPEXTS) -o $@ $(TCLDLL) @<< +$(TCLOBJS) +<< + +$(TMPDIR)\testMain.obj: $(WINDIR)\tclAppInit.c + $(cc32) $(TCL_CFLAGS) -DTCL_TEST -Fo$(TMPDIR)\testMain.obj $? + +# +# Implicit rules +# + +{$(WINDIR)}.c{$(TMPDIR)}.obj: + $(cc32) $(TCL_CFLAGS) -Fo$(TMPDIR)\ $< + +{$(GENERICDIR)}.c{$(TMPDIR)}.obj: + $(cc32) $(TCL_CFLAGS) -Fo$(TMPDIR)\ $< + +{$(ROOT)\compat}.c{$(TMPDIR)}.obj: + $(cc32) $(TCL_CFLAGS) -Fo$(TMPDIR)\ $< + +{$(WINDIR)}.rc{$(TMPDIR)}.res: + $(rc32) -fo $@ -r -i $(GENERICDIR) -i $(WINDIR) $(TCL_DEFINES) $< + +clean: + -@del *.exp + -@del *.lib + -@del *.dll + -@del *.exe + -@del $(TMPDIR)\*.obj + diff --git a/tcl7.6/win/stub16.c b/tcl7.6/win/stub16.c new file mode 100644 index 0000000..0074a34 --- /dev/null +++ b/tcl7.6/win/stub16.c @@ -0,0 +1,197 @@ +/* + * stub16.c + * + * A helper program used for running 16-bit DOS applications under + * Windows 95. + * + * Copyright (c) 1996 by Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) stub16.c 1.4 96/09/12 15:13:30 + */ + +#define STRICT + +#include +#include + +static HANDLE CreateTempFile(void); + +/* + *--------------------------------------------------------------------------- + * + * main + * + * Entry point for the 32-bit console mode app used by Windows 95 to + * help run the 16-bit program specified on the command line. + * + * 1. EOF on a pipe that connects a detached 16-bit process and a + * 32-bit process is never seen. So, this process runs the 16-bit + * process _attached_, and then it is run detached from the calling + * 32-bit process. + * + * 2. If a 16-bit process blocks reading from or writing to a pipe, + * it never wakes up, and eventually brings the whole system down + * with it if you try to kill the process. This app simulates + * pipes. If any of the stdio handles is a pipe, this program + * accumulates information into temp files and forwards it to or + * from the DOS application as appropriate. This means that this + * program must receive EOF from a stdin pipe before it will actually + * start the DOS app, and the DOS app must finish generating stdout + * or stderr before the data will be sent to the next stage of the + * pipe. If the stdio handles are not pipes, no accumulation occurs + * and the data is passed straight through to and from the DOS + * application. + * + * Results: + * None. + * + * Side effects: + * The child process is created and this process waits for it to + * complete. + * + *--------------------------------------------------------------------------- + */ + +int +main() +{ + DWORD dwRead, dwWrite; + char *cmdLine; + HANDLE hStdInput, hStdOutput, hStdError; + HANDLE hFileInput, hFileOutput, hFileError; + STARTUPINFO si; + PROCESS_INFORMATION pi; + char buf[8192]; + DWORD result; + + hFileInput = INVALID_HANDLE_VALUE; + hFileOutput = INVALID_HANDLE_VALUE; + hFileError = INVALID_HANDLE_VALUE; + result = 1; + + /* + * Don't get command line from argc, argv, because the command line + * tokenizer will have stripped off all the escape sequences needed + * for quotes and backslashes, and then we'd have to put them all + * back in again. Get the raw command line and parse off what we + * want ourselves. The command line should be of the form: + * + * stub16.exe program arg1 arg2 ... + */ + + cmdLine = strchr(GetCommandLine(), ' '); + if (cmdLine == NULL) { + return 1; + } + cmdLine++; + + hStdInput = GetStdHandle(STD_INPUT_HANDLE); + hStdOutput = GetStdHandle(STD_OUTPUT_HANDLE); + hStdError = GetStdHandle(STD_ERROR_HANDLE); + + if (GetFileType(hStdInput) == FILE_TYPE_PIPE) { + hFileInput = CreateTempFile(); + if (hFileInput == INVALID_HANDLE_VALUE) { + goto cleanup; + } + while (ReadFile(hStdInput, buf, sizeof(buf), &dwRead, NULL) != FALSE) { + if (dwRead == 0) { + break; + } + if (WriteFile(hFileInput, buf, dwRead, &dwWrite, NULL) == FALSE) { + goto cleanup; + } + } + SetFilePointer(hFileInput, 0, 0, FILE_BEGIN); + SetStdHandle(STD_INPUT_HANDLE, hFileInput); + } + if (GetFileType(hStdOutput) == FILE_TYPE_PIPE) { + hFileOutput = CreateTempFile(); + if (hFileOutput == INVALID_HANDLE_VALUE) { + goto cleanup; + } + SetStdHandle(STD_OUTPUT_HANDLE, hFileOutput); + } + if (GetFileType(hStdError) == FILE_TYPE_PIPE) { + hFileError = CreateTempFile(); + if (hFileError == INVALID_HANDLE_VALUE) { + goto cleanup; + } + SetStdHandle(STD_ERROR_HANDLE, hFileError); + } + + ZeroMemory(&si, sizeof(si)); + si.cb = sizeof(si); + if (CreateProcess(NULL, cmdLine, NULL, NULL, TRUE, 0, NULL, NULL, &si, + &pi) == FALSE) { + goto cleanup; + } + + WaitForInputIdle(pi.hProcess, 5000); + WaitForSingleObject(pi.hProcess, INFINITE); + CloseHandle(pi.hProcess); + CloseHandle(pi.hThread); + result = 0; + + if (hFileOutput != INVALID_HANDLE_VALUE) { + SetFilePointer(hFileOutput, 0, 0, FILE_BEGIN); + while (ReadFile(hFileOutput, buf, sizeof(buf), &dwRead, NULL) != FALSE) { + if (dwRead == 0) { + break; + } + if (WriteFile(hStdOutput, buf, dwRead, &dwWrite, NULL) == FALSE) { + break; + } + } + } + if (hFileError != INVALID_HANDLE_VALUE) { + SetFilePointer(hFileError, 0, 0, FILE_BEGIN); + while (ReadFile(hFileError, buf, sizeof(buf), &dwRead, NULL) != FALSE) { + if (dwRead == 0) { + break; + } + if (WriteFile(hStdError, buf, dwRead, &dwWrite, NULL) == FALSE) { + break; + } + } + } + +cleanup: + if (hFileInput != INVALID_HANDLE_VALUE) { + CloseHandle(hFileInput); + } + if (hFileOutput != INVALID_HANDLE_VALUE) { + CloseHandle(hFileOutput); + } + if (hFileError != INVALID_HANDLE_VALUE) { + CloseHandle(hFileError); + } + CloseHandle(hStdInput); + CloseHandle(hStdOutput); + CloseHandle(hStdError); + ExitProcess(result); +} + +static HANDLE +CreateTempFile() +{ + char name[MAX_PATH]; + SECURITY_ATTRIBUTES sa; + + if (GetTempPath(sizeof(name), name) == 0) { + return INVALID_HANDLE_VALUE; + } + if (GetTempFileName(name, "tcl", 0, name) == 0) { + return INVALID_HANDLE_VALUE; + } + + sa.nLength = sizeof(sa); + sa.lpSecurityDescriptor = NULL; + sa.bInheritHandle = TRUE; + return CreateFile(name, GENERIC_READ | GENERIC_WRITE, 0, &sa, + CREATE_ALWAYS, FILE_ATTRIBUTE_TEMPORARY | FILE_FLAG_DELETE_ON_CLOSE, + NULL); +} diff --git a/tcl7.6/win/tcl.rc b/tcl7.6/win/tcl.rc new file mode 100644 index 0000000..87eb514 --- /dev/null +++ b/tcl7.6/win/tcl.rc @@ -0,0 +1,43 @@ +// SCCS: @(#) tcl.rc 1.20 96/09/12 14:57:51 +// +// Version +// + +#define RESOURCE_INCLUDED +#include + +VS_VERSION_INFO VERSIONINFO + FILEVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL + PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL + FILEFLAGSMASK 0x3fL + FILEFLAGS 0x0L + FILEOS 0x4L + FILETYPE 0x2L + FILESUBTYPE 0x0L +BEGIN + BLOCK "StringFileInfo" + BEGIN + BLOCK "040904b0" + BEGIN + VALUE "FileDescription", "Tcl DLL\0" + VALUE "OriginalFilename", "tcl" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) ".dll\0" + VALUE "CompanyName", "Sun Microsystems, Inc\0" + VALUE "FileVersion", TCL_PATCH_LEVEL + VALUE "LegalCopyright", "Copyright \251 1995-1996\0" + VALUE "ProductName", "Tcl " TCL_VERSION " for Windows\0" + VALUE "ProductVersion", TCL_PATCH_LEVEL + END + END + BLOCK "VarFileInfo" + BEGIN + VALUE "Translation", 0x409, 1200 + END +END + + + + + + + + diff --git a/tcl7.6/win/tcl16.rc b/tcl7.6/win/tcl16.rc new file mode 100644 index 0000000..875a747 --- /dev/null +++ b/tcl7.6/win/tcl16.rc @@ -0,0 +1,37 @@ +// SCCS: @(#) tcl16.rc 1.16 96/09/12 14:58:12 +// +// Version +// + +#define RESOURCE_INCLUDED +#include + +VS_VERSION_INFO VERSIONINFO + FILEVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL + PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL + FILEFLAGSMASK 0x3fL + FILEFLAGS 0x0L + FILEOS 0x1L + FILETYPE 0x2L + FILESUBTYPE 0x0L +BEGIN + BLOCK "StringFileInfo" + BEGIN + BLOCK "040904b0" + BEGIN + VALUE "FileDescription", "Tcl16 DLL, 16-bit thunking module\0" + VALUE "OriginalFilename", "tcl16" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) ".dll\0" + VALUE "CompanyName", "Sun Microsystems, Inc\0" + VALUE "FileVersion", TCL_PATCH_LEVEL + VALUE "LegalCopyright", "Copyright \251 1995-1996\0" + VALUE "ProductName", "Tcl " TCL_VERSION " for Windows\0" + VALUE "ProductVersion", TCL_PATCH_LEVEL + END + END + BLOCK "VarFileInfo" + BEGIN + VALUE "Translation", 0x409, 1200 + END +END + + diff --git a/tcl7.6/win/tclAppInit.c b/tcl7.6/win/tclAppInit.c new file mode 100644 index 0000000..f757fca --- /dev/null +++ b/tcl7.6/win/tclAppInit.c @@ -0,0 +1,176 @@ +/* + * tclAppInit.c -- + * + * Provides a default version of the main program and Tcl_AppInit + * procedure for Tcl applications (without Tk). Note that this + * program must be built in Win32 console mode to work properly. + * + * Copyright (c) 1996 by Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclAppInit.c 1.9 96/10/04 11:01:28 + */ + +#include "tcl.h" +#include +#include + +#ifdef TCL_TEST +EXTERN int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +#endif /* TCL_TEST */ + + +/* + *---------------------------------------------------------------------- + * + * main -- + * + * This is the main program for the application. + * + * Results: + * None: Tcl_Main never returns here, so this procedure never + * returns either. + * + * Side effects: + * Whatever the application does. + * + *---------------------------------------------------------------------- + */ + +int +main(argc, argv) + int argc; /* Number of command-line arguments. */ + char **argv; /* Values of command-line arguments. */ +{ + char *args = GetCommandLine(); + char **argvlist, *p; + int size, i; + + /* + * Set up the default locale to be standard "C" locale so parsing + * is performed correctly. + */ + + setlocale(LC_ALL, "C"); + + /* + * Precompute an overly pessimistic guess at the number of arguments + * in the command line by counting non-space spans. + */ + + for (size = 2, p = args; *p != '\0'; p++) { + if (isspace(*p)) { + size++; + while (isspace(*p)) { + p++; + } + if (*p == '\0') { + break; + } + } + } + argvlist = (char **) ckalloc((unsigned) (size * sizeof(char *))); + argv = argvlist; + + /* + * Parse the Windows command line string. If an argument begins with a + * double quote, then spaces are considered part of the argument until the + * next double quote. The argument terminates at the second quote. Note + * that this is different from the usual Unix semantics. + */ + + for (i = 0, p = args; *p != '\0'; i++) { + while (isspace(*p)) { + p++; + } + if (*p == '\0') { + break; + } + if (*p == '"') { + p++; + argv[i] = p; + while ((*p != '\0') && (*p != '"')) { + p++; + } + } else { + argv[i] = p; + while (*p != '\0' && !isspace(*p)) { + p++; + } + } + if (*p != '\0') { + *p = '\0'; + p++; + } + } + argv[i] = NULL; + argc = i; + + Tcl_Main(argc, argv, Tcl_AppInit); + return 0; /* Needed only to prevent compiler warning. */ +} + + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppInit -- + * + * This procedure performs application-specific initialization. + * Most applications, especially those that incorporate additional + * packages, will have their own version of this procedure. + * + * Results: + * Returns a standard Tcl completion code, and leaves an error + * message in interp->result if an error occurs. + * + * Side effects: + * Depends on the startup script. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_AppInit(interp) + Tcl_Interp *interp; /* Interpreter for application. */ +{ + if (Tcl_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + +#ifdef TCL_TEST + if (Tcltest_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, + (Tcl_PackageInitProc *) NULL); +#endif /* TCL_TEST */ + + /* + * 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. + */ + + /* + * Call Tcl_CreateCommand for application-specific commands, if + * they weren't already created by the init procedures called above. + */ + + /* + * Specify a user-specific startup file to invoke if the application + * is run interactively. Typically the startup file is "~/.apprc" + * where "app" is the name of the application. If this line is deleted + * then no user-specific startup file will be run under any conditions. + */ + + Tcl_SetVar(interp, "tcl_rcFileName", "~/tclshrc.tcl", TCL_GLOBAL_ONLY); + return TCL_OK; +} diff --git a/tcl7.6/win/tclWin16.c b/tcl7.6/win/tclWin16.c new file mode 100644 index 0000000..ffd7c43 --- /dev/null +++ b/tcl7.6/win/tclWin16.c @@ -0,0 +1,434 @@ +/* + * tclWin16.c -- + * + * This file contains code for a 16-bit DLL to handle 32-to-16 bit + * thunking. This is necessary for the Win32s SynchSpawn() call. + * + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclWin16.c 1.13 96/09/12 15:10:06 + */ + +#define STRICT + +#include +#include + +#include +#include + +static int WinSpawn(char *command); +static int DosSpawn(char *command, char *fromFileName, + char *toFileName); +static int WaitForExit(int inst); + + +static char pifData[545] = { +'\000', '\013', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\200', '\000', '\200', '\000', '\103', '\117', '\115', '\115', +'\101', '\116', '\104', '\056', '\103', '\117', '\115', '\000', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\020', '\000', '\000', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\177', '\001', '\000', +'\377', '\031', '\120', '\000', '\000', '\007', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\340', +'\040', '\115', '\111', '\103', '\122', '\117', '\123', '\117', +'\106', '\124', '\040', '\120', '\111', '\106', '\105', '\130', +'\000', '\207', '\001', '\000', '\000', '\161', '\001', '\127', +'\111', '\116', '\104', '\117', '\127', '\123', '\040', '\063', +'\070', '\066', '\040', '\063', '\056', '\060', '\000', '\005', +'\002', '\235', '\001', '\150', '\000', '\200', '\002', '\200', +'\000', '\144', '\000', '\062', '\000', '\000', '\004', '\000', +'\000', '\000', '\004', '\000', '\000', '\002', '\020', '\002', +'\000', '\037', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\057', '\143', '\040', +'\146', '\157', '\157', '\056', '\142', '\141', '\164', '\000', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\127', '\111', '\116', +'\104', '\117', '\127', '\123', '\040', '\062', '\070', '\066', +'\040', '\063', '\056', '\060', '\000', '\377', '\377', '\033', +'\002', '\006', '\000', '\000', '\000', '\000', '\000', '\000', +'\000' +}; + +BOOL CALLBACK +LibMain(HINSTANCE hinst, WORD wDS, WORD cbHeap, LPSTR unused) +{ + // Nothing to do. + + hinst = hinst; + wDS = wDS; + cbHeap = cbHeap; + unused = unused; + + return TRUE; +} + +int WINAPI +UTProc(buf, func) + void *buf; + DWORD func; +{ + char **args; + + args = (char **) buf; + if (func == 0) { + return DosSpawn(args[0], args[1], args[2]); + } else { + return WinSpawn(args[0]); + } +} + +static int +WinSpawn(command) + char *command; +{ + return WaitForExit(WinExec(command, SW_SHOW)); +} +/* + *--------------------------------------------------------------------------- + * + * Spawn -- + * + *--------------------------------------------------------------------------- + */ +static int +DosSpawn(command, fromFileName, toFileName) + char *command; /* The name of the program, plus any + * arguments, to be run. */ + char *fromFileName; /* Standard input for the program is to be + * redirected from this file, or NULL for no + * standard input. */ + char *toFileName; /* Standard output for the program is to be + * redirected to this file, or NULL to + * discard standard output. */ +{ + int result; + HFILE batFile, pifFile; + char batFileName[144], pifFileName[144]; + + GetTempFileName(0, "tcl", 0, batFileName); + unlink(batFileName); + strcpy(strrchr(batFileName, '.'), ".bat"); + batFile = _lcreat(batFileName, 0); + + GetTempFileName(0, "tcl", 0, pifFileName); + unlink(pifFileName); + strcpy(strrchr(pifFileName, '.'), ".pif"); + pifFile = _lcreat(pifFileName, 0); + + _lwrite(batFile, command, strlen(command)); + if (fromFileName == NULL) { + _lwrite(batFile, " < nul", 6); + } else { + _lwrite(batFile, " < ", 3); + _lwrite(batFile, fromFileName, strlen(fromFileName)); + } + if (toFileName == NULL) { + _lwrite(batFile, " > nul", 6); + } else { + _lwrite(batFile, " > ", 3); + _lwrite(batFile, toFileName, strlen(toFileName)); + } + _lwrite(batFile, "\r\n\032", 3); + _lclose(batFile); + + strcpy(pifData + 0x1c8, batFileName); + _lwrite(pifFile, pifData, sizeof(pifData)); + _lclose(pifFile); + + result = WaitForExit(WinExec(pifFileName, SW_MINIMIZE)); + + unlink(pifFileName); + unlink(batFileName); + + return result; +} + +/* + * Results: + * The return value is 1 if the process exited successfully, + * or 0 otherwise. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static int +WaitForExit(inst) + int inst; /* Identifies the instance handle of the + * process to wait for. */ +{ + TASKENTRY te; + MSG msg; + + if (inst < 32) { + return 0; + } + + te.dwSize = sizeof(te); + te.hInst = 0; + TaskFirst(&te); + do { + if (te.hInst == (HINSTANCE) inst) { + break; + } + } while (TaskNext(&te) != FALSE); + + if (te.hInst != (HINSTANCE) inst) { + return 0; + } + while (1) { + if (PeekMessage(&msg, NULL, 0, 0, PM_REMOVE) == TRUE) { + TranslateMessage(&msg); + DispatchMessage(&msg); + } + TaskFirst(&te); + do { + if (te.hInst == (HINSTANCE) inst) { + break; + } + } while (TaskNext(&te) != FALSE); + + if (te.hInst != (HINSTANCE) inst) { + return 1; + } + } +} +#if 0 + + + + + #ifndef APIENTRY +#define APIENTRY +#endif + +#include +#include +#include +#ifdef _MSC_VER +#include "tclWinInt.h" +#else +#include "tclWinIn.h" +#endif + +typedef DWORD (FAR PASCAL * UT16CBPROC)(LPVOID lpBuff, DWORD dwUserDefined, + LPVOID FAR *lpTranslationList); + +HINSTANCE hInstance; + + +/* + *---------------------------------------------------------------------- + * + * LibMain -- + * + * DLL entry point + * + * Results: + * Returns 1. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +int FAR PASCAL +LibMain(instance, dataSeg, heapSize, cmdLine) + HINSTANCE instance; + WORD dataSeg; + WORD heapSize; + LPSTR cmdLine; +{ + hInstance = instance; + return 1; +} + + +/* + *---------------------------------------------------------------------- + * + * UTInit -- + * + * Universal Thunk initialization procedure. + * + * Results: + * Always returns 1. + * + * Side effects: + * Sets the universal thunk callback procedure. + * + *---------------------------------------------------------------------- + */ +DWORD FAR PASCAL _export +UTInit(callback, buf) + UT16CBPROC callback; + LPVOID buf; +{ + return 1; /* Return Success */ +} + +/* + *---------------------------------------------------------------------- + * + * UTProc -- + * + * Universal Thunk dispatch routine. + * + * Results: + * 1 on success, 0 or -1 on failure. + * + * Side effects: + * Executes 16-bit code. + * + *---------------------------------------------------------------------- + */ + +DWORD FAR PASCAL _export +UTProc(buf, func) + LPVOID buf; + DWORD func; +{ + char **argv; + + argv = (char **) buf; + + if (func == 0) { + + + + switch (func) { + + case TCLSYNCHSPAWN: { + HINSTANCE inst; + LPCSTR cmdLine; + UINT cmdShow; + MSG msg; + TASKENTRY te; + + /* Retrieve the command line arguments stored in buffer */ + + cmdLine = (LPSTR) ((LPDWORD)buf)[0]; + cmdShow = (UINT) ((LPDWORD)buf)[1]; + + /* Start the application with WinExec() */ + + inst = WinExec(cmdLine, cmdShow); + if ((int) inst < 32) { + return 0; + } + + /* Loop until the application is terminated. The Toolhelp API + * ModuleFindHandle() returns NULL when the application is + * terminated. NOTE: PeekMessage() is used to yield the + * processor; otherwise, nothing else could execute on the + * system. + */ + + te.dwSize = sizeof(TASKENTRY); + TaskFirst(&te); + do { + if (te.hInst == inst) { + break; + } + } while (TaskNext(&te)); + + if (te.hInst == inst) { + while (1) { + if (PeekMessage(&msg, NULL, 0, 0, PM_REMOVE) != 0) { + TranslateMessage(&msg); + DispatchMessage(&msg); + } + + TaskFirst(&te); + do { + if (te.hInst == inst) { + break; + } + } while (TaskNext(&te)); + + if (te.hInst != inst) { + break; + } + } + } + return 1; + } + } + + return (DWORD)-1L; /* We should never get here. */ +} + +/* + *---------------------------------------------------------------------- + * + * _WEP -- + * + * Windows exit procedure + * + * Results: + * Always returns 1. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int FAR PASCAL +_WEP(dummy) + int dummy; +{ + return 1; +} +#endif diff --git a/tcl7.6/win/tclWin32Dll.c b/tcl7.6/win/tclWin32Dll.c new file mode 100644 index 0000000..bd18e5e --- /dev/null +++ b/tcl7.6/win/tclWin32Dll.c @@ -0,0 +1,311 @@ +/* + * tclWin32Dll.c -- + * + * This file contains the DLL entry point which sets up the 32-to-16-bit + * thunking code for SynchSpawn if the library is running under Win32s. + * + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclWin32Dll.c 1.15 96/09/12 15:10:59 + */ + +#include +#include "tcl.h" +#include "tclPort.h" +#include "tclWinInt.h" + +typedef DWORD (WINAPI * UT32PROC)(LPVOID lpBuff, DWORD dwUserDefined, + LPVOID *lpTranslationList); + +typedef BOOL (WINAPI * PUTREGISTER)(HANDLE hModule, LPCSTR SixteenBitDLL, + LPCSTR InitName, LPCSTR ProcName, UT32PROC* ThirtyTwoBitThunk, + FARPROC UT32Callback, LPVOID Buff); + +typedef VOID (WINAPI * PUTUNREGISTER)(HANDLE hModule); + +static PUTUNREGISTER UTUnRegister = NULL; +static int tclProcessesAttached = 0; + +/* + * The following data structure is used to keep track of all of the DLL's + * opened by Tcl so that they can be freed with the Tcl.dll is unloaded. + */ + +typedef struct LibraryList { + HINSTANCE handle; + struct LibraryList *nextPtr; +} LibraryList; + +static LibraryList *libraryList = NULL; /* List of currently loaded DLL's. */ + +static HINSTANCE tclInstance; /* Global library instance handle. */ + +/* + * Declarations for functions that are only used in this file. + */ + +static void UnloadLibraries _ANSI_ARGS_((void)); + +/* + * The following declaration is for the VC++ DLL entry point. + */ + +BOOL APIENTRY DllMain _ANSI_ARGS_((HINSTANCE hInst, + DWORD reason, LPVOID reserved)); + +/* + *---------------------------------------------------------------------- + * + * DllEntryPoint -- + * + * This wrapper function is used by Borland to invoke the + * initialization code for Tcl. It simply calls the DllMain + * routine. + * + * Results: + * See DllMain. + * + * Side effects: + * See DllMain. + * + *---------------------------------------------------------------------- + */ + +BOOL APIENTRY +DllEntryPoint(hInst, reason, reserved) + HINSTANCE hInst; /* Library instance handle. */ + DWORD reason; /* Reason this function is being called. */ + LPVOID reserved; /* Not used. */ +{ + return DllMain(hInst, reason, reserved); +} + +/* + *---------------------------------------------------------------------- + * + * DllMain -- + * + * This routine is called by the VC++ C run time library init + * code, or the DllEntryPoint routine. It is responsible for + * initializing various dynamically loaded libraries. + * + * Results: + * TRUE on sucess, FALSE on failure. + * + * Side effects: + * Establishes 32-to-16 bit thunk and initializes sockets library. + * + *---------------------------------------------------------------------- + */ +BOOL APIENTRY +DllMain(hInst, reason, reserved) + HINSTANCE hInst; /* Library instance handle. */ + DWORD reason; /* Reason this function is being called. */ + LPVOID reserved; /* Not used. */ +{ + switch (reason) { + case DLL_PROCESS_ATTACH: + + /* + * Registration of UT need to be done only once for first + * attaching process. At that time set the tclWin32s flag + * to indicate if the DLL is executing under Win32s or not. + */ + + if (tclProcessesAttached++) { + return FALSE; /* Not the first initialization. */ + } + + tclInstance = hInst; + return TRUE; + + case DLL_PROCESS_DETACH: + + tclProcessesAttached--; + if (tclProcessesAttached == 0) { + + /* + * Unregister the Tcl thunk. + */ + + if (UTUnRegister != NULL) { + UTUnRegister(hInst); + } + + /* + * Cleanup any dynamically loaded libraries. + */ + + UnloadLibraries(); + } + break; + } + + return TRUE; +} + +/* + *---------------------------------------------------------------------- + * + * TclWinLoadLibrary -- + * + * This function is a wrapper for the system LoadLibrary. It is + * responsible for adding library handles to the library list so + * the libraries can be freed when tcl.dll is unloaded. + * + * Results: + * Returns the handle of the newly loaded library, or NULL on + * failure. + * + * Side effects: + * Loads the specified library into the process. + * + *---------------------------------------------------------------------- + */ + +HINSTANCE +TclWinLoadLibrary(name) + char *name; /* Library file to load. */ +{ + HINSTANCE handle; + LibraryList *ptr; + + handle = LoadLibrary(name); + if (handle != NULL) { + ptr = (LibraryList*) ckalloc(sizeof(LibraryList)); + ptr->handle = handle; + ptr->nextPtr = libraryList; + libraryList = ptr; + } else { + TclWinConvertError(GetLastError()); + } + return handle; +} + +/* + *---------------------------------------------------------------------- + * + * UnloadLibraries -- + * + * Frees any dynamically allocated libraries loaded by Tcl. + * + * Results: + * None. + * + * Side effects: + * Frees the libraries on the library list as well as the list. + * + *---------------------------------------------------------------------- + */ + +static void +UnloadLibraries() +{ + LibraryList *ptr; + + while (libraryList != NULL) { + FreeLibrary(libraryList->handle); + ptr = libraryList->nextPtr; + ckfree(libraryList); + libraryList = ptr; + } +} + +/* + *---------------------------------------------------------------------- + * + * TclSynchSpawn -- + * + * 32-bit entry point to the 16-bit SynchSpawn code. + * + * Results: + * 1 on success, 0 on failure. + * + * Side effects: + * Spawns a command and waits for it to complete. + * + *---------------------------------------------------------------------- + */ +int +TclSynchSpawn(void *args, int type, void **trans, int *pidPtr) +{ + static UT32PROC UTProc = NULL; + static int utErrorCode; + + if (UTUnRegister == NULL) { + /* + * Load the Universal Thunking routines from kernel32.dll. + */ + + HINSTANCE hKernel; + PUTREGISTER UTRegister; + char buffer[] = "TCL16xx.DLL"; + + hKernel = TclWinLoadLibrary("Kernel32.Dll"); + if (hKernel == NULL) { + return 0; + } + + UTRegister = (PUTREGISTER) GetProcAddress(hKernel, "UTRegister"); + UTUnRegister = (PUTUNREGISTER) GetProcAddress(hKernel, "UTUnRegister"); + if (!UTRegister || !UTUnRegister) { + UnloadLibraries(); + return 0; + } + + /* + * Construct the complete name of tcl16xx.dll. + */ + + buffer[5] = '0' + TCL_MAJOR_VERSION; + buffer[6] = '0' + TCL_MINOR_VERSION; + + /* + * Register the Tcl thunk. + */ + + if (UTRegister(tclInstance, buffer, NULL, "UTProc", &UTProc, NULL, + NULL) == FALSE) { + utErrorCode = GetLastError(); + } + } + + if (UTProc == NULL) { + /* + * The 16-bit thunking DLL wasn't found. Return error code that + * indicates this problem. + */ + + SetLastError(utErrorCode); + return 0; + } + + UTProc(args, type, trans); + *pidPtr = 0; + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * TclWinGetTclInstance -- + * + * Retrieves the global library instance handle. + * + * Results: + * Returns the global library instance handle. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +HINSTANCE +TclWinGetTclInstance() +{ + return tclInstance; +} diff --git a/tcl7.6/win/tclWinChan.c b/tcl7.6/win/tclWinChan.c new file mode 100644 index 0000000..02cf290 --- /dev/null +++ b/tcl7.6/win/tclWinChan.c @@ -0,0 +1,1641 @@ +/* + * tclWinChan.c + * + * Channel drivers for Windows channels based on files, command + * pipes and TCP sockets. + * + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclWinChan.c 1.64 96/10/11 15:39:43 + */ + +#include "tclWinInt.h" + +/* + * Static routines for this file: + */ + +static int FileBlockModeProc _ANSI_ARGS_(( + ClientData instanceData, int mode)); +static int FileCloseProc _ANSI_ARGS_((ClientData instanceData, + Tcl_Interp *interp)); +static int FileSeekProc _ANSI_ARGS_((ClientData instanceData, + long offset, int mode, int *errorCode)); +static int FileInputProc _ANSI_ARGS_((ClientData instanceData, + char *buf, int toRead, int *errorCode)); +static int FileOutputProc _ANSI_ARGS_((ClientData instanceData, + char *buf, int toWrite, int *errorCode)); +static int FileType _ANSI_ARGS_((HANDLE h)); +static void FileWatchProc _ANSI_ARGS_((ClientData instanceData, + int mask)); +static int FileReadyProc _ANSI_ARGS_((ClientData instanceData, + int mask)); +static Tcl_File FileGetProc _ANSI_ARGS_((ClientData instanceData, + int direction)); + +static int PipeBlockModeProc _ANSI_ARGS_(( + ClientData instanceData, int mode)); +static int PipeCloseProc _ANSI_ARGS_((ClientData instanceData, + Tcl_Interp *interp)); +static int PipeInputProc _ANSI_ARGS_((ClientData instanceData, + char *buf, int toRead, int *errorCode)); +static int PipeOutputProc _ANSI_ARGS_((ClientData instanceData, + char *buf, int toWrite, int *errorCode)); +static void PipeWatchProc _ANSI_ARGS_((ClientData instanceData, + int mask)); +static int PipeReadyProc _ANSI_ARGS_((ClientData instanceData, + int mask)); +static Tcl_File PipeGetProc _ANSI_ARGS_((ClientData instanceData, + int direction)); + +/* + * This structure describes the channel type structure for file based IO. + */ + +static Tcl_ChannelType fileChannelType = { + "file", /* Type name. */ + FileBlockModeProc, /* Set blocking or non-blocking mode.*/ + FileCloseProc, /* Close proc. */ + FileInputProc, /* Input proc. */ + FileOutputProc, /* Output proc. */ + FileSeekProc, /* Seek proc. */ + NULL, /* Set option proc. */ + NULL, /* Get option proc. */ + FileWatchProc, /* Set up the notifier to watch the channel. */ + FileReadyProc, /* Are events present? */ + FileGetProc, /* Get a Tcl_File from channel. */ +}; + +/* + * This structure describes the channel type structure for command pipe + * based IO. + */ + +static Tcl_ChannelType pipeChannelType = { + "pipe", /* Type name. */ + PipeBlockModeProc, /* Set blocking or non-blocking mode.*/ + PipeCloseProc, /* Close proc. */ + PipeInputProc, /* Input proc. */ + PipeOutputProc, /* Output proc. */ + NULL, /* Seek proc. */ + NULL, /* Set option proc. */ + NULL, /* Get option proc. */ + PipeWatchProc, /* Set up notifier to watch the channel. */ + PipeReadyProc, /* Are events present? */ + PipeGetProc, /* Get a Tcl_File from channel. */ +}; + +/* + * This is the size of the channel name for File based channels + */ + +#define CHANNEL_NAME_SIZE 64 +static char channelName[CHANNEL_NAME_SIZE+1]; + +/* + * Structure describing per-instance state for file based channels. + * + * IMPORTANT NOTE: If you modify this structure, make sure that the + * "asynch" field remains the first field - FilePipeBlockMode depends + * on this. + */ + +typedef struct FileState { + int asynch; /* 1 if channel is in asynch mode. */ + int append; /* 1 if channel is in append mode. */ + Tcl_File inFile; /* Input file. */ + Tcl_File outFile; /* Output file. */ +} FileState; + +/* + * This structure describes per-instance state of a pipe based channel. + * + * IMPORTANT NOTE: If you modify this structure, make sure that the + * "asynch" field remains the first field - FilePipeBlockMode depends + * on this. + */ + +typedef struct PipeState { + int asynch; /* 1 if channel is in asynch mode. */ + Tcl_File readFile; /* Output from pipe. */ + Tcl_File writeFile; /* Input from pipe. */ + Tcl_File errorFile; /* Error output from pipe. */ + int numPids; /* Number of processes attached to pipe. */ + int *pidPtr; /* Pids of attached processes. */ +} PipeState; + +/* + *---------------------------------------------------------------------- + * + * FileBlockModeProc -- + * + * Set blocking or non-blocking mode on channel. + * + * Results: + * 0 if successful, errno when failed. + * + * Side effects: + * Sets the device into blocking or non-blocking mode. + * + *---------------------------------------------------------------------- + */ + +static int +FileBlockModeProc(instanceData, mode) + ClientData instanceData; /* Instance state for channel. */ + int mode; /* The mode to set. */ +{ + FileState *fsPtr = (FileState *) instanceData; + + /* + * Files on Windows can not be switched between blocking and nonblocking, + * hence we have to emulate the behavior. This is done in the input + * function by checking against a bit in the state. We set or unset the + * bit here to cause the input function to emulate the correct behavior. + */ + + fsPtr->asynch = (mode == TCL_MODE_BLOCKING) ? 0 : 1; + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * FileCloseProc -- + * + * Closes the IO channel. + * + * Results: + * 0 if successful, the value of errno if failed. + * + * Side effects: + * Closes the physical channel + * + *---------------------------------------------------------------------- + */ + +static int +FileCloseProc(instanceData, interp) + ClientData instanceData; /* Pointer to FileState structure. */ + Tcl_Interp *interp; /* Not used. */ +{ + FileState *fsPtr = (FileState *) instanceData; + HANDLE handle; + int type, errorCode = 0; + + if (fsPtr->inFile != NULL) { + handle = (HANDLE) Tcl_GetFileInfo(fsPtr->inFile, &type); + + /* + * Check for read/write file so we only close it once. + */ + + if (fsPtr->inFile == fsPtr->outFile) { + fsPtr->outFile = NULL; + } + Tcl_FreeFile(fsPtr->inFile); + + if (CloseHandle(handle) == FALSE) { + TclWinConvertError(GetLastError()); + errorCode = errno; + } + + } + if (fsPtr->outFile != NULL) { + handle = (HANDLE) Tcl_GetFileInfo(fsPtr->outFile, &type); + Tcl_FreeFile(fsPtr->outFile); + + if (CloseHandle(handle) == FALSE) { + TclWinConvertError(GetLastError()); + if (errorCode == 0) { + errorCode = errno; + } + } + } + ckfree((char *) instanceData); + return errorCode; +} + +/* + *---------------------------------------------------------------------- + * + * FileSeekProc -- + * + * Seeks on a file-based channel. Returns the new position. + * + * Results: + * -1 if failed, the new position if successful. If failed, it + * also sets *errorCodePtr to the error code. + * + * Side effects: + * Moves the location at which the channel will be accessed in + * future operations. + * + *---------------------------------------------------------------------- + */ + +static int +FileSeekProc(instanceData, offset, mode, errorCodePtr) + ClientData instanceData; /* File state. */ + long offset; /* Offset to seek to. */ + int mode; /* Relative to where + * should we seek? */ + int *errorCodePtr; /* To store error code. */ +{ + FileState *fsPtr = (FileState *) instanceData; + DWORD moveMethod; + DWORD newPos; + HANDLE handle; + int type; + + *errorCodePtr = 0; + if (fsPtr->inFile != (Tcl_File) NULL) { + handle = (HANDLE) Tcl_GetFileInfo(fsPtr->inFile, &type); + } else if (fsPtr->outFile != (Tcl_File) NULL) { + handle = (HANDLE) Tcl_GetFileInfo(fsPtr->outFile, &type); + } else { + *errorCodePtr = EFAULT; + return -1; + } + + if (mode == SEEK_SET) { + moveMethod = FILE_BEGIN; + } else if (mode == SEEK_CUR) { + moveMethod = FILE_CURRENT; + } else { + moveMethod = FILE_END; + } + + newPos = SetFilePointer(handle, offset, NULL, moveMethod); + if (newPos == 0xFFFFFFFF) { + TclWinConvertError(GetLastError()); + return -1; + } + return newPos; +} + +/* + *---------------------------------------------------------------------- + * + * FileInputProc -- + * + * Reads input from the IO channel into the buffer given. Returns + * count of how many bytes were actually read, and an error indication. + * + * Results: + * A count of how many bytes were read is returned and an error + * indication is returned in an output argument. + * + * Side effects: + * Reads input from the actual channel. + * + *---------------------------------------------------------------------- + */ + +static int +FileInputProc(instanceData, buf, bufSize, errorCode) + ClientData instanceData; /* File state. */ + char *buf; /* Where to store data read. */ + int bufSize; /* How much space is available + * in the buffer? */ + int *errorCode; /* Where to store error code. */ +{ + FileState *statePtr; + HANDLE handle; + DWORD bytesRead; + int type; + + *errorCode = 0; + statePtr = (FileState *) instanceData; + handle = (HANDLE) Tcl_GetFileInfo(statePtr->inFile, &type); + + /* + * Note that we will block on reads from a console buffer until a + * full line has been entered. The only way I know of to get + * around this is to write a console driver. We should probably + * do this at some point, but for now, we just block. + */ + + if (ReadFile(handle, (LPVOID) buf, (DWORD) bufSize, &bytesRead, + (LPOVERLAPPED) NULL) == FALSE) { + goto error; + } + + return bytesRead; + +error: + TclWinConvertError(GetLastError()); + *errorCode = errno; + if (errno == EPIPE) { + return 0; + } + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * FileOutputProc -- + * + * Writes the given output on the IO channel. Returns count of how + * many characters were actually written, and an error indication. + * + * Results: + * A count of how many characters were written is returned and an + * error indication is returned in an output argument. + * + * Side effects: + * Writes output on the actual channel. + * + *---------------------------------------------------------------------- + */ + +static int +FileOutputProc(instanceData, buf, toWrite, errorCode) + ClientData instanceData; /* File state. */ + char *buf; /* The data buffer. */ + int toWrite; /* How many bytes to write? */ + int *errorCode; /* Where to store error code. */ +{ + FileState *statePtr = (FileState *) instanceData; + int type; + DWORD bytesWritten; + HANDLE handle; + + *errorCode = 0; + handle = (HANDLE) Tcl_GetFileInfo(statePtr->outFile, &type); + + /* + * If we are writing to a file that was opened with O_APPEND, we need to + * seek to the end of the file before writing the current buffer. + */ + + if (statePtr->append) { + SetFilePointer(handle, 0, NULL, FILE_END); + } + + if (WriteFile(handle, (LPVOID) buf, (DWORD) toWrite, &bytesWritten, + (LPOVERLAPPED) NULL) == FALSE) { + TclWinConvertError(GetLastError()); + *errorCode = errno; + return -1; + } + FlushFileBuffers(handle); + return bytesWritten; +} + +/* + *---------------------------------------------------------------------- + * + * FileWatchProc -- + * + * Called by the notifier to set up to watch for events on this + * channel. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +FileWatchProc(instanceData, mask) + ClientData instanceData; /* File state. */ + int mask; /* What events to watch for; OR-ed + * combination of TCL_READABLE, + * TCL_WRITABLE and TCL_EXCEPTION. */ +{ + FileState *fsPtr = (FileState *) instanceData; + + if ((mask & TCL_READABLE) && (fsPtr->inFile != (Tcl_File) NULL)) { + Tcl_WatchFile(fsPtr->inFile, TCL_READABLE); + } + if ((mask & TCL_WRITABLE) && (fsPtr->outFile != (Tcl_File) NULL)) { + Tcl_WatchFile(fsPtr->outFile, TCL_WRITABLE); + } + + if (mask & TCL_EXCEPTION) { + if (fsPtr->inFile != (Tcl_File) NULL) { + Tcl_WatchFile(fsPtr->inFile, TCL_EXCEPTION); + } + if (fsPtr->outFile != (Tcl_File) NULL) { + Tcl_WatchFile(fsPtr->outFile, TCL_EXCEPTION); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * FileReadyProc -- + * + * Called by the notifier to check whether events of interest are + * present on the channel. + * + * Results: + * Returns OR-ed combination of TCL_READABLE, TCL_WRITABLE and + * TCL_EXCEPTION to indicate which events of interest are present. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +FileReadyProc(instanceData, mask) + ClientData instanceData; /* The file state. */ + int mask; /* Events of interest; an OR-ed + * combination of TCL_READABLE, + * TCL_WRITABLE and TCL_EXCEPTION. */ +{ + FileState *fsPtr = (FileState *) instanceData; + int present = 0; + + if ((mask & TCL_READABLE) && (fsPtr->inFile != (Tcl_File) NULL)) { + present |= Tcl_FileReady(fsPtr->inFile, TCL_READABLE); + } + if ((mask & TCL_WRITABLE) && (fsPtr->outFile != (Tcl_File) NULL)) { + present |= Tcl_FileReady(fsPtr->outFile, TCL_WRITABLE); + } + if (mask & TCL_EXCEPTION) { + if (fsPtr->inFile != (Tcl_File) NULL) { + present |= Tcl_FileReady(fsPtr->inFile, TCL_EXCEPTION); + } + if (fsPtr->outFile != (Tcl_File) NULL) { + present |= Tcl_FileReady(fsPtr->outFile, TCL_EXCEPTION); + } + } + return present; +} + +/* + *---------------------------------------------------------------------- + * + * FileGetProc -- + * + * Called from Tcl_GetChannelFile to retrieve Tcl_Files from inside + * a file based channel. + * + * Results: + * The appropriate Tcl_File or NULL if not present. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tcl_File +FileGetProc(instanceData, direction) + ClientData instanceData; /* The file state. */ + int direction; /* Which Tcl_File to retrieve? */ +{ + FileState *fsPtr = (FileState *) instanceData; + + if (direction == TCL_READABLE) { + return fsPtr->inFile; + } + if (direction == TCL_WRITABLE) { + return fsPtr->outFile; + } + return (Tcl_File) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * PipeBlockModeProc -- + * + * Set blocking or non-blocking mode on channel. + * + * Results: + * 0 if successful, errno when failed. + * + * Side effects: + * Sets the device into blocking or non-blocking mode. + * + *---------------------------------------------------------------------- + */ + +static int +PipeBlockModeProc(instanceData, mode) + ClientData instanceData; /* Instance state for channel. */ + int mode; /* The mode to set. */ +{ + PipeState *statePtr = (PipeState *) instanceData; + + /* + * Files on Windows can not be switched between blocking and nonblocking, + * hence we have to emulate the behavior. This is done in the input + * function by checking against a bit in the state. We set or unset the + * bit here to cause the input function to emulate the correct behavior. + */ + + statePtr->asynch = (mode == TCL_MODE_BLOCKING) ? 0 : 1; + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * PipeCloseProc -- + * + * Closes a pipe based IO channel. + * + * Results: + * 0 on success, errno otherwise. + * + * Side effects: + * Closes the physical channel. + * + *---------------------------------------------------------------------- + */ + +static int +PipeCloseProc(instanceData, interp) + ClientData instanceData; /* Pointer to PipeState structure. */ + Tcl_Interp *interp; /* For error reporting. */ +{ + PipeState *pipePtr = (PipeState *) instanceData; + FileState *fsPtr; + HANDLE handle; + Tcl_Channel errChan; + int errorCode, result, type; + ClientData clientData; + TclWinPipe *winPipePtr; + + errorCode = 0; + if (pipePtr->readFile != NULL) { + clientData = Tcl_GetFileInfo(pipePtr->readFile, &type); + Tcl_FreeFile(pipePtr->readFile); + if (type == TCL_WIN32S_PIPE) { + winPipePtr = (TclWinPipe *) clientData; + + if (winPipePtr->otherPtr != NULL) { + winPipePtr->otherPtr->otherPtr = NULL; + } else { + if (winPipePtr->fileHandle != INVALID_HANDLE_VALUE) { + CloseHandle(winPipePtr->fileHandle); + } + DeleteFile(winPipePtr->fileName); + ckfree((char *) winPipePtr->fileName); + } + ckfree((char *) winPipePtr); + } else { + handle = (HANDLE) clientData; + if (CloseHandle(handle) == FALSE) { + TclWinConvertError(GetLastError()); + errorCode = errno; + } + } + } + if (pipePtr->writeFile != NULL) { + clientData = Tcl_GetFileInfo(pipePtr->writeFile, &type); + Tcl_FreeFile(pipePtr->writeFile); + if (type == TCL_WIN32S_PIPE) { + winPipePtr = (TclWinPipe *) clientData; + + if (winPipePtr->otherPtr != NULL) { + winPipePtr->otherPtr->otherPtr = NULL; + } else { + if (winPipePtr->fileHandle != INVALID_HANDLE_VALUE) { + CloseHandle(winPipePtr->fileHandle); + } + DeleteFile(winPipePtr->fileName); + ckfree((char *) winPipePtr->fileName); + } + ckfree((char *) winPipePtr); + } else { + handle = (HANDLE) clientData; + if (CloseHandle(handle) == FALSE) { + TclWinConvertError(GetLastError()); + if (errorCode == 0) { + errorCode = errno; + } + } + } + } + + /* + * Wrap the error file into a channel and give it to the cleanup + * routine. + */ + + if (pipePtr->errorFile != NULL) { + fsPtr = (FileState *) ckalloc((unsigned) sizeof(FileState)); + + fsPtr->inFile = pipePtr->errorFile; + fsPtr->outFile = (Tcl_File) NULL; + fsPtr->asynch = 0; + fsPtr->append = 0; + + errChan = Tcl_CreateChannel(&fileChannelType, "pipeError", + (ClientData) fsPtr, TCL_READABLE); + if (Tcl_SetChannelOption(interp, errChan, "-translation", "auto") == + TCL_ERROR) { + Tcl_Close((Tcl_Interp *) NULL, errChan); + errChan = (Tcl_Channel) NULL; + } + if ((errChan != (Tcl_Channel) NULL) && + (Tcl_SetChannelOption(NULL, errChan, "-eofchar", "\032") == + TCL_ERROR)) { + Tcl_Close((Tcl_Interp *) NULL, errChan); + errChan = (Tcl_Channel) NULL; + } + } else { + errChan = NULL; + } + result = TclCleanupChildren(interp, pipePtr->numPids, pipePtr->pidPtr, + errChan); + if (pipePtr->numPids > 0) { + ckfree((char *) pipePtr->pidPtr); + } + ckfree((char *) pipePtr); + if (errorCode == 0) { + return result; + } + return errorCode; +} + +/* + *---------------------------------------------------------------------- + * + * PipeInputProc -- + * + * Reads input from the IO channel into the buffer given. Returns + * count of how many bytes were actually read, and an error indication. + * + * Results: + * A count of how many bytes were read is returned and an error + * indication is returned in an output argument. + * + * Side effects: + * Reads input from the actual channel. + * + *---------------------------------------------------------------------- + */ + +static int +PipeInputProc(instanceData, buf, bufSize, errorCode) + ClientData instanceData; /* Pipe state. */ + char *buf; /* Where to store data read. */ + int bufSize; /* How much space is available + * in the buffer? */ + int *errorCode; /* Where to store error code. */ +{ + PipeState *statePtr; + HANDLE handle; + DWORD count; + DWORD bytesRead; + int type; + ClientData clientData; + TclWinPipe *pipePtr; + + *errorCode = 0; + statePtr = (PipeState *) instanceData; + clientData = Tcl_GetFileInfo(statePtr->readFile, &type); + if (type == TCL_WIN32S_PIPE) { + pipePtr = (TclWinPipe *) clientData; + if (pipePtr->otherPtr != NULL) { + panic("PipeInputProc: child process isn't finished writing"); + } + if (pipePtr->fileHandle == INVALID_HANDLE_VALUE) { + pipePtr->fileHandle = CreateFile(pipePtr->fileName, GENERIC_READ, + 0, NULL, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL); + } + handle = pipePtr->fileHandle; + if (handle == INVALID_HANDLE_VALUE) { + goto error; + } + } else { + handle = (HANDLE) clientData; + + /* + * Pipes will block until the requested number of bytes has been + * read. To avoid blocking unnecessarily, we look ahead and only + * read as much as is available. + */ + + if (PeekNamedPipe(handle, (LPVOID) NULL, (DWORD) 0, (LPDWORD) NULL, + &count, (LPDWORD) NULL) == TRUE) { + if ((count != 0) && ((DWORD) bufSize > count)) { + bufSize = (int) count; + } else if ((count == 0) && statePtr->asynch) { + errno = *errorCode = EAGAIN; + return 0; + } else if ((count == 0) && !statePtr->asynch) { + bufSize = 1; + } + } else { + goto error; + } + } + + /* + * Note that we will block on reads from a console buffer until a + * full line has been entered. The only way I know of to get + * around this is to write a console driver. We should probably + * do this at some point, but for now, we just block. + */ + + if (ReadFile(handle, (LPVOID) buf, (DWORD) bufSize, &bytesRead, + (LPOVERLAPPED) NULL) == FALSE) { + goto error; + } + + return bytesRead; + + error: + TclWinConvertError(GetLastError()); + if (errno == EPIPE) { + return 0; + } + *errorCode = errno; + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * PipeOutputProc -- + * + * Writes the given output on the IO channel. Returns count of how + * many characters were actually written, and an error indication. + * + * Results: + * A count of how many characters were written is returned and an + * error indication is returned in an output argument. + * + * Side effects: + * Writes output on the actual channel. + * + *---------------------------------------------------------------------- + */ + +static int +PipeOutputProc(instanceData, buf, toWrite, errorCode) + ClientData instanceData; /* Pipe state. */ + char *buf; /* The data buffer. */ + int toWrite; /* How many bytes to write? */ + int *errorCode; /* Where to store error code. */ +{ + PipeState *statePtr = (PipeState *) instanceData; + int type; + DWORD bytesWritten; + HANDLE handle; + + *errorCode = 0; + handle = (HANDLE) Tcl_GetFileInfo(statePtr->writeFile, &type); + if (WriteFile(handle, (LPVOID) buf, (DWORD) toWrite, &bytesWritten, + (LPOVERLAPPED) NULL) == FALSE) { + TclWinConvertError(GetLastError()); + if (errno == EPIPE) { + return 0; + } + *errorCode = errno; + return -1; + } + return bytesWritten; +} + +/* + *---------------------------------------------------------------------- + * + * PipeWatchProc -- + * + * Initialize the notifier to watch Tcl_Files from this channel. + * + * Results: + * None. + * + * Side effects: + * Sets up the notifier so that a future event on the channel will + * be seen by Tcl. + * + *---------------------------------------------------------------------- + */ + +static void +PipeWatchProc(instanceData, mask) + ClientData instanceData; /* The pipe state. */ + int mask; /* Events of interest; an OR-ed + * combination of TCL_READABLE, + * TCL_WRITABEL and TCL_EXCEPTION. */ +{ + PipeState *psPtr = (PipeState *) instanceData; + + if ((mask & TCL_READABLE) && (psPtr->readFile != (Tcl_File) NULL)) { + Tcl_WatchFile(psPtr->readFile, TCL_READABLE); + } + if ((mask & TCL_WRITABLE) && (psPtr->writeFile != (Tcl_File) NULL)) { + Tcl_WatchFile(psPtr->writeFile, TCL_WRITABLE); + } + + if (mask & TCL_EXCEPTION) { + if (psPtr->readFile != (Tcl_File) NULL) { + Tcl_WatchFile(psPtr->readFile, TCL_EXCEPTION); + } + if (psPtr->writeFile != (Tcl_File) NULL) { + Tcl_WatchFile(psPtr->writeFile, TCL_EXCEPTION); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * PipeReadyProc -- + * + * Called by the notifier to check whether events of interest are + * present on the channel. + * + * Results: + * Returns OR-ed combination of TCL_READABLE, TCL_WRITABLE and + * TCL_EXCEPTION to indicate which events of interest are present. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +PipeReadyProc(instanceData, mask) + ClientData instanceData; /* The pipe state. */ + int mask; /* Events of interest; an OR-ed + * combination of TCL_READABLE, + * TCL_WRITABLE and TCL_EXCEPTION. */ +{ + PipeState *psPtr = (PipeState *) instanceData; + int present = 0; + + if ((mask & TCL_READABLE) && (psPtr->readFile != (Tcl_File) NULL)) { + present |= Tcl_FileReady(psPtr->readFile, TCL_READABLE); + } + if ((mask & TCL_WRITABLE) && (psPtr->writeFile != (Tcl_File) NULL)) { + present |= Tcl_FileReady(psPtr->writeFile, TCL_WRITABLE); + } + if (mask & TCL_EXCEPTION) { + if (psPtr->readFile != (Tcl_File) NULL) { + present |= Tcl_FileReady(psPtr->readFile, TCL_EXCEPTION); + } + if (psPtr->writeFile != (Tcl_File) NULL) { + present |= Tcl_FileReady(psPtr->writeFile, TCL_EXCEPTION); + } + } + return present; +} + +/* + *---------------------------------------------------------------------- + * + * PipeGetProc -- + * + * Called from Tcl_GetChannelFile to retrieve Tcl_Files from inside + * a command pipeline based channel. + * + * Results: + * The appropriate Tcl_File or NULL if not present. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tcl_File +PipeGetProc(instanceData, direction) + ClientData instanceData; /* The pipe state. */ + int direction; /* Which Tcl_File to retrieve? */ +{ + PipeState *psPtr = (PipeState *) instanceData; + + if (direction == TCL_READABLE) { + return psPtr->readFile; + } + if (direction == TCL_WRITABLE) { + return psPtr->writeFile; + } + return (Tcl_File) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_OpenFileChannel -- + * + * Open an File based channel on Unix systems. + * + * Results: + * The new channel or NULL. If NULL, the output argument + * errorCodePtr is set to a POSIX error. + * + * Side effects: + * May open the channel and may cause creation of a file on the + * file system. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_OpenFileChannel(interp, fileName, modeString, permissions) + Tcl_Interp *interp; /* Interpreter for error reporting; + * can be NULL. */ + char *fileName; /* Name of file to open. */ + char *modeString; /* A list of POSIX open modes or + * a string such as "rw". */ + int permissions; /* If the open involves creating a + * file, with what modes to create + * it? */ +{ + Tcl_File file; + Tcl_Channel chan; + FileState *sPtr; + int seekFlag, mode, readWriteMode; + HANDLE handle; + DWORD accessMode, createMode, shareMode, flags; + SECURITY_ATTRIBUTES sec; + char *nativeName; + Tcl_DString buffer; + + mode = TclGetOpenMode(interp, modeString, &seekFlag); + if (mode == -1) { + return NULL; + } + switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) { + case O_RDONLY: + accessMode = GENERIC_READ; + break; + case O_WRONLY: + accessMode = GENERIC_WRITE; + break; + case O_RDWR: + accessMode = (GENERIC_READ | GENERIC_WRITE); + break; + default: + panic("Tcl_OpenFileChannel: invalid mode value"); + break; + } + + /* + * Map the creation flags to the NT create mode. + */ + + switch (mode & (O_CREAT | O_EXCL | O_TRUNC)) { + case (O_CREAT | O_EXCL): + case (O_CREAT | O_EXCL | O_TRUNC): + createMode = CREATE_NEW; + break; + case (O_CREAT | O_TRUNC): + createMode = CREATE_ALWAYS; + break; + case O_CREAT: + createMode = OPEN_ALWAYS; + break; + case O_TRUNC: + case (O_TRUNC | O_EXCL): + createMode = TRUNCATE_EXISTING; + break; + default: + createMode = OPEN_EXISTING; + break; + } + + /* + * If the file is being created, get the file attributes from the + * permissions argument, else use the existing file attributes. + */ + + if (mode & O_CREAT) { + if (permissions & S_IWRITE) { + flags = FILE_ATTRIBUTE_NORMAL; + } else { + flags = FILE_ATTRIBUTE_READONLY; + } + } else { + flags = GetFileAttributes(fileName); + if (flags == 0xFFFFFFFF) { + flags = 0; + } + } + + /* + * Set up the security attributes so this file is not inherited by + * child processes. + */ + + sec.nLength = sizeof(sec); + sec.lpSecurityDescriptor = NULL; + sec.bInheritHandle = 0; + + /* + * Set up the file sharing mode. We want to allow simultaneous access. + */ + + shareMode = FILE_SHARE_READ | FILE_SHARE_WRITE; + + /* + * Now we get to create the file. + */ + + nativeName = Tcl_TranslateFileName(interp, fileName, &buffer); + if (nativeName == NULL) { + return NULL; + } + handle = CreateFile(nativeName, accessMode, shareMode, &sec, createMode, + flags, (HANDLE) NULL); + Tcl_DStringFree(&buffer); + + if (handle == INVALID_HANDLE_VALUE) { + DWORD err = GetLastError(); + if ((err & 0xffffL) == ERROR_OPEN_FAILED) { + err = (mode & O_CREAT) ? ERROR_FILE_EXISTS : ERROR_FILE_NOT_FOUND; + } + TclWinConvertError(err); + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "couldn't open \"", fileName, "\": ", + Tcl_PosixError(interp), (char *) NULL); + } + return NULL; + } + + file = Tcl_GetFile((ClientData) handle, TCL_WIN_FILE); + + sPtr = (FileState *) ckalloc((unsigned) sizeof(FileState)); + sPtr->asynch = 0; + sPtr->append = (mode & O_APPEND) ? 1 : 0; + readWriteMode = 0; + if (accessMode & GENERIC_READ) { + readWriteMode |= TCL_READABLE; + sPtr->inFile = file; + } else { + sPtr->inFile = (Tcl_File) NULL; + } + if (accessMode & GENERIC_WRITE) { + readWriteMode |= TCL_WRITABLE; + sPtr->outFile = file; + } else { + sPtr->outFile = (Tcl_File) NULL; + } + sprintf(channelName, "file%d", (int) Tcl_GetFileInfo(file, NULL)); + chan = Tcl_CreateChannel(&fileChannelType, channelName, + (ClientData) sPtr, readWriteMode); + if (chan == (Tcl_Channel) NULL) { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "could not open channel \"", + channelName, "\": ", Tcl_PosixError(interp), + (char *) NULL); + } + Tcl_FreeFile(file); + CloseHandle(handle); + ckfree((char *) sPtr); + return NULL; + } + + if (seekFlag) { + if (Tcl_Seek(chan, 0, SEEK_END) < 0) { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "could not seek to end of file on \"", + channelName, "\": ", Tcl_PosixError(interp), + (char *) NULL); + } + Tcl_Close((Tcl_Interp *) NULL, chan); + return NULL; + } + } + + /* + * Files have default translation of AUTO and ^Z eof char, which + * means that a ^Z will be appended to them at close. + */ + + if (Tcl_SetChannelOption(interp, chan, "-translation", "auto") == + TCL_ERROR) { + Tcl_Close((Tcl_Interp *) NULL, chan); + return (Tcl_Channel) NULL; + } + if (Tcl_SetChannelOption(NULL, chan, "-eofchar", "\032 {}") == + TCL_ERROR) { + Tcl_Close((Tcl_Interp *) NULL, chan); + return (Tcl_Channel) NULL; + } + return chan; +} + +/* + *---------------------------------------------------------------------- + * + * FileType -- + * + * Converts a Windows handle type to a Tcl file type + * + * Results: + * The Tcl file type corresponding to the given Windows handle type + * or -1 on error. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +FileType(h) + HANDLE h; /* Convert the type of this handle to + * a Tcl file type. */ +{ + switch (GetFileType(h)) { + case FILE_TYPE_CHAR: + return TCL_WIN_CONSOLE; + case FILE_TYPE_DISK: + return TCL_WIN_FILE; + case FILE_TYPE_PIPE: + return TCL_WIN_PIPE; + default: + return -1; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_MakeFileChannel -- + * + * Creates a Tcl_Channel from an existing platform specific file + * handle. + * + * Results: + * The Tcl_Channel created around the preexisting file. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_MakeFileChannel(inFile, outFile, mode) + ClientData inFile; /* OS level handle used for input. */ + ClientData outFile; /* OS level handle used for output. */ + int mode; /* ORed combination of TCL_READABLE and + * TCL_WRITABLE to indicate whether inFile + * and/or outFile are valid. */ +{ + Tcl_Channel chan; + int fileUsed; + Tcl_File inFd, outFd; + char channelName[20]; + FileState *sPtr; + + if (mode & TCL_READABLE) { + sprintf(channelName, "file%d", (int) inFile); + inFd = Tcl_GetFile(inFile, FileType((HANDLE) inFile)); + } else { + inFd = (Tcl_File) NULL; + } + + if (mode & TCL_WRITABLE) { + sprintf(channelName, "file%d", (int) outFile); + outFd = Tcl_GetFile(outFile, FileType((HANDLE) outFile)); + } else { + outFd = (Tcl_File) NULL; + } + + /* + * See if a channel with the right Tcl_Files in it already exists. If + * so, return it. + */ + + chan = TclFindFileChannel(inFd, outFd, &fileUsed); + if (chan != (Tcl_Channel) NULL) { + return chan; + } + + /* + * If one of the Tcl_Files is already used by another channel, do not + * create a new channel containing it. This will avoid core dumps later + * when the Tcl_File would be freed twice. + */ + + if (fileUsed) { + return (Tcl_Channel) NULL; + } + + sPtr = (FileState *) ckalloc((unsigned) sizeof(FileState)); + sPtr->asynch = 0; + sPtr->append = 0; + sPtr->inFile = inFd; + sPtr->outFile = outFd; + + chan = Tcl_CreateChannel(&fileChannelType, channelName, + (ClientData) sPtr, mode); + if (chan == (Tcl_Channel) NULL) { + ckfree((char *) sPtr); + return NULL; + } + + /* + * Windows files have AUTO translation mode and ^Z eof char on input. + */ + + if (Tcl_SetChannelOption((Tcl_Interp *) NULL, chan, "-translation", + "auto") == TCL_ERROR) { + Tcl_Close((Tcl_Interp *) NULL, chan); + return (Tcl_Channel) NULL; + } + if (Tcl_SetChannelOption((Tcl_Interp *) NULL, chan, "-eofchar", + "\032 {}") == TCL_ERROR) { + Tcl_Close((Tcl_Interp *) NULL, chan); + return (Tcl_Channel) NULL; + } + return chan; +} + +/* + *---------------------------------------------------------------------- + * + * TclCreateCommandChannel -- + * + * This function is called by Tcl_OpenCommandChannel to perform + * the platform specific channel initialization for a command + * channel. + * + * Results: + * Returns a new channel or NULL on failure. + * + * Side effects: + * Allocates a new channel. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +TclCreateCommandChannel(readFile, writeFile, errorFile, numPids, pidPtr) + Tcl_File readFile; /* If non-null, gives the file for reading. */ + Tcl_File writeFile; /* If non-null, gives the file for writing. */ + Tcl_File errorFile; /* If non-null, gives the file where errors + * can be read. */ + int numPids; /* The number of pids in the pid array. */ + int *pidPtr; /* An array of process identifiers. */ +{ + Tcl_Channel channel; + char channelName[20]; + int channelId; + int permissions; + PipeState *statePtr = (PipeState *) ckalloc((unsigned) sizeof(PipeState)); + + statePtr->asynch = 0; + statePtr->readFile = readFile; + statePtr->writeFile = writeFile; + statePtr->errorFile = errorFile; + statePtr->numPids = numPids; + statePtr->pidPtr = pidPtr; + + /* + * Use one of the fds associated with the channel as the + * channel id. + */ + + if (readFile) { + channelId = (int) Tcl_GetFileInfo(readFile, NULL); + } else if (writeFile) { + channelId = (int) Tcl_GetFileInfo(writeFile, NULL); + } else if (errorFile) { + channelId = (int) Tcl_GetFileInfo(errorFile, NULL); + } else { + channelId = 0; + } + + permissions = 0; + if (readFile != (Tcl_File) NULL) { + permissions |= TCL_READABLE; + } + if (writeFile != (Tcl_File) NULL) { + permissions |= TCL_WRITABLE; + } + + /* + * For backward compatibility with previous versions of Tcl, we + * use "file%d" as the base name for pipes even though it would + * be more natural to use "pipe%d". + */ + + sprintf(channelName, "file%d", channelId); + channel = Tcl_CreateChannel(&pipeChannelType, channelName, + (ClientData) statePtr, permissions); + + if (channel == NULL) { + ckfree((char *)statePtr); + return NULL; + } + + /* + * Pipes have AUTO translation mode on Windows and ^Z eof char, which + * means that a ^Z will be appended to them at close. This is needed + * for Windows programs that expect a ^Z at EOF. + */ + + if (Tcl_SetChannelOption((Tcl_Interp *) NULL, channel, "-translation", + "auto") == TCL_ERROR) { + Tcl_Close((Tcl_Interp *) NULL, channel); + return (Tcl_Channel) NULL; + } + if (Tcl_SetChannelOption((Tcl_Interp *) NULL, channel, "-eofchar", + "\032 {}") == TCL_ERROR) { + Tcl_Close((Tcl_Interp *) NULL, channel); + return (Tcl_Channel) NULL; + } + return channel; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PidCmd -- + * + * This procedure is invoked to process the "pid" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_PidCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Channel chan; /* The channel to get pids for. */ + Tcl_ChannelType *typePtr; + PipeState *pipePtr; /* The pipe state. */ + int i; /* Loops over PIDs attached to the + * pipe. */ + char string[50]; /* Temp buffer for string rep. of + * PIDs attached to the pipe. */ + + if (argc > 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " ?channelId?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 1) { + sprintf(interp->result, "%lu", (unsigned long) getpid()); + } else { + chan = Tcl_GetChannel(interp, argv[1], NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + typePtr = Tcl_GetChannelType(chan); + if (typePtr != &pipeChannelType) { + return TCL_OK; + } + pipePtr = (PipeState *) Tcl_GetChannelInstanceData(chan); + for (i = 0; i < pipePtr->numPids; i++) { + sprintf(string, "%lu", (unsigned long) pipePtr->pidPtr[i]); + Tcl_AppendElement(interp, string); + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetDefaultStdChannel -- + * + * Constructs a channel for the specified standard OS handle. + * + * Results: + * Returns the specified default standard channel, or NULL. + * + * Side effects: + * May cause the creation of a standard channel and the underlying + * file. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +TclGetDefaultStdChannel(type) + int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */ +{ + Tcl_Channel channel; + HANDLE handle; + int mode; + char *bufMode; + DWORD handleId; /* Standard handle to retrieve. */ + +#ifdef _MSC_VER + /* + * If this code is compiled under Borland, the stdio handles for + * tclsh get screwed up and the program exits immediately. + */ + + static int hidden = 0; + + if (hidden == 0) { + /* + * The stdio handles for this process are globally visible by all + * children of this process, which means that a badly behaved child + * process could write to its parent's handles. Change the + * permission on the handles so that they are not globally visible, + * then have to tell C that the standard file descriptors are to + * be associated with these handles + */ + + HANDLE hProcess = GetCurrentProcess(); + HANDLE h1, h2; + + h1 = GetStdHandle(STD_INPUT_HANDLE); + if (DuplicateHandle(hProcess, h1, hProcess, &h2, 0, FALSE, + DUPLICATE_SAME_ACCESS) != 0) { + + /* + * The following two commands have the side effects of + * CloseHandle(h1) and SetStdHandle(STD_INPUT_HANDLE, h2). + */ + + _close(0); + _open_osfhandle((long) h2, _O_TEXT); + } + + h1 = GetStdHandle(STD_OUTPUT_HANDLE); + if (DuplicateHandle(hProcess, h1, hProcess, &h2, 0, FALSE, + DUPLICATE_SAME_ACCESS) != 0) { + /* + * The following two commands have the side effects of + * CloseHandle(h1) and SetStdHandle(STD_OUTPUT_HANDLE, h2). + */ + + _close(1); + _open_osfhandle((long) h2, _O_TEXT); + } + + h1 = GetStdHandle(STD_ERROR_HANDLE); + if (DuplicateHandle(hProcess, h1, hProcess, &h2, 0, FALSE, + DUPLICATE_SAME_ACCESS) != 0) { + /* + * The following two commands have the side effects of + * CloseHandle(h1) and SetStdHandle(STD_ERROR_HANDLE, h2). + */ + + _close(2); + _open_osfhandle((long) h2, _O_TEXT); + } + + hidden = 1; + } +#endif + + switch (type) { + case TCL_STDIN: + handleId = STD_INPUT_HANDLE; + mode = TCL_READABLE; + bufMode = "line"; + break; + case TCL_STDOUT: + handleId = STD_OUTPUT_HANDLE; + mode = TCL_WRITABLE; + bufMode = "line"; + break; + case TCL_STDERR: + handleId = STD_ERROR_HANDLE; + mode = TCL_WRITABLE; + bufMode = "none"; + break; + default: + panic("TclGetDefaultStdChannel: Unexpected channel type"); + break; + } + handle = GetStdHandle(handleId); + + /* + * Note that we need to check for 0 because Windows will return 0 if this + * is not a console mode application, even though this is not a valid + * handle. + */ + + if ((handle == INVALID_HANDLE_VALUE) || (handle == 0)) { + return NULL; + } + + channel = Tcl_MakeFileChannel(handle, handle, mode); + + /* + * Set up the normal channel options for stdio handles. + */ + + if (Tcl_SetChannelOption((Tcl_Interp *) NULL, channel, "-translation", + "auto") == TCL_ERROR) { + Tcl_Close((Tcl_Interp *) NULL, channel); + return (Tcl_Channel) NULL; + } + if (Tcl_SetChannelOption((Tcl_Interp *) NULL, channel, "-eofchar", + "\032 {}") == TCL_ERROR) { + Tcl_Close((Tcl_Interp *) NULL, channel); + return (Tcl_Channel) NULL; + } + if (Tcl_SetChannelOption((Tcl_Interp *) NULL, channel, "-buffering", + bufMode) == TCL_ERROR) { + Tcl_Close((Tcl_Interp *) NULL, channel); + return (Tcl_Channel) NULL; + } + return channel; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetAndDetachPids -- + * + * Stores a list of the command PIDs for a command channel in + * interp->result. + * + * Results: + * None. + * + * Side effects: + * Modifies interp->result. + * + *---------------------------------------------------------------------- + */ + +void +TclGetAndDetachPids(interp, chan) + Tcl_Interp *interp; + Tcl_Channel chan; +{ + PipeState *pipePtr; + Tcl_ChannelType *chanTypePtr; + int i; + char buf[20]; + + /* + * Punt if the channel is not a command channel. + */ + + chanTypePtr = Tcl_GetChannelType(chan); + if (chanTypePtr != &pipeChannelType) { + return; + } + + pipePtr = (PipeState *) Tcl_GetChannelInstanceData(chan); + for (i = 0; i < pipePtr->numPids; i++) { + sprintf(buf, "%d", pipePtr->pidPtr[i]); + Tcl_AppendElement(interp, buf); + Tcl_DetachPids(1, &(pipePtr->pidPtr[i])); + } + if (pipePtr->numPids > 0) { + ckfree((char *) pipePtr->pidPtr); + pipePtr->numPids = 0; + } +} + +/* + *---------------------------------------------------------------------- + * + * TclClosePipeFile -- + * + * This function is a simple wrapper for close on a file or + * pipe handle. + * + * Results: + * None. + * + * Side effects: + * Closes the HANDLE and frees the Tcl_File. + * + *---------------------------------------------------------------------- + */ + +void +TclClosePipeFile(file) + Tcl_File file; +{ + int type; + HANDLE handle = (HANDLE) Tcl_GetFileInfo(file, &type); + switch (type) { + case TCL_WIN_FILE: + case TCL_WIN_PIPE: + CloseHandle(handle); + break; + default: + break; + } + Tcl_FreeFile(file); +} diff --git a/tcl7.6/win/tclWinError.c b/tcl7.6/win/tclWinError.c new file mode 100644 index 0000000..4178825 --- /dev/null +++ b/tcl7.6/win/tclWinError.c @@ -0,0 +1,393 @@ +/* + * tclWinError.c -- + * + * This file contains code for converting from Win32 errors to + * errno errors. + * + * Copyright (c) 1995-1996 by Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclWinError.c 1.6 96/10/03 14:59:22 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * The following table contains the mapping from Win32 errors to + * errno errors. + */ + +static char errorTable[] = { + 0, + EINVAL, /* ERROR_INVALID_FUNCTION 1 */ + ENOENT, /* ERROR_FILE_NOT_FOUND 2 */ + ENOENT, /* ERROR_PATH_NOT_FOUND 3 */ + EMFILE, /* ERROR_TOO_MANY_OPEN_FILES 4 */ + EACCES, /* ERROR_ACCESS_DENIED 5 */ + EBADF, /* ERROR_INVALID_HANDLE 6 */ + ENOMEM, /* ERROR_ARENA_TRASHED 7 */ + ENOMEM, /* ERROR_NOT_ENOUGH_MEMORY 8 */ + ENOMEM, /* ERROR_INVALID_BLOCK 9 */ + E2BIG, /* ERROR_BAD_ENVIRONMENT 10 */ + ENOEXEC, /* ERROR_BAD_FORMAT 11 */ + EACCES, /* ERROR_INVALID_ACCESS 12 */ + EINVAL, /* ERROR_INVALID_DATA 13 */ + EFAULT, /* ERROR_OUT_OF_MEMORY 14 */ + ENOENT, /* ERROR_INVALID_DRIVE 15 */ + EACCES, /* ERROR_CURRENT_DIRECTORY 16 */ + EXDEV, /* ERROR_NOT_SAME_DEVICE 17 */ + ENOENT, /* ERROR_NO_MORE_FILES 18 */ + EROFS, /* ERROR_WRITE_PROTECT 19 */ + ENXIO, /* ERROR_BAD_UNIT 20 */ + EBUSY, /* ERROR_NOT_READY 21 */ + EIO, /* ERROR_BAD_COMMAND 22 */ + EIO, /* ERROR_CRC 23 */ + EIO, /* ERROR_BAD_LENGTH 24 */ + EIO, /* ERROR_SEEK 25 */ + EIO, /* ERROR_NOT_DOS_DISK 26 */ + ENXIO, /* ERROR_SECTOR_NOT_FOUND 27 */ + EBUSY, /* ERROR_OUT_OF_PAPER 28 */ + EIO, /* ERROR_WRITE_FAULT 29 */ + EIO, /* ERROR_READ_FAULT 30 */ + EIO, /* ERROR_GEN_FAILURE 31 */ + EACCES, /* ERROR_SHARING_VIOLATION 32 */ + EACCES, /* ERROR_LOCK_VIOLATION 33 */ + ENXIO, /* ERROR_WRONG_DISK 34 */ + ENFILE, /* ERROR_FCB_UNAVAILABLE 35 */ + ENFILE, /* ERROR_SHARING_BUFFER_EXCEEDED 36 */ + EINVAL, /* 37 */ + EINVAL, /* 38 */ + ENOSPC, /* ERROR_HANDLE_DISK_FULL 39 */ + EINVAL, /* 40 */ + EINVAL, /* 41 */ + EINVAL, /* 42 */ + EINVAL, /* 43 */ + EINVAL, /* 44 */ + EINVAL, /* 45 */ + EINVAL, /* 46 */ + EINVAL, /* 47 */ + EINVAL, /* 48 */ + EINVAL, /* 49 */ + ENODEV, /* ERROR_NOT_SUPPORTED 50 */ + EBUSY, /* ERROR_REM_NOT_LIST 51 */ + EEXIST, /* ERROR_DUP_NAME 52 */ + ENOENT, /* ERROR_BAD_NETPATH 53 */ + EBUSY, /* ERROR_NETWORK_BUSY 54 */ + ENODEV, /* ERROR_DEV_NOT_EXIST 55 */ + EAGAIN, /* ERROR_TOO_MANY_CMDS 56 */ + EIO, /* ERROR_ADAP_HDW_ERR 57 */ + EIO, /* ERROR_BAD_NET_RESP 58 */ + EIO, /* ERROR_UNEXP_NET_ERR 59 */ + EINVAL, /* ERROR_BAD_REM_ADAP 60 */ + EFBIG, /* ERROR_PRINTQ_FULL 61 */ + ENOSPC, /* ERROR_NO_SPOOL_SPACE 62 */ + ENOENT, /* ERROR_PRINT_CANCELLED 63 */ + ENOENT, /* ERROR_NETNAME_DELETED 64 */ + EACCES, /* ERROR_NETWORK_ACCESS_DENIED 65 */ + ENODEV, /* ERROR_BAD_DEV_TYPE 66 */ + ENOENT, /* ERROR_BAD_NET_NAME 67 */ + ENFILE, /* ERROR_TOO_MANY_NAMES 68 */ + EIO, /* ERROR_TOO_MANY_SESS 69 */ + EAGAIN, /* ERROR_SHARING_PAUSED 70 */ + EINVAL, /* ERROR_REQ_NOT_ACCEP 71 */ + EAGAIN, /* ERROR_REDIR_PAUSED 72 */ + EINVAL, /* 73 */ + EINVAL, /* 74 */ + EINVAL, /* 75 */ + EINVAL, /* 76 */ + EINVAL, /* 77 */ + EINVAL, /* 78 */ + EINVAL, /* 79 */ + EEXIST, /* ERROR_FILE_EXISTS 80 */ + EINVAL, /* 81 */ + ENOSPC, /* ERROR_CANNOT_MAKE 82 */ + EIO, /* ERROR_FAIL_I24 83 */ + ENFILE, /* ERROR_OUT_OF_STRUCTURES 84 */ + EEXIST, /* ERROR_ALREADY_ASSIGNED 85 */ + EPERM, /* ERROR_INVALID_PASSWORD 86 */ + EINVAL, /* ERROR_INVALID_PARAMETER 87 */ + EIO, /* ERROR_NET_WRITE_FAULT 88 */ + EAGAIN, /* ERROR_NO_PROC_SLOTS 89 */ + EINVAL, /* 90 */ + EINVAL, /* 91 */ + EINVAL, /* 92 */ + EINVAL, /* 93 */ + EINVAL, /* 94 */ + EINVAL, /* 95 */ + EINVAL, /* 96 */ + EINVAL, /* 97 */ + EINVAL, /* 98 */ + EINVAL, /* 99 */ + EINVAL, /* 100 */ + EINVAL, /* 101 */ + EINVAL, /* 102 */ + EINVAL, /* 103 */ + EINVAL, /* 104 */ + EINVAL, /* 105 */ + EINVAL, /* 106 */ + EXDEV, /* ERROR_DISK_CHANGE 107 */ + EAGAIN, /* ERROR_DRIVE_LOCKED 108 */ + EPIPE, /* ERROR_BROKEN_PIPE 109 */ + ENOENT, /* ERROR_OPEN_FAILED 110 */ + EINVAL, /* ERROR_BUFFER_OVERFLOW 111 */ + ENOSPC, /* ERROR_DISK_FULL 112 */ + EMFILE, /* ERROR_NO_MORE_SEARCH_HANDLES 113 */ + EBADF, /* ERROR_INVALID_TARGET_HANDLE 114 */ + EFAULT, /* ERROR_PROTECTION_VIOLATION 115 */ + EINVAL, /* 116 */ + EINVAL, /* 117 */ + EINVAL, /* 118 */ + EINVAL, /* 119 */ + EINVAL, /* 120 */ + EINVAL, /* 121 */ + EINVAL, /* 122 */ + ENOENT, /* ERROR_INVALID_NAME 123 */ + EINVAL, /* 124 */ + EINVAL, /* 125 */ + EINVAL, /* 126 */ + ESRCH, /* ERROR_PROC_NOT_FOUND 127 */ + ECHILD, /* ERROR_WAIT_NO_CHILDREN 128 */ + ECHILD, /* ERROR_CHILD_NOT_COMPLETE 129 */ + EBADF, /* ERROR_DIRECT_ACCESS_HANDLE 130 */ + EINVAL, /* 131 */ + ESPIPE, /* ERROR_SEEK_ON_DEVICE 132 */ + EINVAL, /* 133 */ + EINVAL, /* 134 */ + EINVAL, /* 135 */ + EINVAL, /* 136 */ + EINVAL, /* 137 */ + EINVAL, /* 138 */ + EINVAL, /* 139 */ + EINVAL, /* 140 */ + EINVAL, /* 141 */ + EAGAIN, /* ERROR_BUSY_DRIVE 142 */ + EINVAL, /* 143 */ + EINVAL, /* 144 */ + EEXIST, /* ERROR_DIR_NOT_EMPTY 145 */ + EINVAL, /* 146 */ + EINVAL, /* 147 */ + EINVAL, /* 148 */ + EINVAL, /* 149 */ + EINVAL, /* 150 */ + EINVAL, /* 151 */ + EINVAL, /* 152 */ + EINVAL, /* 153 */ + EINVAL, /* 154 */ + EINVAL, /* 155 */ + EINVAL, /* 156 */ + EINVAL, /* 157 */ + EACCES, /* ERROR_NOT_LOCKED 158 */ + EINVAL, /* 159 */ + EINVAL, /* 160 */ + ENOENT, /* ERROR_BAD_PATHNAME 161 */ + EINVAL, /* 162 */ + EINVAL, /* 163 */ + EINVAL, /* 164 */ + EINVAL, /* 165 */ + EINVAL, /* 166 */ + EACCES, /* ERROR_LOCK_FAILED 167 */ + EINVAL, /* 168 */ + EINVAL, /* 169 */ + EINVAL, /* 170 */ + EINVAL, /* 171 */ + EINVAL, /* 172 */ + EINVAL, /* 173 */ + EINVAL, /* 174 */ + EINVAL, /* 175 */ + EINVAL, /* 176 */ + EINVAL, /* 177 */ + EINVAL, /* 178 */ + EINVAL, /* 179 */ + EINVAL, /* 180 */ + EINVAL, /* 181 */ + EINVAL, /* 182 */ + EEXIST, /* ERROR_ALREADY_EXISTS 183 */ + ECHILD, /* ERROR_NO_CHILD_PROCESS 184 */ + EINVAL, /* 185 */ + EINVAL, /* 186 */ + EINVAL, /* 187 */ + EINVAL, /* 188 */ + EINVAL, /* 189 */ + EINVAL, /* 190 */ + EINVAL, /* 191 */ + EINVAL, /* 192 */ + EINVAL, /* 193 */ + EINVAL, /* 194 */ + EINVAL, /* 195 */ + EINVAL, /* 196 */ + EINVAL, /* 197 */ + EINVAL, /* 198 */ + EINVAL, /* 199 */ + EINVAL, /* 200 */ + EINVAL, /* 201 */ + EINVAL, /* 202 */ + EINVAL, /* 203 */ + EINVAL, /* 204 */ + EINVAL, /* 205 */ + ENAMETOOLONG,/* ERROR_FILENAME_EXCED_RANGE 206 */ + EINVAL, /* 207 */ + EINVAL, /* 208 */ + EINVAL, /* 209 */ + EINVAL, /* 210 */ + EINVAL, /* 211 */ + EINVAL, /* 212 */ + EINVAL, /* 213 */ + EINVAL, /* 214 */ + EINVAL, /* 215 */ + EINVAL, /* 216 */ + EINVAL, /* 217 */ + EINVAL, /* 218 */ + EINVAL, /* 219 */ + EINVAL, /* 220 */ + EINVAL, /* 221 */ + EINVAL, /* 222 */ + EINVAL, /* 223 */ + EINVAL, /* 224 */ + EINVAL, /* 225 */ + EINVAL, /* 226 */ + EINVAL, /* 227 */ + EINVAL, /* 228 */ + EINVAL, /* 229 */ + EPIPE, /* ERROR_BAD_PIPE 230 */ + EAGAIN, /* ERROR_PIPE_BUSY 231 */ + EINVAL, /* 232 */ + EPIPE, /* ERROR_PIPE_NOT_CONNECTED 233 */ + EINVAL, /* 234 */ + EINVAL, /* 235 */ + EINVAL, /* 236 */ + EINVAL, /* 237 */ + EINVAL, /* 238 */ + EINVAL, /* 239 */ + EINVAL, /* 240 */ + EINVAL, /* 241 */ + EINVAL, /* 242 */ + EINVAL, /* 243 */ + EINVAL, /* 244 */ + EINVAL, /* 245 */ + EINVAL, /* 246 */ + EINVAL, /* 247 */ + EINVAL, /* 248 */ + EINVAL, /* 249 */ + EINVAL, /* 250 */ + EINVAL, /* 251 */ + EINVAL, /* 252 */ + EINVAL, /* 253 */ + EINVAL, /* 254 */ + EINVAL, /* 255 */ + EINVAL, /* 256 */ + EINVAL, /* 257 */ + EINVAL, /* 258 */ + EINVAL, /* 259 */ + EINVAL, /* 260 */ + EINVAL, /* 261 */ + EINVAL, /* 262 */ + EINVAL, /* 263 */ + EINVAL, /* 264 */ + EINVAL, /* 265 */ + EINVAL, /* 266 */ + ENOTDIR, /* ERROR_DIRECTORY 267 */ +}; + +static const unsigned int tableLen = sizeof(errorTable); + +/* + * The following table contains the mapping from WinSock errors to + * errno errors. + */ + +static int wsaErrorTable[] = { + EWOULDBLOCK, /* WSAEWOULDBLOCK */ + EINPROGRESS, /* WSAEINPROGRESS */ + EALREADY, /* WSAEALREADY */ + ENOTSOCK, /* WSAENOTSOCK */ + EDESTADDRREQ, /* WSAEDESTADDRREQ */ + EMSGSIZE, /* WSAEMSGSIZE */ + EPROTOTYPE, /* WSAEPROTOTYPE */ + ENOPROTOOPT, /* WSAENOPROTOOPT */ + EPROTONOSUPPORT, /* WSAEPROTONOSUPPORT */ + ESOCKTNOSUPPORT, /* WSAESOCKTNOSUPPORT */ + EOPNOTSUPP, /* WSAEOPNOTSUPP */ + EPFNOSUPPORT, /* WSAEPFNOSUPPORT */ + EAFNOSUPPORT, /* WSAEAFNOSUPPORT */ + EADDRINUSE, /* WSAEADDRINUSE */ + EADDRNOTAVAIL, /* WSAEADDRNOTAVAIL */ + ENETDOWN, /* WSAENETDOWN */ + ENETUNREACH, /* WSAENETUNREACH */ + ENETRESET, /* WSAENETRESET */ + ECONNABORTED, /* WSAECONNABORTED */ + ECONNRESET, /* WSAECONNRESET */ + ENOBUFS, /* WSAENOBUFS */ + EISCONN, /* WSAEISCONN */ + ENOTCONN, /* WSAENOTCONN */ + ESHUTDOWN, /* WSAESHUTDOWN */ + ETOOMANYREFS, /* WSAETOOMANYREFS */ + ETIMEDOUT, /* WSAETIMEDOUT */ + ECONNREFUSED, /* WSAECONNREFUSED */ + ELOOP, /* WSAELOOP */ + ENAMETOOLONG, /* WSAENAMETOOLONG */ + EHOSTDOWN, /* WSAEHOSTDOWN */ + EHOSTUNREACH, /* WSAEHOSTUNREACH */ + ENOTEMPTY, /* WSAENOTEMPTY */ + EAGAIN, /* WSAEPROCLIM */ + EUSERS, /* WSAEUSERS */ + EDQUOT, /* WSAEDQUOT */ + ESTALE, /* WSAESTALE */ + EREMOTE, /* WSAEREMOTE */ +}; + +/* + *---------------------------------------------------------------------- + * + * TclWinConvertError -- + * + * This routine converts a Win32 error into an errno value. + * + * Results: + * None. + * + * Side effects: + * Sets the errno global variable. + * + *---------------------------------------------------------------------- + */ + +void +TclWinConvertError(errCode) + DWORD errCode; /* Win32 error code. */ +{ + if (errCode >= tableLen) { + Tcl_SetErrno(EINVAL); + } else { + Tcl_SetErrno(errorTable[errCode]); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclWinConvertWSAError -- + * + * This routine converts a WinSock error into an errno value. + * + * Results: + * None. + * + * Side effects: + * Sets the errno global variable. + * + *---------------------------------------------------------------------- + */ + +void +TclWinConvertWSAError(errCode) + DWORD errCode; /* Win32 error code. */ +{ + if ((errCode >= WSAEWOULDBLOCK) && (errCode <= WSAEREMOTE)) { + Tcl_SetErrno(wsaErrorTable[errCode - WSAEWOULDBLOCK]); + } else { + Tcl_SetErrno(EINVAL); + } +} diff --git a/tcl7.6/win/tclWinFCmd.c b/tcl7.6/win/tclWinFCmd.c new file mode 100644 index 0000000..20ab0f0 --- /dev/null +++ b/tcl7.6/win/tclWinFCmd.c @@ -0,0 +1,954 @@ +/* + * tclWinFCmd.c + * + * This file implements the Windows specific portion of file manipulation + * subcommands of the "file" command. + * + * Copyright (c) 1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclWinFCmd.c 1.12 96/10/14 14:39:16 + */ + +#include "tclWinInt.h" +#include "tclPort.h" + +/* + * The following constants specify the type of callback when + * TraverseWinTree() calls the traverseProc() + */ + +#define DOTREE_PRED 1 /* pre-order directory */ +#define DOTREE_POSTD 2 /* post-order directory */ +#define DOTREE_F 3 /* regular file */ + +/* + * Prototype for the TraverseWinTree callback function. + */ + +typedef int (TraversalProc)(char *src, char *dst, DWORD attr, int type, + Tcl_DString *errorPtr); + +/* + * Declarations for local procedures defined in this file: + */ + +static int TraversalCopy(char *src, char *dst, DWORD attr, + int type, Tcl_DString *errorPtr); +static int TraversalDelete(char *src, char *dst, DWORD attr, + int type, Tcl_DString *errorPtr); +static int TraverseWinTree(TraversalProc *traverseProc, + Tcl_DString *sourcePtr, Tcl_DString *destPtr, + Tcl_DString *errorPtr); + + +/* + *--------------------------------------------------------------------------- + * + * TclpRenameFile -- + * + * Changes the name of an existing file or directory, from src to dst. + * If src and dst refer to the same file or directory, does nothing + * and returns success. Otherwise if dst already exists, it will be + * deleted and replaced by src subject to the following conditions: + * If src is a directory, dst may be an empty directory. + * If src is a file, dst may be a file. + * In any other situation where dst already exists, the rename will + * fail. + * + * Results: + * If the directory was successfully created, returns TCL_OK. + * Otherwise the return value is TCL_ERROR and errno is set to + * indicate the error. Some possible values for errno are: + * + * EACCES: src or dst parent directory can't be read and/or written. + * EEXIST: dst is a non-empty directory. + * EINVAL: src is a root directory or dst is a subdirectory of src. + * EISDIR: dst is a directory, but src is not. + * ENOENT: src doesn't exist. src or dst is "". + * ENOTDIR: src is a directory, but dst is not. + * EXDEV: src and dst are on different filesystems. + * + * EACCES: exists an open file already referring to src or dst. + * EACCES: src or dst specify the current working directory (NT). + * EACCES: src specifies a char device (nul:, com1:, etc.) + * EEXIST: dst specifies a char device (nul:, com1:, etc.) (NT) + * EACCES: dst specifies a char device (nul:, com1:, etc.) (95) + * + * Side effects: + * The implementation supports cross-filesystem renames of files, + * but the caller should be prepared to emulate cross-filesystem + * renames of directories if errno is EXDEV. + * + *--------------------------------------------------------------------------- + */ + +int +TclpRenameFile( + char *src, /* Pathname of file or dir to be renamed. */ + char *dst) /* New pathname for file or directory. */ +{ + DWORD srcAttr, dstAttr; + + /* + * Would throw an exception under NT if one of the arguments is a char + * block device. + */ + + try { + if (MoveFile(src, dst) != FALSE) { + return TCL_OK; + } + } except (-1) {} + + TclWinConvertError(GetLastError()); + srcAttr = GetFileAttributes(src); + dstAttr = GetFileAttributes(dst); + if (srcAttr == (DWORD) -1) { + srcAttr = 0; + } + if (dstAttr == (DWORD) -1) { + dstAttr = 0; + } + + if (errno == EBADF) { + errno = EACCES; + return TCL_ERROR; + } + if (errno == EACCES) { + decode: + if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) { + char srcPath[MAX_PATH], dstPath[MAX_PATH]; + int srcArgc, dstArgc; + char **srcArgv, **dstArgv; + char *srcRest, *dstRest; + int size; + + size = GetFullPathName(src, sizeof(srcPath), srcPath, &srcRest); + if ((size == 0) || (size > sizeof(srcPath))) { + return TCL_ERROR; + } + size = GetFullPathName(dst, sizeof(dstPath), dstPath, &dstRest); + if ((size == 0) || (size > sizeof(dstPath))) { + return TCL_ERROR; + } + if (srcRest == NULL) { + srcRest = srcPath + strlen(srcPath); + } + if (strnicmp(srcPath, dstPath, srcRest - srcPath) == 0) { + /* + * Trying to move a directory into itself. + */ + + errno = EINVAL; + return TCL_ERROR; + } + Tcl_SplitPath(srcPath, &srcArgc, &srcArgv); + Tcl_SplitPath(dstPath, &dstArgc, &dstArgv); + if (srcArgc == 1) { + /* + * They are trying to move a root directory. Whether + * or not it is across filesystems, this cannot be + * done. + */ + + errno = EINVAL; + } else if ((srcArgc > 0) && (dstArgc > 0) && + (stricmp(srcArgv[0], dstArgv[0]) != 0)) { + /* + * If src is a directory and dst filesystem != src + * filesystem, errno should be EXDEV. It is very + * important to get this behavior, so that the caller + * can respond to a cross filesystem rename by + * simulating it with copy and delete. The MoveFile + * system call already handles the case of moving a + * file between filesystems. + */ + + errno = EXDEV; + } + + ckfree((char *) srcArgv); + ckfree((char *) dstArgv); + } + + /* + * Other types of access failure is that dst is a read-only + * filesystem, that an open file referred to src or dest, or that + * src or dest specified the current working directory on the + * current filesystem. EACCES is returned for those cases. + */ + + } else if (errno == EEXIST) { + /* + * Reports EEXIST any time the target already exists. If it makes + * sense, remove the old file and try renaming again. + */ + + if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) { + if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) { + /* + * Overwrite empty dst directory with src directory. The + * following call will remove an empty directory. If it + * fails, it's because it wasn't empty. + */ + + if (TclpRemoveDirectory(dst, 0, NULL) == TCL_OK) { + /* + * Now that that empty directory is gone, we can try + * renaming again. If that fails, we'll put this empty + * directory back, for completeness. + */ + + if (MoveFile(src, dst) != FALSE) { + return TCL_OK; + } + + /* + * Some new error has occurred. Don't know what it + * could be, but report this one. + */ + + TclWinConvertError(GetLastError()); + CreateDirectory(dst, NULL); + SetFileAttributes(dst, dstAttr); + if (errno == EACCES) { + /* + * Decode the EACCES to a more meaningful error. + */ + + goto decode; + } + } + } else { /* (dstAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */ + errno = ENOTDIR; + } + } else { /* (srcAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */ + if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) { + errno = EISDIR; + } else { + /* + * Overwrite existing file by: + * + * 1. Rename existing file to temp name. + * 2. Rename old file to new name. + * 3. If success, delete temp file. If failure, + * put temp file back to old name. + */ + + char tempName[MAX_PATH]; + int result, size; + char *rest; + + size = GetFullPathName(dst, sizeof(tempName), tempName, &rest); + if ((size == 0) || (size > sizeof(tempName)) || (rest == NULL)) { + return TCL_ERROR; + } + *rest = '\0'; + result = TCL_ERROR; + if (GetTempFileName(tempName, "tclr", 0, tempName) != 0) { + /* + * Strictly speaking, need the following DeleteFile and + * MoveFile to be joined as an atomic operation so no + * other app comes along in the meantime and creates the + * same temp file. + */ + + DeleteFile(tempName); + if (MoveFile(dst, tempName) != FALSE) { + if (MoveFile(src, dst) != FALSE) { + SetFileAttributes(tempName, FILE_ATTRIBUTE_NORMAL); + DeleteFile(tempName); + return TCL_OK; + } else { + DeleteFile(dst); + MoveFile(tempName, dst); + } + } + + /* + * Can't backup dst file or move src file. Return that + * error. Could happen if an open file refers to dst. + */ + + TclWinConvertError(GetLastError()); + if (errno == EACCES) { + /* + * Decode the EACCES to a more meaningful error. + */ + + goto decode; + } + } + return result; + } + } + } + return TCL_ERROR; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpCopyFile -- + * + * Copy a single file (not a directory). If dst already exists and + * is not a directory, it is removed. + * + * Results: + * If the file was successfully copied, returns TCL_OK. Otherwise + * the return value is TCL_ERROR and errno is set to indicate the + * error. Some possible values for errno are: + * + * EACCES: src or dst parent directory can't be read and/or written. + * EISDIR: src or dst is a directory. + * ENOENT: src doesn't exist. src or dst is "". + * + * EACCES: exists an open file already referring to dst (95). + * EACCES: src specifies a char device (nul:, com1:, etc.) (NT) + * ENOENT: src specifies a char device (nul:, com1:, etc.) (95) + * + * Side effects: + * It is not an error to copy to a char device. + * + *--------------------------------------------------------------------------- + */ + +int +TclpCopyFile( + char *src, /* Pathname of file to be copied. */ + char *dst) /* Pathname of file to copy to. */ +{ + /* + * Would throw an exception under NT if one of the arguments is a char + * block device. + */ + + try { + if (CopyFile(src, dst, 0) != FALSE) { + return TCL_OK; + } + } except (-1) {} + + TclWinConvertError(GetLastError()); + if (errno == EBADF) { + errno = EACCES; + return TCL_ERROR; + } + if (errno == EACCES) { + DWORD srcAttr, dstAttr; + + srcAttr = GetFileAttributes(src); + dstAttr = GetFileAttributes(dst); + if (srcAttr != (DWORD) -1) { + if (dstAttr == (DWORD) -1) { + dstAttr = 0; + } + if ((srcAttr & FILE_ATTRIBUTE_DIRECTORY) || + (dstAttr & FILE_ATTRIBUTE_DIRECTORY)) { + errno = EISDIR; + } + if (dstAttr & FILE_ATTRIBUTE_READONLY) { + SetFileAttributes(dst, dstAttr & ~FILE_ATTRIBUTE_READONLY); + if (CopyFile(src, dst, 0) != FALSE) { + return TCL_OK; + } + /* + * Still can't copy onto dst. Return that error, and + * restore attributes of dst. + */ + + TclWinConvertError(GetLastError()); + SetFileAttributes(dst, dstAttr); + } + } + } + return TCL_ERROR; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpDeleteFile -- + * + * Removes a single file (not a directory). + * + * Results: + * If the file was successfully deleted, returns TCL_OK. Otherwise + * the return value is TCL_ERROR and errno is set to indicate the + * error. Some possible values for errno are: + * + * EACCES: a parent directory can't be read and/or written. + * EISDIR: path is a directory. + * ENOENT: path doesn't exist or is "". + * + * EACCES: exists an open file already referring to path. + * EACCES: path is a char device (nul:, com1:, etc.) + * + * Side effects: + * The file is deleted, even if it is read-only. + * + *--------------------------------------------------------------------------- + */ + +int +TclpDeleteFile( + char *path) /* Pathname of file to be removed. */ +{ + DWORD attr; + + if (DeleteFile(path) != FALSE) { + return TCL_OK; + } + TclWinConvertError(GetLastError()); + if (errno == EACCES) { + attr = GetFileAttributes(path); + if (attr != (DWORD) -1) { + if (attr & FILE_ATTRIBUTE_DIRECTORY) { + /* + * Windows NT reports removing a directory as EACCES instead + * of EISDIR. + */ + + errno = EISDIR; + } else if (attr & FILE_ATTRIBUTE_READONLY) { + SetFileAttributes(path, attr & ~FILE_ATTRIBUTE_READONLY); + if (DeleteFile(path) != FALSE) { + return TCL_OK; + } + TclWinConvertError(GetLastError()); + SetFileAttributes(path, attr); + } + } + } else if (errno == ENOENT) { + attr = GetFileAttributes(path); + if (attr != (DWORD) -1) { + if (attr & FILE_ATTRIBUTE_DIRECTORY) { + /* + * Windows 95 reports removing a directory as ENOENT instead + * of EISDIR. + */ + + errno = EISDIR; + } + } + } else if (errno == EINVAL) { + /* + * Windows NT reports removing a char device as EINVAL instead of + * EACCES. + */ + + errno = EACCES; + } + + return TCL_ERROR; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpCreateDirectory -- + * + * Creates the specified directory. All parent directories of the + * specified directory must already exist. The directory is + * automatically created with permissions so that user can access + * the new directory and create new files or subdirectories in it. + * + * Results: + * If the directory was successfully created, returns TCL_OK. + * Otherwise the return value is TCL_ERROR and errno is set to + * indicate the error. Some possible values for errno are: + * + * EACCES: a parent directory can't be read and/or written. + * EEXIST: path already exists. + * ENOENT: a parent directory doesn't exist. + * + * Side effects: + * A directory is created. + * + *--------------------------------------------------------------------------- + */ + +int +TclpCreateDirectory( + char *path) /* Pathname of directory to create */ +{ + if (CreateDirectory(path, NULL) == 0) { + TclWinConvertError(GetLastError()); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpCopyDirectory -- + * + * Recursively copies a directory. The target directory dst must + * not already exist. Note that this function does not merge two + * directory hierarchies, even if the target directory is an an + * empty directory. + * + * Results: + * If the directory was successfully copied, returns TCL_OK. + * Otherwise the return value is TCL_ERROR, errno is set to indicate + * the error, and the pathname of the file that caused the error + * is stored in errorPtr. See TclpCreateDirectory and TclpCopyFile + * for a description of possible values for errno. + * + * Side effects: + * An exact copy of the directory hierarchy src will be created + * with the name dst. If an error occurs, the error will + * be returned immediately, and remaining files will not be + * processed. + * + *--------------------------------------------------------------------------- + */ + +int +TclpCopyDirectory( + char *src, /* Pathname of directory to be copied. */ + char *dst, /* Pathname of target directory. */ + Tcl_DString *errorPtr) /* If non-NULL, initialized DString for + * error reporting. */ +{ + int result; + Tcl_DString srcBuffer; + Tcl_DString dstBuffer; + + Tcl_DStringInit(&srcBuffer); + Tcl_DStringInit(&dstBuffer); + Tcl_DStringAppend(&srcBuffer, src, -1); + Tcl_DStringAppend(&dstBuffer, dst, -1); + result = TraverseWinTree(TraversalCopy, &srcBuffer, &dstBuffer, + errorPtr); + Tcl_DStringFree(&srcBuffer); + Tcl_DStringFree(&dstBuffer); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclpRemoveDirectory -- + * + * Removes directory (and its contents, if the recursive flag is set). + * + * Results: + * If the directory was successfully removed, returns TCL_OK. + * Otherwise the return value is TCL_ERROR, errno is set to indicate + * the error, and the pathname of the file that caused the error + * is stored in errorPtr. Some possible values for errno are: + * + * EACCES: path directory can't be read and/or written. + * EEXIST: path is a non-empty directory. + * EINVAL: path is root directory or current directory. + * ENOENT: path doesn't exist or is "". + * ENOTDIR: path is not a directory. + * + * EACCES: path is a char device (nul:, com1:, etc.) (95) + * EINVAL: path is a char device (nul:, com1:, etc.) (NT) + * + * Side effects: + * Directory removed. If an error occurs, the error will be returned + * immediately, and remaining files will not be deleted. + * + *---------------------------------------------------------------------- + */ + +int +TclpRemoveDirectory( + char *path, /* Pathname of directory to be removed. */ + int recursive, /* If non-zero, removes directories that + * are nonempty. Otherwise, will only remove + * empty directories. */ + Tcl_DString *errorPtr) /* If non-NULL, initialized DString for + * error reporting. */ +{ + int result; + Tcl_DString buffer; + OSVERSIONINFO os; + DWORD attr; + + if (RemoveDirectory(path) != FALSE) { + return TCL_OK; + } + TclWinConvertError(GetLastError()); + if (errno == EACCES) { + attr = GetFileAttributes(path); + if (attr != (DWORD) -1) { + if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) { + /* + * Windows 95 reports calling RemoveDirectory on a file as an + * EACCES, not an ENOTDIR. + */ + + errno = ENOTDIR; + goto end; + } + + if (attr & FILE_ATTRIBUTE_READONLY) { + attr &= ~FILE_ATTRIBUTE_READONLY; + if (SetFileAttributes(path, attr) == FALSE) { + goto end; + } + if (RemoveDirectory(path) != FALSE) { + return TCL_OK; + } + TclWinConvertError(GetLastError()); + SetFileAttributes(path, attr | FILE_ATTRIBUTE_READONLY); + } + + /* + * Windows 95 reports removing a non-empty directory as + * an EACCES, not an EEXIST. If the directory is not empty, + * change errno so caller knows what's going on. + */ + + os.dwOSVersionInfoSize = sizeof(os); + GetVersionEx(&os); + if (os.dwPlatformId == VER_PLATFORM_WIN32_WINDOWS) { + HANDLE handle; + WIN32_FIND_DATA data; + Tcl_DString buffer; + char *find; + int len; + + Tcl_DStringInit(&buffer); + find = Tcl_DStringAppend(&buffer, path, -1); + len = Tcl_DStringLength(&buffer); + if ((len > 0) && (find[len - 1] != '\\')) { + Tcl_DStringAppend(&buffer, "\\", 1); + } + find = Tcl_DStringAppend(&buffer, "*.*", 3); + handle = FindFirstFile(find, &data); + if (handle != INVALID_HANDLE_VALUE) { + while (1) { + if ((strcmp(data.cFileName, ".") != 0) + && (strcmp(data.cFileName, "..") != 0)) { + /* + * Found something in this directory. + */ + + errno = EEXIST; + break; + } + if (FindNextFile(handle, &data) == FALSE) { + break; + } + } + FindClose(handle); + } + Tcl_DStringFree(&buffer); + } + } + } + if (errno == ENOTEMPTY) { + /* + * The caller depends on EEXIST to signify that the directory is + * not empty, not ENOTEMPTY. + */ + + errno = EEXIST; + } + if ((recursive != 0) && (errno == EEXIST)) { + /* + * The directory is nonempty, but the recursive flag has been + * specified, so we recursively remove all the files in the directory. + */ + + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, path, -1); + result = TraverseWinTree(TraversalDelete, &buffer, NULL, errorPtr); + Tcl_DStringFree(&buffer); + return result; + } + + end: + if (errorPtr != NULL) { + Tcl_DStringAppend(errorPtr, path, -1); + } + return TCL_ERROR; +} + +/* + *--------------------------------------------------------------------------- + * + * TraverseWinTree -- + * + * Traverse directory tree specified by sourcePtr, calling the function + * traverseProc for each file and directory encountered. If destPtr + * is non-null, each of name in the sourcePtr directory is appended to + * the directory specified by destPtr and passed as the second argument + * to traverseProc() . + * + * Results: + * Standard Tcl result. + * + * Side effects: + * None caused by TraverseWinTree, however the user specified + * traverseProc() may change state. If an error occurs, the error will + * be returned immediately, and remaining files will not be processed. + * + *--------------------------------------------------------------------------- + */ + +static int +TraverseWinTree( + TraversalProc *traverseProc,/* Function to call for every file and + * directory in source hierarchy. */ + Tcl_DString *sourcePtr, /* Pathname of source directory to be + * traversed. */ + Tcl_DString *targetPtr, /* Pathname of directory to traverse in + * parallel with source directory. */ + Tcl_DString *errorPtr) /* If non-NULL, an initialized DString for + * error reporting. */ +{ + DWORD sourceAttr; + char *source, *target, *errfile; + int result, sourceLen, targetLen, sourceLenOriginal, targetLenOriginal; + HANDLE handle; + WIN32_FIND_DATA data; + + result = TCL_OK; + source = Tcl_DStringValue(sourcePtr); + sourceLenOriginal = Tcl_DStringLength(sourcePtr); + if (targetPtr != NULL) { + target = Tcl_DStringValue(targetPtr); + targetLenOriginal = Tcl_DStringLength(targetPtr); + } else { + target = NULL; + targetLenOriginal = 0; + } + + errfile = NULL; + + sourceAttr = GetFileAttributes(source); + if (sourceAttr == (DWORD) -1) { + errfile = source; + goto end; + } + if ((sourceAttr & FILE_ATTRIBUTE_DIRECTORY) == 0) { + /* + * Process the regular file + */ + + return (*traverseProc)(source, target, sourceAttr, DOTREE_F, errorPtr); + } + + /* + * When given the pathname of the form "c:\" (one that already ends + * with a backslash), must make sure not to add another "\" to the end + * otherwise it will try to access a network drive. + */ + + sourceLen = sourceLenOriginal; + if ((sourceLen > 0) && (source[sourceLen - 1] != '\\')) { + Tcl_DStringAppend(sourcePtr, "\\", 1); + sourceLen++; + } + source = Tcl_DStringAppend(sourcePtr, "*.*", 3); + handle = FindFirstFile(source, &data); + Tcl_DStringSetLength(sourcePtr, sourceLen); + if (handle == INVALID_HANDLE_VALUE) { + /* + * Can't read directory + */ + + TclWinConvertError(GetLastError()); + errfile = source; + goto end; + } + + result = (*traverseProc)(source, target, sourceAttr, DOTREE_PRED, errorPtr); + if (result != TCL_OK) { + FindClose(handle); + return result; + } + + if (targetPtr != NULL) { + targetLen = targetLenOriginal; + if ((targetLen > 0) && (target[targetLen - 1] != '\\')) { + target = Tcl_DStringAppend(targetPtr, "\\", 1); + targetLen++; + } + } + + while (1) { + if ((strcmp(data.cFileName, ".") != 0) + && (strcmp(data.cFileName, "..") != 0)) { + /* + * Append name after slash, and recurse on the file. + */ + + Tcl_DStringAppend(sourcePtr, data.cFileName, -1); + if (targetPtr != NULL) { + Tcl_DStringAppend(targetPtr, data.cFileName, -1); + } + result = TraverseWinTree(traverseProc, sourcePtr, targetPtr, + errorPtr); + if (result != TCL_OK) { + break; + } + + /* + * Remove name after slash. + */ + + Tcl_DStringSetLength(sourcePtr, sourceLen); + if (targetPtr != NULL) { + Tcl_DStringSetLength(targetPtr, targetLen); + } + } + if (FindNextFile(handle, &data) == FALSE) { + break; + } + } + FindClose(handle); + + /* + * Strip off the trailing slash we added + */ + + Tcl_DStringSetLength(sourcePtr, sourceLenOriginal); + source = Tcl_DStringValue(sourcePtr); + if (targetPtr != NULL) { + Tcl_DStringSetLength(targetPtr, targetLenOriginal); + target = Tcl_DStringValue(targetPtr); + } + + if (result == TCL_OK) { + /* + * Call traverseProc() on a directory after visiting all the + * files in that directory. + */ + + result = (*traverseProc)(source, target, sourceAttr, + DOTREE_POSTD, errorPtr); + } + end: + if (errfile != NULL) { + TclWinConvertError(GetLastError()); + if (errorPtr != NULL) { + Tcl_DStringAppend(errorPtr, errfile, -1); + } + result = TCL_ERROR; + } + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TraversalCopy + * + * Called from TraverseUnixTree in order to execute a recursive + * copy of a directory. + * + * Results: + * Standard Tcl result. + * + * Side effects: + * Depending on the value of type, src may be copied to dst. + * + *---------------------------------------------------------------------- + */ + +static int +TraversalCopy( + char *src, /* Source pathname to copy. */ + char *dst, /* Destination pathname of copy. */ + DWORD srcAttr, /* File attributes for src. */ + int type, /* Reason for call - see TraverseWinTree() */ + Tcl_DString *errorPtr) /* If non-NULL, initialized DString for + * error return. */ +{ + switch (type) { + case DOTREE_F: + if (TclpCopyFile(src, dst) == TCL_OK) { + return TCL_OK; + } + break; + + case DOTREE_PRED: + if (TclpCreateDirectory(dst) == TCL_OK) { + if (SetFileAttributes(dst, srcAttr) != FALSE) { + return TCL_OK; + } + TclWinConvertError(GetLastError()); + } + break; + + case DOTREE_POSTD: + return TCL_OK; + + } + + /* + * There shouldn't be a problem with src, because we already + * checked it to get here. + */ + + if (errorPtr != NULL) { + Tcl_DStringAppend(errorPtr, dst, -1); + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * TraversalDelete -- + * + * Called by procedure TraverseWinTree for every file and + * directory that it encounters in a directory hierarchy. This + * procedure unlinks files, and removes directories after all the + * containing files have been processed. + * + * Results: + * Standard Tcl result. + * + * Side effects: + * Files or directory specified by src will be deleted. If an + * error occurs, the windows error is converted to a Posix error + * and errno is set accordingly. + * + *---------------------------------------------------------------------- + */ + +static int +TraversalDelete( + char *src, /* Source pathname. */ + char *ignore, /* Destination pathname (not used). */ + DWORD srcAttr, /* File attributes for src (not used). */ + int type, /* Reason for call - see TraverseWinTree(). */ + Tcl_DString *errorPtr) /* If non-NULL, initialized DString for + * error return. */ +{ + switch (type) { + case DOTREE_F: + if (TclpDeleteFile(src) == TCL_OK) { + return TCL_OK; + } + break; + + case DOTREE_PRED: + return TCL_OK; + + case DOTREE_POSTD: + if (TclpRemoveDirectory(src, 0, NULL) == TCL_OK) { + return TCL_OK; + } + break; + + } + + if (errorPtr != NULL) { + Tcl_DStringAppend(errorPtr, src, -1); + } + return TCL_ERROR; +} diff --git a/tcl7.6/win/tclWinFile.c b/tcl7.6/win/tclWinFile.c new file mode 100644 index 0000000..4c429d6 --- /dev/null +++ b/tcl7.6/win/tclWinFile.c @@ -0,0 +1,764 @@ +/* + * tclWinFile.c -- + * + * This file contains temporary wrappers around UNIX file handling + * functions. These wrappers map the UNIX functions to Win32 HANDLE-style + * files, which can be manipulated through the Win32 console redirection + * interfaces. + * + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclWinFile.c 1.37 96/09/18 15:10:45 + */ + +#include +#include "tclWinInt.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; + + +/* + *---------------------------------------------------------------------- + * + * TclCreateTempFile -- + * + * This function opens a unique file with the property that it + * will be deleted when its file handle is closed. The temporary + * file is created in the system temporary directory. + * + * Results: + * Returns a valid C file descriptor, or -1 on failure. + * + * Side effects: + * Creates a new temporary file. + * + *---------------------------------------------------------------------- + */ + +Tcl_File +TclCreateTempFile(contents, namePtr) + char *contents; /* String to write into temp file, or NULL. */ + Tcl_DString *namePtr; /* If non-NULL, pointer to initialized + * DString that is filled with the name of + * the temp file that was created. */ +{ + char name[MAX_PATH]; + HANDLE handle; + + if (!GetTempPath(MAX_PATH, name) + || !GetTempFileName(name, "TCL", 0, name)) { + return NULL; + } + + handle = CreateFile(name, GENERIC_READ | GENERIC_WRITE, 0, NULL, + CREATE_ALWAYS, FILE_ATTRIBUTE_TEMPORARY | FILE_FLAG_DELETE_ON_CLOSE, + NULL); + + /* + * Under Win32s a file created with FILE_FLAG_DELETE_ON_CLOSE won't + * actually be deleted when it is closed. This was causing tcl to leak + * temp files. The DeleteFile() call will delete the file now under + * Win32s. Under 95 and NT, the call will fail because the file is + * locked (because it was just opened), but it will get deleted when + * it is closed, due to the FILE_FLAG_DELETE_ON_CLOSE. + */ + + DeleteFile(name); + + if (handle == INVALID_HANDLE_VALUE) { + goto error; + } + + /* + * Write the file out, doing line translations on the way. + */ + + if (contents != NULL) { + DWORD result, length; + char *p; + + for (p = contents; *p != '\0'; p++) { + if (*p == '\n') { + length = p - contents; + if (length > 0) { + if (!WriteFile(handle, contents, length, &result, NULL)) { + goto error; + } + } + if (!WriteFile(handle, "\r\n", 2, &result, NULL)) { + goto error; + } + contents = p+1; + } + } + length = p - contents; + if (length > 0) { + if (!WriteFile(handle, contents, length, &result, NULL)) { + goto error; + } + } + } + if (SetFilePointer(handle, 0, NULL, FILE_BEGIN) == 0xFFFFFFFF) { + goto error; + } + + Tcl_DStringAppend(namePtr, name, -1); + return Tcl_GetFile((ClientData) handle, TCL_WIN_FILE); + + error: + TclWinConvertError(GetLastError()); + CloseHandle(handle); + DeleteFile(name); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TclOpenFile -- + * + * This function wraps the normal system open() to ensure that + * files are opened with the _O_NOINHERIT flag set. + * + * Results: + * Same as open(). + * + * Side effects: + * Same as open(). + * + *---------------------------------------------------------------------- + */ + +Tcl_File +TclOpenFile(path, mode) + char *path; + int mode; +{ + HANDLE handle; + DWORD accessMode; + DWORD createMode; + DWORD shareMode; + DWORD flags; + SECURITY_ATTRIBUTES sec; + + /* + * Map the access bits to the NT access mode. + */ + + switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) { + case O_RDONLY: + accessMode = GENERIC_READ; + break; + case O_WRONLY: + accessMode = GENERIC_WRITE; + break; + case O_RDWR: + accessMode = (GENERIC_READ | GENERIC_WRITE); + break; + default: + TclWinConvertError(ERROR_INVALID_FUNCTION); + return NULL; + } + + /* + * Map the creation flags to the NT create mode. + */ + + switch (mode & (O_CREAT | O_EXCL | O_TRUNC)) { + case (O_CREAT | O_EXCL): + case (O_CREAT | O_EXCL | O_TRUNC): + createMode = CREATE_NEW; + break; + case (O_CREAT | O_TRUNC): + createMode = CREATE_ALWAYS; + break; + case O_CREAT: + createMode = OPEN_ALWAYS; + break; + case O_TRUNC: + case (O_TRUNC | O_EXCL): + createMode = TRUNCATE_EXISTING; + break; + default: + createMode = OPEN_EXISTING; + break; + } + + /* + * If the file is not being created, use the existing file attributes. + */ + + flags = 0; + if (!(mode & O_CREAT)) { + flags = GetFileAttributes(path); + if (flags == 0xFFFFFFFF) { + flags = 0; + } + } + + /* + * Set up the security attributes so this file is not inherited by + * child processes. + */ + + sec.nLength = sizeof(sec); + sec.lpSecurityDescriptor = NULL; + sec.bInheritHandle = 0; + + /* + * Set up the file sharing mode. We want to allow simultaneous access. + */ + + shareMode = FILE_SHARE_READ | FILE_SHARE_WRITE; + + /* + * Now we get to create the file. + */ + + handle = CreateFile(path, accessMode, shareMode, &sec, createMode, flags, + (HANDLE) NULL); + if (handle == INVALID_HANDLE_VALUE) { + DWORD err = GetLastError(); + if ((err & 0xffffL) == ERROR_OPEN_FAILED) { + err = (mode & O_CREAT) ? ERROR_FILE_EXISTS : ERROR_FILE_NOT_FOUND; + } + TclWinConvertError(err); + return NULL; + } + + return Tcl_GetFile((ClientData) handle, TCL_WIN_FILE); +} + +/* + *---------------------------------------------------------------------- + * + * TclCloseFile -- + * + * Closes a file on Windows. + * + * Results: + * 0 on success, -1 on failure. + * + * Side effects: + * The file is closed. + * + *---------------------------------------------------------------------- + */ + +int +TclCloseFile(file) + Tcl_File file; /* The file to close. */ +{ + HANDLE handle; + int type; + ClientData clientData; + TclWinPipe *pipePtr; + + clientData = Tcl_GetFileInfo(file, &type); + + if (type == TCL_WIN_FILE) { + handle = (HANDLE) clientData; + if (CloseHandle(handle) == FALSE) { + TclWinConvertError(GetLastError()); + return -1; + } + } else if (type == TCL_WIN32S_PIPE) { + pipePtr = (TclWinPipe *) clientData; + + if (pipePtr->otherPtr != NULL) { + pipePtr->otherPtr->otherPtr = NULL; + } else { + if (pipePtr->fileHandle != INVALID_HANDLE_VALUE) { + CloseHandle(pipePtr->fileHandle); + } + DeleteFile(pipePtr->fileName); + ckfree((char *) pipePtr->fileName); + } + ckfree((char *) pipePtr); + } else { + panic("Tcl_CloseFile: unexpected file type"); + } + + Tcl_FreeFile(file); + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclSeekFile -- + * + * Sets the file pointer on a file indicated by the file. + * + * Results: + * The new position at which the file pointer is after it was + * moved, or -1 on failure. + * + * Side effects: + * May move the position at which subsequent operations on the + * file access it. + * + *---------------------------------------------------------------------- + */ + +int +TclSeekFile(file, offset, whence) + Tcl_File file; /* File to seek on. */ + int offset; /* How much to move. */ + int whence; /* Relative to where? */ +{ + DWORD moveMethod; + DWORD newPos; + HANDLE handle; + int type; + + handle = (HANDLE) Tcl_GetFileInfo(file, &type); + if (type != TCL_WIN_FILE) { + panic("Tcl_SeekFile: unexpected file type"); + } + + if (whence == SEEK_SET) { + moveMethod = FILE_BEGIN; + } else if (whence == SEEK_CUR) { + moveMethod = FILE_CURRENT; + } else { + moveMethod = FILE_END; + } + + newPos = SetFilePointer(handle, offset, NULL, moveMethod); + if (newPos == 0xFFFFFFFF) { + TclWinConvertError(GetLastError()); + return -1; + } + return newPos; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FindExecutable -- + * + * This procedure computes the absolute path name of the current + * application, given its argv[0] value. + * + * Results: + * None. + * + * Side effects: + * The variable tclExecutableName gets filled in with the file + * name for the application, if we figured it out. If we couldn't + * figure it out, Tcl_FindExecutable is set to NULL. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_FindExecutable(argv0) + char *argv0; /* The value of the application's argv[0]. */ +{ + Tcl_DString buffer; + int length; + + Tcl_DStringInit(&buffer); + + if (tclExecutableName != NULL) { + ckfree(tclExecutableName); + tclExecutableName = NULL; + } + + /* + * Under Windows we ignore argv0, and return the path for the file used to + * create this process. + */ + + Tcl_DStringSetLength(&buffer, MAX_PATH+1); + length = GetModuleFileName(NULL, Tcl_DStringValue(&buffer), MAX_PATH+1); + if (length > 0) { + tclExecutableName = (char *) ckalloc((unsigned) (length + 1)); + strcpy(tclExecutableName, Tcl_DStringValue(&buffer)); + } + Tcl_DStringFree(&buffer); +} + +/* + *---------------------------------------------------------------------- + * + * TclMatchFiles -- + * + * This routine is used by the globbing code to search a + * directory for all files which match a given pattern. + * + * Results: + * If the tail argument is NULL, then the matching files are + * added to the interp->result. Otherwise, TclDoGlob is called + * recursively for each matching subdirectory. The return value + * is a standard Tcl result indicating whether an error occurred + * in globbing. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- */ + +int +TclMatchFiles(interp, separators, dirPtr, pattern, tail) + Tcl_Interp *interp; /* Interpreter to receive results. */ + char *separators; /* Directory separators to pass to TclDoGlob. */ + Tcl_DString *dirPtr; /* Contains path to directory to search. */ + char *pattern; /* Pattern to match against. */ + char *tail; /* Pointer to end of pattern. Tail must + * point to a location in pattern. */ +{ + char drivePattern[4] = "?:\\"; + char *newPattern, *p, *dir, *root, c; + int length, matchDotFiles; + int result = TCL_OK; + int baseLength = Tcl_DStringLength(dirPtr); + Tcl_DString buffer; + DWORD atts, volFlags; + HANDLE handle; + WIN32_FIND_DATA data; + BOOL found; + + /* + * Convert the path to normalized form since some interfaces only + * accept backslashes. Also, ensure that the directory ends with a + * separator character. + */ + + Tcl_DStringInit(&buffer); + if (baseLength == 0) { + Tcl_DStringAppend(&buffer, ".", 1); + } else { + Tcl_DStringAppend(&buffer, Tcl_DStringValue(dirPtr), + Tcl_DStringLength(dirPtr)); + } + for (p = Tcl_DStringValue(&buffer); *p != '\0'; p++) { + if (*p == '/') { + *p = '\\'; + } + } + p--; + if (*p != '\\' && *p != ':') { + Tcl_DStringAppend(&buffer, "\\", 1); + } + dir = Tcl_DStringValue(&buffer); + + /* + * First verify that the specified path is actually a directory. + */ + + atts = GetFileAttributes(dir); + if ((atts == 0xFFFFFFFF) || ((atts & FILE_ATTRIBUTE_DIRECTORY) == 0)) { + Tcl_DStringFree(&buffer); + return TCL_OK; + } + + /* + * Next check the volume information for the directory to see whether + * comparisons should be case sensitive or not. If the root is null, then + * we use the root of the current directory. If the root is just a drive + * specifier, we use the root directory of the given drive. + */ + + switch (Tcl_GetPathType(dir)) { + case TCL_PATH_RELATIVE: + found = GetVolumeInformation(NULL, NULL, 0, NULL, + NULL, &volFlags, NULL, 0); + break; + case TCL_PATH_VOLUME_RELATIVE: + if (*dir == '\\') { + root = NULL; + } else { + root = drivePattern; + *root = *dir; + } + found = GetVolumeInformation(root, NULL, 0, NULL, + NULL, &volFlags, NULL, 0); + break; + case TCL_PATH_ABSOLUTE: + if (dir[1] == ':') { + root = drivePattern; + *root = *dir; + found = GetVolumeInformation(root, NULL, 0, NULL, + NULL, &volFlags, NULL, 0); + } else if (dir[1] == '\\') { + p = strchr(dir+2, '\\'); + p = strchr(p+1, '\\'); + p++; + c = *p; + *p = 0; + found = GetVolumeInformation(dir, NULL, 0, NULL, + NULL, &volFlags, NULL, 0); + *p = c; + } + break; + } + + if (!found) { + Tcl_DStringFree(&buffer); + TclWinConvertError(GetLastError()); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "couldn't read volume information for \"", + dirPtr->string, "\": ", Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + + /* + * If the volume is not case sensitive, then we need to convert the pattern + * to lower case. + */ + + length = tail - pattern; + newPattern = ckalloc(length+1); + if (volFlags & FS_CASE_SENSITIVE) { + strncpy(newPattern, pattern, length); + newPattern[length] = '\0'; + } else { + char *src, *dest; + for (src = pattern, dest = newPattern; src < tail; src++, dest++) { + *dest = (char) tolower(*src); + } + *dest = '\0'; + } + + /* + * We need to check all files in the directory, so append a *.* + * to the path. + */ + + + dir = Tcl_DStringAppend(&buffer, "*.*", 3); + + /* + * Now open the directory for reading and iterate over the contents. + */ + + handle = FindFirstFile(dir, &data); + Tcl_DStringFree(&buffer); + + if (handle == INVALID_HANDLE_VALUE) { + TclWinConvertError(GetLastError()); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "couldn't read directory \"", + dirPtr->string, "\": ", Tcl_PosixError(interp), (char *) NULL); + ckfree(newPattern); + return TCL_ERROR; + } + + /* + * Clean up the tail pointer. Leave the tail pointing to the + * first character after the path separator or NULL. + */ + + if (*tail == '\\') { + tail++; + } + if (*tail == '\0') { + tail = NULL; + } else { + tail++; + } + + /* + * Check to see if the pattern needs to compare with dot files. + */ + + if ((newPattern[0] == '.') + || ((pattern[0] == '\\') && (pattern[1] == '.'))) { + matchDotFiles = 1; + } else { + matchDotFiles = 0; + } + + /* + * Now iterate over all of the files in the directory. + */ + + Tcl_DStringInit(&buffer); + for (found = 1; found; found = FindNextFile(handle, &data)) { + char *matchResult; + + /* + * Ignore hidden files. + */ + + if ((data.dwFileAttributes & FILE_ATTRIBUTE_HIDDEN) + || (!matchDotFiles && (data.cFileName[0] == '.'))) { + continue; + } + + /* + * Check to see if the file matches the pattern. If the volume is not + * case sensitive, we need to convert the file name to lower case. If + * the volume also doesn't preserve case, then we return the lower case + * form of the name, otherwise we return the system form. + */ + + matchResult = NULL; + if (!(volFlags & FS_CASE_SENSITIVE)) { + Tcl_DStringSetLength(&buffer, 0); + Tcl_DStringAppend(&buffer, data.cFileName, -1); + for (p = buffer.string; *p != '\0'; p++) { + *p = (char) tolower(*p); + } + if (Tcl_StringMatch(buffer.string, newPattern)) { + if (volFlags & FS_CASE_IS_PRESERVED) { + matchResult = data.cFileName; + } else { + matchResult = buffer.string; + } + } + } else { + if (Tcl_StringMatch(data.cFileName, newPattern)) { + matchResult = data.cFileName; + } + } + + if (matchResult == NULL) { + continue; + } + + /* + * If the file matches, then we need to process the remainder of the + * path. If there are more characters to process, then ensure matching + * files are directories and call TclDoGlob. Otherwise, just add the + * file to the result. + */ + + Tcl_DStringSetLength(dirPtr, baseLength); + Tcl_DStringAppend(dirPtr, matchResult, -1); + if (tail == NULL) { + Tcl_AppendElement(interp, dirPtr->string); + } else { + atts = GetFileAttributes(dirPtr->string); + if (atts & FILE_ATTRIBUTE_DIRECTORY) { + Tcl_DStringAppend(dirPtr, "/", 1); + result = TclDoGlob(interp, separators, dirPtr, tail); + if (result != TCL_OK) { + break; + } + } + } + } + + Tcl_DStringFree(&buffer); + FindClose(handle); + ckfree(newPattern); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclChdir -- + * + * Change the current working directory. + * + * Results: + * The result is a standard Tcl result. If an error occurs and + * interp isn't NULL, an error message is left in interp->result. + * + * Side effects: + * The working directory for this application is changed. Also + * the cache maintained used by TclGetCwd is deallocated and + * set to NULL. + * + *---------------------------------------------------------------------- + */ + +int +TclChdir(interp, dirName) + Tcl_Interp *interp; /* If non NULL, used for error reporting. */ + char *dirName; /* Path to new working directory. */ +{ + if (currentDir != NULL) { + ckfree(currentDir); + currentDir = NULL; + } + if (!SetCurrentDirectory(dirName)) { + TclWinConvertError(GetLastError()); + if (interp != NULL) { + Tcl_AppendResult(interp, "couldn't change working directory to \"", + dirName, "\": ", Tcl_PosixError(interp), (char *) NULL); + } + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetCwd -- + * + * Return the path name of the current working directory. + * + * Results: + * The result is the full path name of the current working + * directory, or NULL if an error occurred while figuring it + * out. If an error occurs and interp isn't NULL, an error + * message is left in interp->result. + * + * Side effects: + * The path name is cached to avoid having to recompute it + * on future calls; if it is already cached, the cached + * value is returned. + * + *---------------------------------------------------------------------- + */ + +char * +TclGetCwd(interp) + Tcl_Interp *interp; /* If non NULL, used for error reporting. */ +{ + char buffer[MAXPATHLEN+1], *bufPtr; + + if (currentDir == NULL) { + if (GetCurrentDirectory(MAXPATHLEN+1, buffer) == 0) { + TclWinConvertError(GetLastError()); + if (interp != 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 NULL; + } + /* + * Watch for the wierd Windows '95 c:\\UNC syntax. + */ + + if (buffer[0] != '\0' && buffer[1] == ':' && buffer[2] == '\\' + && buffer[3] == '\\') { + bufPtr = &buffer[2]; + } else { + bufPtr = buffer; + } + currentDir = (char *) ckalloc((unsigned) (strlen(bufPtr) + 1)); + strcpy(currentDir, bufPtr); + + /* + * Convert to forward slashes for easier use in scripts. + */ + + for (bufPtr = currentDir; *bufPtr != '\0'; bufPtr++) { + if (*bufPtr == '\\') { + *bufPtr = '/'; + } + } + } + return currentDir; +} diff --git a/tcl7.6/win/tclWinInit.c b/tcl7.6/win/tclWinInit.c new file mode 100644 index 0000000..c315fa6 --- /dev/null +++ b/tcl7.6/win/tclWinInit.c @@ -0,0 +1,355 @@ +/* + * tclWinInit.c -- + * + * Contains the Windows-specific interpreter initialization functions. + * + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclWinInit.c 1.23 96/10/04 17:05:02 + */ + +#include "tclInt.h" +#include "tclPort.h" +#include +#include +#include + +/* + * The following declaration is a workaround for some Microsoft brain damage. + * The SYSTEM_INFO structure is different in various releases, even though the + * layout is the same. So we overlay our own structure on top of it so we + * can access the interesting slots in a uniform way. + */ + +typedef struct { + WORD wProcessorArchitecture; + WORD wReserved; +} OemId; + +/* + * The following macros are missing from some versions of winnt.h. + */ + +#ifndef PROCESSOR_ARCHITECTURE_INTEL +#define PROCESSOR_ARCHITECTURE_INTEL 0 +#endif +#ifndef PROCESSOR_ARCHITECTURE_MIPS +#define PROCESSOR_ARCHITECTURE_MIPS 1 +#endif +#ifndef PROCESSOR_ARCHITECTURE_ALPHA +#define PROCESSOR_ARCHITECTURE_ALPHA 2 +#endif +#ifndef PROCESSOR_ARCHITECTURE_PPC +#define PROCESSOR_ARCHITECTURE_PPC 3 +#endif +#ifndef PROCESSOR_ARCHITECTURE_UNKNOWN +#define PROCESSOR_ARCHITECTURE_UNKNOWN 0xFFFF +#endif + +/* + * The following arrays contain the human readable strings for the Windows + * platform and processor values. + */ + + +#define NUMPLATFORMS 3 +static char* platforms[NUMPLATFORMS] = { + "Win32s", "Windows 95", "Windows NT" +}; + +#define NUMPROCESSORS 4 +static char* processors[NUMPROCESSORS] = { + "intel", "mips", "alpha", "ppc" +}; + +/* + * The following string is the startup script executed in new + * interpreters. It looks on disk in several different directories + * for a script "init.tcl" that is compatible with this version + * of Tcl. The init.tcl script does all of the real work of + * initialization. + */ + +static char *initScript = +"proc init {} {\n\ + global tcl_library tcl_version tcl_patchLevel env\n\ + rename init {}\n\ + set dirs {}\n\ + if [info exists env(TCL_LIBRARY)] {\n\ + lappend dirs $env(TCL_LIBRARY)\n\ + }\n\ + lappend dirs $tcl_library\n\ + lappend dirs [file join [file dirname [file dirname [info nameofexecutable]]] lib/tcl$tcl_version]\n\ + if [string match {*[ab]*} $tcl_patchLevel] {\n\ + set lib tcl$tcl_patchLevel\n\ + } else {\n\ + set lib tcl$tcl_version\n\ + }\n\ + lappend dirs [file join [file dirname [file dirname [pwd]]] $lib/library]\n\ + lappend dirs [file join [file dirname [pwd]] library]\n\ + foreach i $dirs {\n\ + set tcl_library $i\n\ + if ![catch {uplevel #0 source [list [file join $i init.tcl]]}] {\n\ + return\n\ + }\n\ + }\n\ + set msg \"Can't find a usable init.tcl in the following directories: \n\"\n\ + append msg \" $dirs\n\"\n\ + append msg \"This probably means that Tcl wasn't installed properly.\n\"\n\ + error $msg\n\ +}\n\ +init"; + +/* + *---------------------------------------------------------------------- + * + * TclPlatformInit -- + * + * Performs Windows-specific interpreter initialization related to the + * tcl_library variable. Also sets up the HOME environment variable + * if it is not already set. + * + * Results: + * None. + * + * Side effects: + * Sets "tcl_library" and "env(HOME)" Tcl variables + * + *---------------------------------------------------------------------- + */ + +void +TclPlatformInit(interp) + Tcl_Interp *interp; +{ + char *ptr; + char buffer[13]; + Tcl_DString ds; + OSVERSIONINFO osInfo; + SYSTEM_INFO sysInfo; + int isWin32s; /* True if we are running under Win32s. */ + OemId *oemId; + HKEY key; + DWORD size; + + tclPlatform = TCL_PLATFORM_WINDOWS; + + Tcl_DStringInit(&ds); + + /* + * Find out what kind of system we are running on. + */ + + osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); + GetVersionEx(&osInfo); + + isWin32s = (osInfo.dwPlatformId == VER_PLATFORM_WIN32s); + + /* + * Since Win32s doesn't support GetSystemInfo, we use a default value. + */ + + oemId = (OemId *) &sysInfo; + if (!isWin32s) { + GetSystemInfo(&sysInfo); + } else { + oemId->wProcessorArchitecture = PROCESSOR_ARCHITECTURE_INTEL; + } + + /* + * Initialize the tcl_library variable from the registry. + */ + + if (!isWin32s) { + if ((RegOpenKeyEx(HKEY_LOCAL_MACHINE, + "Software\\Sun\\Tcl\\" TCL_VERSION, 0, KEY_READ, &key) + == ERROR_SUCCESS) + && (RegQueryValueEx(key, "Root", NULL, NULL, NULL, &size) + == ERROR_SUCCESS)) { + Tcl_DStringSetLength(&ds, size); + RegQueryValueEx(key, "Root", NULL, NULL, Tcl_DStringValue(&ds), + &size); + } + } else { + if ((RegOpenKeyEx(HKEY_CLASSES_ROOT, + "Software\\Sun\\Tcl\\" TCL_VERSION, 0, KEY_READ, &key) + == ERROR_SUCCESS) + && (RegQueryValueEx(key, "", NULL, NULL, NULL, &size) + == ERROR_SUCCESS)) { + Tcl_DStringSetLength(&ds, size); + RegQueryValueEx(key, "", NULL, NULL, Tcl_DStringValue(&ds), &size); + } + } + Tcl_SetVar(interp, "tcl_library", Tcl_DStringValue(&ds), TCL_GLOBAL_ONLY); + if (Tcl_DStringLength(&ds) > 0) { + char *argv[3]; + argv[0] = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY); + argv[1] = "lib"; + argv[2] = NULL; + Tcl_DStringSetLength(&ds, 0); + Tcl_SetVar(interp, "tcl_pkgPath", Tcl_JoinPath(2, argv, &ds), + TCL_GLOBAL_ONLY); + argv[1] = "lib/tcl" TCL_VERSION; + Tcl_DStringSetLength(&ds, 0); + Tcl_SetVar(interp, "tcl_library", Tcl_JoinPath(2, argv, &ds), + TCL_GLOBAL_ONLY); + } + + /* + * Define the tcl_platform array. + */ + + Tcl_SetVar2(interp, "tcl_platform", "platform", "windows", + TCL_GLOBAL_ONLY); + if (osInfo.dwPlatformId < NUMPLATFORMS) { + Tcl_SetVar2(interp, "tcl_platform", "os", + platforms[osInfo.dwPlatformId], TCL_GLOBAL_ONLY); + } + sprintf(buffer, "%d.%d", osInfo.dwMajorVersion, osInfo.dwMinorVersion); + Tcl_SetVar2(interp, "tcl_platform", "osVersion", buffer, TCL_GLOBAL_ONLY); + if (oemId->wProcessorArchitecture < NUMPROCESSORS) { + Tcl_SetVar2(interp, "tcl_platform", "machine", + processors[oemId->wProcessorArchitecture], + TCL_GLOBAL_ONLY); + } + + /* + * Set up the HOME environment variable from the HOMEDRIVE & HOMEPATH + * environment variables, if necessary. + */ + + ptr = Tcl_GetVar2(interp, "env", "HOME", TCL_GLOBAL_ONLY); + if (ptr == NULL) { + Tcl_DStringSetLength(&ds, 0); + ptr = Tcl_GetVar2(interp, "env", "HOMEDRIVE", TCL_GLOBAL_ONLY); + if (ptr != NULL) { + Tcl_DStringAppend(&ds, ptr, -1); + } + ptr = Tcl_GetVar2(interp, "env", "HOMEPATH", TCL_GLOBAL_ONLY); + if (ptr != NULL) { + Tcl_DStringAppend(&ds, ptr, -1); + } + if (Tcl_DStringLength(&ds) > 0) { + Tcl_SetVar2(interp, "env", "HOME", Tcl_DStringValue(&ds), + TCL_GLOBAL_ONLY); + } else { + Tcl_SetVar2(interp, "env", "HOME", "c:\\", TCL_GLOBAL_ONLY); + } + } + + Tcl_DStringFree(&ds); +} + +/* + *---------------------------------------------------------------------- + * + * 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. */ +{ + return Tcl_Eval(interp, initScript); +} + +/* + *---------------------------------------------------------------------- + * + * TclWinGetPlatform -- + * + * This is a kludge that allows the test library to get access + * the internal tclPlatform variable. + * + * Results: + * Returns a pointer to the tclPlatform variable. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +TclPlatformType * +TclWinGetPlatform() +{ + return &tclPlatform; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SourceRCFile -- + * + * This procedure is typically invoked by Tcl_Main of Tk_Main + * procedure to source an application specific rc file into the + * interpreter at startup time. + * + * Results: + * None. + * + * Side effects: + * Depends on what's in the rc script. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SourceRCFile(interp) + Tcl_Interp *interp; /* Interpreter to source rc file into. */ +{ + Tcl_DString temp; + char *fileName; + Tcl_Channel errChannel; + + fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY); + + if (fileName != NULL) { + Tcl_Channel c; + char *fullName; + + Tcl_DStringInit(&temp); + fullName = Tcl_TranslateFileName(interp, fileName, &temp); + if (fullName == NULL) { + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel) { + Tcl_Write(errChannel, interp->result, -1); + Tcl_Write(errChannel, "\n", 1); + } + } else { + + /* + * Test for the existence of the rc file before trying to read it. + */ + + c = Tcl_OpenFileChannel(NULL, fullName, "r", 0); + if (c != (Tcl_Channel) NULL) { + Tcl_Close(NULL, c); + if (Tcl_EvalFile(interp, fullName) != TCL_OK) { + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel) { + Tcl_Write(errChannel, interp->result, -1); + Tcl_Write(errChannel, "\n", 1); + } + } + } + } + Tcl_DStringFree(&temp); + } +} diff --git a/tcl7.6/win/tclWinInt.h b/tcl7.6/win/tclWinInt.h new file mode 100644 index 0000000..0ff5c26 --- /dev/null +++ b/tcl7.6/win/tclWinInt.h @@ -0,0 +1,57 @@ +/* + * tclWinInt.h -- + * + * Declarations of Windows-specific shared variables and procedures. + * + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclWinInt.h 1.4 96/10/03 14:58:46 + */ + +#ifndef _TCLWININT +#define _TCLWININT + +#ifndef _TCLINT +#include "tclInt.h" +#endif +#ifndef _TCLPORT +#include "tclPort.h" +#endif + +/* + * Some versions of Borland C have a define for the OSVERSIONINFO for + * Win32s and for NT, but not for Windows 95. + */ + +#ifndef VER_PLATFORM_WIN32_WINDOWS +#define VER_PLATFORM_WIN32_WINDOWS 1 +#endif + +/* + * The following structure represents a synchronous pipe under Win32s. + * It is stored as the clientData for a Tcl_File of type TCL_WIN32S_PIPE. + */ + +typedef struct TclWinPipe { + struct TclWinPipe *otherPtr;/* Pointer to the TclWinPipe structure that + * corresponds to the other end of this + * pipe. */ + char *fileName; /* The name of the staging file that gets + * the data written to this pipe. Malloc'd. + * and shared by both ends of the pipe. Only + * when both ends are freed will fileName be + * freed and the file it refers to deleted. */ + HANDLE fileHandle; /* When Tcl is reading from "pipe", this + * handle will refer to the open fileName. + * Otherwise, it is INVALID_HANDLE_VALUE. */ +} TclWinPipe; + + +EXTERN int TclSynchSpawn(void *args, int type, void **trans, + int *pipePtr); + + +#endif /* _TCLWININT */ diff --git a/tcl7.6/win/tclWinLoad.c b/tcl7.6/win/tclWinLoad.c new file mode 100644 index 0000000..8106671 --- /dev/null +++ b/tcl7.6/win/tclWinLoad.c @@ -0,0 +1,114 @@ +/* + * tclWinLoad.c -- + * + * This procedure provides a version of the TclLoadFile that + * works with the Windows "LoadLibrary" and "GetProcAddress" + * API for dynamic loading. + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclWinLoad.c 1.6 96/02/15 11:54:07 + */ + +#include "tclInt.h" +#include "tclPort.h" + + +/* + *---------------------------------------------------------------------- + * + * TclLoadFile -- + * + * Dynamically loads a binary code file into memory and returns + * the addresses of two procedures within that file, if they + * are defined. + * + * Results: + * A standard Tcl completion code. If an error occurs, an error + * message is left in interp->result. + * + * Side effects: + * New code suddenly appears in memory. + * + *---------------------------------------------------------------------- + */ + +int +TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *fileName; /* Name of the file containing the desired + * code. */ + char *sym1, *sym2; /* Names of two procedures to look up in + * the file's symbol table. */ + Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; + /* Where to return the addresses corresponding + * to sym1 and sym2. */ +{ + HINSTANCE handle; + char *buffer; + + handle = TclWinLoadLibrary(fileName); + if (handle == NULL) { + Tcl_AppendResult(interp, "couldn't load file \"", fileName, + "\": ", Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + + /* + * For each symbol, check for both Symbol and _Symbol, since Borland + * generates C symbols with a leading '_' by default. + */ + + *proc1Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, sym1); + if (*proc1Ptr == NULL) { + buffer = ckalloc(strlen(sym1)+2); + buffer[0] = '_'; + strcpy(buffer+1, sym1); + *proc1Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, buffer); + ckfree(buffer); + } + + *proc2Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, sym2); + if (*proc2Ptr == NULL) { + buffer = ckalloc(strlen(sym2)+2); + buffer[0] = '_'; + strcpy(buffer+1, sym2); + *proc2Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, buffer); + ckfree(buffer); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclGuessPackageName -- + * + * If the "load" command is invoked without providing a package + * name, this procedure is invoked to try to figure it out. + * + * Results: + * Always returns 0 to indicate that we couldn't figure out a + * package name; generic code will then try to guess the package + * from the file name. A return value of 1 would have meant that + * we figured out the package name and put it in bufPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclGuessPackageName(fileName, bufPtr) + char *fileName; /* Name of file containing package (already + * translated to local form if needed). */ + Tcl_DString *bufPtr; /* Initialized empty dstring. Append + * package name to this if possible. */ +{ + return 0; +} diff --git a/tcl7.6/win/tclWinMtherr.c b/tcl7.6/win/tclWinMtherr.c new file mode 100644 index 0000000..98c528d --- /dev/null +++ b/tcl7.6/win/tclWinMtherr.c @@ -0,0 +1,61 @@ +/* + * tclWinMtherr.c -- + * + * This function provides a default implementation of the + * _matherr function for Borland C++. + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclWinMtherr.c 1.2 96/02/15 11:54:05 + */ + +#include "tclInt.h" +#include "tclPort.h" +#include + +/* + * 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 by Borland C++ when certain + * errors occur in mathematical functions. This procedure + * replaces the default implementation which generates pop-up + * warnings. + * + * 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/tcl7.6/win/tclWinNotify.c b/tcl7.6/win/tclWinNotify.c new file mode 100644 index 0000000..75975a9 --- /dev/null +++ b/tcl7.6/win/tclWinNotify.c @@ -0,0 +1,266 @@ +/* + * tclWinNotify.c -- + * + * This file contains Windows-specific procedures for the notifier, + * which is the lowest-level part of the Tcl event loop. This file + * works together with ../generic/tclNotify.c. + * + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclWinNotify.c 1.11 96/10/03 14:57:16 + */ + +#include "tclInt.h" +#include "tclPort.h" +#include + +/* + * The following variable is a backdoor for use by Tk. It is set when + * Tk needs to process events on the Tcl event queue without reentering + * the system event loop. Tk uses it to flush the Tcl event queue. + */ + +static int ignoreEvents = 0; + +/* + *---------------------------------------------------------------------- + * + * TclWinFlushEvents -- + * + * This function is a special purpose hack to allow Tk to + * process queued Window events during a recursive event loop + * without looking for new events on the system event queue. + * + * Results: + * None. + * + * Side effects: + * Services any pending Tcl events and calls idle handlers. + * + *---------------------------------------------------------------------- + */ + +void +TclWinFlushEvents() +{ + ignoreEvents = 1; + while (Tcl_DoOneEvent(TCL_DONT_WAIT|TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS)) { + } + ignoreEvents = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_WatchFile -- + * + * Arrange for Tcl_DoOneEvent to include this file in the masks + * for the next call to select. This procedure is invoked by + * event sources, which are in turn invoked by Tcl_DoOneEvent + * before it invokes select. + * + * Results: + * None. + * + * Side effects: + * + * The notifier will generate a file event when the I/O channel + * given by fd next becomes ready in the way indicated by mask. + * If fd is already registered then the old mask will be replaced + * with the new one. Once the event is sent, the notifier will + * not send any more events about the fd until the next call to + * Tcl_NotifyFile. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_WatchFile(file, mask) + Tcl_File file; /* Opaque identifier for a stream. */ + int mask; /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, and TCL_EXCEPTION: + * indicates conditions to wait for + * in select. */ +{ + int type; + + (void) Tcl_GetFileInfo(file, &type); + + if (type == TCL_WIN_SOCKET) { + TclWinWatchSocket(file, mask); + } else if (type == TCL_WIN_FILE) { + Tcl_Time timeout = { 0, 0 }; + + /* + * Files are always ready under Windows, so we just set a + * 0 timeout. + */ + + Tcl_SetMaxBlockTime(&timeout); + } else if (type == TCL_WIN_PIPE) { + /* + * We don't support waiting on pipes yet. + */ + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FileReady -- + * + * Indicates what conditions (readable, writable, etc.) were + * present on a file the last time the notifier invoked select. + * This procedure is typically invoked by event sources to see + * if they should queue events. + * + * Results: + * The return value is 0 if none of the conditions specified by mask + * was true for fd the last time the system checked. If any of the + * conditions were true, then the return value is a mask of those + * that were true. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_FileReady(file, mask) + Tcl_File file; /* File handle for a stream. */ + int mask; /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, and TCL_EXCEPTION: + * indicates conditions caller cares about. */ +{ + int type; + + (void) Tcl_GetFileInfo(file, &type); + + if (type == TCL_WIN_SOCKET) { + return TclWinSocketReady(file, mask); + } else if (type == TCL_WIN_FILE) { + /* + * Under Windows, files are always ready, so we just return the + * mask that was passed in. + */ + + return mask; + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_WaitForEvent -- + * + * This procedure does the lowest level wait for events in a + * platform-specific manner. It uses information provided by + * previous calls to Tcl_WatchFile, plus the timePtr argument, + * to determine what to wait for and how long to wait. + * + * Results: + * The return value is normally TCL_OK. However, if there are + * no events to wait for (e.g. no files and no timers) so that + * the procedure would block forever, then it returns TCL_ERROR. + * + * Side effects: + * May put the process to sleep for a while, depending on timePtr. + * When this procedure returns, an event of interest to the application + * has probably, but not necessarily, occurred. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_WaitForEvent(timePtr) + Tcl_Time *timePtr; /* Specifies the maximum amount of time + * that this procedure should block before + * returning. The time is given as an + * interval, not an absolute wakeup time. + * NULL means block forever. */ +{ + MSG msg; + int foundEvent = 1; + + /* + * If we are ignoring events from the system, just return immediately. + */ + + if (ignoreEvents) { + return TCL_OK; + } + + /* + * Set up the asynchronous select handlers for any sockets we + * are watching. + */ + + TclWinNotifySocket(); + + /* + * Look for an event, setting a timer so we don't block forever. + */ + + if (timePtr != NULL) { + UINT ms; + ms = timePtr->sec * 1000; + ms += timePtr->usec / 1000; + + if (ms > 0) { + UINT timerHandle = SetTimer(NULL, 0, ms, NULL); + GetMessage(&msg, NULL, 0, 0); + KillTimer(NULL, timerHandle); + } else { + + /* + * If the timeout is too small, we just poll. + */ + + foundEvent = PeekMessage(&msg, NULL, 0, 0, PM_REMOVE); + } + } else { + GetMessage(&msg, NULL, 0, 0); + } + + /* + * Dispatch the message, if we found one. If we are exiting, be + * sure to inform Tcl so we can clean up properly. + */ + + if (foundEvent) { + if (msg.message == WM_QUIT) { + Tcl_Exit(0); + } + TranslateMessage(&msg); + DispatchMessage(&msg); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Sleep -- + * + * Delay execution for the specified number of milliseconds. + * + * Results: + * None. + * + * Side effects: + * Time passes. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_Sleep(ms) + int ms; /* Number of milliseconds to sleep. */ +{ + Sleep(ms); +} diff --git a/tcl7.6/win/tclWinPipe.c b/tcl7.6/win/tclWinPipe.c new file mode 100644 index 0000000..7280767 --- /dev/null +++ b/tcl7.6/win/tclWinPipe.c @@ -0,0 +1,1091 @@ +/* + * tclWinPipe.c -- + * + * This file implements the Windows-specific pipeline exec functions. + * + * Copyright (c) 1996 by Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclWinPipe.c 1.32 96/10/11 17:39:22 + */ + +#include "tclWinInt.h" + +#include +#include +#include +#include +#include + +/* + * The following defines identify the various types of applications that + * run under windows. There is special case code for the various types. + */ + +#define APPL_NONE 0 +#define APPL_DOS 1 +#define APPL_WIN3X 2 +#define APPL_WIN32 3 + +/* + * This value indicates whether this module has been initialized. + */ + +static int initialized = 0; + +/* + * This list is used to map from pids to process handles. + */ + +typedef struct ProcInfo { + HANDLE hProcess; + DWORD dwProcessId; + struct ProcInfo *nextPtr; +} ProcInfo; + +static ProcInfo *procList = NULL; + +/* + * Declarations for functions used only in this file. + */ + +static int ApplicationType(Tcl_Interp *interp, + const char *fileName, char *fullName); +static void BuildCommandLine(int argc, char **argv, + Tcl_DString *linePtr); +static char * MakeTempFile(Tcl_DString *namePtr); +static void CopyFileByHandles(HANDLE dst, HANDLE src); +static BOOL HasConsole(void); + +/* + *---------------------------------------------------------------------- + * + * Tcl_WaitPid -- + * + * Emulates the waitpid system call. + * + * Results: + * Returns 0 if the process is still alive, -1 on an error, or + * the pid on a clean close. + * + * Side effects: + * Unless WNOHANG is set and the wait times out, the process + * information record will be deleted and the process handle + * will be closed. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_WaitPid(pid, statPtr, options) + pid_t pid; + int *statPtr; + int options; +{ + ProcInfo *infoPtr, **prevPtrPtr; + int flags, result; + DWORD ret; + + if (options & WNOHANG) { + flags = 0; + } else { + flags = INFINITE; + } + if (pid == 0) { + *statPtr = 0; + return 0; + } + + /* + * Find the process on the process list. + */ + + prevPtrPtr = &procList; + for (infoPtr = procList; infoPtr != NULL; + prevPtrPtr = &infoPtr->nextPtr, infoPtr = infoPtr->nextPtr) { + if (infoPtr->dwProcessId == (DWORD)pid) { + break; + } + } + if (infoPtr == NULL) { + return 0; + } + + ret = WaitForSingleObject(infoPtr->hProcess, flags); + if (ret == WAIT_TIMEOUT) { + *statPtr = 0; + if (options & WNOHANG) { + return 0; + } else { + result = 0; + } + } else if (ret != WAIT_FAILED) { + GetExitCodeProcess(infoPtr->hProcess, (DWORD*)statPtr); + *statPtr = ((*statPtr << 8) & 0xff00); + result = pid; + } else { + errno = ECHILD; + result = -1; + } + + /* + * Remove the process from the process list and close the process handle. + */ + CloseHandle(infoPtr->hProcess); + *prevPtrPtr = infoPtr->nextPtr; + ckfree((char*)infoPtr); + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclpCreateProcess -- + * + * Create a child process that has the specified files as its + * standard input, output, and error. The child process runs + * synchronously under Win32s and asynchronously under Windows NT + * and Windows 95, and runs with the same environment variables + * as the creating process. + * + * The complete Windows search path is searched to find the specified + * executable. If an executable by the given name is not found, + * automatically tries appending ".com", ".exe", and ".bat" to the + * executable name. + * + * Results: + * The return value is TCL_ERROR and an error message is left in + * interp->result if there was a problem creating the child + * process. Otherwise, the return value is TCL_OK and *pidPtr is + * filled with the process id of the child process. + * + * Side effects: + * A process is created. + * + *---------------------------------------------------------------------- + */ + +int +TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile, + inputFileName, outputFileName, errorFileName, pidPtr) + Tcl_Interp *interp; /* Interpreter in which to leave errors that + * occurred when creating the child process. + * Error messages from the child process + * itself are sent to errorFile. */ + int argc; /* Number of arguments in following array. */ + char **argv; /* Array of argument strings. argv[0] + * contains the name of the executable + * converted to native format (using the + * Tcl_TranslateFileName call). Additional + * arguments have not been converted. */ + Tcl_File inputFile; /* If non-NULL, gives the file to use as + * input for the child process. If inputFile + * file is not readable or is NULL, the child + * will receive no standard input. */ + Tcl_File outputFile; /* If non-NULL, gives the file that + * receives output from the child process. If + * outputFile file is not writeable or is + * NULL, output from the child will be + * discarded. */ + Tcl_File errorFile; /* If non-NULL, gives the file that + * receives errors from the child process. If + * errorFile file is not writeable or is NULL, + * errors from the child will be discarded. + * errorFile may be the same as outputFile. */ + char *inputFileName; /* If non-NULL, gives the name of the disk + * file that corresponds to inputFile. If + * NULL, then the name was not available + * because inputFile corresponds to a channel, + * pipe, socket, etc. */ + char *outputFileName; /* If non-NULL, gives the name of the disk + * file that corresponds to outputFile. If + * NULL, then the name was not available + * because outputFile corresponds to a + * channel, pipe, socket, etc. */ + char *errorFileName; /* If non-NULL, gives the name of the disk + * file that corresponds to errorFile. If + * NULL, then the name was not available + * because errorFile corresponds to a channel, + * pipe, socket, etc. */ + int *pidPtr; /* If this procedure is successful, pidPtr + * is filled with the process id of the child + * process. */ +{ + int result, type, applType, createFlags; + Tcl_DString cmdLine; + STARTUPINFO startInfo; + PROCESS_INFORMATION procInfo; + SECURITY_ATTRIBUTES secAtts; + HANDLE hProcess, h, inputHandle, outputHandle, errorHandle; + char execPath[MAX_PATH]; + char *originalName; + OSVERSIONINFO os; + + os.dwOSVersionInfoSize = sizeof(os); + GetVersionEx(&os); + + applType = ApplicationType(interp, argv[0], execPath); + if (applType == APPL_NONE) { + return TCL_ERROR; + } + originalName = argv[0]; + argv[0] = execPath; + + result = TCL_ERROR; + Tcl_DStringInit(&cmdLine); + + if (os.dwPlatformId == VER_PLATFORM_WIN32s) { + /* + * Under Win32s, there are no pipes. In order to simulate pipe + * behavior, the child processes are run synchronously and their + * I/O is redirected from/to temporary files before the next + * stage of the pipeline is started. + */ + + Tcl_DString inputTempFile, outputTempFile; + ClientData clientData; + TclWinPipe *pipePtr; + DWORD args[4]; + void *trans[5]; + DWORD status; + MSG msg; + + BuildCommandLine(argc, argv, &cmdLine); + + ZeroMemory(&startInfo, sizeof(startInfo)); + startInfo.cb = sizeof(startInfo); + + Tcl_DStringInit(&inputTempFile); + Tcl_DStringInit(&outputTempFile); + outputHandle = INVALID_HANDLE_VALUE; + + if (inputFileName == NULL) { + if (inputFile != NULL) { + clientData = Tcl_GetFileInfo(inputFile, &type); + if (type == TCL_WIN_FILE) { + h = INVALID_HANDLE_VALUE; + inputFileName = MakeTempFile(&inputTempFile); + if (inputFileName != NULL) { + h = CreateFile(inputFileName, GENERIC_WRITE, 0, + NULL, CREATE_ALWAYS, 0, NULL); + } + if (h == INVALID_HANDLE_VALUE) { + Tcl_AppendResult(interp, "couldn't duplicate input handle: ", + Tcl_PosixError(interp), (char *) NULL); + goto end32s; + } + CopyFileByHandles(h, (HANDLE) clientData); + CloseHandle(h); + } else if (type == TCL_WIN32S_PIPE) { + pipePtr = (TclWinPipe *) clientData; + inputFileName = pipePtr->fileName; + } + } + if (inputFileName == NULL) { + inputFileName = "nul"; + } + } + if (outputFileName == NULL) { + if (outputFile != NULL) { + clientData = Tcl_GetFileInfo(outputFile, &type); + if ((type >= TCL_WIN_PIPE) && (type <= TCL_WIN_CONSOLE)) { + outputFileName = MakeTempFile(&outputTempFile); + if (outputFileName == NULL) { + Tcl_AppendResult(interp, "couldn't duplicate output handle: ", + Tcl_PosixError(interp), (char *) NULL); + goto end32s; + } + outputHandle = (HANDLE) clientData; + } else if (type == TCL_WIN32S_PIPE) { + pipePtr = (TclWinPipe *) clientData; + outputFileName = pipePtr->fileName; + } + } + if (outputFileName == NULL) { + outputFileName = "nul"; + } + } + + if (applType == APPL_DOS) { + args[0] = (DWORD) Tcl_DStringValue(&cmdLine); + args[1] = (DWORD) inputFileName; + args[2] = (DWORD) outputFileName; + trans[0] = &args[0]; + trans[1] = &args[1]; + trans[2] = &args[2]; + trans[3] = NULL; + if (TclSynchSpawn(args, 0, trans, pidPtr) != 0) { + result = TCL_OK; + } + } else if (applType == APPL_WIN3X) { + args[0] = (DWORD) Tcl_DStringValue(&cmdLine); + trans[0] = &args[0]; + trans[1] = NULL; + if (TclSynchSpawn(args, 1, trans, pidPtr) != 0) { + result = TCL_OK; + } + } else { + if (CreateProcess(NULL, Tcl_DStringValue(&cmdLine), NULL, NULL, + FALSE, DETACHED_PROCESS, NULL, NULL, &startInfo, + &procInfo) != 0) { + CloseHandle(procInfo.hThread); + while (1) { + if (GetExitCodeProcess(procInfo.hProcess, &status) == FALSE) { + break; + } + if (status != STILL_ACTIVE) { + break; + } + if (PeekMessage(&msg, NULL, 0, 0, PM_REMOVE) == TRUE) { + TranslateMessage(&msg); + DispatchMessage(&msg); + } + } + *pidPtr = (int) procInfo.dwProcessId; + if (*pidPtr != 0) { + ProcInfo *procPtr = (ProcInfo *)ckalloc(sizeof(ProcInfo)); + procPtr->hProcess = procInfo.hProcess; + procPtr->dwProcessId = procInfo.dwProcessId; + procPtr->nextPtr = procList; + procList = procPtr; + } + result = TCL_OK; + } + } + if (result != TCL_OK) { + TclWinConvertError(GetLastError()); + Tcl_AppendResult(interp, "couldn't execute \"", originalName, + "\": ", Tcl_PosixError(interp), (char *) NULL); + } + + end32s: + if (outputHandle != INVALID_HANDLE_VALUE) { + /* + * Now copy stuff from temp file to actual output handle. Don't + * close outputHandle because it is associated with the output + * file owned by the caller. + */ + + h = CreateFile(outputFileName, GENERIC_READ, 0, NULL, OPEN_ALWAYS, + 0, NULL); + if (h != INVALID_HANDLE_VALUE) { + CopyFileByHandles(outputHandle, h); + } + CloseHandle(h); + } + + if (inputFileName == Tcl_DStringValue(&inputTempFile)) { + DeleteFile(inputFileName); + } + if (outputFileName == Tcl_DStringValue(&outputTempFile)) { + DeleteFile(outputFileName); + } + + Tcl_DStringFree(&inputTempFile); + Tcl_DStringFree(&outputTempFile); + Tcl_DStringFree(&cmdLine); + return result; + } + hProcess = GetCurrentProcess(); + + /* + * STARTF_USESTDHANDLES must be used to pass handles to child process. + * Using SetStdHandle() and/or dup2() only works when a console mode + * parent process is spawning an attached console mode child process. + */ + + ZeroMemory(&startInfo, sizeof(startInfo)); + startInfo.cb = sizeof(startInfo); + startInfo.dwFlags = STARTF_USESTDHANDLES; + startInfo.hStdInput = INVALID_HANDLE_VALUE; + startInfo.hStdOutput= INVALID_HANDLE_VALUE; + startInfo.hStdError = INVALID_HANDLE_VALUE; + + secAtts.nLength = sizeof(SECURITY_ATTRIBUTES); + secAtts.lpSecurityDescriptor = NULL; + secAtts.bInheritHandle = TRUE; + + /* + * We have to check the type of each file, since we cannot duplicate + * some file types. + */ + + inputHandle = INVALID_HANDLE_VALUE; + if (inputFile != NULL) { + h = (HANDLE) Tcl_GetFileInfo(inputFile, &type); + if ((type >= TCL_WIN_PIPE) && (type <= TCL_WIN_CONSOLE)) { + inputHandle = h; + } + } + outputHandle = INVALID_HANDLE_VALUE; + if (outputFile != NULL) { + h = (HANDLE) Tcl_GetFileInfo(outputFile, &type); + if ((type >= TCL_WIN_PIPE) && (type <= TCL_WIN_CONSOLE)) { + outputHandle = h; + } + } + errorHandle = INVALID_HANDLE_VALUE; + if (errorFile != NULL) { + h = (HANDLE) Tcl_GetFileInfo(errorFile, &type); + if ((type >= TCL_WIN_PIPE) && (type <= TCL_WIN_CONSOLE)) { + errorHandle = h; + } + } + + /* + * Duplicate all the handles which will be passed off as stdin, stdout + * and stderr of the child process. The duplicate handles are set to + * be inheritable, so the child process can use them. + */ + + if (inputHandle == INVALID_HANDLE_VALUE) { + /* + * If handle was not set, stdin should return immediate EOF. + * Under Windows95, some applications (both 16 and 32 bit!) + * cannot read from the NUL device; they read from console + * instead. When running tk, this is fatal because the child + * process would hang forever waiting for EOF from the unmapped + * console window used by the helper application. + * + * Fortunately, the helper application detects a closed pipe + * as an immediate EOF and can pass that information to the + * child process. + */ + + if (CreatePipe(&startInfo.hStdInput, &h, &secAtts, 0) != FALSE) { + CloseHandle(h); + } + } else { + DuplicateHandle(hProcess, inputHandle, hProcess, &startInfo.hStdInput, + 0, TRUE, DUPLICATE_SAME_ACCESS); + } + if (startInfo.hStdInput == INVALID_HANDLE_VALUE) { + TclWinConvertError(GetLastError()); + Tcl_AppendResult(interp, "couldn't duplicate input handle: ", + Tcl_PosixError(interp), (char *) NULL); + goto end; + } + + if (outputHandle == INVALID_HANDLE_VALUE) { + /* + * If handle was not set, output should be sent to an infinitely + * deep sink. Under Windows 95, some 16 bit applications cannot + * have stdout redirected to NUL; they send their output to + * the console instead. Some applications, like "more" or "dir /p", + * when outputting multiple pages to the console, also then try and + * read from the console to go the next page. When running tk, this + * is fatal because the child process would hang forever waiting + * for input from the unmapped console window used by the helper + * application. + * + * Fortunately, the helper application will detect a closed pipe + * as a sink. + */ + + if ((os.dwPlatformId == VER_PLATFORM_WIN32_WINDOWS) + && (applType == APPL_DOS)) { + if (CreatePipe(&h, &startInfo.hStdOutput, &secAtts, 0) != FALSE) { + CloseHandle(h); + } + } else { + startInfo.hStdOutput = CreateFile("NUL:", GENERIC_WRITE, 0, + &secAtts, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL); + } + } else { + DuplicateHandle(hProcess, outputHandle, hProcess, &startInfo.hStdOutput, + 0, TRUE, DUPLICATE_SAME_ACCESS); + } + if (startInfo.hStdOutput == INVALID_HANDLE_VALUE) { + TclWinConvertError(GetLastError()); + Tcl_AppendResult(interp, "couldn't duplicate output handle: ", + Tcl_PosixError(interp), (char *) NULL); + goto end; + } + + if (errorHandle == INVALID_HANDLE_VALUE) { + /* + * If handle was not set, errors should be sent to an infinitely + * deep sink. + */ + + startInfo.hStdError = CreateFile("NUL:", GENERIC_WRITE, 0, + &secAtts, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); + } else { + DuplicateHandle(hProcess, errorHandle, hProcess, &startInfo.hStdError, + 0, TRUE, DUPLICATE_SAME_ACCESS); + } + if (startInfo.hStdError == INVALID_HANDLE_VALUE) { + TclWinConvertError(GetLastError()); + Tcl_AppendResult(interp, "couldn't duplicate error handle: ", + Tcl_PosixError(interp), (char *) NULL); + goto end; + } + /* + * If we do not have a console window, then we must run DOS and + * WIN32 console mode applications as detached processes. This tells + * the loader that the child application should not inherit the + * console, and that it should not create a new console window for + * the child application. The child application should get its stdio + * from the redirection handles provided by this application, and run + * in the background. + * + * If we are starting a GUI process, they don't automatically get a + * console, so it doesn't matter if they are started as foreground or + * detached processes. The GUI window will still pop up to the + * foreground. + */ + + if (os.dwPlatformId == VER_PLATFORM_WIN32_NT) { + if (HasConsole()) { + createFlags = 0; + } else if (applType == APPL_DOS) { + /* + * Under NT, 16-bit DOS applications will not run unless they + * can be attached to a console. If we are running without a + * console, run the 16-bit program as an normal process inside + * of a hidden console application, and then run that hidden + * console as a detached process. + */ + + startInfo.wShowWindow = SW_HIDE; + startInfo.dwFlags |= STARTF_USESHOWWINDOW; + createFlags = CREATE_NEW_CONSOLE; + Tcl_DStringAppend(&cmdLine, "cmd.exe /c ", -1); + } else { + createFlags = DETACHED_PROCESS; + } + } else { + if (HasConsole()) { + createFlags = 0; + } else { + createFlags = DETACHED_PROCESS; + } + + if (applType == APPL_DOS) { + /* + * Under Windows 95, 16-bit DOS applications do not work well + * with pipes: + * + * 1. EOF on a pipe between a detached 16-bit DOS application + * and another application is not seen at the other + * end of the pipe, so the listening process blocks forever on + * reads. This inablity to detect EOF happens when either a + * 16-bit app or the 32-bit app is the listener. + * + * 2. If a 16-bit DOS application (detached or not) blocks when + * writing to a pipe, it will never wake up again, and it + * eventually brings the whole system down around it. + * + * The 16-bit application is run as a normal process inside + * of a hidden helper console app, and this helper may be run + * as a detached process. If any of the stdio handles is + * a pipe, the helper application accumulates information + * into temp files and forwards it to or from the DOS + * application as appropriate. This means that DOS apps + * must receive EOF from a stdin pipe before they will actually + * begin, and must finish generating stdout or stderr before + * the data will be sent to the next stage of the pipe. + * + * The helper app should be located in the same directory as + * the tcl dll. + */ + + if (createFlags != 0) { + startInfo.wShowWindow = SW_HIDE; + startInfo.dwFlags |= STARTF_USESHOWWINDOW; + createFlags = CREATE_NEW_CONSOLE; + } + Tcl_DStringAppend(&cmdLine, "tclpip" STRINGIFY(TCL_MAJOR_VERSION) + STRINGIFY(TCL_MINOR_VERSION) ".dll ", -1); + } + } + + /* + * cmdLine gets the full command line used to invoke the executable, + * including the name of the executable itself. The command line + * arguments in argv[] are stored in cmdLine separated by spaces. + * Special characters in individual arguments from argv[] must be + * quoted when being stored in cmdLine. + * + * When calling any application, bear in mind that arguments that + * specify a path name are not converted. If an argument contains + * forward slashes as path separators, it may or may not be + * recognized as a path name, depending on the program. In general, + * most applications accept forward slashes only as option + * delimiters and backslashes only as paths. + * + * Additionally, when calling a 16-bit dos or windows application, + * all path names must use the short, cryptic, path format (e.g., + * using ab~1.def instead of "a b.default"). + */ + + BuildCommandLine(argc, argv, &cmdLine); + + if (!CreateProcess(NULL, Tcl_DStringValue(&cmdLine), NULL, NULL, TRUE, + createFlags, NULL, NULL, &startInfo, &procInfo)) { + TclWinConvertError(GetLastError()); + Tcl_AppendResult(interp, "couldn't execute \"", originalName, + "\": ", Tcl_PosixError(interp), (char *) NULL); + goto end; + } + + if (applType == APPL_DOS) { + WaitForSingleObject(hProcess, 50); + } + + /* + * "When an application spawns a process repeatedly, a new thread + * instance will be created for each process but the previous + * instances may not be cleaned up. This results in a significant + * virtual memory loss each time the process is spawned. If there + * is a WaitForInputIdle() call between CreateProcess() and + * CloseHandle(), the problem does not occur." PSS ID Number: Q124121 + */ + + WaitForInputIdle(procInfo.hProcess, 5000); + CloseHandle(procInfo.hThread); + + *pidPtr = (int) procInfo.dwProcessId; + if (*pidPtr != 0) { + ProcInfo *procPtr = (ProcInfo *)ckalloc(sizeof(ProcInfo)); + procPtr->hProcess = procInfo.hProcess; + procPtr->dwProcessId = procInfo.dwProcessId; + procPtr->nextPtr = procList; + procList = procPtr; + } + result = TCL_OK; + + end: + Tcl_DStringFree(&cmdLine); + if (startInfo.hStdInput != INVALID_HANDLE_VALUE) { + CloseHandle(startInfo.hStdInput); + } + if (startInfo.hStdOutput != INVALID_HANDLE_VALUE) { + CloseHandle(startInfo.hStdOutput); + } + if (startInfo.hStdError != INVALID_HANDLE_VALUE) { + CloseHandle(startInfo.hStdError); + } + return result; +} + + +/* + *---------------------------------------------------------------------- + * + * HasConsole -- + * + * Determines whether the current application is attached to a + * console. + * + * Results: + * Returns TRUE if this application has a console, else FALSE. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static BOOL +HasConsole() +{ + HANDLE handle = CreateFile("CONOUT$", GENERIC_WRITE, FILE_SHARE_WRITE, + NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); + + if (handle != INVALID_HANDLE_VALUE) { + CloseHandle(handle); + return TRUE; + } else { + return FALSE; + } +} + +/* + *---------------------------------------------------------------------- + * + * TclCreatePipe -- + * + * Creates an anonymous pipe. Under Win32s, creates a temp file + * that is used to simulate a pipe. + * + * Results: + * Returns 1 on success, 0 on failure. + * + * Side effects: + * Creates a pipe. + * + *---------------------------------------------------------------------- + */ + +int +TclCreatePipe(readPipe, writePipe) + Tcl_File *readPipe; /* Location to store file handle for + * read side of pipe. */ + Tcl_File *writePipe; /* Location to store file handle for + * write side of pipe. */ +{ + HANDLE readHandle, writeHandle; + OSVERSIONINFO os; + + if (CreatePipe(&readHandle, &writeHandle, NULL, 0) != 0) { + *readPipe = Tcl_GetFile((ClientData) readHandle, TCL_WIN_FILE); + *writePipe = Tcl_GetFile((ClientData) writeHandle, TCL_WIN_FILE); + return 1; + } + + os.dwOSVersionInfoSize = sizeof(os); + GetVersionEx(&os); + + if (os.dwPlatformId == VER_PLATFORM_WIN32s) { + TclWinPipe *readPipePtr, *writePipePtr; + char buf[MAX_PATH]; + + if ((GetTempPath(MAX_PATH, buf) != 0) + && (GetTempFileName(buf, "TCL", 0, buf) != 0)) { + + readPipePtr = (TclWinPipe *) ckalloc(sizeof(TclWinPipe)); + writePipePtr = (TclWinPipe *) ckalloc(sizeof(TclWinPipe)); + + readPipePtr->otherPtr = writePipePtr; + readPipePtr->fileName = strcpy(ckalloc(strlen(buf) + 1), buf); + readPipePtr->fileHandle = INVALID_HANDLE_VALUE; + writePipePtr->otherPtr = readPipePtr; + writePipePtr->fileName = readPipePtr->fileName; + writePipePtr->fileHandle = INVALID_HANDLE_VALUE; + *readPipe = Tcl_GetFile((ClientData) readPipePtr, TCL_WIN32S_PIPE); + *writePipe = Tcl_GetFile((ClientData) writePipePtr, TCL_WIN32S_PIPE); + return 1; + } + } + + TclWinConvertError(GetLastError()); + return 0; +} + +/* + *-------------------------------------------------------------------- + * + * ApplicationType -- + * + * Search for the specified program and identify if it refers to a DOS, + * Windows 3.X, or Win32 program. Used to determine how to invoke + * a program, or if it can even be invoked. + * + * It is possible to almost positively identify DOS and Windows + * applications that contain the appropriate magic numbers. However, + * DOS .com files do not seem to contain a magic number; if the program + * name ends with .com and could not be identified as a Windows .com + * file, it will be assumed to be a DOS application, even if it was + * just random data. If the program name does not end with .com, no + * such assumption is made. + * + * The Win32 procedure GetBinaryType incorrectly identifies any + * junk file that ends with .exe as a dos executable and some + * executables that don't end with .exe as not executable. Plus it + * doesn't exist under win95, so I won't feel bad about reimplementing + * functionality. + * + * Results: + * The return value is one of APPL_DOS, APPL_WIN3X, or APPL_WIN32 + * if the filename referred to the corresponding application type. + * If the file name could not be found or did not refer to any known + * application type, APPL_NONE is returned and an error message is + * left in interp. .bat files are identified as APPL_DOS. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ApplicationType(interp, originalName, fullPath) + Tcl_Interp *interp; /* Interp, for error message. */ + const char *originalName; /* Name of the application to find. */ + char fullPath[MAX_PATH]; /* Filled with complete path to + * application. */ +{ + int applType, i; + HANDLE hFile; + char *ext; + char buf[2]; + DWORD read; + IMAGE_DOS_HEADER header; + static char extensions[][5] = {"", ".com", ".exe", ".bat"}; + + /* Look for the program as an external program. First try the name + * as it is, then try adding .com, .exe, and .bat, in that order, to + * the name, looking for an executable. + * + * Using the raw SearchPath() procedure doesn't do quite what is + * necessary. If the name of the executable already contains a '.' + * character, it will not try appending the specified extension when + * searching (in other words, SearchPath will not find the program + * "a.b.exe" if the arguments specified "a.b" and ".exe"). + * So, first look for the file as it is named. Then manually append + * the extensions, looking for a match. + */ + + applType = APPL_NONE; + for (i = 0; i < (int) (sizeof(extensions) / sizeof(extensions[0])); i++) { + lstrcpyn(fullPath, originalName, MAX_PATH - 5); + lstrcat(fullPath, extensions[i]); + + if (SearchPath(NULL, fullPath, NULL, MAX_PATH, fullPath, NULL) == 0) { + continue; + } + + /* + * Ignore matches on directories or data files, return if identified + * a known type. + */ + + if (GetFileAttributes(fullPath) & FILE_ATTRIBUTE_DIRECTORY) { + continue; + } + + ext = strrchr(fullPath, '.'); + if ((ext != NULL) && (strcmpi(ext, ".bat") == 0)) { + applType = APPL_DOS; + break; + } + + hFile = CreateFile(fullPath, GENERIC_READ, FILE_SHARE_READ, NULL, + OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); + if (hFile == INVALID_HANDLE_VALUE) { + continue; + } + + header.e_magic = 0; + ReadFile(hFile, (void *) &header, sizeof(header), &read, NULL); + if (header.e_magic != IMAGE_DOS_SIGNATURE) { + /* + * Doesn't have the magic number for relocatable executables. If + * filename ends with .com, assume it's a DOS application anyhow. + * Note that we didn't make this assumption at first, because some + * supposed .com files are really 32-bit executables with all the + * magic numbers and everything. + */ + + CloseHandle(hFile); + if ((ext != NULL) && (strcmpi(ext, ".com") == 0)) { + applType = APPL_DOS; + break; + } + continue; + } + if (header.e_lfarlc != sizeof(header)) { + /* + * All Windows 3.X and Win32 and some DOS programs have this value + * set here. If it doesn't, assume that since it already had the + * other magic number it was a DOS application. + */ + + CloseHandle(hFile); + applType = APPL_DOS; + break; + } + + /* + * The DWORD at header.e_lfanew points to yet another magic number. + */ + + buf[0] = '\0'; + SetFilePointer(hFile, header.e_lfanew, NULL, FILE_BEGIN); + ReadFile(hFile, (void *) buf, 2, &read, NULL); + CloseHandle(hFile); + + if ((buf[0] == 'L') && (buf[1] == 'E')) { + applType = APPL_DOS; + } else if ((buf[0] == 'N') && (buf[1] == 'E')) { + applType = APPL_WIN3X; + } else if ((buf[0] == 'P') && (buf[1] == 'E')) { + applType = APPL_WIN32; + } else { + continue; + } + break; + } + + if (applType == APPL_NONE) { + TclWinConvertError(GetLastError()); + Tcl_AppendResult(interp, "couldn't execute \"", originalName, + "\": ", Tcl_PosixError(interp), (char *) NULL); + return APPL_NONE; + } + + if ((applType == APPL_DOS) || (applType == APPL_WIN3X)) { + /* + * Replace long path name of executable with short path name for + * 16-bit applications. Otherwise the application may not be able + * to correctly parse its own command line to separate off the + * application name from the arguments. + */ + + GetShortPathName(fullPath, fullPath, MAX_PATH); + } + return applType; +} + +/* + *---------------------------------------------------------------------- + * + * BuildCommandLine -- + * + * The command line arguments are stored in linePtr separated + * by spaces, in a form that CreateProcess() understands. Special + * characters in individual arguments from argv[] must be quoted + * when being stored in cmdLine. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +BuildCommandLine(argc, argv, linePtr) + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ + Tcl_DString *linePtr; /* Initialized Tcl_DString that receives the + * command line. */ +{ + char *start, *special; + int quote, i; + + for (i = 0; i < argc; i++) { + if (i > 0) { + Tcl_DStringAppend(linePtr, " ", 1); + } + + quote = 0; + for (start = argv[i]; *start != '\0'; start++) { + if (isspace(*start)) { + quote = 1; + Tcl_DStringAppend(linePtr, "\"", 1); + break; + } + } + + start = argv[i]; + for (special = argv[i]; ; ) { + if ((*special == '\\') && + (special[1] == '\\' || special[1] == '"')) { + Tcl_DStringAppend(linePtr, start, special - start); + start = special; + while (1) { + special++; + if (*special == '"') { + /* + * N backslashes followed a quote -> insert + * N * 2 + 1 backslashes then a quote. + */ + + Tcl_DStringAppend(linePtr, start, special - start); + break; + } + if (*special != '\\') { + break; + } + } + Tcl_DStringAppend(linePtr, start, special - start); + start = special; + } + if (*special == '"') { + Tcl_DStringAppend(linePtr, start, special - start); + Tcl_DStringAppend(linePtr, "\\\"", 2); + start = special + 1; + } + if (*special == '\0') { + break; + } + special++; + } + Tcl_DStringAppend(linePtr, start, special - start); + if (quote) { + Tcl_DStringAppend(linePtr, "\"", 1); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * MakeTempFile -- + * + * Helper function for TclpCreateProcess under Win32s. Makes a + * temporary file that _won't_ go away automatically when it's file + * handle is closed. Used for simulated pipes, which are written + * in one pass and reopened and read in the next pass. + * + * Results: + * namePtr is filled with the name of the temporary file. + * + * Side effects: + * A temporary file with the name specified by namePtr is created. + * The caller is responsible for deleting this temporary file. + * + *---------------------------------------------------------------------- + */ + +static char * +MakeTempFile(namePtr) + Tcl_DString *namePtr; /* Initialized Tcl_DString that is filled + * with the name of the temporary file that + * was created. */ +{ + char name[MAX_PATH]; + + if ((GetTempPath(MAX_PATH, name) == 0) + || (GetTempFileName(name, "TCL", 0, name) == 0)) { + return NULL; + } + + Tcl_DStringAppend(namePtr, name, -1); + return Tcl_DStringValue(namePtr); +} + +/* + *---------------------------------------------------------------------- + * + * CopyFileByHandles -- + * + * Helper function used by TclpCreateProcess under Win32s. Copies + * what remains of source file to destination file; source file + * pointer need not be positioned at the beginning of the file if + * all of source file is not desired, but data is copied up to end + * of source file. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +CopyFileByHandles(dst, src) + HANDLE dst; /* Destination file. */ + HANDLE src; /* Source file. */ +{ + char buf[8192]; + DWORD dwRead, dwWrite; + + while (ReadFile(src, buf, sizeof(buf), &dwRead, NULL) != FALSE) { + if (dwRead == 0) { + break; + } + if (WriteFile(dst, buf, dwRead, &dwWrite, NULL) == FALSE) { + break; + } + } +} diff --git a/tcl7.6/win/tclWinPort.h b/tcl7.6/win/tclWinPort.h new file mode 100644 index 0000000..b0d50f2 --- /dev/null +++ b/tcl7.6/win/tclWinPort.h @@ -0,0 +1,406 @@ +/* + * tclWinPort.h -- + * + * This header file handles porting issues that occur because of + * differences between Windows and Unix. It should be the only + * file that contains #ifdefs to handle different flavors of OS. + * + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclWinPort.h 1.41 96/09/30 12:00:36 + */ + +#ifndef _TCLWINPORT +#define _TCLWINPORT + +#include +#include + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#define WIN32_LEAN_AND_MEAN +#include +#undef WIN32_LEAN_AND_MEAN + +/* + * Define EINPROGRESS in terms of WSAEINPROGRESS. + */ + +#ifndef EINPROGRESS +#define EINPROGRESS WSAEINPROGRESS +#endif + +/* + * If ENOTSUP is not defined, define it to a value that will never occur. + */ + +#ifndef ENOTSUP +#define ENOTSUP -1030507 +#endif + +/* + * The following defines denote malloc and free as the system calls + * used to allocate new memory. These defines are only used in the + * file tclCkalloc.c. + */ + +#define TclpAlloc(size) malloc(size) +#define TclpFree(ptr) free(ptr) +#define TclpRealloc(ptr, size) realloc(ptr, size) + +/* + * The default platform eol translation on Windows is TCL_TRANSLATE_CRLF: + */ + +#define TCL_PLATFORM_TRANSLATION TCL_TRANSLATE_CRLF + +/* + * Declare dynamic loading extension macro. + */ + +#define TCL_SHLIB_EXT ".dll" + +/* + * Supply definitions for macros to query wait status, if not already + * defined in header files above. + */ + +#if TCL_UNION_WAIT +# define WAIT_STATUS_TYPE union wait +#else +# define WAIT_STATUS_TYPE int +#endif + +#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 + +/* + * Define constants for waitpid() system call if they aren't defined + * by a system header file. + */ + +#ifndef WNOHANG +# define WNOHANG 1 +#endif +#ifndef WUNTRACED +# define WUNTRACED 2 +#endif + +/* + * Define MAXPATHLEN in terms of MAXPATH if available + */ + +#ifndef MAXPATH +#define MAXPATH MAX_PATH +#endif /* MAXPATH */ + +#ifndef MAXPATHLEN +#define MAXPATHLEN MAXPATH +#endif /* MAXPATHLEN */ + +#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 + +/* + * Define pid_t and uid_t if they're not already defined. + */ + +#if ! TCL_PID_T +# define pid_t int +#endif +#if ! TCL_UID_T +# define uid_t int +#endif + +/* + * Provide an implementation of TclSetSystemEnv in terms of the equivalent + * Win32 call. + */ + +#define TclSetSystemEnv(a,b) SetEnvironmentVariable(a,b) + +/* + * Provide a stub definition for TclGetUserHome(). + */ + +#define TclGetUserHome(name,bufferPtr) (NULL) + +/* + * Visual C++ has some odd names for common functions, so we need to + * define a few macros to handle them. Also, it defines EDEADLOCK and + * EDEADLK as the same value, which confuses Tcl_ErrnoId(). + */ + +#ifdef _MSC_VER +# define environ _environ +# define hypot _hypot +# define exception _exception +# undef EDEADLOCK +#endif /* _MSC_VER */ + +/* + * The following defines redefine the Windows Socket errors as + * BSD errors so Tcl_PosixError can do the right thing. + */ + +#ifndef EWOULDBLOCK +#define EWOULDBLOCK EAGAIN +#endif +#ifndef EALREADY +#define EALREADY 149 /* operation already in progress */ +#endif +#ifndef ENOTSOCK +#define ENOTSOCK 95 /* Socket operation on non-socket */ +#endif +#ifndef EDESTADDRREQ +#define EDESTADDRREQ 96 /* Destination address required */ +#endif +#ifndef EMSGSIZE +#define EMSGSIZE 97 /* Message too long */ +#endif +#ifndef EPROTOTYPE +#define EPROTOTYPE 98 /* Protocol wrong type for socket */ +#endif +#ifndef ENOPROTOOPT +#define ENOPROTOOPT 99 /* Protocol not available */ +#endif +#ifndef EPROTONOSUPPORT +#define EPROTONOSUPPORT 120 /* Protocol not supported */ +#endif +#ifndef ESOCKTNOSUPPORT +#define ESOCKTNOSUPPORT 121 /* Socket type not supported */ +#endif +#ifndef EOPNOTSUPP +#define EOPNOTSUPP 122 /* Operation not supported on socket */ +#endif +#ifndef EPFNOSUPPORT +#define EPFNOSUPPORT 123 /* Protocol family not supported */ +#endif +#ifndef EAFNOSUPPORT +#define EAFNOSUPPORT 124 /* Address family not supported */ +#endif +#ifndef EADDRINUSE +#define EADDRINUSE 125 /* Address already in use */ +#endif +#ifndef EADDRNOTAVAIL +#define EADDRNOTAVAIL 126 /* Can't assign requested address */ +#endif +#ifndef ENETDOWN +#define ENETDOWN 127 /* Network is down */ +#endif +#ifndef ENETUNREACH +#define ENETUNREACH 128 /* Network is unreachable */ +#endif +#ifndef ENETRESET +#define ENETRESET 129 /* Network dropped connection on reset */ +#endif +#ifndef ECONNABORTED +#define ECONNABORTED 130 /* Software caused connection abort */ +#endif +#ifndef ECONNRESET +#define ECONNRESET 131 /* Connection reset by peer */ +#endif +#ifndef ENOBUFS +#define ENOBUFS 132 /* No buffer space available */ +#endif +#ifndef EISCONN +#define EISCONN 133 /* Socket is already connected */ +#endif +#ifndef ENOTCONN +#define ENOTCONN 134 /* Socket is not connected */ +#endif +#ifndef ESHUTDOWN +#define ESHUTDOWN 143 /* Can't send after socket shutdown */ +#endif +#ifndef ETOOMANYREFS +#define ETOOMANYREFS 144 /* Too many references: can't splice */ +#endif +#ifndef ETIMEDOUT +#define ETIMEDOUT 145 /* Connection timed out */ +#endif +#ifndef ECONNREFUSED +#define ECONNREFUSED 146 /* Connection refused */ +#endif +#ifndef ELOOP +#define ELOOP 90 /* Symbolic link loop */ +#endif +#ifndef EHOSTDOWN +#define EHOSTDOWN 147 /* Host is down */ +#endif +#ifndef EHOSTUNREACH +#define EHOSTUNREACH 148 /* No route to host */ +#endif +#ifndef ENOTEMPTY +#define ENOTEMPTY 93 /* directory not empty */ +#endif +#ifndef EUSERS +#define EUSERS 94 /* Too many users (for UFS) */ +#endif +#ifndef EDQUOT +#define EDQUOT 49 /* Disc quota exceeded */ +#endif +#ifndef ESTALE +#define ESTALE 151 /* Stale NFS file handle */ +#endif +#ifndef EREMOTE +#define EREMOTE 66 /* The object is remote */ +#endif + +/* + * The following defines map from standard socket names to our internal + * wrappers that redirect through the winSock function table (see the + * file tclWinSock.c). + */ + +#define getservbyname TclWinGetServByName +#define getsockopt TclWinGetSockOpt +#define ntohs TclWinNToHS +#define setsockopt TclWinSetSockOpt + +/* + * The following implements the Windows method for exiting the process. + */ +#define TclPlatformExit(status) exit(status) + + +/* + * The following declarations belong in tclInt.h, but depend on platform + * specific types (e.g. struct tm). + */ + +EXTERN struct tm * TclpGetDate _ANSI_ARGS_((const time_t *tp, + int useGMT)); +EXTERN size_t TclStrftime _ANSI_ARGS_((char *s, size_t maxsize, + const char *format, const struct tm *t)); + +/* + * Declarations for Windows specific functions. + */ + +EXTERN void TclWinConvertError _ANSI_ARGS_((DWORD errCode)); +EXTERN void TclWinConvertWSAError _ANSI_ARGS_((DWORD errCode)); +EXTERN struct servent * PASCAL FAR + TclWinGetServByName _ANSI_ARGS_((const char FAR *nm, + const char FAR *proto)); +EXTERN int PASCAL FAR TclWinGetSockOpt _ANSI_ARGS_((SOCKET s, int level, + int optname, char FAR * optval, int FAR *optlen)); +EXTERN HINSTANCE TclWinGetTclInstance _ANSI_ARGS_((void)); +EXTERN HINSTANCE TclWinLoadLibrary _ANSI_ARGS_((char *name)); +EXTERN void TclWinNotifySocket _ANSI_ARGS_((void)); +EXTERN u_short PASCAL FAR + TclWinNToHS _ANSI_ARGS_((u_short ns)); +EXTERN int PASCAL FAR TclWinSetSockOpt _ANSI_ARGS_((SOCKET s, int level, + int optname, const char FAR * optval, int optlen)); +EXTERN int TclWinSocketReady _ANSI_ARGS_((Tcl_File file, + int mask)); +EXTERN void TclWinWatchSocket _ANSI_ARGS_((Tcl_File file, + int mask)); +#endif /* _TCLWINPORT */ diff --git a/tcl7.6/win/tclWinSock.c b/tcl7.6/win/tclWinSock.c new file mode 100644 index 0000000..91e8c02 --- /dev/null +++ b/tcl7.6/win/tclWinSock.c @@ -0,0 +1,1684 @@ +/* + * tclWinSock.c -- + * + * This file contains Windows-specific socket related code. + * + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclWinSock.c 1.50 96/10/03 15:01:29 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * The following structure contains pointers to all of the WinSock API entry + * points used by Tcl. It is initialized by InitSockets. Since we + * dynamically load Winsock.dll on demand, we must use this function table + * to refer to functions in the socket API. + */ + +static struct { + SOCKET (PASCAL FAR *accept)(SOCKET s, struct sockaddr FAR *addr, + int FAR *addrlen); + int (PASCAL FAR *bind)(SOCKET s, const struct sockaddr FAR *addr, + int namelen); + int (PASCAL FAR *closesocket)(SOCKET s); + int (PASCAL FAR *connect)(SOCKET s, const struct sockaddr FAR *name, + int namelen); + int (PASCAL FAR *ioctlsocket)(SOCKET s, long cmd, u_long FAR *argp); + int (PASCAL FAR *getsockopt)(SOCKET s, int level, int optname, + char FAR * optval, int FAR *optlen); + u_short (PASCAL FAR *htons)(u_short hostshort); + unsigned long (PASCAL FAR *inet_addr)(const char FAR * cp); + char FAR * (PASCAL FAR *inet_ntoa)(struct in_addr in); + int (PASCAL FAR *listen)(SOCKET s, int backlog); + u_short (PASCAL FAR *ntohs)(u_short netshort); + int (PASCAL FAR *recv)(SOCKET s, char FAR * buf, int len, int flags); + int (PASCAL FAR *send)(SOCKET s, const char FAR * buf, int len, int flags); + int (PASCAL FAR *setsockopt)(SOCKET s, int level, int optname, + const char FAR * optval, int optlen); + int (PASCAL FAR *shutdown)(SOCKET s, int how); + SOCKET (PASCAL FAR *socket)(int af, int type, int protocol); + struct hostent FAR * (PASCAL FAR *gethostbyname)(const char FAR * name); + struct hostent FAR * (PASCAL FAR *gethostbyaddr)(const char FAR *addr, + int addrlen, int addrtype); + int (PASCAL FAR *gethostname)(char FAR * name, int namelen); + int (PASCAL FAR *getpeername)(SOCKET sock, struct sockaddr FAR *name, + int FAR *namelen); + struct servent FAR * (PASCAL FAR *getservbyname)(const char FAR * name, + const char FAR * proto); + int (PASCAL FAR *getsockname)(SOCKET sock, struct sockaddr FAR *name, + int FAR *namelen); + int (PASCAL FAR *WSAStartup)(WORD wVersionRequired, LPWSADATA lpWSAData); + int (PASCAL FAR *WSACleanup)(void); + int (PASCAL FAR *WSAGetLastError)(void); + int (PASCAL FAR *WSAAsyncSelect)(SOCKET s, HWND hWnd, u_int wMsg, + long lEvent); +} winSock; + +/* + * The following define declares a new user message for use on the + * socket window. + */ + +#define SOCKET_MESSAGE WM_USER+1 + +/* + * The following structure is used to store the data associated with + * each socket. A Tcl_File of type TCL_WIN_SOCKET will contain a + * pointer to one of these structures in the clientdata slot. + */ + +typedef struct SocketInfo { + SOCKET socket; /* Windows SOCKET handle. */ + int flags; /* Bit field comprised of the flags + * described below. */ + int watchMask; /* OR'ed combination of TCL_READABLE and + * TCL_WRITABLE as set by Tcl_WatchFile. */ + int eventMask; /* OR'ed combination of FD_READ, FD_WRITE, + * FD_CLOSE, FD_ACCEPT and FD_CONNECT. */ + int occurredMask; /* OR'ed combination of the above flags + * for those events that have actually + * occurred on the socket. */ + Tcl_File file; /* The file handle for the socket. */ + Tcl_TcpAcceptProc *acceptProc; /* Proc to call on accept. */ + ClientData acceptProcData; /* The data for the accept proc. */ + struct SocketInfo *nextPtr; /* The next socket on the global socket + * list. */ +} SocketInfo; + +/* + * This defines the minimum buffersize maintained by the kernel. + */ + +#define TCP_BUFFER_SIZE 4096 + +/* + * The following macros may be used to set the flags field of + * a SocketInfo structure. We leave the first three bits open + * for TCL_READABLE, TCL_WRITABLE and TCL_EXCEPTION + */ + +#define SOCKET_WATCH (1<<4) + /* TclWinWatchSocket has been called since the + * last time we entered Tcl_WaitForEvent. */ +#define SOCKET_REGISTERED (1<<5) + /* A valid WSAAsyncSelect handler is + * registered. */ +#define SOCKET_ASYNCH (1<<6) + /* The socket is in asynch mode. */ +#define SOCKET_CLOSED (1<<7) /* The socket had an FD_CLOSE event. */ +#define SOCKET_EOF (1<<8) /* A zero read happened on the socket. */ + +/* + * Every open socket has an entry on the following list. + */ + +static SocketInfo *socketList = NULL; + +/* + * Static functions defined in this file. + */ + +static void CleanupSockets _ANSI_ARGS_((ClientData clientData)); +static SocketInfo * CreateSocket _ANSI_ARGS_((Tcl_Interp *interp, + int port, char *host, int server, char *myaddr, + int myport, int async)); +static int CreateSocketAddress _ANSI_ARGS_( + (struct sockaddr_in *sockaddrPtr, + char *host, int port)); +static int InitSockets _ANSI_ARGS_((void)); +static SocketInfo * NewSocketInfo _ANSI_ARGS_((Tcl_File file)); +static void SocketFreeProc _ANSI_ARGS_((ClientData clientData)); +static LRESULT CALLBACK SocketProc _ANSI_ARGS_((HWND hwnd, UINT message, + WPARAM wParam, LPARAM lParam)); +static void TcpAccept _ANSI_ARGS_((ClientData data, int mask)); +static int TcpCloseProc _ANSI_ARGS_((ClientData instanceData, + Tcl_Interp *interp)); +static int TcpGetOptionProc _ANSI_ARGS_((ClientData instanceData, + char *optionName, Tcl_DString *optionValue)); +static int TcpInputProc _ANSI_ARGS_((ClientData instanceData, + char *buf, int toRead, int *errorCode)); +static int TcpOutputProc _ANSI_ARGS_((ClientData instanceData, + char *buf, int toWrite, int *errorCode)); +static void TcpWatchProc _ANSI_ARGS_((ClientData instanceData, + int mask)); +static int TcpReadyProc _ANSI_ARGS_((ClientData instanceData, + int mask)); +static Tcl_File TcpGetProc _ANSI_ARGS_((ClientData instanceData, + int direction)); + +/* + * This structure describes the channel type structure for TCP socket + * based IO. + */ + +static Tcl_ChannelType tcpChannelType = { + "tcp", /* Type name. */ + NULL, /* Block: Not used. */ + TcpCloseProc, /* Close proc. */ + TcpInputProc, /* Input proc. */ + TcpOutputProc, /* Output proc. */ + NULL, /* Seek proc. */ + NULL, /* Set option proc. */ + TcpGetOptionProc, /* Get option proc. */ + TcpWatchProc, /* Initialize notifier to watch this channel. */ + TcpReadyProc, /* Are events present? */ + TcpGetProc, /* Get a Tcl_File from channel. */ +}; + +/* + * Socket notification window. This window is used to receive socket + * notification events. + */ + +static HWND socketWindow = NULL; + +/* + * Window class for creating the socket notification window. + */ + +static ATOM socketClass; + +/* + * Define version of Winsock required by Tcl. + */ + +#define WSA_VERSION_REQD MAKEWORD(1,1) + +/* + *---------------------------------------------------------------------- + * + * InitSockets -- + * + * Initialize the socket module. Attempts to load the wsock32.dll + * library and set up the winSock function table. If successful, + * registers the event window for the socket notifier code. + * + * Results: + * Returns 1 on successful initialization, 0 on failure. + * + * Side effects: + * Dynamically loads wsock32.dll, and registers a new window + * class and creates a window for use in asynchronous socket + * notification. + * + *---------------------------------------------------------------------- + */ + +static int +InitSockets() +{ + WSADATA wsaData; + WNDCLASS class; + HINSTANCE handle; + + /* + * Load the socket DLL and initialize the function table. + */ + + handle = TclWinLoadLibrary("wsock32.dll"); + if (handle != NULL) { + winSock.accept = (SOCKET (PASCAL FAR *)(SOCKET s, + struct sockaddr FAR *addr, int FAR *addrlen)) + GetProcAddress(handle, "accept"); + winSock.bind = (int (PASCAL FAR *)(SOCKET s, + const struct sockaddr FAR *addr, int namelen)) + GetProcAddress(handle, "bind"); + winSock.closesocket = (int (PASCAL FAR *)(SOCKET s)) + GetProcAddress(handle, "closesocket"); + winSock.connect = (int (PASCAL FAR *)(SOCKET s, + const struct sockaddr FAR *name, int namelen)) + GetProcAddress(handle, "connect"); + winSock.ioctlsocket = (int (PASCAL FAR *)(SOCKET s, long cmd, + u_long FAR *argp)) GetProcAddress(handle, "ioctlsocket"); + winSock.getsockopt = (int (PASCAL FAR *)(SOCKET s, + int level, int optname, char FAR * optval, int FAR *optlen)) + GetProcAddress(handle, "getsockopt"); + winSock.htons = (u_short (PASCAL FAR *)(u_short hostshort)) + GetProcAddress(handle, "htons"); + winSock.inet_addr = (unsigned long (PASCAL FAR *)(const char FAR *cp)) + GetProcAddress(handle, "inet_addr"); + winSock.inet_ntoa = (char FAR * (PASCAL FAR *)(struct in_addr in)) + GetProcAddress(handle, "inet_ntoa"); + winSock.listen = (int (PASCAL FAR *)(SOCKET s, int backlog)) + GetProcAddress(handle, "listen"); + winSock.ntohs = (u_short (PASCAL FAR *)(u_short netshort)) + GetProcAddress(handle, "ntohs"); + winSock.recv = (int (PASCAL FAR *)(SOCKET s, char FAR * buf, + int len, int flags)) GetProcAddress(handle, "recv"); + winSock.send = (int (PASCAL FAR *)(SOCKET s, const char FAR * buf, + int len, int flags)) GetProcAddress(handle, "send"); + winSock.setsockopt = (int (PASCAL FAR *)(SOCKET s, int level, + int optname, const char FAR * optval, int optlen)) + GetProcAddress(handle, "setsockopt"); + winSock.shutdown = (int (PASCAL FAR *)(SOCKET s, int how)) + GetProcAddress(handle, "shutdown"); + winSock.socket = (SOCKET (PASCAL FAR *)(int af, int type, + int protocol)) GetProcAddress(handle, "socket"); + winSock.gethostbyaddr = (struct hostent FAR * (PASCAL FAR *) + (const char FAR *addr, int addrlen, int addrtype)) + GetProcAddress(handle, "gethostbyaddr"); + winSock.gethostbyname = (struct hostent FAR * (PASCAL FAR *) + (const char FAR *name)) + GetProcAddress(handle, "gethostbyname"); + winSock.gethostname = (int (PASCAL FAR *)(char FAR * name, + int namelen)) GetProcAddress(handle, "gethostname"); + winSock.getpeername = (int (PASCAL FAR *)(SOCKET sock, + struct sockaddr FAR *name, int FAR *namelen)) + GetProcAddress(handle, "getpeername"); + winSock.getservbyname = (struct servent FAR * (PASCAL FAR *) + (const char FAR * name, const char FAR * proto)) + GetProcAddress(handle, "getservbyname"); + winSock.getsockname = (int (PASCAL FAR *)(SOCKET sock, + struct sockaddr FAR *name, int FAR *namelen)) + GetProcAddress(handle, "getsockname"); + winSock.WSAStartup = (int (PASCAL FAR *)(WORD wVersionRequired, + LPWSADATA lpWSAData)) GetProcAddress(handle, "WSAStartup"); + winSock.WSACleanup = (int (PASCAL FAR *)(void)) + GetProcAddress(handle, "WSACleanup"); + winSock.WSAGetLastError = (int (PASCAL FAR *)(void)) + GetProcAddress(handle, "WSAGetLastError"); + winSock.WSAAsyncSelect = (int (PASCAL FAR *)(SOCKET s, HWND hWnd, + u_int wMsg, long lEvent)) + GetProcAddress(handle, "WSAAsyncSelect"); + } + + /* + * Initialize the winsock library and check the version number. + */ + + if ((*winSock.WSAStartup)(WSA_VERSION_REQD, &wsaData) != 0) { + return 0; + } + if (wsaData.wVersion != WSA_VERSION_REQD) { + (*winSock.WSACleanup)(); + return 0; + } + + /* + * Register the async notification window class and window. + */ + + class.style = 0; + class.cbClsExtra = 0; + class.cbWndExtra = 0; + class.hInstance = TclWinGetTclInstance(); + class.hbrBackground = NULL; + class.lpszMenuName = NULL; + class.lpszClassName = "TclSocket"; + class.lpfnWndProc = SocketProc; + class.hIcon = NULL; + class.hCursor = NULL; + + socketClass = RegisterClass(&class); + if (!socketClass) { + TclWinConvertError(GetLastError()); + (*winSock.WSACleanup)(); + return 0; + } + socketWindow = CreateWindowEx(0, (LPCTSTR)socketClass, "TclSocket", + WS_OVERLAPPED, 0, 0, 0, 0, NULL, NULL, + TclWinGetTclInstance(), NULL); + if (socketWindow == NULL) { + TclWinConvertError(GetLastError()); + UnregisterClass((LPCTSTR)socketClass, TclWinGetTclInstance()); + (*winSock.WSACleanup)(); + return 0; + } + + Tcl_CreateExitHandler(CleanupSockets, (ClientData) NULL); + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * CleanupSockets -- + * + * Callback invoked during exit clean up to release the WinSock + * DLL. + * + * Results: + * None. + * + * Side effects: + * Releases the WinSock DLL. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +CleanupSockets(clientData) + ClientData clientData; /* Not used. */ +{ + DestroyWindow(socketWindow); + UnregisterClass((LPCTSTR)socketClass, TclWinGetTclInstance()); + (*winSock.WSACleanup)(); +} + +/* + *---------------------------------------------------------------------- + * + * TcpCloseProc -- + * + * This procedure is called by the generic IO level to perform + * channel type specific cleanup on a socket based channel + * when the channel is closed. + * + * Results: + * 0 if successful, the value of errno if failed. + * + * Side effects: + * Closes the socket. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TcpCloseProc(instanceData, interp) + ClientData instanceData; /* The socket to close. */ + Tcl_Interp *interp; /* Unused. */ +{ + SocketInfo *infoPtr = (SocketInfo *) instanceData; + int errorCode = 0; + + /* + * Clean up the OS socket handle. + */ + + (void) ((*winSock.shutdown)(infoPtr->socket, 2)); + if ((*winSock.closesocket)(infoPtr->socket) == SOCKET_ERROR) { + TclWinConvertWSAError((*winSock.WSAGetLastError)()); + errorCode = errno; + } + + /* + * Delete a file handler that may be active for this socket. + * Channel handlers are already deleted in the generic IO close + * code which called this function. + */ + + Tcl_DeleteFileHandler(infoPtr->file); + + /* + * Free the file handle. As a side effect, this will call the + * SocketFreeProc to release the SocketInfo associated with this file. + */ + + Tcl_FreeFile(infoPtr->file); + + return errorCode; +} + +/* + *---------------------------------------------------------------------- + * + * SocketFreeProc -- + * + * This callback is invoked by Tcl_FreeFile in order to delete + * the notifier data associated with a file handle. + * + * Results: + * None. + * + * Side effects: + * Removes the SocketInfo from the global socket list. + * + *---------------------------------------------------------------------- + */ + +static void +SocketFreeProc(clientData) + ClientData clientData; +{ + SocketInfo *infoPtr = (SocketInfo *) clientData; + + /* + * Remove the socket from socketList. + */ + + if (infoPtr == socketList) { + socketList = infoPtr->nextPtr; + } else { + SocketInfo *p; + for (p = socketList; p != NULL; p = p->nextPtr) { + if (p->nextPtr == infoPtr) { + p->nextPtr = infoPtr->nextPtr; + break; + } + } + } + ckfree((char *) infoPtr); +} + +/* + *---------------------------------------------------------------------- + * + * NewSocketInfo -- + * + * This function allocates and initializes a new SocketInfo + * structure. + * + * Results: + * Returns a newly allocated SocketInfo. + * + * Side effects: + * Adds the socket to the global socket list. + * + *---------------------------------------------------------------------- + */ + +static SocketInfo * +NewSocketInfo(file) + Tcl_File file; +{ + SocketInfo *infoPtr; + + infoPtr = (SocketInfo *) ckalloc((unsigned) sizeof(SocketInfo)); + infoPtr->socket = (SOCKET) Tcl_GetFileInfo(file, NULL); + infoPtr->flags = 0; + infoPtr->watchMask = 0; + infoPtr->eventMask = 0; + infoPtr->occurredMask = 0; + infoPtr->file = file; + infoPtr->acceptProc = NULL; + infoPtr->nextPtr = socketList; + socketList = infoPtr; + + Tcl_SetNotifierData(file, SocketFreeProc, (ClientData) infoPtr); + return infoPtr; +} + +/* + *---------------------------------------------------------------------- + * + * CreateSocket -- + * + * This function opens a new socket and initializes the + * SocketInfo structure. + * + * Results: + * Returns a new SocketInfo, or NULL with an error in interp. + * + * Side effects: + * Adds a new socket to the socketList. + * + *---------------------------------------------------------------------- + */ + +static SocketInfo * +CreateSocket(interp, port, host, server, myaddr, myport, async) + Tcl_Interp *interp; /* For error reporting; can be NULL. */ + int port; /* Port number to open. */ + char *host; /* Name of host on which to open port. */ + int server; /* 1 if socket should be a server socket, + * else 0 for a client socket. */ + char *myaddr; /* Optional client-side address */ + int myport; /* Optional client-side port */ + int async; /* If nonzero, connect client socket + * asynchronously. Unused. */ +{ + int status; + struct sockaddr_in sockaddr; /* Socket address */ + struct sockaddr_in mysockaddr; /* Socket address for client */ + SOCKET sock; + + if (! CreateSocketAddress(&sockaddr, host, port)) { + goto addressError; + } + if ((myaddr != NULL || myport != 0) && + ! CreateSocketAddress(&mysockaddr, myaddr, myport)) { + goto addressError; + } + + sock = (*winSock.socket)(AF_INET, SOCK_STREAM, 0); + if (sock == INVALID_SOCKET) { + goto addressError; + } + + /* + * Set kernel space buffering + */ + + TclSockMinimumBuffers(sock, TCP_BUFFER_SIZE); + + if (server) { + /* + * Bind to the specified port. Note that we must not call setsockopt + * with SO_REUSEADDR because Microsoft allows addresses to be reused + * even if they are still in use. + */ + + status = (*winSock.bind)(sock, (struct sockaddr *) &sockaddr, + sizeof(sockaddr)); + if (status != SOCKET_ERROR) { + (*winSock.listen)(sock, 5); + } + } else { + if (myaddr != NULL || myport != 0) { + status = (*winSock.bind)(sock, (struct sockaddr *) &mysockaddr, + sizeof(struct sockaddr)); + if (status < 0) { + goto bindError; + } + } + status = (*winSock.connect)(sock, (struct sockaddr *) &sockaddr, + sizeof(sockaddr)); + } + if (status != SOCKET_ERROR) { + u_long flag = 1; + status = (*winSock.ioctlsocket)(sock, FIONBIO, &flag); + } + +bindError: + if (status == SOCKET_ERROR) { + TclWinConvertWSAError((*winSock.WSAGetLastError)()); + if (interp != NULL) { + Tcl_AppendResult(interp, "couldn't open socket: ", + Tcl_PosixError(interp), (char *) NULL); + } + (*winSock.closesocket)(sock); + return NULL; + } + + /* + * Add this socket to the global list of sockets. + */ + + return NewSocketInfo(Tcl_GetFile((ClientData) sock, TCL_WIN_SOCKET)); + +addressError: + TclWinConvertWSAError((*winSock.WSAGetLastError)()); + if (interp != NULL) { + Tcl_AppendResult(interp, "couldn't open socket: ", + Tcl_PosixError(interp), (char *) NULL); + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * CreateSocketAddress -- + * + * This function initializes a sockaddr structure for a host and port. + * + * Results: + * 1 if the host was valid, 0 if the host could not be converted to + * an IP address. + * + * Side effects: + * Fills in the *sockaddrPtr structure. + * + *---------------------------------------------------------------------- + */ + +static int +CreateSocketAddress(sockaddrPtr, host, port) + struct sockaddr_in *sockaddrPtr; /* Socket address */ + char *host; /* Host. NULL implies INADDR_ANY */ + int port; /* Port number */ +{ + struct hostent *hostent; /* Host database entry */ + struct in_addr addr; /* For 64/32 bit madness */ + + (void) memset((char *) sockaddrPtr, '\0', sizeof(struct sockaddr_in)); + sockaddrPtr->sin_family = AF_INET; + sockaddrPtr->sin_port = (*winSock.htons)((short) (port & 0xFFFF)); + if (host == NULL) { + addr.s_addr = INADDR_ANY; + } else { + addr.s_addr = (*winSock.inet_addr)(host); + if (addr.s_addr == INADDR_NONE) { + hostent = (*winSock.gethostbyname)(host); + if (hostent != NULL) { + memcpy((char *) &addr, + (char *) hostent->h_addr_list[0], + (size_t) hostent->h_length); + } else { +#ifdef EHOSTUNREACH + errno = EHOSTUNREACH; +#else +#ifdef ENXIO + errno = ENXIO; +#endif +#endif + return 0; /* Error. */ + } + } + } + + /* + * NOTE: On 64 bit machines the assignment below is rumored to not + * do the right thing. Please report errors related to this if you + * observe incorrect behavior on 64 bit machines such as DEC Alphas. + * Should we modify this code to do an explicit memcpy? + */ + + sockaddrPtr->sin_addr.s_addr = addr.s_addr; + return 1; /* Success. */ +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_OpenTcpClient -- + * + * Opens a TCP client socket and creates a channel around it. + * + * Results: + * The channel or NULL if failed. An error message is returned + * in the interpreter on failure. + * + * Side effects: + * Opens a client socket and creates a new channel. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async) + Tcl_Interp *interp; /* For error reporting; can be NULL. */ + int port; /* Port number to open. */ + char *host; /* Host on which to open port. */ + char *myaddr; /* Client-side address */ + int myport; /* Client-side port */ + int async; /* If nonzero, should connect + * client socket asynchronously. */ +{ + Tcl_Channel chan; + SocketInfo *infoPtr; + char channelName[20]; + + if (TclHasSockets(interp) != TCL_OK) { + return NULL; + } + + /* + * Create a new client socket and wrap it in a channel. + */ + + infoPtr = CreateSocket(interp, port, host, 0, myaddr, myport, async); + if (infoPtr == NULL) { + return NULL; + } + + sprintf(channelName, "sock%d", infoPtr->socket); + + chan = Tcl_CreateChannel(&tcpChannelType, channelName, + (ClientData) infoPtr, (TCL_READABLE | TCL_WRITABLE)); + if (Tcl_SetChannelOption(interp, chan, "-translation", "auto crlf") == + TCL_ERROR) { + Tcl_Close((Tcl_Interp *) NULL, chan); + return (Tcl_Channel) NULL; + } + if (Tcl_SetChannelOption(NULL, chan, "-eofchar", "") == TCL_ERROR) { + Tcl_Close((Tcl_Interp *) NULL, chan); + return (Tcl_Channel) NULL; + } + return chan; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_MakeTcpClientChannel -- + * + * Creates a Tcl_Channel from an existing client TCP socket. + * + * Results: + * The Tcl_Channel wrapped around the preexisting TCP socket. + * + * Side effects: + * None. + * + * NOTE: Code contributed by Mark Diekhans (markd@grizzly.com) + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_MakeTcpClientChannel(sock) + ClientData sock; /* The socket to wrap up into a channel. */ +{ + SocketInfo *infoPtr; + char channelName[20]; + Tcl_Channel chan; + int flag = 1; + + if (TclHasSockets(NULL) != TCL_OK) { + return NULL; + } + + /* + * Set kernel space buffering and non-blocking. + */ + + TclSockMinimumBuffers((SOCKET) sock, TCP_BUFFER_SIZE); + + if ((*winSock.ioctlsocket)((SOCKET)sock, FIONBIO, &flag) == SOCKET_ERROR) { + TclWinConvertWSAError ((*winSock.WSAGetLastError)()); + return NULL; + } + + infoPtr = NewSocketInfo (Tcl_GetFile((ClientData) sock, + TCL_WIN_SOCKET)); + + sprintf(channelName, "sock%d", infoPtr->socket); + + chan = Tcl_CreateChannel(&tcpChannelType, channelName, + (ClientData) infoPtr, (TCL_READABLE | TCL_WRITABLE)); + if (Tcl_SetChannelOption((Tcl_Interp *) NULL, chan, + "-translation", "auto crlf") == + TCL_ERROR) { + Tcl_Close((Tcl_Interp *) NULL, chan); + return (Tcl_Channel) NULL; + } + if (Tcl_SetChannelOption(NULL, chan, "-eofchar", "") == TCL_ERROR) { + Tcl_Close((Tcl_Interp *) NULL, chan); + return (Tcl_Channel) NULL; + } + return chan; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_OpenTcpServer -- + * + * Opens a TCP server socket and creates a channel around it. + * + * Results: + * The channel or NULL if failed. An error message is returned + * in the interpreter on failure. + * + * Side effects: + * Opens a server socket and creates a new channel. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_OpenTcpServer(interp, port, host, acceptProc, acceptProcData) + Tcl_Interp *interp; /* For error reporting - may be + * NULL. */ + int port; /* Port number to open. */ + char *host; /* Name of local host. */ + Tcl_TcpAcceptProc *acceptProc; /* Callback for accepting connections + * from new clients. */ + ClientData acceptProcData; /* Data for the callback. */ +{ + Tcl_Channel chan; + SocketInfo *infoPtr; + char channelName[20]; + + if (TclHasSockets(interp) != TCL_OK) { + return NULL; + } + + /* + * Create a new client socket and wrap it in a channel. + */ + + infoPtr = CreateSocket(interp, port, host, 1, NULL, 0, 0); + if (infoPtr == NULL) { + return NULL; + } + + infoPtr->acceptProc = acceptProc; + infoPtr->acceptProcData = acceptProcData; + + /* + * Set up the callback mechanism for accepting connections + * from new clients. The caller will use Tcl_TcpRegisterCallback + * to register a callback to call when a new connection is + * accepted. + */ + + Tcl_CreateFileHandler(infoPtr->file, TCL_READABLE, TcpAccept, + (ClientData) infoPtr); + + sprintf(channelName, "sock%d", infoPtr->socket); + + chan = Tcl_CreateChannel(&tcpChannelType, channelName, + (ClientData) infoPtr, 0); + if (Tcl_SetChannelOption(interp, chan, "-eofchar", "") == TCL_ERROR) { + Tcl_Close((Tcl_Interp *) NULL, chan); + return (Tcl_Channel) NULL; + } + + return chan; +} + +/* + *---------------------------------------------------------------------- + * + * TcpAccept -- + * Accept a TCP socket connection. This is called by the event loop, + * and it in turns calls any registered callbacks for this channel. + * + * Results: + * None. + * + * Side effects: + * Evals the Tcl script associated with the server socket. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +TcpAccept(data, mask) + ClientData data; /* Callback token. */ + int mask; /* Not used. */ +{ + SOCKET newSocket; + SocketInfo *infoPtr = (SocketInfo *) data; + SocketInfo *newInfoPtr; + struct sockaddr_in addr; + int len; + Tcl_Channel chan; + char channelName[20]; + u_long flag = 1; + + len = sizeof(struct sockaddr_in); + newSocket = (*winSock.accept)(infoPtr->socket, (struct sockaddr *)&addr, + &len); + + infoPtr->flags= (~(TCL_READABLE)); + + if (newSocket == INVALID_SOCKET) { + return; + } + + /* + * Clear the inherited event mask. + */ + + (*winSock.WSAAsyncSelect)(newSocket, socketWindow, 0, 0); + + /* + * Set the socket into non-blocking mode. + */ + + if ((*winSock.ioctlsocket)(newSocket, FIONBIO, &flag) != 0) { + (*winSock.closesocket)(newSocket); + return; + } + + /* + * Add this socket to the global list of sockets. + */ + + newInfoPtr = NewSocketInfo(Tcl_GetFile((ClientData) newSocket, + TCL_WIN_SOCKET)); + + + sprintf(channelName, "sock%d", newSocket); + chan = Tcl_CreateChannel(&tcpChannelType, channelName, + (ClientData) newInfoPtr, (TCL_READABLE | TCL_WRITABLE)); + if (Tcl_SetChannelOption(NULL, chan, "-translation", "auto crlf") == + TCL_ERROR) { + Tcl_Close((Tcl_Interp *) NULL, chan); + return; + } + if (Tcl_SetChannelOption(NULL, chan, "-eofchar", "") == TCL_ERROR) { + Tcl_Close((Tcl_Interp *) NULL, chan); + return; + } + + /* + * Invoke the accept callback procedure. + */ + + if (infoPtr->acceptProc != NULL) { + (infoPtr->acceptProc) (infoPtr->acceptProcData, chan, + (*winSock.inet_ntoa)(addr.sin_addr), + (*winSock.ntohs)(addr.sin_port)); + } +} + +/* + *---------------------------------------------------------------------- + * + * TcpInputProc -- + * + * This procedure is called by the generic IO level to read data from + * a socket based channel. + * + * Results: + * The number of bytes read or -1 on error. + * + * Side effects: + * Consumes input from the socket. + * + *---------------------------------------------------------------------- + */ + +static int +TcpInputProc(instanceData, buf, toRead, errorCodePtr) + ClientData instanceData; /* The socket state. */ + char *buf; /* Where to store data. */ + int toRead; /* Maximum number of bytes to read. */ + int *errorCodePtr; /* Where to store error codes. */ +{ + SocketInfo *infoPtr = (SocketInfo *) instanceData; + int bytesRead; + + *errorCodePtr = 0; + + /* + * First check to see if EOF was already detected, to prevent + * calling the socket stack after the first time EOF is detected. + */ + + if (infoPtr->flags & SOCKET_EOF) { + return 0; + } + + /* + * No EOF yet, so try to read more from the socket. + */ + + bytesRead = (*winSock.recv)(infoPtr->socket, buf, toRead, 0); + if (bytesRead == SOCKET_ERROR) { + TclWinConvertWSAError((*winSock.WSAGetLastError)()); + *errorCodePtr = errno; + bytesRead = -1; + } + + /* + * Ensure that the socket stays readable until we get either an EWOULDBLOCK + * or a zero sized read. + */ + + if (errno == EWOULDBLOCK) { + infoPtr->flags &= (~(TCL_READABLE)); + } else if (bytesRead == 0) { + infoPtr->flags |= SOCKET_EOF; + } else { + infoPtr->flags |= TCL_READABLE; + } + + return bytesRead; +} + +/* + *---------------------------------------------------------------------- + * + * TcpOutputProc -- + * + * This procedure is called by the generic IO level to write data + * to a socket based channel. + * + * Results: + * The number of bytes written or -1 on failure. + * + * Side effects: + * Produces output on the socket. + * + *---------------------------------------------------------------------- + */ + +static int +TcpOutputProc(instanceData, buf, toWrite, errorCodePtr) + ClientData instanceData; /* The socket state. */ + char *buf; /* Where to get data. */ + int toWrite; /* Maximum number of bytes to write. */ + int *errorCodePtr; /* Where to store error codes. */ +{ + SocketInfo *infoPtr = (SocketInfo *) instanceData; + int bytesWritten; + + *errorCodePtr = 0; + bytesWritten = (*winSock.send)(infoPtr->socket, buf, toWrite, 0); + if (bytesWritten == SOCKET_ERROR) { + TclWinConvertWSAError((*winSock.WSAGetLastError)()); + if (errno == EWOULDBLOCK) { + infoPtr->flags &= (~(TCL_WRITABLE)); + } + *errorCodePtr = errno; + return -1; + } + + /* + * Clear the writable bit in the flags. If an async handler + * is still registered for this socket, then it will generate a new + * event if there is still data available. When the event is + * processed, the readable bit will be turned back on. + */ + + infoPtr->flags &= (~(TCL_WRITABLE)); + + return bytesWritten; +} + +/* + *---------------------------------------------------------------------- + * + * TcpGetOptionProc -- + * + * Computes an option value for a TCP socket based channel, or a + * list of all options and their values. + * + * Note: This code is based on code contributed by John Haxby. + * + * Results: + * A standard Tcl result. The value of the specified option or a + * list of all options and their values is returned in the + * supplied DString. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TcpGetOptionProc(instanceData, optionName, dsPtr) + ClientData instanceData; /* Socket state. */ + char *optionName; /* Name of the option to + * retrieve the value for, or + * NULL to get all options and + * their values. */ + Tcl_DString *dsPtr; /* Where to store the computed + * value; initialized by caller. */ +{ + SocketInfo *infoPtr; + struct sockaddr_in sockname; + struct sockaddr_in peername; + struct hostent *hostEntPtr; + SOCKET sock; + int size = sizeof(struct sockaddr_in); + size_t len = 0; + char buf[128]; + + infoPtr = (SocketInfo *) instanceData; + sock = (int) infoPtr->socket; + if (optionName != (char *) NULL) { + len = strlen(optionName); + } + + if ((len == 0) || + ((len > 1) && (optionName[1] == 'p') && + (strncmp(optionName, "-peername", len) == 0))) { + if ((*winSock.getpeername)(sock, (struct sockaddr *) &peername, &size) + >= 0) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-peername"); + Tcl_DStringStartSublist(dsPtr); + } + Tcl_DStringAppendElement(dsPtr, + (*winSock.inet_ntoa)(peername.sin_addr)); + hostEntPtr = (*winSock.gethostbyaddr)( + (char *) &(peername.sin_addr), sizeof(peername.sin_addr), + AF_INET); + if (hostEntPtr != (struct hostent *) NULL) { + Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name); + } else { + Tcl_DStringAppendElement(dsPtr, + (*winSock.inet_ntoa)(peername.sin_addr)); + } + sprintf(buf, "%d", (*winSock.ntohs)(peername.sin_port)); + Tcl_DStringAppendElement(dsPtr, buf); + if (len == 0) { + Tcl_DStringEndSublist(dsPtr); + } else { + return TCL_OK; + } + } + } + + if ((len == 0) || + ((len > 1) && (optionName[1] == 's') && + (strncmp(optionName, "-sockname", len) == 0))) { + if ((*winSock.getsockname)(sock, (struct sockaddr *) &sockname, &size) + >= 0) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-sockname"); + Tcl_DStringStartSublist(dsPtr); + } + Tcl_DStringAppendElement(dsPtr, + (*winSock.inet_ntoa)(sockname.sin_addr)); + hostEntPtr = (*winSock.gethostbyaddr)( + (char *) &(sockname.sin_addr), sizeof(peername.sin_addr), + AF_INET); + if (hostEntPtr != (struct hostent *) NULL) { + Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name); + } else { + Tcl_DStringAppendElement(dsPtr, + (*winSock.inet_ntoa)(sockname.sin_addr)); + } + sprintf(buf, "%d", (*winSock.ntohs)(sockname.sin_port)); + Tcl_DStringAppendElement(dsPtr, buf); + if (len == 0) { + Tcl_DStringEndSublist(dsPtr); + } else { + return TCL_OK; + } + } + } + + if (len > 0) { + Tcl_SetErrno(EINVAL); + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TcpWatchProc -- + * + * Initialize the notifier to watch Tcl_Files from this channel. + * + * Results: + * None. + * + * Side effects: + * Sets up the notifier so that a future event on the channel will + * be seen by Tcl. + * + *---------------------------------------------------------------------- + */ + +static void +TcpWatchProc(instanceData, mask) + ClientData instanceData; /* The socket state. */ + int mask; /* Events of interest; an OR-ed + * combination of TCL_READABLE, + * TCL_WRITABEL and TCL_EXCEPTION. */ +{ + SocketInfo *infoPtr = (SocketInfo *) instanceData; + + Tcl_WatchFile(infoPtr->file, mask); +} + +/* + *---------------------------------------------------------------------- + * + * TcpReadyProc -- + * + * Called by the notifier to check whether events of interest are + * present on the channel. + * + * Results: + * Returns OR-ed combination of TCL_READABLE, TCL_WRITABLE and + * TCL_EXCEPTION to indicate which events of interest are present. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TcpReadyProc(instanceData, mask) + ClientData instanceData; /* The socket state. */ + int mask; /* Events of interest; an OR-ed + * combination of TCL_READABLE, + * TCL_WRITABLE and TCL_EXCEPTION. */ +{ + SocketInfo *infoPtr = (SocketInfo *) instanceData; + + return Tcl_FileReady(infoPtr->file, mask); +} + +/* + *---------------------------------------------------------------------- + * + * TcpGetProc -- + * + * Called from Tcl_GetChannelFile to retrieve Tcl_Files from inside + * a TCP socket based channel. + * + * Results: + * The appropriate Tcl_File or NULL if not present. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static Tcl_File +TcpGetProc(instanceData, direction) + ClientData instanceData; /* The socket state. */ + int direction; /* Which Tcl_File to retrieve? */ +{ + SocketInfo *statePtr = (SocketInfo *) instanceData; + + return statePtr->file; +} + +/* + *---------------------------------------------------------------------- + * + * TclWinWatchSocket -- + * + * This function imlements the socket specific portion of the + * Tcl_WatchFile function in the notifier. + * + * Results: + * None. + * + * Side effects: + * The watched socket will be placed into non-blocking mode, and + * an entry on the asynch handler list will be created if necessary. + * + *---------------------------------------------------------------------- + */ + +void +TclWinWatchSocket(file, mask) + Tcl_File file; /* Socket to watch. */ + int mask; /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, and TCL_EXCEPTION: + * indicates conditions to wait for + * in select. */ +{ + SocketInfo *infoPtr = (SocketInfo *) Tcl_GetNotifierData(file, NULL); + Tcl_Time dontBlock; + + dontBlock.sec = 0; dontBlock.usec = 0; + + /* + * Create socket info on demand if necessary. We should only enter this + * code if the socket was created outside of Tcl. Since this may be + * the first time that the socket code has been called, we need to invoke + * TclHasSockets to ensure that everything is initialized properly. + */ + + if (infoPtr == NULL) { + if (TclHasSockets(NULL) != TCL_OK) { + return; + } + infoPtr = NewSocketInfo(file); + } + + infoPtr->flags |= SOCKET_WATCH; + + /* + * If the new mask includes more conditions than the current mask, + * then we mark the socket as unregistered so it will be reregistered + * the next time we enter Tcl_WaitForEvent. + */ + + mask |= infoPtr->watchMask; + if (infoPtr->watchMask != mask) { + infoPtr->flags &= (~(SOCKET_REGISTERED)); + infoPtr->watchMask = mask; + } + + /* + * Check if any bits are set on the flags. If there are, this + * means that the socket already had events on it, and we need to + * check it immediately. To do this, set the maximum block time to + * zero. + */ + + if ((infoPtr->flags & (TCL_READABLE|TCL_WRITABLE|TCL_EXCEPTION)) != 0) { + Tcl_SetMaxBlockTime(&dontBlock); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclWinNotifySocket -- + * + * Set up event notifiers for any sockets that are being watched. + * Also, clean up any sockets that are no longer being watched. + * + * Results: + * None. + * + * Side effects: + * Adds and removes asynch select handlers. + * + *---------------------------------------------------------------------- + */ + +void +TclWinNotifySocket() +{ + SocketInfo *infoPtr; + + if (socketList == NULL) { + return; + } + + /* + * Establish or remove any notifiers. + */ + + for (infoPtr = socketList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { + if (infoPtr->flags & SOCKET_WATCH) { + if (!(infoPtr->flags & SOCKET_REGISTERED)) { + int events = 0; + + if (infoPtr->watchMask & TCL_READABLE) { + events |= (FD_READ | FD_ACCEPT | FD_CLOSE); + } + if (infoPtr->watchMask & TCL_WRITABLE) { + events |= (FD_WRITE | FD_CONNECT); + } + + /* + * If we are interested in any events, mark the + * socket as registered. + */ + + if (events != 0) { + infoPtr->flags |= SOCKET_REGISTERED; + } + + /* + * If the new event interest mask does not match what is + * currently set into the socket, set the new mask. + */ + + if (events != infoPtr->eventMask) { + infoPtr->eventMask = events; + (*winSock.WSAAsyncSelect)(infoPtr->socket, socketWindow, + SOCKET_MESSAGE, events); + } + + } + } else { + + /* + * We are no longer supposed to be watching this socket. Remove + * its registration and remember that we are not interested in + * any events on it. + */ + + if (infoPtr->flags & SOCKET_REGISTERED) { + infoPtr->flags &= ~(SOCKET_REGISTERED); + infoPtr->eventMask = 0; + (*winSock.WSAAsyncSelect)(infoPtr->socket, socketWindow, 0, 0); + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TclWinSocketReady -- + * + * This function is invoked by Tcl_FileReady to check whether + * the specified conditions are present on a socket. + * + * Results: + * The return value is 0 if none of the conditions specified by + * mask were true for socket the last time the system checked. + * If any of the conditions were true, then the return value is a + * mask of those that were true. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclWinSocketReady(file, mask) + Tcl_File file; /* File handle for a stream. */ + int mask; /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, and TCL_EXCEPTION: + * indicates conditions caller cares about. */ +{ + SocketInfo *infoPtr = (SocketInfo *) Tcl_GetNotifierData(file, NULL); + int result, status, occurred; + u_long nBytes; + + result = (infoPtr->flags & mask); + occurred = infoPtr->occurredMask; + infoPtr->occurredMask = 0; + infoPtr->flags &= (~(SOCKET_WATCH)); + + if (result & TCL_READABLE) { + + /* + * Must check for readability condition still being present on the + * socket, because someone might have consumed the data in the + * meantime. If we are accepting on the socket or it got closed, + * the socket is readable. + */ + + if (occurred & FD_ACCEPT) { + /* Empty body. */ + } else if (occurred & FD_CLOSE) { + /* Remember the FD_CLOSE event. */ + infoPtr->flags |= SOCKET_CLOSED; + } else { + + /* + * Otherwise it is readable only if there is data present. + * NOTE: We do not really care whether FD_READ happened.. + */ + + status = (*winSock.ioctlsocket)(infoPtr->socket, FIONREAD, + &nBytes); + if ((status == SOCKET_ERROR) || + ((nBytes == 0) && (!(infoPtr->flags & SOCKET_CLOSED)))) { + result &= (~(TCL_READABLE)); + infoPtr->flags &= (~(TCL_READABLE)); + } + } + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * SocketProc -- + * + * This function is called when WSAAsyncSelect has been used + * to register interest in a socket event, and the event has + * occurred. + * + * Results: + * 0 on success. + * + * Side effects: + * The flags for the given socket are updated to reflect the + * event that occured. + * + *---------------------------------------------------------------------- + */ + +static LRESULT CALLBACK +SocketProc(hwnd, message, wParam, lParam) + HWND hwnd; + UINT message; + WPARAM wParam; + LPARAM lParam; +{ + int event; + SOCKET socket; + SocketInfo *infoPtr; + + if ((hwnd != socketWindow) || (message != SOCKET_MESSAGE)) { + return DefWindowProc(hwnd, message, wParam, lParam); + } + event = WSAGETSELECTEVENT(lParam); + socket = (SOCKET) wParam; + + /* + * Find the specified socket on the socket list and update its + * check flags. + */ + + for (infoPtr = socketList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { + if (infoPtr->socket == socket) { + + if (event & (FD_READ | FD_ACCEPT | FD_CLOSE)) { + infoPtr->flags |= TCL_READABLE; + } + if (event & (FD_WRITE | FD_CONNECT)) { + infoPtr->flags |= TCL_WRITABLE; + } + infoPtr->occurredMask |= event; + break; + } + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetHostName -- + * + * Returns the name of the local host. + * + * Results: + * Returns a string containing the host name, or NULL on error. + * The returned string must be freed by the caller. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_GetHostName() +{ + static int hostnameInitialized = 0; + static char hostname[255]; /* This buffer should be big enough for + * hostname plus domain name. */ + + if (TclHasSockets(NULL) != TCL_OK) { + return ""; + } + + if (hostnameInitialized) { + return hostname; + } + if ((*winSock.gethostname)(hostname, 100) == 0) { + hostnameInitialized = 1; + return hostname; + } + return (char *) NULL; +} +/* + *---------------------------------------------------------------------- + * + * TclHasSockets -- + * + * This function determines whether sockets are available on the + * current system and returns an error in interp if they are not. + * Note that interp may be NULL. + * + * Results: + * Returns TCL_OK if the system supports sockets, or TCL_ERROR with + * an error in interp. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclHasSockets(interp) + Tcl_Interp *interp; +{ + static int initialized = 0; /* 1 if the socket system has been + * initialized. */ + static int hasSockets = 0; /* 1 if the system supports sockets. */ + + if (!initialized) { + OSVERSIONINFO info; + + initialized = 1; + + /* + * Find out if we're running on Win32s. + */ + + info.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); + GetVersionEx(&info); + + /* + * Check to see if Sockets are supported on this system. Since + * win32s panics if we call WSAStartup on a system that doesn't + * have winsock.dll, we need to look for it on the system first. + * If we find winsock, then load the library and initialize the + * stub table. + */ + + if ((info.dwPlatformId != VER_PLATFORM_WIN32s) + || (SearchPath(NULL, "WINSOCK", ".DLL", 0, NULL, NULL) != 0)) { + hasSockets = InitSockets(); + } + } + + if (hasSockets) { + return TCL_OK; + } + if (interp != NULL) { + Tcl_AppendResult(interp, "sockets are not available on this system", + NULL); + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * TclWinGetSockOpt, et al. -- + * + * These functions are wrappers that let us bind the WinSock + * API dynamically so we can run on systems that don't have + * the wsock32.dll. We need wrappers for these interfaces + * because they are called from the generic Tcl code + * + * Results: + * As defined for each function. + * + * Side effects: + * As defined for each function. + * + *---------------------------------------------------------------------- + */ + +int PASCAL FAR +TclWinGetSockOpt(SOCKET s, int level, int optname, char FAR * optval, + int FAR *optlen) +{ + return (*winSock.getsockopt)(s, level, optname, optval, optlen); +} + +int PASCAL FAR +TclWinSetSockOpt(SOCKET s, int level, int optname, const char FAR * optval, + int optlen) +{ + return (*winSock.setsockopt)(s, level, optname, optval, optlen); +} + +u_short PASCAL FAR +TclWinNToHS(u_short netshort) +{ + return (*winSock.ntohs)(netshort); +} + +struct servent FAR * PASCAL FAR +TclWinGetServByName(const char FAR * name, const char FAR * proto) +{ + return (*winSock.getservbyname)(name, proto); +} diff --git a/tcl7.6/win/tclWinTest.c b/tcl7.6/win/tclWinTest.c new file mode 100644 index 0000000..302d0b1 --- /dev/null +++ b/tcl7.6/win/tclWinTest.c @@ -0,0 +1,48 @@ +/* + * tclWinTest.c -- + * + * Contains commands for platform specific tests on Windows. + * + * Copyright (c) 1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclWinTest.c 1.1 96/03/26 12:50:46 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * Forward declarations of procedures defined later in this file: + */ +int TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp)); + +/* + *---------------------------------------------------------------------- + * + * TclplatformtestInit -- + * + * Defines commands that test platform specific functionality for + * Unix platforms. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Defines new commands. + * + *---------------------------------------------------------------------- + */ + +int +TclplatformtestInit(interp) + Tcl_Interp *interp; /* Interpreter to add commands to. */ +{ + /* + * Add commands for platform specific tests for Windows here. + */ + + return TCL_OK; +} diff --git a/tcl7.6/win/tclWinTime.c b/tcl7.6/win/tclWinTime.c new file mode 100644 index 0000000..cd7bb40 --- /dev/null +++ b/tcl7.6/win/tclWinTime.c @@ -0,0 +1,373 @@ +/* + * tclWinTime.c -- + * + * Contains Windows specific versions of Tcl functions that + * obtain time values from the operating system. + * + * Copyright 1995 by Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclWinTime.c 1.5 96/07/23 16:19:01 + */ + +#include "tclInt.h" +#include "tclPort.h" + +#define SECSPERDAY (60L * 60L * 24L) +#define SECSPERYEAR (SECSPERDAY * 365L) +#define SECSPER4YEAR (SECSPERYEAR * 4L + SECSPERDAY) + +/* + * The following arrays contain the day of year for the last day of + * each month, where index 1 is January. + */ + +static int normalDays[] = { + -1, 30, 58, 89, 119, 150, 180, 211, 242, 272, 303, 333, 364 +}; + +static int leapDays[] = { + -1, 30, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365 +}; + +/* + * Declarations for functions defined later in this file. + */ + +static struct tm * ComputeGMT _ANSI_ARGS_((const time_t *tp)); + +/* + *---------------------------------------------------------------------- + * + * TclpGetSeconds -- + * + * This procedure returns the number of seconds from the epoch. + * On most Unix systems the epoch is Midnight Jan 1, 1970 GMT. + * + * Results: + * Number of seconds from the epoch. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +unsigned long +TclpGetSeconds() +{ + return (unsigned long) time((time_t *) NULL); +} + +/* + *---------------------------------------------------------------------- + * + * TclpGetClicks -- + * + * This procedure returns a value that represents the highest + * resolution clock available on the system. There are no + * guarantees on what the resolution will be. In Tcl we will + * call this value a "click". The start time is also system + * dependant. + * + * Results: + * Number of clicks from some start time. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +unsigned long +TclpGetClicks() +{ + return GetTickCount(); +} + +/* + *---------------------------------------------------------------------- + * + * TclpGetTimeZone -- + * + * Determines the current timezone. The method varies wildly + * between different Platform implementations, so its hidden in + * this function. + * + * Results: + * Minutes west of GMT. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclpGetTimeZone (currentTime) + unsigned long currentTime; +{ + int timeZone; + + tzset(); + timeZone = _timezone / 60; + + return timeZone; +} + +/* + *---------------------------------------------------------------------- + * + * TclpGetTime -- + * + * Gets the current system time in seconds and microseconds + * since the beginning of the epoch: 00:00 UCT, January 1, 1970. + * + * Results: + * Returns the current time in timePtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclpGetTime(timePtr) + Tcl_Time *timePtr; /* Location to store time information. */ +{ + struct timeb t; + + ftime(&t); + timePtr->sec = t.time; + timePtr->usec = t.millitm * 1000; +} + +/* + *---------------------------------------------------------------------- + * + * TclpGetTZName -- + * + * Gets the current timezone string. + * + * Results: + * Returns a pointer to a static string, or NULL on failure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +TclpGetTZName() +{ + tzset(); + if (_daylight && _tzname[1] != NULL) { + return _tzname[1]; + } else { + return _tzname[0]; + } +} + +/* + *---------------------------------------------------------------------- + * + * TclpGetDate -- + * + * This function converts between seconds and struct tm. If + * useGMT is true, then the returned date will be in Greenwich + * Mean Time (GMT). Otherwise, it will be in the local time zone. + * + * Results: + * Returns a static tm structure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +struct tm * +TclpGetDate(tp, useGMT) + const time_t *tp; + int useGMT; +{ + struct tm *tmPtr; + long time; + + if (!useGMT) { + tzset(); + + /* + * If we are in the valid range, let the C run-time library + * handle it. Otherwise we need to fake it. Note that this + * algorithm ignores daylight savings time before the epoch. + */ + + time = *tp - _timezone; + if (time >= 0) { + return localtime(tp); + } + + /* + * If we aren't near to overflowing the long, just add the bias and + * use the normal calculation. Otherwise we will need to adjust + * the result at the end. + */ + + if (*tp < (LONG_MAX - 2 * SECSPERDAY) + && *tp > (LONG_MIN + 2 * SECSPERDAY)) { + tmPtr = ComputeGMT(&time); + } else { + tmPtr = ComputeGMT(tp); + + tzset(); + + /* + * Add the bias directly to the tm structure to avoid overflow. + * Propagate seconds overflow into minutes, hours and days. + */ + + time = tmPtr->tm_sec - _timezone; + tmPtr->tm_sec = (int)(time % 60); + if (tmPtr->tm_sec < 0) { + tmPtr->tm_sec += 60; + time -= 60; + } + + time = tmPtr->tm_min + time/60; + tmPtr->tm_min = (int)(time % 60); + if (tmPtr->tm_min < 0) { + tmPtr->tm_min += 60; + time -= 60; + } + + time = tmPtr->tm_hour + time/60; + tmPtr->tm_hour = (int)(time % 24); + if (tmPtr->tm_hour < 0) { + tmPtr->tm_hour += 24; + time -= 24; + } + + time /= 24; + tmPtr->tm_mday += time; + tmPtr->tm_yday += time; + tmPtr->tm_wday = (tmPtr->tm_wday + time) % 7; + } + } else { + tmPtr = ComputeGMT(tp); + } + return tmPtr; +} + +/* + *---------------------------------------------------------------------- + * + * ComputeGMT -- + * + * This function computes GMT given the number of seconds since + * the epoch (midnight Jan 1 1970). + * + * Results: + * Returns a statically allocated struct tm. + * + * Side effects: + * Updates the values of the static struct tm. + * + *---------------------------------------------------------------------- + */ + +static struct tm * +ComputeGMT(tp) + const time_t *tp; +{ + static struct tm tm; /* This should be allocated per thread.*/ + long tmp, rem; + int isLeap; + int *days; + + /* + * Compute the 4 year span containing the specified time. + */ + + tmp = *tp / SECSPER4YEAR; + rem = *tp % SECSPER4YEAR; + + /* + * Correct for weird mod semantics so the remainder is always positive. + */ + + if (rem < 0) { + tmp--; + rem += SECSPER4YEAR; + } + + /* + * Compute the year after 1900 by taking the 4 year span and adjusting + * for the remainder. This works because 2000 is a leap year, and + * 1900/2100 are out of the range. + */ + + tmp = (tmp * 4) + 70; + isLeap = 0; + if (rem >= SECSPERYEAR) { /* 1971, etc. */ + tmp++; + rem -= SECSPERYEAR; + if (rem > SECSPERYEAR) { /* 1972, etc. */ + tmp++; + rem -= SECSPERYEAR; + if (rem > SECSPERYEAR + SECSPERDAY) { /* 1973, etc. */ + tmp++; + rem -= SECSPERYEAR + SECSPERDAY; + } else { + isLeap = 1; + } + } + } + tm.tm_year = tmp; + + /* + * Compute the day of year and leave the seconds in the current day in + * the remainder. + */ + + tm.tm_yday = rem / SECSPERDAY; + rem %= SECSPERDAY; + + /* + * Compute the time of day. + */ + + tm.tm_hour = rem / 3600; + rem %= 3600; + tm.tm_min = rem / 60; + tm.tm_sec = rem % 60; + + /* + * Compute the month and day of month. + */ + + days = (isLeap) ? leapDays : normalDays; + for (tmp = 1; days[tmp] < tm.tm_yday; tmp++) { + } + tm.tm_mon = --tmp; + tm.tm_mday = tm.tm_yday - days[tmp]; + + /* + * Compute day of week. Epoch started on a Thursday. + */ + + tm.tm_wday = (*tp / SECSPERDAY) + 4; + if ((*tp % SECSPERDAY) < 0) { + tm.tm_wday--; + } + tm.tm_wday %= 7; + if (tm.tm_wday < 0) { + tm.tm_wday += 7; + } + + return &tm; +} diff --git a/tcl7.6/win/tclsh.rc b/tcl7.6/win/tclsh.rc new file mode 100644 index 0000000..39e109e --- /dev/null +++ b/tcl7.6/win/tclsh.rc @@ -0,0 +1,36 @@ +// SCCS: @(#) tclsh.rc 1.14 96/09/12 14:59:29 +// +// Version +// + +#define RESOURCE_INCLUDED +#include + +VS_VERSION_INFO VERSIONINFO + FILEVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL + PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL + FILEFLAGSMASK 0x3fL + FILEFLAGS 0x0L + FILEOS 0x4L + FILETYPE 0x1L + FILESUBTYPE 0x0L +BEGIN + BLOCK "StringFileInfo" + BEGIN + BLOCK "040904b0" + BEGIN + VALUE "FileDescription", "Tclsh Application\0" + VALUE "OriginalFilename", "tclsh" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) ".exe\0" + VALUE "CompanyName", "Sun Microsystems, Inc\0" + VALUE "FileVersion", TCL_PATCH_LEVEL + VALUE "LegalCopyright", "Copyright \251 1995-1996\0" + VALUE "ProductName", "Tcl " TCL_VERSION " for Windows\0" + VALUE "ProductVersion", TCL_PATCH_LEVEL + END + END + BLOCK "VarFileInfo" + BEGIN + VALUE "Translation", 0x409, 1200 + END +END + diff --git a/tcl7.6/win/winDumpExts.c b/tcl7.6/win/winDumpExts.c new file mode 100644 index 0000000..8bc496e --- /dev/null +++ b/tcl7.6/win/winDumpExts.c @@ -0,0 +1,503 @@ +/* + * winDumpExts.c -- + * Author: Gordon Chaffee, Scott Stanton + * + * History: The real functionality of this file was written by + * Matt Pietrek in 1993 in his pedump utility. I've + * modified it to dump the externals in a bunch of object + * files to create a .def file. + * + * 10/12/95 Modified by Scott Stanton to support Relocatable Object Module + * Format files for Borland C++ 4.5. + * + * Notes: Visual C++ puts an underscore before each exported symbol. + * This file removes them. I don't know if this is a problem + * this other compilers. If _MSC_VER is defined, + * the underscore is removed. If not, it isn't. To get a + * full dump of an object file, use the -f option. This can + * help determine the something that may be different with a + * compiler other than Visual C++. + *---------------------------------------------------------------------- + * + * SCCS: @(#) winDumpExts.c 1.11 96/09/18 15:25:11 + */ + +#include +#include +#include +#include + +#ifdef _ALPHA_ +#define e_magic_number IMAGE_FILE_MACHINE_ALPHA +#else +#define e_magic_number IMAGE_FILE_MACHINE_I386 +#endif + +/* + *---------------------------------------------------------------------- + * GetArgcArgv -- + * + * Break up a line into argc argv + *---------------------------------------------------------------------- + */ +int +GetArgcArgv(char *s, char **argv) +{ + int quote = 0; + int argc = 0; + char *bp; + + bp = s; + while (1) { + while (isspace(*bp)) { + bp++; + } + if (*bp == '\n' || *bp == '\0') { + *bp = '\0'; + return argc; + } + if (*bp == '\"') { + quote = 1; + bp++; + } + argv[argc++] = bp; + + while (*bp != '\0') { + if (quote) { + if (*bp == '\"') { + quote = 0; + *bp = '\0'; + bp++; + break; + } + bp++; + continue; + } + if (isspace(*bp)) { + *bp = '\0'; + bp++; + break; + } + bp++; + } + } +} + +/* + * The names of the first group of possible symbol table storage classes + */ +char * SzStorageClass1[] = { + "NULL","AUTOMATIC","EXTERNAL","STATIC","REGISTER","EXTERNAL_DEF","LABEL", + "UNDEFINED_LABEL","MEMBER_OF_STRUCT","ARGUMENT","STRUCT_TAG", + "MEMBER_OF_UNION","UNION_TAG","TYPE_DEFINITION","UNDEFINED_STATIC", + "ENUM_TAG","MEMBER_OF_ENUM","REGISTER_PARAM","BIT_FIELD" +}; + +/* + * The names of the second group of possible symbol table storage classes + */ +char * SzStorageClass2[] = { + "BLOCK","FUNCTION","END_OF_STRUCT","FILE","SECTION","WEAK_EXTERNAL" +}; + +/* + *---------------------------------------------------------------------- + * GetSZStorageClass -- + * + * Given a symbol storage class value, return a descriptive + * ASCII string + *---------------------------------------------------------------------- + */ +PSTR +GetSZStorageClass(BYTE storageClass) +{ + if ( storageClass <= IMAGE_SYM_CLASS_BIT_FIELD ) + return SzStorageClass1[storageClass]; + else if ( (storageClass >= IMAGE_SYM_CLASS_BLOCK) + && (storageClass <= IMAGE_SYM_CLASS_WEAK_EXTERNAL) ) + return SzStorageClass2[storageClass-IMAGE_SYM_CLASS_BLOCK]; + else + return "???"; +} + +/* + *---------------------------------------------------------------------- + * GetSectionName -- + * + * Used by DumpSymbolTable, it gives meaningful names to + * the non-normal section number. + * + * Results: + * A name is returned in buffer + *---------------------------------------------------------------------- + */ +void +GetSectionName(WORD section, PSTR buffer, unsigned cbBuffer) +{ + char tempbuffer[10]; + + switch ( (SHORT)section ) + { + case IMAGE_SYM_UNDEFINED: strcpy(tempbuffer, "UNDEF"); break; + case IMAGE_SYM_ABSOLUTE: strcpy(tempbuffer, "ABS "); break; + case IMAGE_SYM_DEBUG: strcpy(tempbuffer, "DEBUG"); break; + default: wsprintf(tempbuffer, "%-5X", section); + } + + strncpy(buffer, tempbuffer, cbBuffer-1); +} + +/* + *---------------------------------------------------------------------- + * DumpSymbolTable -- + * + * Dumps a COFF symbol table from an EXE or OBJ. We only use + * it to dump tables from OBJs. + *---------------------------------------------------------------------- + */ +void +DumpSymbolTable(PIMAGE_SYMBOL pSymbolTable, FILE *fout, unsigned cSymbols) +{ + unsigned i; + PSTR stringTable; + char sectionName[10]; + + fprintf(fout, "Symbol Table - %X entries (* = auxillary symbol)\n", + cSymbols); + + fprintf(fout, + "Indx Name Value Section cAux Type Storage\n" + "---- -------------------- -------- ---------- ----- ------- --------\n"); + + /* + * The string table apparently starts right after the symbol table + */ + stringTable = (PSTR)&pSymbolTable[cSymbols]; + + for ( i=0; i < cSymbols; i++ ) { + fprintf(fout, "%04X ", i); + if ( pSymbolTable->N.Name.Short != 0 ) + fprintf(fout, "%-20.8s", pSymbolTable->N.ShortName); + else + fprintf(fout, "%-20s", stringTable + pSymbolTable->N.Name.Long); + + fprintf(fout, " %08X", pSymbolTable->Value); + + GetSectionName(pSymbolTable->SectionNumber, sectionName, + sizeof(sectionName)); + fprintf(fout, " sect:%s aux:%X type:%02X st:%s\n", + sectionName, + pSymbolTable->NumberOfAuxSymbols, + pSymbolTable->Type, + GetSZStorageClass(pSymbolTable->StorageClass) ); +#if 0 + if ( pSymbolTable->NumberOfAuxSymbols ) + DumpAuxSymbols(pSymbolTable); +#endif + + /* + * Take into account any aux symbols + */ + i += pSymbolTable->NumberOfAuxSymbols; + pSymbolTable += pSymbolTable->NumberOfAuxSymbols; + pSymbolTable++; + } +} + +/* + *---------------------------------------------------------------------- + * DumpExternals -- + * + * Dumps a COFF symbol table from an EXE or OBJ. We only use + * it to dump tables from OBJs. + *---------------------------------------------------------------------- + */ +void +DumpExternals(PIMAGE_SYMBOL pSymbolTable, FILE *fout, unsigned cSymbols) +{ + unsigned i; + PSTR stringTable; + char *s, *f; + char symbol[1024]; + + /* + * The string table apparently starts right after the symbol table + */ + stringTable = (PSTR)&pSymbolTable[cSymbols]; + + for ( i=0; i < cSymbols; i++ ) { + if (pSymbolTable->SectionNumber > 0 && pSymbolTable->Type == 0x20) { + if (pSymbolTable->StorageClass == IMAGE_SYM_CLASS_EXTERNAL) { + if (pSymbolTable->N.Name.Short != 0) { + strncpy(symbol, pSymbolTable->N.ShortName, 8); + symbol[8] = 0; + } else { + s = stringTable + pSymbolTable->N.Name.Long; + strcpy(symbol, s); + } + s = symbol; + f = strchr(s, '@'); + if (f) { + *f = 0; + } +#if defined(_MSC_VER) && defined(_X86_) + if (symbol[0] == '_') { + s = &symbol[1]; + } +#endif + if ((stricmp(s, "DllEntryPoint") != 0) + && (stricmp(s, "DllMain") != 0)) { + fprintf(fout, "\t%s\n", s); + } + } + } + + /* + * Take into account any aux symbols + */ + i += pSymbolTable->NumberOfAuxSymbols; + pSymbolTable += pSymbolTable->NumberOfAuxSymbols; + pSymbolTable++; + } +} + +/* + *---------------------------------------------------------------------- + * DumpObjFile -- + * + * Dump an object file--either a full listing or just the exported + * symbols. + *---------------------------------------------------------------------- + */ +void +DumpObjFile(PIMAGE_FILE_HEADER pImageFileHeader, FILE *fout, int full) +{ + PIMAGE_SYMBOL PCOFFSymbolTable; + DWORD COFFSymbolCount; + + PCOFFSymbolTable = (PIMAGE_SYMBOL) + ((DWORD)pImageFileHeader + pImageFileHeader->PointerToSymbolTable); + COFFSymbolCount = pImageFileHeader->NumberOfSymbols; + + if (full) { + DumpSymbolTable(PCOFFSymbolTable, fout, COFFSymbolCount); + } else { + DumpExternals(PCOFFSymbolTable, fout, COFFSymbolCount); + } +} + +/* + *---------------------------------------------------------------------- + * SkipToNextRecord -- + * + * Skip over the current ROMF record and return the type of the + * next record. + *---------------------------------------------------------------------- + */ + +BYTE +SkipToNextRecord(BYTE **ppBuffer) +{ + int length; + (*ppBuffer)++; /* Skip over the type.*/ + length = *((WORD*)(*ppBuffer))++; /* Retrieve the length. */ + *ppBuffer += length; /* Skip over the rest. */ + return **ppBuffer; /* Return the type. */ +} + +/* + *---------------------------------------------------------------------- + * DumpROMFObjFile -- + * + * Dump a Relocatable Object Module Format file, displaying only + * the exported symbols. + *---------------------------------------------------------------------- + */ +void +DumpROMFObjFile(LPVOID pBuffer, FILE *fout) +{ + BYTE type, length; + char symbol[1024], *s; + + while (1) { + type = SkipToNextRecord(&(BYTE*)pBuffer); + if (type == 0x90) { /* PUBDEF */ + if (((BYTE*)pBuffer)[4] != 0) { + length = ((BYTE*)pBuffer)[5]; + strncpy(symbol, ((char*)pBuffer) + 6, length); + symbol[length] = '\0'; + s = symbol; + if ((stricmp(s, "DllEntryPoint") != 0) + && (stricmp(s, "DllMain") != 0)) { + if (s[0] == '_') { + s++; + fprintf(fout, "\t_%s\n\t%s=_%s\n", s, s, s); + } else { + fprintf(fout, "\t%s\n", s); + } + } + } + } else if (type == 0x8B || type == 0x8A) { /* MODEND */ + break; + } + } +} + +/* + *---------------------------------------------------------------------- + * DumpFile -- + * + * Open up a file, memory map it, and call the appropriate + * dumping routine + *---------------------------------------------------------------------- + */ +void +DumpFile(LPSTR filename, FILE *fout, int full) +{ + HANDLE hFile; + HANDLE hFileMapping; + LPVOID lpFileBase; + PIMAGE_DOS_HEADER dosHeader; + + hFile = CreateFile(filename, GENERIC_READ, FILE_SHARE_READ, NULL, + OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); + + if (hFile == INVALID_HANDLE_VALUE) { + fprintf(stderr, "Couldn't open file with CreateFile()\n"); + return; + } + + hFileMapping = CreateFileMapping(hFile, NULL, PAGE_READONLY, 0, 0, NULL); + if (hFileMapping == 0) { + CloseHandle(hFile); + fprintf(stderr, "Couldn't open file mapping with CreateFileMapping()\n"); + return; + } + + lpFileBase = MapViewOfFile(hFileMapping, FILE_MAP_READ, 0, 0, 0); + if (lpFileBase == 0) { + CloseHandle(hFileMapping); + CloseHandle(hFile); + fprintf(stderr, "Couldn't map view of file with MapViewOfFile()\n"); + return; + } + + dosHeader = (PIMAGE_DOS_HEADER)lpFileBase; + if (dosHeader->e_magic == IMAGE_DOS_SIGNATURE) { +#if 0 + DumpExeFile( dosHeader ); +#else + fprintf(stderr, "File is an executable. I don't dump those.\n"); + return; +#endif + } + /* Does it look like a i386 COFF OBJ file??? */ + else if ((dosHeader->e_magic == e_magic_number) + && (dosHeader->e_sp == 0)) { + /* + * The two tests above aren't what they look like. They're + * really checking for IMAGE_FILE_HEADER.Machine == i386 (0x14C) + * and IMAGE_FILE_HEADER.SizeOfOptionalHeader == 0; + */ + DumpObjFile((PIMAGE_FILE_HEADER) lpFileBase, fout, full); + } else if (*((BYTE *)lpFileBase) == 0x80) { + /* + * This file looks like it might be a ROMF file. + */ + DumpROMFObjFile(lpFileBase, fout); + } else { + printf("unrecognized file format\n"); + } + UnmapViewOfFile(lpFileBase); + CloseHandle(hFileMapping); + CloseHandle(hFile); +} + +void +main(int argc, char **argv) +{ + char *fargv[1000]; + char cmdline[10000]; + int i, arg; + FILE *fout; + int pos; + int full = 0; + char *outfile = NULL; + + if (argc < 3) { + Usage: + fprintf(stderr, "Usage: %s ?-o outfile? ?-f(ull)? ..\n", argv[0]); + exit(1); + } + + arg = 1; + while (argv[arg][0] == '-') { + if (strcmp(argv[arg], "--") == 0) { + arg++; + break; + } else if (strcmp(argv[arg], "-f") == 0) { + full = 1; + } else if (strcmp(argv[arg], "-o") == 0) { + arg++; + if (arg == argc) { + goto Usage; + } + outfile = argv[arg]; + } + arg++; + } + if (arg == argc) { + goto Usage; + } + + if (outfile) { + fout = fopen(outfile, "w+"); + if (fout == NULL) { + fprintf(stderr, "Unable to open \'%s\' for writing:\n", + argv[arg]); + perror(""); + exit(1); + } + } else { + fout = stdout; + } + + if (! full) { + char *dllname = argv[arg]; + arg++; + if (arg == argc) { + goto Usage; + } + fprintf(fout, "LIBRARY %s\n", dllname); + fprintf(fout, "EXETYPE WINDOWS\n"); + fprintf(fout, "CODE PRELOAD MOVEABLE DISCARDABLE\n"); + fprintf(fout, "DATA PRELOAD MOVEABLE MULTIPLE\n\n"); + fprintf(fout, "EXPORTS\n"); + } + + for (; arg < argc; arg++) { + if (argv[arg][0] == '@') { + FILE *fargs = fopen(&argv[arg][1], "r"); + if (fargs == NULL) { + fprintf(stderr, "Unable to open \'%s\' for reading:\n", + argv[arg]); + perror(""); + exit(1); + } + pos = 0; + for (i = 0; i < arg; i++) { + strcpy(&cmdline[pos], argv[i]); + pos += strlen(&cmdline[pos]) + 1; + fargv[i] = argv[i]; + } + fgets(&cmdline[pos], sizeof(cmdline), fargs); + fprintf(stderr, "%s\n", &cmdline[pos]); + fclose(fargs); + i += GetArgcArgv(&cmdline[pos], &fargv[i]); + argc = i; + argv = fargv; + } + DumpFile(argv[arg], fout, full); + } + exit(0); +} diff --git a/tk3.6/Makefile.in b/tk3.6/Makefile.in deleted file mode 100755 index 740cff5..0000000 --- a/tk3.6/Makefile.in +++ /dev/null @@ -1,284 +0,0 @@ -# -# This file is a Makefile for Tk. If it has the name "Makefile.in" -# then it is a template for a Makefile; to generate the actual Makefile, -# run "./configure", which is a configuration script generated by the -# "autoconf" program (constructs like "@foo@" will get replaced in the -# actual Makefile. - -#---------------------------------------------------------------- -# Things you can change to personalize the Makefile for your own -# site (you can make these changes in either Makefile.in or -# Makefile, but changes to Makefile will get lost if you re-run -# the configuration script). -#---------------------------------------------------------------- - -# Default top-level directories in which to install architecture- -# specific files (exec_prefix) and machine-independent files such -# as scripts (prefix). The values specified here may be overridden -# at configure-time with the --exec-prefix and --prefix options -# to the "configure" script. - -exec_prefix = /usr/local -prefix = /usr/local - -# Directory in which to install the library of Tk scripts and demos -# (note: you can set the TK_LIBRARY environment variable at run-time to -# override the compiled-in location): -TK_LIBRARY = $(prefix)/lib/tk - -# Directory in which to install the archive libtk.a: -LIB_DIR = $(exec_prefix)/lib - -# Directory in which to install the program wish: -BIN_DIR = $(exec_prefix)/bin - -# Directory in which to install the include file tk.h: -INCLUDE_DIR = $(prefix)/include - -# Top-level directory for manual entries: -MAN_DIR = $(prefix)/man - -# Directory in which to install manual entry for wish: -MAN1_DIR = $(MAN_DIR)/man1 - -# Directory in which to install manual entries for Tk's C library -# procedures: -MAN3_DIR = $(MAN_DIR)/man3 - -# Directory in which to install manual entries for the built-in -# Tcl commands implemented by Tk: -MANN_DIR = $(MAN_DIR)/mann - -# The directory containing the Tcl sources and headers appropriate -# for this version of Tk ("@srcdir@" will be replaced or has already -# been replaced by the configure script): -TCL_DIR = @srcdir@/../tcl7.3 - -# The directory containing the Tcl library archive file appropriate -# for this version of Tk: -TCL_BIN_DIR = ../tcl7.3 - -# A "-I" switch that can be used when compiling to make all of the -# X11 include files accessible (the configure script will try to -# set this value, and will cause it to be an empty string if the -# include files are accessible via /usr/include). -X11_INCLUDES = @XINCLUDES@ - -# Linker switch(es) to use to link with the X11 library archive (the -# configure script will try to set this value automatically, but you -# can override it). -X11_LIB_SWITCHES = @XLIBSW@ - -# Libraries to use when linking: must include at least Tk, Tcl, Xlib, -# and the math library (in that order). The "@LIBS@" part will be -# replaced (or has already been replaced) with relevant libraries as -# determined by the configure script. -LIBS = libtk.a $(TCL_BIN_DIR)/libtcl.a $(X11_LIB_SWITCHES) @LIBS@ -lm - -# To change the compiler switches, for example to change from -O -# to -g, change the following line: -CFLAGS = -O - -# To turn off the security checks that disallow incoming sends when -# the X server appears to be insecure, reverse the comments on the -# following lines: -SECURITY_FLAGS = -#SECURITY_FLAGS = -DTK_NO_SECURITY - -# To disable ANSI-C procedure prototypes reverse the comment characters -# on the following lines: -PROTO_FLAGS = -#PROTO_FLAGS = -DNO_PROTOTYPE - -# To enable memory debugging reverse the comment characters on the following -# lines. Warning: if you enable memory debugging, you must do it -# *everywhere*, including all the code that calls Tcl, and you must use -# ckalloc and ckfree everywhere instead of malloc and free. -MEM_DEBUG_FLAGS = -#MEM_DEBUG_FLAGS = -DTCL_MEM_DEBUG - -# Some versions of make, like SGI's, use the following variable to -# determine which shell to use for executing commands: -SHELL = /bin/sh - -#---------------------------------------------------------------- -# The information below is modified by the configure script when -# Makefile is generated from Makefile.in. You shouldn't normally -# modify any of this stuff by hand. -#---------------------------------------------------------------- - -AC_FLAGS = @DEFS@ -INSTALL = @INSTALL@ -INSTALL_PROGRAM = @INSTALL_PROGRAM@ -INSTALL_DATA = @INSTALL_DATA@ -RANLIB = @RANLIB@ -SRC_DIR = @srcdir@ -VPATH = @srcdir@ - -#---------------------------------------------------------------- -# The information below should be usable as is. The configure -# script won't modify it and you shouldn't need to modify it -# either. -#---------------------------------------------------------------- - - -CC = @CC@ -CC_SWITCHES = ${CFLAGS} -I${SRC_DIR} -I${TCL_DIR} ${X11_INCLUDES} \ -${AC_FLAGS} ${PROTO_FLAGS} ${SECURITY_FLAGS} ${MEM_DEBUG_FLAGS} \ --DTK_LIBRARY=\"${TK_LIBRARY}\" - -WIDGOBJS = tkButton.o tkEntry.o tkFrame.o tkListbox.o \ - tkMenu.o tkMenubutton.o tkMessage.o tkScale.o \ - tkScrollbar.o - -CANVOBJS = tkCanvas.o tkCanvArc.o tkCanvBmap.o tkCanvLine.o \ - tkCanvPoly.o tkCanvPs.o tkCanvText.o tkCanvWind.o \ - tkRectOval.o tkTrig.o - -TEXTOBJS = tkText.o tkTextBTree.o tkTextDisp.o tkTextIndex.o tkTextTag.o - -OBJS = tk3d.o tkArgv.o tkAtom.o tkBind.o tkBitmap.o tkCmds.o \ - tkColor.o tkConfig.o tkCursor.o tkError.o tkEvent.o \ - tkFocus.o tkFont.o tkGet.o tkGC.o tkGeometry.o tkGrab.o \ - tkMain.o tkOption.o tkPack.o tkPlace.o tkPreserve.o tkSelect.o \ - tkSend.o tkWindow.o tkWm.o $(WIDGOBJS) \ - $(CANVOBJS) $(TEXTOBJS) -DEMOPROGS = browse color dialog hello ixset rmt rolodex size square \ - tcolor timer widget - -all: libtk.a wish - -libtk.a: $(OBJS) - rm -f libtk.a - ar cr libtk.a $(OBJS) - $(RANLIB) libtk.a - -wish: tkAppInit.o libtk.a $(TCL_BIN_DIR)/libtcl.a - $(CC) $(CC_SWITCHES) tkAppInit.o $(LIBS) -o wish - -tktest: tkTest.o libtk.a $(TCL_BIN_DIR)/libtcl.a - ${CC} ${CC_SWITCHES} tkTest.o $(LIBS) -o tktest - -test: tktest - @cwd=`pwd`; \ - cd $(TCL_DIR); TCL_LIBRARY=`pwd`/library; export TCL_LIBRARY; \ - cd $$cwd; cd $(SRC_DIR); TK_LIBRARY=`pwd`/library; export TK_LIBRARY; \ - cd $$cwd; ( echo cd $(SRC_DIR)/tests\; source all\; exit ) | ./tktest - -install: install-binaries install-libraries install-demos install-man - -install-binaries: libtk.a wish - @for i in $(LIB_DIR) $(BIN_DIR) ; \ - do \ - if [ ! -d $$i ] ; then \ - echo "Making directory $$i"; \ - mkdir $$i; \ - chmod 755 $$i; \ - else true; \ - fi; \ - done; - @echo "Installing libtk.a" - @$(INSTALL_DATA) libtk.a $(LIB_DIR) - @$(RANLIB) $(LIB_DIR)/libtk.a - @echo "Installing wish" - @$(INSTALL_PROGRAM) wish $(BIN_DIR) - -install-libraries: - @for i in $(prefix)/lib $(INCLUDE_DIR) $(TK_LIBRARY) ; \ - do \ - if [ ! -d $$i ] ; then \ - echo "Making directory $$i"; \ - mkdir $$i; \ - chmod 755 $$i; \ - else true; \ - fi; \ - done; - @echo "Installing tk.h" - @$(INSTALL_DATA) $(SRC_DIR)/tk.h $(INCLUDE_DIR) - @cd $(SRC_DIR)/library; for i in *.tcl tclIndex prolog.ps; \ - do \ - echo "Installing library/$$i"; \ - $(INSTALL_DATA) $$i $(TK_LIBRARY); \ - done; - -install-demos: - @for i in $(prefix)/lib $(TK_LIBRARY) $(TK_LIBRARY)/demos \ - $(TK_LIBRARY)/demos/bitmaps ; \ - do \ - if [ ! -d $$i ] ; then \ - echo "Making directory $$i"; \ - mkdir $$i; \ - chmod 755 $$i; \ - else true; \ - fi; \ - done; - @cd $(SRC_DIR)/library/demos; for i in *; \ - do \ - if [ -f $$i ] ; then \ - echo "Installing library/demos/$$i"; \ - sed -e '1 s|/usr/local/bin/wish|$(BIN_DIR)/wish|' \ - $$i > $(TK_LIBRARY)/demos/$$i; \ - fi; \ - done; - @for i in $(DEMOPROGS); \ - do \ - chmod 755 $(TK_LIBRARY)/demos/$$i; \ - done; - @cd $(SRC_DIR)/library/demos/bitmaps; for i in *; \ - do \ - echo "Installing library/demos/bitmaps/$$i"; \ - $(INSTALL_DATA) $$i $(TK_LIBRARY)/demos/bitmaps; \ - done; - -install-man: - @for i in $(MAN_DIR) $(MAN1_DIR) $(MAN3_DIR) $(MANN_DIR) ; \ - do \ - if [ ! -d $$i ] ; then \ - echo "Making directory $$i"; \ - mkdir $$i; \ - chmod 755 $$i; \ - else true; \ - fi; \ - done; - @cd $(SRC_DIR)/doc; for i in *.1; \ - do \ - echo "Installing doc/$$i"; \ - rm -f $(MAN1_DIR)/$$i; \ - sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \ - $$i > $(MAN1_DIR)/$$i; \ - chmod 444 $(MAN1_DIR)/$$i; \ - done; - @cd $(SRC_DIR)/doc; for i in *.3; \ - do \ - echo "Installing doc/$$i"; \ - rm -f $(MAN3_DIR)/$$i; \ - sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \ - $$i > $(MAN3_DIR)/$$i; \ - chmod 444 $(MAN3_DIR)/$$i; \ - done; - @cd $(SRC_DIR)/doc; for i in *.n; \ - do \ - echo "Installing doc/$$i"; \ - rm -f $(MANN_DIR)/$$i; \ - sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \ - $$i > $(MANN_DIR)/$$i; \ - chmod 444 $(MANN_DIR)/$$i; \ - done; - -Makefile: $(SRC_DIR)/Makefile.in - $(SHELL) config.status - -clean: - rm -f *.a *.o core errs *~ \#* TAGS *.E a.out errors tktest wish - -distclean: clean - rm -f Makefile config.status - -.c.o: - $(CC) -c $(CC_SWITCHES) $< - -$(OBJS) tkTest.o: tk.h tkInt.h tkConfig.h -$(WIDGOBJS): default.h -$(CANVOBJS): default.h tkCanvas.h -$(TEXTOBJS): default.h tkText.h -tkWindow.o: patchlevel.h diff --git a/tk3.6/README b/tk3.6/README deleted file mode 100644 index d701cb9..0000000 --- a/tk3.6/README +++ /dev/null @@ -1,248 +0,0 @@ -The Tk Toolkit - -by John Ousterhout -University of California at Berkeley -ouster@cs.berkeley.edu - -1. Introduction ---------------- - -This directory contains the sources and documentation for Tk, an -X11 toolkit that provides the Motif look and feel and is implemented -using the Tcl scripting language. The information here corresponds -to Tk 3.6. It is designed to work with Tcl 7.3 and may not work -with other releases of Tcl. - -2. Documentation ----------------- - -The best way to get started with Tk 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 II of the book provides -an introduction to writing Tcl scripts for Tk and Part IV describes how -to build new widgets and geometry managers in C using Tk's library -procedures. - -The "doc" subdirectory in this release contains a complete set of manual -entries for Tk. Files with extension ".1" are for programs such as -wish; files with extension ".3" are for C library procedures; and files -with extension ".n" describe Tcl commands. To print any of the manual -entries, cd to the "doc" directory and invoke your favorite variant of -troff using the normal -man macros, for example - - ditroff -man wish.1 - -to print wish.1. If Tk 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 wish - -3. Compiling and installing Tk ------------------------------- - -This release should compile and run with little or no effort on any -UNIX-like system that approximates POSIX, BSD, or System V and runs -the X Window System. 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 Tk, do the following: - - (a) Make sure that this directory and the corresponding release of - Tcl are both subdirectories of the same directory. This - directory should be named tk3.6 and the Tcl release directory - should be named tcl7.3. - - (b) 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 Tk configuration for your site; for details on - how you can do this, see the file "configure.info". - - (c) Type "make". This will create a library archive called "libtk.a" - and an interpreter application called "wish" that allows you to type - Tcl commands interactively or execute script files. - - (d) 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. - - (e) Type "make install" to install Tk's binaries and script files in - standard places. In the default configuration information will - be installed in /usr/local so you'll need write permission on - this directory. - - (f) At this point you can play with Tcl by invoking the "wish" - program and typing Tcl commands. However, if you haven't installed - Tk then you'll first need to set your TK_LIBRARY environment - variable to hold the full path name of the "library" subdirectory. - If you haven't installed Tcl either then you'll need to set your - TCL_LIBRARY environment variable as well (see the Tcl README file - for information on this). - -If you have trouble compiling Tk, 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 Tk running on a new configuration -and had to make non-trivial changes to do it, 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 -------------- - -Tk now has the beginnings of a self-test suite, consisting of a set of -scripts in the subdirectory "tests". To run the test suite 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. Getting started ------------------- - -Once wish is compiled you can use it to play around with the Tk -facilities. If you run wish with no arguments, it will open a small -window on the screen and read Tcl commands from standard input. -Or, you can play with some of the pre-canned scripts in the subdirectory -library/demos. See the README file in the directory for a description -of what's available. The file library/demos/widget is a script that -you can use to invoke many individual demonstrations of Tk's facilities. - -If you want to start typing Tcl/Tk commands to wish, I'd suggest -starting with a widget-creation command like "button", and also learn -about the "pack" and "place" commands for geometry management. Note: -when you create a widget, it won't appear on the screen until you tell -a geometry manager about it. The only geometry managers at present -are the packer and the placer. If you don't already know Tcl, read the -Tcl book excerpt that can be FTP'ed separately from the distribution -directory. - -Andrew Payne has written a very nice demo script called "The Widget Tour" -that introduces you to writing Tk scripts. This script is available -from the Tcl contributed archive described below. If you're just -getting started with Tk I strongly recommend trying out the widget tour. - -6. Summary of changes in recent releases ----------------------------------------- - -Tk 3.6 is a minor new release that is identical to 3.4 except that it -fixes a portability bug that prevents tkMain.c from compiling on some -machines (R_OK isn't properly defined). Tk 3.6 should be completely -compatible with both 3.4 and 3.3. - -Tk 3.5 was mistake, and was withdrawn shortly after it was released. - -Tk 3.4 is a minor release consisting almost entirely of bug fixes. There -are no significant feature changes and Tk 3.4 should be completely -compatible with Tk 3.3. - -Tk 3.3 consists mostly of bug fixes plus upgrades to make it compatible -with Tcl 7.0. It should not introduce any compatibility problems itself, -but it requires Tcl 7.0, which introduces several incompatibilities -(see the Tcl README file for details). The file "changes" contains a -complete list of all changes to Tk, including both bug fixes and new -features. Here is a short list of a few of the most significant new -features: - - 1. Tk is now consistent with the book drafts. This means that the - new packer syntax has been implemented and additional bitmaps and - reliefs are available. - - 2. Tk now supports stacking order. Windows will stack in the order - created, and "raise" and "lower" commands are available to change - the stacking order. - - 3. There have been several improvements in configuration: GNU - autoconf is now used for configuration; wish now supports the - Tcl_AppInit procedure; and there's a patchlevel.h file that will - be used for future patches. The Tk release no longer includes a - Tcl release; you'll have to retrieve Tcl separately. - - 4. The Tk script library contains a new procedure "tk_dialog" for - creating dialog boxes, and the default "tkerror" has been improved - to use tk_dialog. - - 5. Tk now provides its own "exit" command that cleans up properly, - so it's now safe to use "exit" instead of "destroy ." to end wish - applications. - - 6. Cascade menu entries now display proper Motif arrows. - - 7. The main window is now a legitimate toplevel widget. - - 8. Wish allows prompts to be user-settable via the "tcl_prompt1" - and "tcl_prompt2" variables. - -7. Tcl/Tk 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 -this 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. - -8. Tcl/Tk contributed archive --------------------------- - -Many people have created exciting packages and applications based on Tcl -and/or Tk 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". - -9. 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 Tk turns into a kitchen sink). It's becoming -increasingly difficult to make incompatible changes to Tk, but it's -not totally out of the question. - -The Tcl/Tk 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/Tk support and training are available commercially from -NeoSoft. For more information, send e-mail to "info@neosoft.com". - - -10. Release organization ---------------------------- - -Each Tk release is identified by two numbers separated by a dot, e.g. -3.2 or 3.3. 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: 3.0, 4.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. 3.1, 3.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, -Tk 3.3b1 is the first beta release of Tk version 3.3, Tk 3.3b2 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. 4.0) then I can't -promise to maintain compatibility among its beta releases. For example, -release 4.0b2 may not be backward compatible with 4.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. diff --git a/tk3.6/ToDo b/tk3.6/ToDo deleted file mode 100644 index ae460b5..0000000 --- a/tk3.6/ToDo +++ /dev/null @@ -1,167 +0,0 @@ -This file contains a list of bugs to fix and minor feature changes -needed in the Tk toolkit. The list is ordered by the time when the -idea for the change first arose; no priority should be inferred from -the order. - -6. Fill in default argument table in tkArgv.c, and document it. - -8. Change Tk_Uid stuff so that there's a fast way to tell if a -string is really a Tk_Uid. - -10. Write procedure to translate from a string to a Pixmap. - -26. Extend "configure" widget command to output the type of the -option (string, color, etc.)? Or should this be done with the class -field? - -28. Need mechanism to change the name of a top-level window. - -30. Make "." a frame widget in wish? - -47. Add new "option" subcommands to (a) query whole database or -(b) query all the option patterns that match for a particular option -(i.e. don't just return the one that will actually be used). - -50. In error-handling code, ignore BadWindow errors if they occur -for a seemingly-legitimate Tk window. - -63. Provide way to determine "type" of window (i.e. command under which -it was created) rather than current class? - -68. Write manual entries for new exported binding procedures. - -75. Change Tk_Uid typedef to prevent confusion with (char *)? - -76. Change listbox selection handling to return multiple items separated -by newlines rather than as a Tcl list? - -81. For check and radio buttons, change "command" config to separate -commands invoked when button becomes selected/deselected? - -86. Change "tkVersion" variable to "tk_version" for consistency. - -89. Eliminate hard-wired behavior for scales and scrollbars: use class -bindings instead. - -92. Add mechanism for interposing constraints in geometry management, -e.g. to allow a collection of buttons to all request same width (for -tables) or to provide a generic mechanism for padding widgets internally. - -93. Add way to find out which geometry manager "owns" a particular -window. Also, Tk_SetInternalBorder isn't notify geometry managers -correctly (it assumes that slaves are children). Also, it would be -nice to have a callback to notify a geometry manager if one of its -slaves is taken away from it by another geometry manager. - -98. Add Tk command to compute the bbox of a given text string in a given -font? - -100. Extend scrollbar "set" command so that arrow increment can be set -explicitly. Or, change scrollbar interface completely so that the -scrollbar only gets two numbers giving slider position, and sends -commands of the form "foo scroll up1" or "foo scroll upScreen". - -101. Eliminate TK_DONT_WAIT option to Tk_DoOneEvent. - -103. Get image displaying widget from Paul Mackerras (paulus@cs.anu.edu.au) -and incorporate into Tk. - -105. Eliminate the "activate" and "deactivate" commands for buttons -and menu buttons. - -106. Add feature to buttons for automatic defaulting, where button -allocates extra space for default ring. - -107. Eliminate the "disable" and "enable" commands for menus. - -108. Change Tk_GetAtomName to return NULL instead of "?bad atom?". - -110. Extend bitmaps to allow direct specification (#0xffff ...) - -114. Change default so that windows are normally resizable? - -115. Change Tk_GetSelection to look in the cut buffer if no selection -can be found. - -117. Implement a mechanism for retrieving just the value of a configuration -option, without all the other stuff (name, default, etc.). Perhaps -a "cvalue" widget command? - -124. Remove "-geometry" option from all widgets, and use "-width" and -"-height" instead. - -128. Scroll windows when selecting off edge of window (do for listboxes, -entries, and text)? - -129. Add keyboard traversal to text and listboxes. - -131. Should new characters in text widget get tags of character they -precede or character they follow (currently it's "follow")? Or neither? - -132. Extend "option" command to make it possible to retrieve the original -resource pattern specs. - -134. Allow upper-left character in text not to be the first character -of a line: otherwise, with very long line and small window, won't be -able to view the end of a line. - -136. Implement mechanism for using existing window as main window for -application, support with command-line argument in wish. - -137. Modify default bindings so that they can handle multiple mice working -simultaneously on different displays (right now there is a single variable -that keeps track of the active window, for example). - -138. Add packer option not to set requested geometry for parent window? - -139. Change canvas Postscript generation to be smarter about font names -that have been abbreviated: use X to look up the full name. - -140. Canvas Postscript isn't stippling text like it should: the code -seems not to have been written at all. - -141. Change "send" code to be cleverer about reclaiming names of dead -interpreters. E.g. check for duplicate window names in the registry -or check for a unique-id property on the commWindow. - -142. Need to add "-displayfor" option to the following commands: -focus, selection, send. - -143. There are tricky issues about send and multiple displays. Does -some name get registered for a top-level window on a new display? If -so, how to deal with multiple different names for application? If not, -can this window be sent to by other applications on its display? - -144. In text widgets, if you backspace over a newline, the caret sometimes -leaves garbage at the left edge of its previous (lower) line. - -145. Incorporate Mark Diekhans' "addinput" or something like it. - -146. Change main.c to use "name" to set the class, instead of Tk. - -147. Add "window" entry to menus. - -148. Add an "initProc" and a "freeProc" to TK_CONFIG_CUSTOM config types. - -149. Remove Tcl_PrintDouble override macro in tkInt.h. - -150. In SYNONYM options, specify a command-line switch for the other -option, not a database name. - -151. Rename "pack newinfo" to "pack info". - -152. Make canvas window items restack in response to canvase "raise" -and "lower" commands. - -153. Some fonts (e.g. Times) have underline characters that extend -*below* the official descent of the font. Right now the underline -is invisible for these fonts in text widgets. Find a way to make -this work in text? - -154. Eliminate "geometry" variable from tkMain.c. - -155. Change all bindings to ignore extra modifiers by default? This -seems to be right more often than it's wrong. - -156. Eliminate "alwaysRedraw" for canvases and add an undisplayProc -instead. diff --git a/tk3.6/bitmaps/RCS/error,v b/tk3.6/bitmaps/RCS/error,v deleted file mode 100644 index 679d6e4..0000000 --- a/tk3.6/bitmaps/RCS/error,v +++ /dev/null @@ -1,56 +0,0 @@ -head 1.2; -branch ; -access ; -symbols ; -locks ; strict; -comment @# @; - - -1.2 -date 93.03.11.09.45.58; author ouster; state Exp; -branches ; -next 1.1; - -1.1 -date 93.03.11.09.22.15; author ouster; state Exp; -branches ; -next ; - - -desc -@@ - - -1.2 -log -@Resized so bitmap is only as large as the bits. -@ -text -@#define error_width 17 -#define error_height 17 -static char error_bits[] = { - 0xf0, 0x0f, 0x00, 0x58, 0x15, 0x00, 0xac, 0x2a, 0x00, 0x16, 0x50, 0x00, - 0x2b, 0xa0, 0x00, 0x55, 0x40, 0x01, 0xa3, 0xc0, 0x00, 0x45, 0x41, 0x01, - 0x83, 0xc2, 0x00, 0x05, 0x45, 0x01, 0x03, 0xca, 0x00, 0x05, 0x74, 0x01, - 0x0a, 0xa8, 0x00, 0x14, 0x58, 0x00, 0xe8, 0x2f, 0x00, 0x50, 0x15, 0x00, - 0xa0, 0x0a, 0x00}; -@ - - -1.1 -log -@Initial revision -@ -text -@d1 2 -a2 2 -#define error_width 18 -#define error_height 18 -d4 5 -a8 5 - 0x00, 0x00, 0x00, 0xf0, 0x0f, 0x00, 0x58, 0x15, 0x00, 0xac, 0x2a, 0x00, - 0x16, 0x50, 0x00, 0x2b, 0xa0, 0x00, 0x55, 0x40, 0x01, 0xa3, 0xc0, 0x00, - 0x45, 0x41, 0x01, 0x83, 0xc2, 0x00, 0x05, 0x45, 0x01, 0x03, 0xca, 0x00, - 0x05, 0x74, 0x01, 0x0a, 0xa8, 0x00, 0x14, 0x58, 0x00, 0xe8, 0x2f, 0x00, - 0x50, 0x15, 0x00, 0xa0, 0x0a, 0x00}; -@ diff --git a/tk3.6/bitmaps/RCS/gray25,v b/tk3.6/bitmaps/RCS/gray25,v deleted file mode 100644 index 58e4085..0000000 --- a/tk3.6/bitmaps/RCS/gray25,v +++ /dev/null @@ -1,31 +0,0 @@ -head 1.1; -branch ; -access ; -symbols ; -locks ; strict; -comment @# @; - - -1.1 -date 93.03.11.09.22.16; author ouster; state Exp; -branches ; -next ; - - -desc -@@ - - - -1.1 -log -@Initial revision -@ -text -@#define gray25_width 16 -#define gray25_height 16 -static char gray25_bits[] = { - 0x00, 0x00, 0x22, 0x22, 0x00, 0x00, 0x88, 0x88, 0x00, 0x00, 0x22, 0x22, - 0x00, 0x00, 0x88, 0x88, 0x00, 0x00, 0x22, 0x22, 0x00, 0x00, 0x88, 0x88, - 0x00, 0x00, 0x22, 0x22, 0x00, 0x00, 0x88, 0x88}; -@ diff --git a/tk3.6/bitmaps/RCS/gray50,v b/tk3.6/bitmaps/RCS/gray50,v deleted file mode 100644 index ac3794a..0000000 --- a/tk3.6/bitmaps/RCS/gray50,v +++ /dev/null @@ -1,31 +0,0 @@ -head 1.1; -branch ; -access ; -symbols ; -locks ; strict; -comment @# @; - - -1.1 -date 93.03.11.09.22.18; author ouster; state Exp; -branches ; -next ; - - -desc -@@ - - - -1.1 -log -@Initial revision -@ -text -@#define gray50_width 16 -#define gray50_height 16 -static char gray50_bits[] = { - 0x55, 0x55, 0xaa, 0xaa, 0x55, 0x55, 0xaa, 0xaa, 0x55, 0x55, 0xaa, 0xaa, - 0x55, 0x55, 0xaa, 0xaa, 0x55, 0x55, 0xaa, 0xaa, 0x55, 0x55, 0xaa, 0xaa, - 0x55, 0x55, 0xaa, 0xaa, 0x55, 0x55, 0xaa, 0xaa}; -@ diff --git a/tk3.6/bitmaps/RCS/hourglass,v b/tk3.6/bitmaps/RCS/hourglass,v deleted file mode 100644 index 7518c21..0000000 --- a/tk3.6/bitmaps/RCS/hourglass,v +++ /dev/null @@ -1,58 +0,0 @@ -head 1.2; -branch ; -access ; -symbols ; -locks ; strict; -comment @# @; - - -1.2 -date 93.03.11.09.46.11; author ouster; state Exp; -branches ; -next 1.1; - -1.1 -date 93.03.11.09.22.18; author ouster; state Exp; -branches ; -next ; - - -desc -@@ - - -1.2 -log -@Resized so bitmap is only as large as the bits. -@ -text -@#define hourglass_width 19 -#define hourglass_height 21 -static char hourglass_bits[] = { - 0xff, 0xff, 0x07, 0x55, 0x55, 0x05, 0xa2, 0x2a, 0x03, 0x66, 0x15, 0x01, - 0xa2, 0x2a, 0x03, 0x66, 0x15, 0x01, 0xc2, 0x0a, 0x03, 0x46, 0x05, 0x01, - 0x82, 0x0a, 0x03, 0x06, 0x05, 0x01, 0x02, 0x03, 0x03, 0x86, 0x05, 0x01, - 0xc2, 0x0a, 0x03, 0x66, 0x15, 0x01, 0xa2, 0x2a, 0x03, 0x66, 0x15, 0x01, - 0xa2, 0x2a, 0x03, 0x66, 0x15, 0x01, 0xa2, 0x2a, 0x03, 0xff, 0xff, 0x07, - 0xab, 0xaa, 0x02}; -@ - - -1.1 -log -@Initial revision -@ -text -@d1 2 -a2 2 -#define hourglass_width 24 -#define hourglass_height 24 -d4 6 -a9 6 - 0x00, 0x00, 0x00, 0xfc, 0xff, 0x1f, 0x54, 0x55, 0x15, 0x88, 0xaa, 0x0c, - 0x98, 0x55, 0x04, 0x88, 0xaa, 0x0c, 0x98, 0x55, 0x04, 0x08, 0x2b, 0x0c, - 0x18, 0x55, 0x04, 0x08, 0x2a, 0x0c, 0x18, 0x14, 0x04, 0x08, 0x0c, 0x0c, - 0x18, 0x16, 0x04, 0x08, 0x2b, 0x0c, 0x98, 0x55, 0x04, 0x88, 0xaa, 0x0c, - 0x98, 0x55, 0x04, 0x88, 0xaa, 0x0c, 0x98, 0x55, 0x04, 0x88, 0xaa, 0x0c, - 0xfc, 0xff, 0x1f, 0xac, 0xaa, 0x0a, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; -@ diff --git a/tk3.6/bitmaps/RCS/info,v b/tk3.6/bitmaps/RCS/info,v deleted file mode 100644 index 9247f6a..0000000 --- a/tk3.6/bitmaps/RCS/info,v +++ /dev/null @@ -1,54 +0,0 @@ -head 1.2; -branch ; -access ; -symbols ; -locks ; strict; -comment @# @; - - -1.2 -date 93.03.11.09.46.12; author ouster; state Exp; -branches ; -next 1.1; - -1.1 -date 93.03.11.09.22.19; author ouster; state Exp; -branches ; -next ; - - -desc -@@ - - -1.2 -log -@Resized so bitmap is only as large as the bits. -@ -text -@#define info_width 8 -#define info_height 21 -static char info_bits[] = { - 0x3c, 0x2a, 0x16, 0x2a, 0x14, 0x00, 0x00, 0x3f, 0x15, 0x2e, 0x14, 0x2c, - 0x14, 0x2c, 0x14, 0x2c, 0x14, 0x2c, 0xd7, 0xab, 0x55}; -@ - - -1.1 -log -@Initial revision -@ -text -@d1 2 -a2 2 -#define info_width 24 -#define info_height 24 -d4 2 -a5 6 - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x3c, 0x00, 0x00, 0x2a, 0x00, - 0x00, 0x16, 0x00, 0x00, 0x2a, 0x00, 0x00, 0x14, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x3f, 0x00, 0x00, 0x15, 0x00, 0x00, 0x2e, 0x00, - 0x00, 0x14, 0x00, 0x00, 0x2c, 0x00, 0x00, 0x14, 0x00, 0x00, 0x2c, 0x00, - 0x00, 0x14, 0x00, 0x00, 0x2c, 0x00, 0x00, 0x14, 0x00, 0x00, 0x2c, 0x00, - 0x00, 0xd7, 0x00, 0x00, 0xab, 0x00, 0x00, 0x55, 0x00, 0x00, 0x00, 0x00}; -@ diff --git a/tk3.6/bitmaps/RCS/questhead,v b/tk3.6/bitmaps/RCS/questhead,v deleted file mode 100644 index d95a357..0000000 --- a/tk3.6/bitmaps/RCS/questhead,v +++ /dev/null @@ -1,58 +0,0 @@ -head 1.2; -branch ; -access ; -symbols ; -locks ; strict; -comment @# @; - - -1.2 -date 93.03.11.09.46.14; author ouster; state Exp; -branches ; -next 1.1; - -1.1 -date 93.03.11.09.22.20; author ouster; state Exp; -branches ; -next ; - - -desc -@@ - - -1.2 -log -@Resized so bitmap is only as large as the bits. -@ -text -@#define questhead_width 20 -#define questhead_height 22 -static char questhead_bits[] = { - 0xf8, 0x1f, 0x00, 0xac, 0x2a, 0x00, 0x56, 0x55, 0x00, 0xeb, 0xaf, 0x00, - 0xf5, 0x5f, 0x01, 0xfb, 0xbf, 0x00, 0x75, 0x5d, 0x01, 0xfb, 0xbe, 0x02, - 0x75, 0x5d, 0x05, 0xab, 0xbe, 0x0a, 0x55, 0x5f, 0x07, 0xab, 0xaf, 0x00, - 0xd6, 0x57, 0x01, 0xac, 0xab, 0x00, 0xd8, 0x57, 0x00, 0xb0, 0xaa, 0x00, - 0x50, 0x55, 0x00, 0xb0, 0x0b, 0x00, 0xd0, 0x17, 0x00, 0xb0, 0x0b, 0x00, - 0x58, 0x15, 0x00, 0xa8, 0x2a, 0x00}; -@ - - -1.1 -log -@Initial revision -@ -text -@d1 2 -a2 2 -#define questhead_width 24 -#define questhead_height 24 -d4 6 -a9 6 - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xf0, 0x3f, 0x00, 0x58, 0x55, 0x00, - 0xac, 0xaa, 0x00, 0xd6, 0x5f, 0x01, 0xea, 0xbf, 0x02, 0xf6, 0x7f, 0x01, - 0xea, 0xba, 0x02, 0xf6, 0x7d, 0x05, 0xea, 0xba, 0x0a, 0x56, 0x7d, 0x15, - 0xaa, 0xbe, 0x1e, 0x56, 0x5f, 0x01, 0xac, 0xaf, 0x02, 0x58, 0x57, 0x01, - 0xb0, 0xaf, 0x00, 0x60, 0x55, 0x01, 0xa0, 0xaa, 0x00, 0x60, 0x17, 0x00, - 0xa0, 0x2f, 0x00, 0x60, 0x17, 0x00, 0xb0, 0x2a, 0x00, 0x50, 0x55, 0x00}; -@ diff --git a/tk3.6/bitmaps/RCS/question,v b/tk3.6/bitmaps/RCS/question,v deleted file mode 100644 index 8e51c57..0000000 --- a/tk3.6/bitmaps/RCS/question,v +++ /dev/null @@ -1,35 +0,0 @@ -head 1.1; -branch ; -access ; -symbols ; -locks ; strict; -comment @# @; - - -1.1 -date 93.03.11.09.22.21; author ouster; state Exp; -branches ; -next ; - - -desc -@@ - - - -1.1 -log -@Initial revision -@ -text -@#define question_width 17 -#define question_height 27 -static char question_bits[] = { - 0xf0, 0x0f, 0x00, 0x58, 0x15, 0x00, 0xac, 0x2a, 0x00, 0x56, 0x55, 0x00, - 0x2b, 0xa8, 0x00, 0x15, 0x50, 0x01, 0x0b, 0xa0, 0x00, 0x05, 0x60, 0x01, - 0x0b, 0xa0, 0x00, 0x05, 0x60, 0x01, 0x0b, 0xb0, 0x00, 0x00, 0x58, 0x01, - 0x00, 0xaf, 0x00, 0x80, 0x55, 0x00, 0xc0, 0x2a, 0x00, 0x40, 0x15, 0x00, - 0xc0, 0x02, 0x00, 0x40, 0x01, 0x00, 0xc0, 0x02, 0x00, 0x40, 0x01, 0x00, - 0xc0, 0x02, 0x00, 0x00, 0x00, 0x00, 0x80, 0x01, 0x00, 0xc0, 0x02, 0x00, - 0x40, 0x01, 0x00, 0xc0, 0x02, 0x00, 0x00, 0x01, 0x00}; -@ diff --git a/tk3.6/bitmaps/RCS/warning,v b/tk3.6/bitmaps/RCS/warning,v deleted file mode 100644 index b5ce54c..0000000 --- a/tk3.6/bitmaps/RCS/warning,v +++ /dev/null @@ -1,54 +0,0 @@ -head 1.2; -branch ; -access ; -symbols ; -locks ; strict; -comment @# @; - - -1.2 -date 93.03.11.09.46.15; author ouster; state Exp; -branches ; -next 1.1; - -1.1 -date 93.03.11.09.22.21; author ouster; state Exp; -branches ; -next ; - - -desc -@@ - - -1.2 -log -@Resized so bitmap is only as large as the bits. -@ -text -@#define warning_width 6 -#define warning_height 19 -static char warning_bits[] = { - 0x0c, 0x16, 0x2b, 0x15, 0x2b, 0x15, 0x2b, 0x16, 0x0a, 0x16, 0x0a, 0x16, - 0x0a, 0x00, 0x00, 0x1e, 0x0a, 0x16, 0x0a}; -@ - - -1.1 -log -@Initial revision -@ -text -@d1 2 -a2 2 -#define warning_width 24 -#define warning_height 24 -d4 2 -a5 6 - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x0c, 0x00, 0x00, 0x16, 0x00, - 0x00, 0x2b, 0x00, 0x00, 0x15, 0x00, 0x00, 0x2b, 0x00, 0x00, 0x15, 0x00, - 0x00, 0x2b, 0x00, 0x00, 0x16, 0x00, 0x00, 0x0a, 0x00, 0x00, 0x16, 0x00, - 0x00, 0x0a, 0x00, 0x00, 0x16, 0x00, 0x00, 0x0a, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x1e, 0x00, 0x00, 0x0a, 0x00, 0x00, 0x16, 0x00, - 0x00, 0x0a, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; -@ diff --git a/tk3.6/changes b/tk3.6/changes deleted file mode 100644 index 202b7e8..0000000 --- a/tk3.6/changes +++ /dev/null @@ -1,1226 +0,0 @@ -This file summarizes all changes made to Tk since version 1.0 was -released on March 13, 1991. Changes that aren't backward compatible -are marked specially. - -3/16/91 (bug fix) Modified tkWindow.c to remove Tk's Tcl commands from -the interpreter when the main window is deleted (otherwise there will -be dangling pointers to the non-existent window). - -3/16/91 (bug fix) Modified tkColor.c not to free black or white colors: -some X servers get upset at this. - -3/18/91 (bug fix) Modified tkShare.c to fix bug causing "DeleteGroup -couldn't find group on shareList" panic. - -3/18/91 (bug fix) Several changes to tkListbox.c and tkScrollbar.c to -handle listboxes (and scrollbars) with zero total entries in them. - -3/22/91 (bug fix) Fixed a few ='s in tkListbox.c that should be ==. - -3/22/91 (bug fix) Fixed error in main.c that caused BadWindow errors -in some cases where wish scripts invoke "destroy .". - -3/23/91 (new feature) Added Tk_CancelIdleCall to remove Tk_DoWhenIdle -handler. - -3/23/91 (bug fix and new feature) Added -name option to main.c, made -it more clever about choosing name (was always using the name "wish" -on most Unix systems). - -3/23/91 (new feature) Added TK_CONFIG_STRING option to Tk_ConfigureWidget, -used it to malloc strings for various widget options that used to be -Tk_Uid's (e.g. button text, message strings, etc.). Eliminates core -leaks when values change in continuous non-repeating fashion. - -3/29/91 (new feature) Added Tk_Preserve, Tk_Release, and -Tk_EventuallyFree procedures to help manage widget records and avoid -premature memory free-ing. - -4/4/91 (bug fix) Fixed problem in tkWm.c where top-level window geometry -wasn't tracking correctly when wm-induced size change also changed window -position (e.g. menus wouldn't be displayed at the right places). - -4/5/91 (new feature) Added "invoke" option to widget command for buttons, -check buttons, and radio buttons. - -4/5/91 (new feature) Added "unpack" option to "pack" command. - -4/5/91 (bug fix) Changed tkPack.c to use new Tk_Preserve code and be -more careful about window deletions that occur while repacking is in -progress. - -4/6/91 (bug fix) Major overhaul of deletion code in all widgets to use -Tk_Preserve and Tk_Release. Should fix many problems. - -4/6/91 (bug fix) Changed "winfo children" to generate correct lists -when child names have embedded spaces. - -4/6/91 (new feature) Added "screenheight" and "screenwidth" options to -"winfo". - -4/18/91 (bug fix) Binding mechanism didn't correctly handle very long -%-substitutions in commands (e.g. long path names) and caused memory -to be overwritten. Modified tkBind.c to fix. - ----------------------- Release 1.1, 4/18/91 ------------------------- - -4/19/91 (bug fix) Inconsistent ICCCM handling of coordinates of reparented -windows causes windows to gradually walk south when moved or resized. -Fixed tkWm.c to patch around the problem. - ----------------------- Release 1.2, 4/24/91 ------------------------- - -4/26/91 (new feature) Added -geometry and -display switches to wish. -Also wrote wish manual entry. - -5/3/91 (bug fix) Fixed bug in tkListbox.c that caused garbage to appear -at right edge of window when strings were to large to fit in window. - -5/3/91 (bug fix) Fixed bug in tkListbox.c where topIndex wasn't getting -updated when elements were deleted: tended to cause errors in -communication with scrollbars. - -5/16/91 (bug fix) Fixed bug in tk3d.c, which caused core dumps when -consecutive points in a polygon were the same (happened with some -configurations of radio buttons, for example). - -5/16/91 (bug fix) Fixed main.c to allow stdin to be redirected. - -6/1/91 (bug fix) Make sure that pointers are never used after being -freed. - -6/15/91 (bug fix) Fixed bug in tkBind.c that caused current binding -values to not always be printed correctly. - -6/15/91 (bug fix) Make sure that interpreters are always unregistered -when their main windows are deleted, and make wish delete the main -window before exiting. - -8/21/91 (misfeature correction) Automatically set source of window -position to "user" in "wm geometry" command, unless it has been -explicitly set to "program". - -9/5/91 (bug fix) Modified option code to accept '#' as a comment -character in .Xdefaults files, in addition to '!'. - -9/10/91 (misfeature correction) Changed binding mechanism so that -numeric %-sequences are output in decimal instead of hex. - -9/19/91 (bug fix) Fixed bug in Tk_DoOneEvent(1) where it wasn't -checking files and X connections properly so it missed events. - -10/6/91 (new feature) Reorganized tkBind.c to provide generic "binding -table" structure, which can be used to create bindings on items in -canvases as well as windows. - -10/6/91 (new feature) Upgraded buttons and menus to use new tracing -code in Tcl 6.0. Allows radio buttons and check buttons to both set -and clear themselves when associated variable changes. - -10/17/91 (bug fix) Fixed 2 bugs in listboxes: accidentally advanced the -selection when new entries were inserted in the listbox after the location -of the selected item(s), and goofed up on redisplay if selected item -was deleted and then selection was immediately lost. - -10/27/91 (bug fix) "pack unpack" wasn't telling Tk that it no longer -manages window; this led to core dumps in some situations. - -10/31/91 (reorganization) Renamed manual entries so that they are no -more than 14 characters in length. - -10/31/91 (reorganization) Changed tk.h and tkInt.h so that tkInt.h -doesn't needed to be included by tk.h. - -11/3/91 (portability improvement) Eliminated use of "class" as a variable -name, since it's a reserved word in C++. - -11/7/91 (reorganization) Many changes to upgrade for Tcl 6.1 including -use of Tcl hash tables instead of separate "Hash_" module. The "lib" -subdirectory is no longer needed in Tk. - ----------------------- Release 1.3, 11/7/91 ------------------------- - -11/24/91 (bug fix) Fixed bug causing occasional errors if existing bindings -are modified (FindSequence in tkBind.c forget to set *maskPtr). - -11/24/91 (bug fix) Used wrong hash table in Tk_GetColorByValue. Could -cause new entries to get created unnecessarily. - -12/2/91 (bug fix) Changed "bind" code to put backslashes in front of -special characters (e.g. [ or \) that appear in %-replacements, so that -they can be parsed cleanly. - -12/10/91 (bug fix) Manual entries had first lines that caused "man" program -to try weird preprocessor. Added blank comment lines to fix problem. - -1/2/92 (documentation cleanup) Changed manual entries for Tk_GetBitmap -and the like to make it more clear that the argument must be a Tk_Uid -and not a string. - -1/2/92 (bug fix) Fixed problem where scrollbars that were very short or -very narrow (too small to hold both arrows) could cause negative values -in calls to XClearArea, which crashed some servers. - -1/2/92 (bug fix) Fixed bug in TkMeasureChars occurring when maxChars -is 0. Occasionally affected things like message window geometry. - -1/3/92 (new feature) Added procedures Tk_GetJustify, Tk_GetAnchor, -Tk_GetCapStyle, and Tk_GetJoinStyle, plus support for these things -in Tk_ConfigureWidget. - ----------------------- Release 1.4, 1/10/92 ------------------------- - -1/12/92 (bug fix) TkMenubutton.c wasn't cleaning up mbPtr->varName -properly during menubutton cleanup if an error occurred during -menubutton creation. - -1/19/92 (bug fix) Fixed off-by-one bug in tkListbox.c that caused -scrollbars to display a slider that was too large. - -2/10/92 (bug fix) Tk_CreateFileHandler didn't correctly handle case -where new mask was specified for existing handler. - -2/13/92 (bug fix) Tk_DeleteAllBindings wasn't correctly removing -bindings from the pattern table: only did the removal for the -first pattern in a pattern list. - -2/15/92 (new feature) Added procedures Tk_DefineBitmap and -Tk_SizeOfBitmap. Tk_GetBitmapFromData is now considered obsolete -and probably shouldn't be used anymore. Tk_GetBitmapFromData -is now implemented by calling Tk_DefineBitmap and Tk_GetBitmap. - -2/15/92 (new feature) Added "curselection" and "select clear" options -to widget command for listboxes. - -2/15/92 (new feature) Added Tk_3DBorderColor procedure. - -2/17/92 (relaxed limitations) Changed scrollbars so they no longer limit -the slider position to lie within the object's range: can scroll off the -end of an object, if the object permits it. Changed listboxes and -entries to explicitly prevent viewing off the ends. Also relaxed -listbox index checks so that out-of-range indices are automatically -adjust to fit within the listbox range. - -2/19/92 (bug fix) tkWindow.c tended to leave half-created windows around -if a new window's name was found to be in use already. Fixed to clean -them up. - -2/22/92 (new feature) Added -anchor, -bitmap, -height, -textvariable, --width options to labels, buttons, check buttons, menu buttons, and radio -buttons. This means that (a) size can be controlled better, (b) bitmaps -can be displayed in any buttons, (c) the position of the text within the -button can be controlled, and (d) a button can be made to display the value -of a variable, continuously updating itself. Also changed -selector option -so that if it's specified as an empty string then no selector is drawn -for the button. - -2/22/92 (new feature) Changed menus to support bitmaps in menu entries: -added new -bitmap option for entries. - -2/26/92 (bug fix) "after" command, when invoked with just one argument, -called Tk_Sleep rather than registering a timer handler and looping on -Tk_DoOneEvent. As a result, it caused the application to become non- -responsive to X events during the sleep. Changed to use a Tk_DoOneEvent -loop so that it is responsive. - -2/26/92 (bug fix) Tk's main program didn't map the main window until -after the startup script returned. Changed to map the window as a -do-when-idle handler, so that scripts can cause the window to be -mapped immediately with a call to "update" or "after". - -2/28/92 (bug fix) "wm withdraw" wasn't working if invoked before window -was originally mapped: window got mapped anyway. Fixed so that the -window doesn't get mapped as long as it's withdrawn. - -2/29/92 (new feature) Can use "focus none" to clear input focus. - -2/29/92 (bug fix) Fixed tkEvent.c to generate SubstructureNotify events -properly. These weren't being generated previously. - -2/29/92 (bug fix) Fixed entries so that newline characters can be properly -displayed (as `\x0a'). Had to change interface to TkDisplayChars in order -to do this (added flags argument). - -2/29/92 (bug fix) Change Tk not to update size and position of top-level -windows directly during calls like Tk_ResizeWindow. Instead, wait until -actual event is received. This makes updates happen at same time as -callbacks. - -3/6/92 (bug fix) TkMenubutton.c was dumping core when a menubutton was -pressed at a time when there was no associated menu for the button. - -3/6/92 (new feature) Added Tk script library directory with official -Tk initialization file "tk.tcl". Other procedures used by Tk are in -other files. Tk procedures and variables all have names starting -with "tk_". Also added Wish startup script "wish.tcl", which sources -both the Tk and Tcl startup scripts. This means that things like -auto-loading and abbreviation expansion are now available in wish. -Added new variables tk_library, tk_priv, and tk_version. - -3/6/92 (new feature) It's now possible to set bindings for whole -classes by using the class name in the bind command. For example, -"bind Button {puts stdout Hi!}" will cause a message to be -printed whenever any mouse button is entered. Can also use "all" -to set bindings for all widgets. Widget-specific bindings override -class bindings which override "all" bindings. - -3/6/92 (reorganization) Changed buttons (all flavors) and listboxes to -eliminate all hard-wired behavior. Instead, default behavior is set -by class bindings in tk.tcl. Also set up class bindings for menus, -menubuttons, and entries, which previously had no default behavior at -all. Scrollbars and scales still have hard-wired behavior that can't -be overridden. - -3/7/92 (look-and-feel change) Changed listboxes and entries and menus -to use button 2 for scanning instead of button 3. This is more consistent -with the official Motif use of button 2 for dragging. - -3/10/92 (new features) Added more options to "winfo" command: screencells, -screendepth, screenmmheight, screenmmwidth, and screenvisual. - -3/13/92 (bug fix) Event sharing mechanism (tkShare.c) wasn't checking -to see whether window was mapped before sharing events with it. - -3/16/92 (bug fix) Tk_SetInternalBorderWidth was passing wrong window to -geometry-management procedures, causing core-dumps when menu buttons -had their border widths changed. - -3/16/92 (bug fix) Menus were setting their geometry directory rather -than using Tk_GeometryRequest mechanism. - -3/17/92 (new feature) Added -cursor option to all widgets to set the -active cursor for the widget. Also added TK_CONFIG_ACTIVE_CURSOR -configure type. - -3/18/92 (new feature) Implemented generalized screen coordinates to -allow resolution-independent specification in many cases (but pixel- -based coordinates are still OK). Added Tk_GetScreenMM(), -Tk_GetPixels(), new configure types TK_CONFIG_SCREEN_MM and -TK_CONFIG_PIXELS. Changed widgets to use this new configure types -wherever possible (a few of the more complex cases still haven't -been taken care of yet). Added "pixels" and "fpixels" options to -"winfo" command. - -3/18/92 (new feature) First cut at canvas widgets is done and part of -the official Tk now. Canvases display text and structured graphics, -and allow you to bind commands to events related to the text and -graphics. - -3/21/92 (new feature) Added new "place" command. It implements a -new geometry manager that provides fixed placement, rubber-sheet -placement, and combinations of the two. Eliminated the commands -"move", "resize", and "map" that were provided by main.c but never -officially supported; the placer provides all of this functionality. - -3/23/92 (bug fix) Fixed bug in tkWm.c where top-level windows were -occasionally not being given the right size. The problem occurred -when a string of resizes happened all in a row (such as deleting all -the windows in an application and then recreating them). - -3/23/92 (new feature) Added Tk_CoordsToWindow procedure and -"winfo containing" command. These may be used to locate the window -containing a given point. - -3/28/92 (new feature) Added "-exportselection" option to listboxes, -so that listbox selection need not necessarily be the X selection. - -4/12/92 (bug fix) Changed menu buttons to store name of menubutton -in the associated variable, rather than the name of the menu. This -is necessary in order to allow several menu buttons to share the -same menu. -*** POTENTIAL INCOMPATIBILITY *** - -4/12/92 (bug fix) Fixed core dump that occurred in tkError.c when -removing the first error record from the error list. - -4/15/92 (bug fix) Fixed bug in tkBind.c that prevented -event specifications from being processed correctly: the "1" was -treated as a button name rather than a keysym. - -4/18/92 (new feature) Added Tk_DefineCursor and Tk_UndefineCursor -procedures. - -4/18/92 (new feature) Major revision to listboxes. Can now scroll and -scan in both x and y, plus -exportselection option allows selection not -to be exported. The "view" widget command has been replaced by "xview" -and "yview", and the "scan" widget command has a new syntax. -*** POTENTIAL INCOMPATIBILITY *** - -4/18/92 (new feature) Added -exportselection option to entries, so you -can select whether you want the entry selection to be the X selection -or not. - -4/24/92 (new features) Added TK_CONFIG_CUSTOM type to Tk_ConfigureWidget, -plus added new flags TK_CONFIG_NULL_OK, TK_CONFIG_DONT_SET_DEFAULT, -and TK_CONFIG_OPTION_SPECIFIED. Several other new types, such as -TK_CONFIG_CAP_STYLE, were also added as part of implementing canvases. - -4/29/92 (bug fix) Changed "-selector" default for menus to have separate -values for mono and color. - -4/30/92 (bug fix) Fixed bug in tkListbox.c where it occasionally generated -bogus scroll commands (last index less than first). - -4/30/92 (reorganization) Moved demos directory to "library/demos". - ----------------------- Release 2.0, 5/1/92 ------------------------- - -5/2/92 (bug fix) Fixed problem in tkListbox.c where it was doing too many -redisplays after repeated insertions. Also reduced number of invocations -of scrollbar commands. - -5/7/92 (portability improvement) Changed main.c not to use TK_EXCEPTION -flag; it isn't needed and it causes problems on some systems. - -5/9/92 (bug fix) Plugged core leaks in tkListbox.c and tkBind.c - -5/9/92 (bug fix) TkBind.c was accidentally deleting bindings during -attempts to print non-existent bindings. - -5/11/92 (bug fix) Maximum name length for applications (name used in -"send" commands) was too short (only 20); increased to 1000. Also -fixed bug related to over-long names that caused core dumps. - -5/13/92 (bug fix) tkShare.c was using a dangling pointer if a share -group was deleted as a side-effect of a shared event. - -5/13/92 (bug fix) Various initialization and core leak problems in -tkGC.c, tkSend.c, tkMenu.c, tkEvent.c, tkCanvas.c, tkCanvPoly.c, -tkCanvLine.c, tkListbox.c, tkEntry.c. - -5/13/92 (bug fix) Empty entries could be scanned off the left edge, -displaying a garbage character. - -5/13/92 (bug fix) Fixed a few problems with window manager interactions, -such as tendency for windows to spontaneously shrink in size. By no -means are all of the problems fixed, though. - -5/13/92 (performance optimization) Changed Tk_GeometryRequest not to -invoke geometry manager unless requested size has changed. - ----------------------- Release 2.1, 5/14/92 ------------------------- - -5/1/92 (new features) Added flags like TK_IDLE_EVENTS to Tk_DoWhenIdle, -plus added "idletasks" option to "update" command. Tk_DoWhenIdle arguments -look different now, but the change should be upward-compatible. - -5/17/92 (new feature/bug fix) Added support for VisibilityNotify events -to the "bind" command. For some reason they weren't supported previously. - -5/17/92 (new feature) Added "tkwait" command. - -5/17/92 (new feature) Added "grab" command. - -5/17/92 (new feature) Added "-width" option to messages. Also changed -messages to use the computed (i.e. desired) line length when displaying, -not the actual width of the window. - -5/17/92 (bug fixes) Did some more fiddling with tkWm.c in the hopes -of improving window manager interactions. Now there won't be more than -one configure request outstanding to the wm at a time. - -5/17/92 (bug fix) Arrowheads on canvas lines weren't being translated -or scaled correctly. - -5/20/92 (bug fix) Page-mode scrolling didn't work correctly for canvases -(wrong windowUnits was passed to scrollbars). - -5/20/92 (bug fix) Changed scrollbars not to lose highlight when pointer -leaves window with button down. Also changed redisplay to double-buffer -for smoother redraws. - -5/21/92 (new feature) Added "gray50" and "gray25" as predefined bitmaps. - -5/22/92 (new feature) Buttons can now be disabled using the "-state" and -"-disabledforeground configuration options. The "activate" and "deactivate" -widget commands for buttons are now obsolete and will go away soon. -Please change Tcl scripts not to use them. - -5/23/92 (new feature) Entries can now be disabled using the "-state" -config option. Also improved class bindings for entries to keep the -cursor visible in the window when operations occur. Also made slight -improvements in the way redisplay is done. - -5/23/92 (new feature) Added "-textvariable" option to entries so that -the text in an entry can be tied to the value of a global variable in -a fashion similar to buttons. - -5/27/92 (new feature) Added "-textvariable" and "-anchor" options to -messages. - -5/28/92 (new feature) Added "-padx" and "-pady" and "-underline" options -to menubuttons. - -5/28/92 (feature change) Changed "-width" and "-height" options on -all flavors of buttons and menubuttons so that they are orthogonal -to "-padx" and "-pady". It used to be that -width overrode -padx -(no padding). Now they accumulate. - -5/29/92 (new feature) Added "-disabledforeground" option to menus and -all flavors of buttons (can specify color for disabled things rather -than just using stipple to gray out). - -5/29/92 (new features) Added many new options to menu entries: --activebackground, -background, -font, -state, -underline. The -"disable" and "enable" widget commands for menus are now obsolete -and will go away soon. Please change Tcl scripts not to use them. - -5/29/92 (new features) Added "atom" and "atomname" options to "winfo" -command. - -5/29/92 (new feature) Wrote tk_listboxSingleSelect procedure, which -can be used to change listbox behavior so that only a single item is -selected at once. - -6/1/92 (new feature) Added new modifier names "Meta" and "Alt" for -"bind" command. - -6/3/92 (new feature) Added "winfo toplevel" command. - -6/3/92 (new feature) Made several changes for greater Motif compliance, -including: - - menu retention if you click and release in the menu button, - - keyboard traversal of menus (see traversal.man) - - no widget flashing if you set $tk_strictMotif to 1 - -6/15/92 (bug fix) Fixed problem in tkBind.c where command string for a -binding could get reallocated while the command was being executed (e.g. -bindings that delete or change themselves). - -6/15/92 (bug fix) Don't allow "tabWidth" field to become zero in tkFont.c: -can cause core dumps for fonts that don't enough information to compute -tab widths. - -6/19/92 (bug fix) Fixed bug in binding mechanism that caused structure- -related events to be reported both to the correct window and its parent. - -7/14/92 (bug fix) Changed tkColor.c not to free colors for visual types -StaticGray or StaticColor. - -7/15/92 (new feature) Text widgets now exist. They display any number of -lines of text with a variety of display formats, and include hypertext -facilities. See the manual page for details. - -7/20/92 (bug fix) If a top-level window was put in the iconic state to -begin with, it could be deiconified with "wm deiconify .foo" until it had -first been deiconified by hand from the window manager. Tk was getting -confused and thought the window was mapped when it wasn't. - -7/29/92 (bug fix) Don't permit rectangles or ovals to have zero-sized -dimensions. Round up to at least one pixel. - -7/29/92 (new features) Major upgrade to canvases: - - new item types: arc, window, bitmap - - added Bezier spline support for lines and polygons - - rectangles and ovals now center their outlines on the shape, - rather than drawing them entirely inside the shape - - new "coords" and "bbox" widget commands - - new "-tags" option for all item types. - - new "-confine" option to prevent scrolling off edge of canvas. - -8/6/92 (new feature) Added "-width" and "-height" options to frames. -The "-geometry" option is now obsolete and should be removed from Tcl -scripts: it may go away in the future. - -8/7/92 (bug fix) Error messages in Tk_ParseArgv were sometimes including -the option name where they should have included its value. - ----------------------- Release 2.2, 8/7/92 ------------------------- - -8/7/92 (bug fix) Changed tkCanvas.c to be more conservative in the area -it passes to XCopyArea. - -8/8/92 (bug fix) Fixed bug in tkTextDisp.c that sometimes caused core -dumps when text views changed (e.g. typing return on last line of screen). - -8/8/92 (bug fix) Fixed bug in menu.tcl that caused errors when using -keyboard to traverse over separator menu entries. - -8/10/92 (bug fix) Changed to use OPEN_MAX instead of MAX_FD to compute -maximum # of open files. - -8/10/92 (bug fix) Canvases weren't updating scrollbars on window size -changes. They also weren't recentering canvases on window size changes. - -8/10/92 (bug fix) There were still a few places where commands were being -invoked at local level instead of global level (e.g. commands associated -with buttons and menu entries). - -8/10/92 (bug fix) TkBind.c used to ignore explicit shift modifiers for -all keys (i.e. was treated the same as ). Modified to -allow explicit request for shift modifier, like . - -8/13/92 (feature change) Changed default fonts to request "Adobe" fonts -explicitly. - -8/16/92 (bug fixes) Modified tkCanvArc.c and tkTrig.c to increase slightly -the bounding boxes for arcs, in order to make sure that proper redisplay -occurs when arcs are moved (little turds were getting left behind). - -8/16/92 (bug fix) Modified tkCanvas.c not to redraw at all if the redisplay -area is off the screen. Also, only do a background clear for the portion -of the redraw area that is on-screen. Also, reduced size of off-screen -pixmaps used for redisplaying, which speeds up redisplay in some cases. - -8/19/92 (bug fix) Canvases that were taller than wide were not being -redisplayed properly. - -8/20/92 (new feature) Added Tk_CreateGenericHandler procedure for trapping -all X events (useful for tracing, watching non-Tk windows, etc.). - -8/21/92 (bug fix) Widgets weren't always being notified when they got -the focus back again (the problem had to do with grabs and menus in -particular). - -8/21/92 (new feature) Added "-state" option to scale widgets. - -8/22/92 (new feature) Changed tkBitmap.c to allow tilde-substitution -to occur in bitmap file names. - ----------------------- Release 2.3, 8/24/92 ------------------------- - -8/27/92 (bug fix) Changes to -activebackground and -activeforeground options -for menubuttons were being lost. - -8/27/92 (bug fix) Entries were selecting last character when a B1-drag -occurred past the right edge of the text. - -8/28/92 (bug fix) Fixed bug in canvases where a grab during a button -press caused the canvas state to lock up so that it didn't select a -new current item. - -9/7/92 (bug fix) Changed tkMenu.c to accept numerical menu indices that -are out of range; now it just rounds them off to the nearest existing -entry. - -9/7/92 (bug fix) Fixed bug in tkTextDisp.c that caused core dumps when -invoking "yview -pickplace" widget command on texts that are too small -to hold any lines at all. - -9/11/92 (bug fix) Fixed bug in tkTextDisp.c that caused core dumps -when adding tags to non-existent lines. - -9/11/92 (bug fix) Line items in canvases didn't permit an empty fill -color (i.e. couldn't make them transparent). - -9/14/92 (reorganization) Changed manual entries to use .1, .3, and .n -extensions. Added "install" target to Makefile to suggest how Tk should -be installed. - -9/16/92 (bug fix) Changed tkSend.c to always specify the root window of -screen 0 rather than using DefaultRootWindow. DefaultRootWindow doesn't -always go to screen 0 on displays with multiple screens, which can result -in send's not being possible between the screens. - -9/18/92 (new feature) Added three new options to "wm" command: "protocol", -"client", and "command". These provide support for window manager protocols -such as WM_DELETE_WINDOW and WM_TAKE_FOCUS, plus support for the -WM_CLIENT_MACHINE and WM_COMMAND properties. - -9/30/92 (new feature) Implemented color model support, including -"tk colormodel" command and Tk_GetColorModel and Tk_SetColorModel -procedures. These allow you to force mono operation even on a color -display. Also changed color allocation not to give errors when colors -run out, but just to switch to a mono color model. - -10/1/92 (bug fixes) Fixed two bugs in tkTextBTree.c that caused core dumps -during text deletion. - -10/5/92 (bug work-around) Changed tkColor.c to ignore errors when freeing -colors. This is needed to work around improper reference count management -for colormap entries under X11/NeWS. - -10/7/92 (new feature) Added support for different visual types, including -procedures Tk_SetWindowVisual and Tk_SetWindowColormap, plus macros -Tk_Visual, Tk_Depth, and Tk_Colormap. The code for this was contributed -by Paul Mackerras. - -10/7/92 (new feature) Added Tk_IsTopLevel macro. - -10/12/92 (bug fix) Fixed bug in tk.tcl that caused torn-off menus with -cascaded children not to track mouse motion correctly (the cascade -switched in response to mouse motions within the cascaded child). - -10/12/92 (new feature) Major changes to focus handling: -(a) Tk watches FocusIn and FocusOut events for focus changes, not Enter - and Leave, so it will work better with explicit-focus-model window - managers (e.g. mwm in default mode). -(b) Tk generates FocusIn and FocusOut events for the focus window now. - The old procedural interface (via Tk_CreateFocusHandler) is obsolete - and is no longer used inside Tk. It is still supported for - compatibility, but won't be for long. You should change your code - to use FocusIn and FocusOut events instead. -(c) The model for FocusIn and FocusOut events is different than the - one described in Xlib documentation. See the "focus" manual entry - for details. -(d) If there is no input focus then keyboard events are discarded. They - used to be directed to the mouse pointer window, although this wasn't - documented. The focus now defaults to the root window. -*** POTENTIAL INCOMPATIBILITY *** - -10/15/92 (bug fix) Fixed text items in canvases where they didn't -display the insertion cursor if the item had no characters in it. - -10/26/92 (bug fix) Fixed bug in tkSelect.c that occasionally caused -BadWindow X protocol errors when retrieving the selection. Tk wasn't -making sure that a window existed before using it to retrieve the -selection. - -10/30/92 (feature change) Changed canvases so that if the scroll region -is smaller than the window and -confine is on, the scroll region isn't -forced to be centered in the window; it can be anywhere that meets the -confinement restrictions. - -11/2/92 (new feature) Added "winfo exists" command. - -11/5/92 (new feature) Changed DoWhenIdle handlers so that if a new -when-idle handler is created as a side-effect of another when-idle -handler, the new handler isn't invoked until Tk has first checked -for other events to process. - -11/6/92 (bug fixes, new features) Major overhaul of window manager -interface: -(a) Tk should now work with virtual-root window managers; -(b) windows will now place more accurately on the screen and stay where - they're supposed to; -(c) size changes handled more reliably; -(d) code now works robustly in the face of withdrawals followed - immediately by deiconifications. -(e) Added new procedure Tk_GetVRootInfo and new options to "winfo" command: - vrootx, vrooty, vrootwidth, vrootheight. -(f) Added "overrideredirect" option to "wm". -(g) Fixed bug where change in width-only via "wm geom" didn't always work - (min and max window sizes weren't being set properly for the wm). - -11/6/92 (bug fixes) Modified menus so that they work correctly with -virtual root window managers. Also fixed bug where menus didn't move -along with their associated windows, so that the menu popped up at -the old location of the window rather than its new location. - -11/9/92 (new constraint) Made it illegal to give windows names that -start with upper-case letters, since such names will goof up the -option database by appearing to be classes rather than names. -*** POTENTIAL INCOMPATIBILITY *** - -11/10/92 (new feature) Added Postscript output to canvases. - -11/13/92 (bug fix) Changed default for maximum size passed to window -manager from 1000000 (which causes some wm's to make windows too large -when "maximized") to the size of the display. - -11/14/92 (feature change) Major overhaul of menubuttons and pull-down -menus. Removed event-sharing code, including Tk_ShareEvents and -Tk_UnshareEvents. The -variable option for menubuttons has been -removed,and the "post" and "unpost" widget commands for menubuttons -no longer exist. The "post" widget command for menus no longer -allows a group option. The procedure tk_menus has been replaced -with a new procedure, tk_menuBar, which has a slightly different -interface. -*** POTENTIAL INCOMPATIBILITY *** - -11/20/92 (new features, feature changes) Major overhaul of grab -mechanism to produce more correct event streams. Also changed Tcl -commands to require explicit window for grab releases (makes it -possible for grabs to work on multiple displays simultaneously). -The old "grab none" command no longer exists, but new options -have been added: "current", "release", "set", and "status". -*** POTENTIAL INCOMPATIBILITY *** - -11/20/92 (new feature) Use TK_LIBRARY environment variable to set library -directory location, if it is defined. Otherwise fall back on usual -compiled-in value. - -11/25/92 (bug fix) "wm grid" command was using wrong window. - -11/29/92 (bug fix) Fixed core dump that occurred when trying to use -placer on top-level windows: return error instead. - -11/29/92 (bug fix) Selection retrieval wasn't making sure that the window -on whose behalf selection is being retrieved actually exists. - -12/3/92 (new feature) Added support for Mode_switch key to support the -full ISO character set. Also added event handlers for MappingNotify -events so that Tk updates itself in response to keycode and modifier -changes. - -12/6/92 (bug fix) Ignore recursive attempts to destroy window. - -12/9/92 (new demos) Added "tcolor" and "rmt" demos. - -12/10/92 (new features) Added "yposition" widget command for menus, -changed "delete" widget command to take an optional second index, -and changed -command option for cascade entries so that it is -invoked when the entry is activated rather than when it is invoked. -*** POTENTIAL INCOMPATIBILITY *** - -12/12/92 (implementation change) Changed the procedures Tk_FreeBitmap, -Tk_NameOfBitmap, Tk_SizeOfBitmap, Tk_FreeCursor, Tk_NameOfCursor, and -Tk_FreeGC to require an addition Display argument. This is needed for -Tk to function correctly when an application has windows on multiple -displays. -*** POTENTIAL INCOMPATIBILITY *** - -12/12/92 (new feature) Started creating a test suite. Right now it -only has a few tests. - -12/12/92 (new feature) Modified the packer so that a window can be -packed in descendants of its parent (used to be restricted to the -parent alone). This makes it possible to hide extra windows used -for geometry management. Also, can use generalized screen distances -in the "pack" command. - -12/16/92 (feature change) Boolean options such as -exportselection now -print as 0/1 rather than true/false (both the default and current values -print this way). This makes it easier to use these values in expressions. -*** POTENTIAL INCOMPATIBILITY *** - -12/16/92 (name change) The classes "RadioButton" and "CheckButton" have -been renamed "Radiobutton" and "Checkbutton" for consistency. From now -on widget class names will have exactly one capital letter. -*** POTENTIAL INCOMPATIBILITY *** - -12/16/92 (new feature) Added -setgrid option to listboxes. - -12/16/92 (new feature) The "destroy" command, and the "delete" widget -command for canvases, now accept any number of arguments, including -zero. - -12/16/92 (new feature) Changed internal TkBindError procedure to -Tk_BackgroundError and exported it to Tk clients. - -12/16/92 (option name change) Changed the place command's "dependents" -option to "slaves" for better consistency with documentation. -*** POTENTIAL INCOMPATIBILITY *** - -12/16/92 (name changes) Renamed the "cursor*" options in entries and -canvases to "insert*". Also renamed the "cursor" index to "insert" and -the "cursor" widget command to "icursor". This was done to avoid -confusion between the mouse cursor and the insertion cursor. -*** POTENTIAL INCOMPATIBILITY *** - ----------------------- Release 3.0, 12/17/92 ------------------------- - -12/17/92 (bug fix) Fixed dangling-pointer bug in canvases that occurred -if a binding deleted the current item. - -12/18/92 (bug fix) Core dump occurred if "wm" invoked with no arguments. -Also, tkWm.c wasn't properly setting WM_CLASS property on application -startup. - -12/18/92 (incorrect documentation) Updated manual entries for Tk_FreeGC, -Tk_FreeCursor, and Tk_FreeBitmap to reflect new interface that requires -"display" argument. - -12/18/92 (missing documentation) Added documentation for the canvas -"postscript" command, which was missing in the 3.0 release. - -12/21/92 (bug fixes) There were lots of problems with the new installation -targets in the Makefiles, such as using "cp -f" and not installing -prolog.ps. Made several other miscellaneous improvements to Makefile. - -12/21/92 (bug fix) Arrowheads on canvas line items weren't moving properly -after coordinate changes made with the "coords" widget command. - -12/21/92 (bug fix) If top-level window was initially withdrawn, couldn't -ever deiconify it again. - -12/21/92 (bug fix) Double-button event sequences didn't always trigger -properly when grabs were in effect. - -12/22/92 (bug fix) The packer didn't display any top or bottom windows -after a left or right expanded window, and vice versa. Also made the -distribution of space among expanded windows more even. - -12/28/92 (new features) Several improvements to selection: -(a) Added procedures Tk_ClearSelection and Tk_DeleteSelHandler. -(b) Added "clear" and "own" options to "selection" command, extended - "handle" option to delete handlers. -(c) Error returns from "selection handle" scripts are now turned into - selection retrieval errors ("no such selection") rather than an - empty selection. -(d) Tk responds automatically for targets APPLICATION (name of application, - so you can "send" to it) and WINDOW_NAME (name of window within - application. -(e) Added test file "select.test" to test suite. - -12/28/92 (bug fix) Fixed problem with flashing menus that occurred -because menu.tcl was willing to unpost and then immediately repost -the same menu. - -1/6/93 (bug fix) Test for UnmapNotify events in tkPack.c used = instead -of ==. - -1/21/93 (bug fix) Changed many widgets to eliminate use of -DefaultVisualofScreen, DefaultColormap, etc. and use the visuals -and colormaps for the actual windows instead. Also changed to -inherit colormaps and windows from parent by default. - -1/21/93 (new features) Added new winfo options "cells", "depth", and -"visual". - -1/23/93 (bug fix) Fixed problem with text display that could result -in negative XCopyArea heights being sent to X server. This causes some -servers (e.g. some versions of OpenWindows) to crash. - -1/25/93 (new feature) Added -postcommand option to menus, so that menus -can be reconfigured before each posting. - -1/29/93 (feature change) Changed %X and %Y in bindings so that they -refer to the virtual root rather than the true root. Although -potentially incompatible, this change should almost always "do the -right thing". -*** POTENTIAL INCOMPATIBILITY *** - -1/31/93 (bug fix) Changed "send" code to grab server while updating -the registry property (before this fix, two programs could allocate -the same interpreter name if they started up simultaneously). In -order to make this fix I had to change the code for reclaiming -names of dead interpreters in a way that sometimes allows dead -interpreters to persist in the registry. - -2/1/93 (feature change) Changed entries to allow leftmost "visible" -character to be the end of the text (i.e. no characters actually visible). -This is needed so that the cursor can be displayed even if the last -actual character is too wide to fit in the window. - -2/3/93 (bug fix) Fixed two bugs in tkFocus.c: (a) FocusIn events -were getting lost in some cases because the focus window hadn't been -created yet (e.g. new top-level window pops up underneath the mouse); -(b) Tk was accidentally triggering FocusOut events when the mouse -moved from a top-level window to one of its children. - -2/4/93 (new feature) Added "visibility" option to "tkwait" command to make -it easier to wait for a new window to appear on the screen. - ----------------------- Release 3.1, 2/5/93 ------------------------- - -2/10/93 (installation improvements) Makefile improvements: added RANLIB -variable for easier Sys-V installation, changed to use INCLUDE_DIR -properly, and added SHELL variable for SGI systems. - ----------------------- Release 3.2, 2/11/93 ------------------------- - -2/11/93 (new feature) Added "wm state" command, and improved wm so that -the right thing will happen if you invoke "wm iconify" when a window is -withdrawn. - -2/14/93 (bug fix) When -colormap option was used in generating Postscript -for canvases, Tk didn't add an extra space after the color command. - -2/14/93 (new feature) Changed "extern" declarations in tk.h to "EXTERN", -which will use the definition of EXTERN from tcl.h and work correctly -in C++ programs. - -2/18/93 (bug fix) Item-specific bindings weren't getting deleted from -canvas items when the items were deleted. As a result, they could -suddenly re-appear for new items if the new items were allocated a -record at the same addresses as the old ones. - -2/18/93 (feature reversal) Changed "after" back again, so that it sleeps -*without* responding to events when it is invoked with just one argument; -can always use tkwait plus after with additional arguments to achieve -the effect of responding to events. -*** POTENTIAL INCOMPATIBILITY *** - -2/20/93 (bug fix) Fixed bug in tkWindow.c where colormaps weren't being -set correctly for new top-level windows on different screens than their -parents (the bug results in X protocol errors: "invalid Colormap -parameter"). - -2/22/93 (bug fix) Changed "#!/usr/local/wish" in demo scripts to -"#!/usr/local/bin/wish" to reflect new location of binary. - -2/22/93 (new feature) Added new reliefs "groove" and "ridge". - -2/25/93 (new feature) Added new built-in bitmaps: "error", "hourglass", -"info", "question", "questhead", and "warning". Also added new demo in -"widget" to display all of these (under the Miscellaneous menu). - -2/25/93 (improved implementation) Changed DrawText procedure in -prolog for outputting Postscript from canvases to use stringwidth -instead of charpath+pathbbox: avoids limitcheck problems with long -strings, and also properly includes space characters in calculation. - -2/25/93 (bug fix) Fixed several bugs in library/menu.tcl that caused -menu traversal to mis-behave when menu had no entries. - -2/26/93 (new feature) Added "wm frame" command. - -3/6/93 (bug fix) Mwm in click-to-focus mode was goofing up grabs so that -pull-down menus were sometimes unresponsive. Modified tk.tcl to ignore -the spurious B1-Enter events generated by mwm, plus modified tkGrab.c to -release simulated button grabs correctly. - -3/8/93 (bug fix) Tk had wrong interpretation of "lbearing" font metric, -which caused text to be displayed at the wrong horizontal position in -several places (labels/buttons, listboxes, canvas text, scales). This -change will cause slight changes in the way certain widgets are -displayed. - -3/12/93 (bug fix) Fixed core dumps that occurred in tkEntry.c because of -zero values in entryPtr->avgWidth. - -3/12/93 (bug fix) Tk_CoordsToWindow was using root coordinates always. -Changed to use virtual-root coordinates when a virtual-root window -manager is being used. Before this fix, "winfo containing" didn't -return the correct window under virtual-root window managers. - -3/18/93 (bug fix) Modified tkWm.c so that Tk doesn't fight with window -manager over position of window; it just takes what the window manager -gives it. - -3/21/93 (new feature) Changed menus to display cascade entries with -standard Motif arrows at right side.a - -3/22/93 (bug fix) Fixed bug in tkPack.c that was causing memory to -get trashed with the integer value 1. - -3/22/93 (bug fix) Canvas text didn't print correctly if it contained -an open paren (or other special character) immediately followed by -an octal digit. - -3/22/93 (bug fix) Text widgets didn't redisplay properly in cases -where two or more groups of lines both got taller at the same time -(e.g. from tag changes), causing two separate bit copies where the -first bit copy's target area overlapped the source area for -the second bit copy. - -4/1/93 (bug fix) Changed canvases to use ISO Latin-1 font encoding -if that's supported by the Postscript interpreter. Also added workaround -for bug in NeWSprint related to stipple fills. - -4/1/93 (bug fixes) Made various changes to focusing and grabs to -eliminate extraneous focus events and generally improve behavior. - -4/2/93 (bug fix) Modified tkWm.c not to wait indefinitely for the window -manager to map or reconfigure a window: this led to deadlock in some -situations, such as creating a new top-level window with a grab held. - -4/19/93 (bug fix) Fixed another bug in tkWm.c that caused windows to walk -across the screen in some situations. Also fixed problem where rapid -posting and unposting of cascaded submenus (or menus?) could cause Tk -to become confused about whether or not a window is mapped (added -TkWmUnmapWindow procedure to make top-level unmaps synchronous). - -4/24/93 (feature change) Changed the "after" command to allow times -less than or equal to 0, and to use 0 whenever they occur. - -4/26/93 (new feature) Implemented security check for "send" as proposed -by Bennett Todd: incoming sends are now rejected unless (a) xhost-style -access control is enabled and (b) the list of authorized hosts is -empty. In other words, you have to use xauth to use send. This feature -can be disabled by setting the TK_NO_SECURITY flag at compile-time. - -5/15/93 (improvement) Switched to use Tcl_PrintDouble whenever returning -real values as Tcl results. This potentially allows higher precision. -Switched to use %.15g whenever printing reals in Postscript files. -However, the change Tcl_PrintDouble causes incompatibilities. For -now, it's disabled with a macro in tclInt.h that redefines Tcl_PrintDouble. -Tk 4.0 will delete the macro, and you can also delete it now if you -want the better (but incompatible) behavior. - -5/19/93 (bug fix) Fixed divide-by-zero problem that could occur in -closeness calculations for canvas oval items. - -5/30/93 (bug fix) PROP and CONFIG were accidentally #defined to the same -value in tkBind.c, which could cause incorrect %-substitutions in event -bindings in a few exotic cases. - -6/4/93 (improvement) Changed to use GNU autoconfig for configuration. -Makefile format changed, and Tcl is no longer automatically included -in Tk releases. - -6/7/93 (bug fix) Fixed off-by-one error in rounding negative coordinates -during redisplay of canvases. - -6/9/93 (feature improvement) Modified default bindings for entries to -keep one character visible to the left of the cursor during backspaces. - -6/18/93 (feature improvement) Added patchlevel.h, for use in coordinating -future patch releases, and also added tk_patchLevel variable to make the -patch level available in scripts. - -6/26/93 (bug fix) Fixed numeric problems in scales that occurred with -very large scale values. - -6/26/93 (bug fix) Polygon items in canvases could cause core dumps if -the "coords" widget command was used to add one new coordinate. - -6/26/93 (bug fix) Changed canvases to handle large stipple patterns -gracefully (stipples used to jump around during redisplay and lose -coherency). - -7/1/93 (syntax change, new feature) Implemented the new packer syntax -as described in the book. For now the old syntax will continue to be -supported too. Converting over is straightforward except (a) use -"-anchor" instead of "frame", and (b) padding is different (separate -internal and external padding, plus pad amounts are *on each side* -instead of total). Also added "pack propagate" command for keeping -the packer from setting the master's requested size. - -7/1/93 Changed copyright notices. The effect is the same as with the -old notices, but the new notices more clearly disclaim liability. - -7/7/93 (new feature) Added support for window stacking order. Windows -will now stack in the order created (most recent on top), plus "raise" -and "lower" commands may be used to restack (Tk_RestackWindow procedure -is available from C level). - -7/7/93 (reorganization) Moved main.c to tkMain.c, reorganized it to -call Tcl_AppInit just like tclsh does, and added argv0 variable to contain -application name, and added default Tcl_AppInit procedure for wish. -Also added tkTest.c to hold C code for testing. - -7/7/93 (new feature) Added new Tk-specific "exit" command, which cleans -up properly before exiting. It replaces the Tcl "exit" command, and -can be used in place of "destroy .". - -7/9/93 (new features) Added tk_dialog library procedure that creates -dialogs with a bitmap, message, and any number of buttons. Also changed -default tkerror procedure to use tk_dialog plus offer the user a chance -to see a Tcl stack trace. - --------------------- Release 3.3 Beta 1, 7/9/93 ------------------------- - -7/12/93 (configuration changes) Eliminated leading blank line in -configure script; provided separate targets in Makefile for installing -binary and non-binary information; fixed -lnsl and -lsocket handling -in configure; added autoconf support for fd_set type; check for various -typedefs like mode_t and size_t, and provide substitutes if they -don't exist; don't include tkAppInit.o in libtk.a; try to locate the -X includes and library in all of the standard places for various systems. - -7/14/93 (new feature) Modified tkMain.c so that it stores the value -of the -display command-line option into the DISPLAY environment -variable, if it is specified. - -7/15/93 (feature removal) Removed auto-initialization feature from -Tk_ConfigureWidget, so that you must once again initialize all fields -of a widget record before calling Tk_ConfigureWidget. This restores -the behavior back to what it was in Tk 3.2. - -7/16/93 (bug fix) Modified tkBind.c to ignore the Caps Lock modifier -unless it is explicitly requested in a binding. Without this fix, -buttons and menus and other things didn't work if the Caps Lock key -was active. - --------------------- Release 3.3 Beta 2, 7/21/93 ------------------------- - -7/21/93 (new feature) Change "make install" so that it will modify the -#! lines on demo scripts to reflect the place where the wish binary -is installed. - -7/23/93 (new feature) Added Tk_MainWindow procedure that returns the -main window associated with a Tcl interpreter. This is intended for -use by Tcl_AppInit and other initialization procedures. - -7/24/93 (configuration improvements) Changed configure script not to -omplain about "fd_set" missing if it's defined in . - -7/28/93 (bug fix) "Bad Match - parameter mismatch" errors were -sometimes occurring when several top-level windows got created -at the same time, due to wrong choice of sibling when stacking -windows. - -8/14/93 (new feature) Added support for tcl_prompt1 and tcl_prompt2 -to wish main program: makes prompts user-settable. - -8/19/93 (bug fix) Bindings to event sequences like "aD" never matched -because the Shift key has to be pressed before D. Modified Tk to -ignore extraneous keypresses if they are for modifier keys. - -8/26/93 (configuration changes) Added Tk_Init, modified Tcl_AppInit -procedures to use it and Tcl_Init. Added support for .wishrc file. - -8/28/93 (new feature) The main window is now a legitimate toplevel -widget. - --------------------- Release 3.3 Beta 3, 8/30/93 ------------------------- - -9/2/93 (bug fix) The packer wasn't always relaying out a master after -changes to some of the configuration options of its slaves. - -9/2/93 (bug fix) The binding mechanism made it impossible for patterns -like to ever match. - -9/2/93 (bug fix) Fixed core dump that occurred for bitmap canvas items -if Postscript is generated but no -bitmap option has been specified. - -9/4/93 (enhancement) Slight improvements to menu traversal: set menu -traversal bindings for menubar window in tk_menuBar, plus trigger -traversal on instead of . - -9/9/93 (bug fix) Changed tkBind.c so that the Num_Lock key doesn't -prevent events from triggering bindings. - -9/9/93 (bug fix) Changed tkOption.c to always fetch RESOURCE_MANAGER -property from root window of screen 0, rather than using default -screen. - -9/9/93 (bug fix) Entry widgets weren't allocating quite enough width -for themselves. Fixed this and changed the size computation to match -what's done for buttons and texts. - -9/16/93 (bug fix) Changed tkMain.c not to call exit C procedure directly; -instead always invoke "exit" Tcl command so that application can redefine -the command to do additional cleanup. - --------------------- Release 3.3, 9/29/93 ------------------------- - -9/30/93 (bug fix) Packer wasn't unmapping slaves when master got deleted. - -9/30/93 (bug fix) Binding event sequences such as were being -misprinted as ASCII characters such as "S". - -10/6/93 (bug fix) Canvases weren't unmapping window items when the canvas -got unmapped, which caused problems for window items whose windows weren't -descendants of the canvas (they got left on the screen). - -10/7/93 (feature change) NULL proc arguments to Tk_CreateFileHandler used -to have a special undocumented meaning (fd was display); eliminated this -special interpretation. - -10/7/93 (configuration change) Eliminated dependency of tkMain.c on -tkInt.h and tkConfig.h, so that it's easier for people to copy the file -out of the source directory to make modified versions. - -10/8/93 (bug fix) 3.0 introduced a bug where the class of the application -wasn't being set properly, so options based on the application class -weren't triggering. Fixed by adding new argument to Tk_CreateMainWindow. - -10/11/93 (bug fix) Fixed bug in tkTextBTree.c where some deletions would -cause core dumps due to halfwayLinePtr not getting set correctly. - -10/18/93 (bug fix) Fixed a couple of bugs that made it hard to actually -display N characters in an entry with "-width N" (tended to scroll the -entry so that only N-1 characters were visible at once). - -10/22/93 (bug fix) During configuration, XINCLUDE_DIR and XLIBRARY_DIR -weren't overriding xmkmf like they were supposed to. - -10/23/93 (new feature) Allow negative scale factors in canvas "scale" -widget command. - -10/23/93 (bug fix) Grabs weren't being cleaned up right if the grab -window was deleted, causing core-dumps in some cases. - -10/23/93 (bug fix) tk_TextSelectTo wasn't checking to be sure that -the "anchor" mark exists. - -10/27/93 (bug fix) Fixed core dump that could occur in a text widget if -the scroll command modifies the text. - -11/1/93 (bug fix) Change texts so that the -yscrollcommand option is -invoked at display time, not when the window is re-layed out. This -eliminated various core dumps that could occur if -yscrollcommand modified -the text. - --------------------- Release 3.4, 11/04/93 ------------------------- - -Note: there is no 3.5 release. It was flawed and was thus withdrawn -shortly after it was released. - -11/12/93 (bug fix) TkMain.c didn't compile on some systems because of -R_OK in call to "access". Changed to eliminate call to "access". - --------------------- Release 3.6, 11/26/93 ------------------------- diff --git a/tk3.6/configure b/tk3.6/configure deleted file mode 100755 index 4270a82..0000000 --- a/tk3.6/configure +++ /dev/null @@ -1,688 +0,0 @@ -#!/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=tk.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} - -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 < -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 -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* - - -#-------------------------------------------------------------------- -# Include sys/select.h if it exists and if it supplies things -# that appear to be useful and aren't already in sys/types.h. -# This appears to be true only on the RS/6000 under AIX. Some -# systems like OSF/1 have a sys/select.h that's of no use, and -# other systems like SCO UNIX have a sys/select.h that's -# pernicious. If "fd_set" isn't defined anywhere then set a -# special flag. -#-------------------------------------------------------------------- - -echo checking for sys/select.h -echo checking for fd_set -cat > conftest.c < -int main() { exit(0); } -int t() { fd_set readMask, writeMask; } -EOF -if eval $compile; then - : -else - echo '#include ' > conftest.c -eval "$CPP \$DEFS conftest.c > conftest.out 2>&1" -if egrep "fd_mask" conftest.out >/dev/null 2>&1; then - -{ -test -n "$verbose" && \ -echo " defining HAVE_SYS_SELECT_H" -DEFS="$DEFS -DHAVE_SYS_SELECT_H=1" -} - -else - -{ -test -n "$verbose" && \ -echo " defining NO_FD_SET" -DEFS="$DEFS -DNO_FD_SET=1" -} - -fi -rm -f conftest* - -fi -rm -f conftest* - - -#-------------------------------------------------------------------- -# Supply a substitute for stdlib.h if it doesn't define strtol, -# strtoul, or strtod (which it doesn't in some versions of SunOS). -#-------------------------------------------------------------------- - -echo checking for proper stdlib.h -echo '#include ' > conftest.c -eval "$CPP \$DEFS conftest.c > conftest.out 2>&1" -if egrep "strtol" conftest.out >/dev/null 2>&1; then - tk_stdlib=1 -else - tk_stdlib=0 -fi -rm -f conftest* - -echo '#include ' > conftest.c -eval "$CPP \$DEFS conftest.c > conftest.out 2>&1" -if egrep "strtoul" conftest.out >/dev/null 2>&1; then - : -else - tk_stdlib=0 -fi -rm -f conftest* - -echo '#include ' > conftest.c -eval "$CPP \$DEFS conftest.c > conftest.out 2>&1" -if egrep "strtod" conftest.out >/dev/null 2>&1; then - : -else - tk_stdlib=0 -fi -rm -f conftest* - -if test $tk_stdlib = 0; then - -{ -test -n "$verbose" && \ -echo " defining NO_STDLIB_H" -DEFS="$DEFS -DNO_STDLIB_H=1" -} - -fi - -#-------------------------------------------------------------------- -# Check for various typedefs and provide substitutes if -# they don't exist. -#-------------------------------------------------------------------- - -echo checking for mode_t in sys/types.h -echo '#include ' > 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 ' > 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 ' > 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 ' > 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* - - -#-------------------------------------------------------------------- -# Locate the X11 header files and the X11 library archive. Try -# the ac_find_x macro first, but if it doesn't find the X stuff -# (e.g. because there's no xmkmf program) then check through -# a list of possible directories. -#-------------------------------------------------------------------- - -if test -z "$tk_ok"; then - # Extract the first word of `xmkmf', so it can be a program name with args. - set dummy xmkmf; 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 - tk_ok="1" - break - fi - done - IFS="$saveifs" -fi -test -z "$tk_ok" && tk_ok="0" -test -n "$tk_ok" -a -n "$verbose" && echo " setting tk_ok to $tk_ok" - -if test $tk_ok = 1; then - # If we find X, set shell vars x_includes and x_libraries to the paths. -echo checking for X include and library files with xmkmf -rm -fr conftestdir -if mkdir conftestdir; then - cd conftestdir - cat > Imakefile </dev/null 2>/dev/null && test -f Makefile; then - eval `make acfindx` - fi - cd .. - rm -fr conftestdir -fi - -fi -if test "$XINCLUDE_DIR" != ""; then - x_includes="$XINCLUDE_DIR" -fi -if test "$x_includes" = /usr/include; then - XINCLUDES="# no special path needed" -elif test "$x_includes" != ""; then - XINCLUDES=" -I$x_includes" -else - echo checking for X11 header files - XINCLUDES="# no special path needed" - cat > conftest.c < -EOF -err=`eval "($CPP \$DEFS conftest.c >/dev/null) 2>&1"` -if test -z "$err"; then - : -else - XINCLUDES="nope" -fi -rm -f conftest* - if test "$XINCLUDES" = nope; then - dirs="/usr/unsupported/include /usr/local/include /usr/X386/include /usr/include/X11R4 /usr/X11R5/include /usr/include/X11R5 /usr/openwin/include /usr/X11/include" - for i in $dirs ; do - if test -r $i/X11/Intrinsic.h; then - XINCLUDES=" -I$i" - fi - done - fi -fi -if test "$XINCLUDES" = nope; then - echo "Warning: couldn't find any X11 include files." - XINCLUDES="# no include files found" -fi - - -if test "$XLIBRARY_DIR" != ""; then - x_libraries="$XLIBRARY_DIR" -fi -if test "$x_libraries" = /usr/lib; then - XLIBSW=-lX11 -elif test "$x_libraries" != ""; then - XLIBSW="-L$x_libraries -lX11" -else - echo "checking for X11 library archive" - LIBS_save="${LIBS}" -LIBS="${LIBS} -lX11" -have_lib="" -echo checking for -lX11 -cat > conftest.c < conftest.c < conftest.c < conftest.c < conftest.c <conftest.def < config.status </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' -CPP='$CPP' -tk_ok='$tk_ok' -XINCLUDES='$XINCLUDES' -XLIBSW='$XLIBSW' -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%@CPP@%$CPP%g -s%@tk_ok@%$tk_ok%g -s%@XINCLUDES@%$XINCLUDES%g -s%@XLIBSW@%$XLIBSW%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/tk3.6/configure.in b/tk3.6/configure.in deleted file mode 100755 index e2e3614..0000000 --- a/tk3.6/configure.in +++ /dev/null @@ -1,125 +0,0 @@ -dnl This file is an input file used by the GNU "autoconf" program to -dnl generate the file "configure", which is run during Tk installation -dnl to configure the system for the local environment. -AC_INIT(tk.h) -AC_PROG_INSTALL -AC_PROG_RANLIB -CC=${CC-cc} -AC_SUBST(CC) -AC_UNISTD_H - -#-------------------------------------------------------------------- -# Include sys/select.h if it exists and if it supplies things -# that appear to be useful and aren't already in sys/types.h. -# This appears to be true only on the RS/6000 under AIX. Some -# systems like OSF/1 have a sys/select.h that's of no use, and -# other systems like SCO UNIX have a sys/select.h that's -# pernicious. If "fd_set" isn't defined anywhere then set a -# special flag. -#-------------------------------------------------------------------- - -echo checking for sys/select.h -AC_COMPILE_CHECK(fd_set, [#include ], - [fd_set readMask, writeMask;], , - AC_HEADER_EGREP(fd_mask, sys/select.h, AC_DEFINE(HAVE_SYS_SELECT_H), - AC_DEFINE(NO_FD_SET))) - -#-------------------------------------------------------------------- -# Supply a substitute for stdlib.h if it doesn't define strtol, -# strtoul, or strtod (which it doesn't in some versions of SunOS). -#-------------------------------------------------------------------- - -echo checking for proper stdlib.h -AC_HEADER_EGREP(strtol, stdlib.h, tk_stdlib=1, tk_stdlib=0) -AC_HEADER_EGREP(strtoul, stdlib.h, , tk_stdlib=0) -AC_HEADER_EGREP(strtod, stdlib.h, , tk_stdlib=0) -if test $tk_stdlib = 0; then - AC_DEFINE(NO_STDLIB_H) -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 - -#-------------------------------------------------------------------- -# Locate the X11 header files and the X11 library archive. Try -# the ac_find_x macro first, but if it doesn't find the X stuff -# (e.g. because there's no xmkmf program) then check through -# a list of possible directories. -#-------------------------------------------------------------------- - -AC_PROGRAM_CHECK(tk_ok, xmkmf, 1, 0) -if test $tk_ok = 1; then - AC_FIND_X -fi -if test "$XINCLUDE_DIR" != ""; then - x_includes="$XINCLUDE_DIR" -fi -if test "$x_includes" = /usr/include; then - XINCLUDES="# no special path needed" -elif test "$x_includes" != ""; then - XINCLUDES=" -I$x_includes" -else - echo checking for X11 header files - XINCLUDES="# no special path needed" - AC_TEST_CPP([#include ], , XINCLUDES="nope") - if test "$XINCLUDES" = nope; then - dirs="/usr/unsupported/include /usr/local/include /usr/X386/include /usr/include/X11R4 /usr/X11R5/include /usr/include/X11R5 /usr/openwin/include /usr/X11/include" - for i in $dirs ; do - if test -r $i/X11/Intrinsic.h; then - XINCLUDES=" -I$i" - fi - done - fi -fi -if test "$XINCLUDES" = nope; then - echo "Warning: couldn't find any X11 include files." - XINCLUDES="# no include files found" -fi -AC_SUBST(XINCLUDES) - -if test "$XLIBRARY_DIR" != ""; then - x_libraries="$XLIBRARY_DIR" -fi -if test "$x_libraries" = /usr/lib; then - XLIBSW=-lX11 -elif test "$x_libraries" != ""; then - XLIBSW="-L$x_libraries -lX11" -else - echo "checking for X11 library archive" - AC_HAVE_LIBRARY(X11, XLIBSW="-lX11", XLIBSW=nope) - if test "$XLIBSW" = nope; then - dirs="/usr/unsupported/lib /usr/local/lib /usr/X386/lib /usr/lib/X11R4 /usr/X11R5/lib /usr/lib/X11R5 /usr/openwin/lib /usr/X11/lib" - for i in $dirs ; do - if test -r $i/libX11.a; then - XLIBSW="-L$i -lX11" - fi - done - fi -fi -if test "$XLIBSW" = nope ; then - AC_HAVE_LIBRARY(Xwindow, XLIBSW=-lXwindow) -fi -if test "$XLIBSW" = nope ; then - echo "Warning: couldn't find the X11 library archive. Using -lX11." - XLIBSW=-lX11 -fi -AC_SUBST(XLIBSW) - -#-------------------------------------------------------------------- -# Check for the existence of various libraries. The order here -# is important, so that then end up in the right order in the -# command line generated by Make. -#-------------------------------------------------------------------- - -AC_HAVE_LIBRARY(Xbsd, [LIBS="$LIBS -lXbsd"]) -AC_HAVE_LIBRARY(socket, [LIBS="$LIBS -lsocket"]) -AC_HAVE_LIBRARY(nsl, [LIBS="$LIBS -lnsl"]) - -AC_OUTPUT(Makefile) diff --git a/tk3.6/configure.info b/tk3.6/configure.info deleted file mode 100755 index a84f764..0000000 --- a/tk3.6/configure.info +++ /dev/null @@ -1,85 +0,0 @@ -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. -XINCLUDE_DIR Full path name of directory containing "X11" subdirectory - with X include files. -XLIBRARY_DIR Full path name of directory containing library archive - for X. - -(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/tk3.6/doc/BackgdErr.3 b/tk3.6/doc/BackgdErr.3 deleted file mode 100644 index 7705c8f..0000000 --- a/tk3.6/doc/BackgdErr.3 +++ /dev/null @@ -1,57 +0,0 @@ -'\" -'\" Copyright (c) 1992 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/wish/man/RCS/BackgdErr.3,v 1.3 93/04/01 09:41:07 ouster Exp $ SPRITE (Berkeley) -'\" -.so man.macros -.HS Tk_BackgroundError tkc -.BS -.SH NAME -Tk_BackgroundError \- report Tcl error that occurred in background processing -.SH SYNOPSIS -.nf -\fB#include \fR -.sp -\fBTk_BackgroundError\fR(\fIinterp\fR) -.SH ARGUMENTS -.AS Tcl_Interp *interp -.AP Tcl_Interp *interp in -Interpreter in which the error occurred. -.BE - -.SH DESCRIPTION -.PP -This procedure is typically invoked when a Tcl error occurs during -``background processing'' such as executing a Tcl command in response -to a button press or menu entry invocation. -When such an error occurs, the error condition is reported to Tk -or to a widget or some other C code, and there is not usually any -obvious way for that code to report the error to the user. -In these cases the code calls \fBTk_BackgroundError\fR with an -\fIinterp\fR argument identifying the interpreter in which the -error occurred. -\fBTk_BackgroundError\fR attempts to invoke the \fBtkerror\fR -Tcl command to report the error in an application-specific fashion. -If no \fBtkerror\fR command exists, or if it returns with an error condition, -then \fBTk_BackgroundError\fR reports the error itself by printing -a message on the standard error file. - -.SH KEYWORDS -background, error, tkerror diff --git a/tk3.6/doc/ClrSelect.3 b/tk3.6/doc/ClrSelect.3 deleted file mode 100644 index 1292e5c..0000000 --- a/tk3.6/doc/ClrSelect.3 +++ /dev/null @@ -1,53 +0,0 @@ -'\" -'\" Copyright (c) 1992 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/wish/man/RCS/ClrSelect.3,v 1.3 93/04/01 09:41:08 ouster Exp $ SPRITE (Berkeley) -'\" -.so man.macros -.HS Tk_ClearSelection tkc -.BS -.SH NAME -Tk_ClearSelection \- Deselect the selection -.SH SYNOPSIS -.nf -\fB#include \fR -.sp -\fBTk_ClearSelection\fR(\fItkwin\fR) -.SH ARGUMENTS -.AS Tk_Window tkwin -.AP Tk_Window tkwin in -The selection will be cleared from the display containing this -window. -.BE - -.SH DESCRIPTION -.PP -\fBTk_ClearSelection\fR cancels the selection for the display -containing \fItkwin\fR. -The selection need not be in \fItkwin\fR itself or even in -\fItkwin\fR's application. -If there is a window anywhere on \fItkwin\fR's display that -owns the primary selection, the window will be notified and the -selection will be cleared. -If there is no primary selection on the display, then the -procedure has no effect. - -.SH KEYWORDS -clear, selection diff --git a/tk3.6/doc/CrtMainWin.3 b/tk3.6/doc/CrtMainWin.3 deleted file mode 100644 index 48cda10..0000000 --- a/tk3.6/doc/CrtMainWin.3 +++ /dev/null @@ -1,213 +0,0 @@ -'\" -'\" Copyright (c) 1990 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/wish/man/RCS/CrtMainWin.3,v 1.16 93/10/15 09:37:03 ouster Exp $ SPRITE (Berkeley) -'\" -.so man.macros -.HS Tk_CreateMainWindow tkc -.BS -.SH NAME -Tk_CreateMainWindow, Tk_CreateWindow, Tk_CreateWindowFromPath, Tk_DestroyWindow, Tk_MakeWindowExist \- create or delete window -.SH SYNOPSIS -.nf -\fB#include \fR -.sp -Tk_Window -.VS -\fBTk_CreateMainWindow\fR(\fIinterp, screenName, baseName, className\fR) -.VE -.sp -Tk_Window -\fBTk_CreateWindow\fR(\fIinterp, parent, name, topLevScreen\fR) -.sp -Tk_Window -\fBTk_CreateWindowFromPath\fR(\fIinterp, tkwin, pathName, topLevScreen\fR) -.sp -\fBTk_DestroyWindow\fR(\fItkwin\fR) -.sp -\fBTk_MakeWindowExist\fR(\fItkwin\fR) -.SH ARGUMENTS -.AS Tcl_Interp *topLevScreen -.AP Tcl_Interp *interp out -Tcl interpreter to use for error reporting. If no error occurs, -then \fI*interp\fR isn't modified. For \fBTk_CreateMainWindow\fR, -this interpreter is associated permanently with the created window, -and Tk-related commands are bound into the interpreter. -.AP char *screenName in -String name of screen on which to create window. Has the form -\fIdisplayName\fB.\fIscreenNum\fR, where \fIdisplayName\fR is the -name of a display and \fIscreenNum\fR is a screen number. If -the dot and \fIscreenNum\fR are omitted, the screen number defaults -to 0. If \fIscreenName\fR is NULL or empty string, defaults to -contents of DISPLAY environment variable. -.AP char *baseName in -Name to use for this main window. See below for details. -.AP char *className in -.VS -Class to use for application and for main window. -.VE -.AP Tk_Window parent in -Token for the window that is to serve as the logical parent of -the new window. -.AP char *name in -Name to use for this window. Must be unique among all children of -the same \fIparent\fR. -.AP char *topLevScreen in -Has same format as \fIscreenName\fR. If NULL, then new window is -created as an internal window. If non-NULL, new window is created as -a top-level window on screen \fItopLevScreen\fR. If \fItopLevScreen\fR -is an empty string (``'') then new -window is created as top-level window of \fIparent\fR's screen. -.AP Tk_Window tkwin in -Token for window. -.AP char *pathName in -Name of new window, specified as path name within application -(e.g. \fB.a.b.c\fR). -.BE - -.SH DESCRIPTION -.PP -The three procedures \fBTk_CreateMainWindow\fR, \fBTk_CreateWindow\fR, -and \fBTk_CreateWindowFromPath\fR are used to create new windows for -use in Tk-based applications. Each of the procedures returns a token -that can be used to manipulate the window in other calls to the Tk -library. If the window couldn't be created successfully, then NULL -is returned and \fIinterp->result\fR is modified to hold an error -message. -.PP -Tk supports three different kinds of windows: main windows, internal -windows, and top-level windows. -A main window is the outermost window corresponding to an application. -Main windows correspond to the independent units of an application, -such as a view on a file that is part of an editor, or a clock, or -a terminal emulator. A main window is created as a child of the root -window of the screen indicated by the \fIscreenName\fR. Each main -window, and all its descendants, are typically associated with a -single Tcl command interpreter. -An internal window is an interior window of a Tk application, such as a -scrollbar or menu bar or button. A top-level window is one that is -created as a child of a screen's root window, rather than as an -interior window, but which is logically part of some existing main -window. Examples of top-level windows are pop-up menus and dialog boxes. -.PP -\fBTk_CreateMainWindow\fR creates a new main window and associates -.VS -its \fIinterp\fR argument with that window and all its eventual -descendants. -\fBTk_CreateMainWindow\fR also carries out several other actions to -set up the new application. -First, it adds all the Tk commands to those already defined -for \fIinterp\fR. -Second, it turns the new window into a \fBtoplevel\fR widget, which -will cause the X window to be created and mapped as soon as the -application goes idle. -Third, \fBTk_CreateMainWindow\fR registers \fIinterp\fR so that it -.VE -can be accessed remotely by other Tk applications using the \fBsend\fR -command and the name \fIbaseName\fR. Normally, \fIbaseName\fR consists -of the name of the application followed by a space and an identifier for this -particular main window (if such an identifier is relevant). For example, -an editor named \fBmx\fR displaying the file \fBfoo.c\fR would use -``mx foo.c'' as the basename. An application that doesn't usually -have multiple instances, such as a clock program, would just use the -name of the application, e.g. ``xclock''. If \fIbaseName\fR is already -in use by some other registered interpreter, then \fBTk_CreateMainWindow\fR -extends \fIbaseName\fR with a number to produce a unique name like -``mx foo.c #2'' or ``xclock #12''. This name is used both as the name -of the window (returned by \fBTk_Name\fR) and as the registered name -of the interpreter. -.VS -Fourth, \fBTk_CreateMainWindow\fR sets \fIclassName\fR as the class of -the application (among other things, this is used for lookups in -the option database), and also as the class of the main widget. -.VE -.PP -Either internal or top-level windows may be created by calling -\fBTk_CreateWindow\fR. If the \fItopLevScreen\fR argument is -NULL, then the new window will be an internal window. If -\fItopLevScreen\fR is non-NULL, then the new window will be a -top-level window: \fItopLevScreen\fR indicates the name of -a screen and the new window will be created as a child of the -root window of \fItopLevScreen\fR. In either case Tk will -consider the new window to be the logical child of \fIparent\fR: -the new window's path name will reflect this fact, options may -be specified for the new window under this assumption, and so on. -The only difference is that new X window for a top-level window -will not be a child of \fIparent\fR's X window. For example, a pull-down -menu's \fIparent\fR would be the button-like window used to invoke it, -which would in turn be a child of the menu bar window. A dialog box might -have the application's main window as its parent. This approach -means that all the windows of an application fall into a hierarchical -arrangement with a single logical root: the application's main window. -.PP -\fBTk_CreateWindowFromPath\fR offers an alternate way of specifying -new windows. In \fBTk_CreateWindowFromPath\fR the new -window is specified with a token for any window in the target -application (\fItkwin\fR), plus a path name for the new window. -It produces the same effect as \fBTk_CreateWindow\fR and allows -both top-level and internal windows to be created, depending on -the value of \fItopLevScreen\fR. In calls to \fBTk_CreateWindowFromPath\fR, -as in calls to \fBTk_CreateWindow\fR, the parent of the new window -must exist at the time of the call, but the new window must not -already exist. -.PP -In truth, the window-creation procedures don't -actually issue the command to X to create a window. -Instead, they create a local data structure associated with -the window and defer the creation of the X window. -The window will actually be created by the first call to -\fBTk_MapWindow\fR. Deferred window creation allows various -aspects of the window (such as its size, background color, -etc.) to be modified after its creation without incurring -any overhead in the X server. When the window is finally -mapped all of the window attributes can be set while creating -the window. -.PP -The value returned by a window-creation procedure is not the -X token for the window (it can't be, since X hasn't been -asked to create the window yet). Instead, it is a token -for Tk's local data structure for the window. Most -of the Tk library procedures take Tk_Window tokens, rather -than X identifiers. The actual -X window identifier can be retrieved from the local -data structure using the \fBTk_WindowId\fR macro; see -the manual entry for \fBTk_WindowId\fR for details. -.PP -\fBTk_DestroyWindow\fR deletes a window and all the data -strutures associated with it, including any event handlers -created with \fBTk_CreateEventHandler\fR. In addition, -\fBTk_DestroyWindow\fR will delete any children of \fItkwin\fR -recursively (where children are defined in the Tk sense, consisting -of all windows that were created with the given window as \fIparent\fR). -If \fItkwin\fR was created by \fBTk_CreateInternalWindow\fR then event -handlers interested in destroy events -are invoked immediately. If \fItkwin\fR is a top-level or main window, -then the event handlers will be invoked later, after X has seen -the request and returned an event for it. -.PP -If a window has been created -but hasn't been mapped, so no X window exists, it is -possible to force the creation of the X window by -calling \fBTk_MakeWindowExist\fR. This procedure issues -the X commands to instantiate the window given by \fItkwin\fR. - -.SH KEYWORDS -create, deferred creation, destroy, display, internal window, main window, -register, screen, top-level window, window diff --git a/tk3.6/doc/DoOneEvent.3 b/tk3.6/doc/DoOneEvent.3 deleted file mode 100644 index 1ac9aba..0000000 --- a/tk3.6/doc/DoOneEvent.3 +++ /dev/null @@ -1,143 +0,0 @@ -'\" -'\" Copyright (c) 1990-1992 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/wish/man/RCS/DoOneEvent.3,v 1.8 93/04/01 09:41:17 ouster Exp $ SPRITE (Berkeley) -'\" -.so man.macros -.HS Tk_DoOneEvent tkc -.BS -.SH NAME -Tk_DoOneEvent, Tk_MainLoop, Tk_HandleEvent \- wait for events and -invoke event handlers -.SH SYNOPSIS -.nf -\fB#include \fR -.sp -int -.VS -\fBTk_DoOneEvent\fR(\fIflags\fR) -.VE -.sp -\fBTk_MainLoop\fR() -.sp -\fBTk_HandleEvent\fR(\fIeventPtr\fR) -.SH ARGUMENTS -.AS XEvent *eventPtr -.AP int flags in -.VS -This parameter is normally zero. It may be an OR-ed combination -of any of the following flag bits: TK_X_EVENTS, TK_FILE_EVENTS, -TK_TIMER_EVENTS, TK_IDLE_EVENTS, TK_ALL_EVENTS, or TK_DONT_WAIT. -.VE -.AP XEvent *eventPtr in -Pointer to X event to dispatch to relevant handler(s). -.BE - -.SH DESCRIPTION -.PP -These three procedures are responsible for waiting for events -and dispatching to event handlers created with the procedures -\fBTk_CreateEventHandler\fR, \fBTk_CreateFileHandler\fR, -\fBTk_CreateTimerHandler\fR, and \fBTk_DoWhenIdle\fR. -\fBTk_DoOneEvent\fR is the key procedure. It waits for a single -event of any sort to occur, invokes the handler(s) for that -event, and then returns. \fBTk_DoOneEvent\fR first checks -for X events and file-related events; if one is found then -it calls the handler(s) for the event and returns. If there -are no X or file events pending, then \fBTk_DoOneEvent\fR -checks to see if timer callbacks are ready; if so, it -makes a single callback and returns. If no timer callbacks -are ready, \fBTk_DoOneEvent\fR checks for \fBTk_DoWhenIdle\fR -callbacks; if any are found, it invokes all of them and returns. -Finally, if events or work have been found found, \fBTk_DoOneEvent\fR -sleeps until a timer, file, or X event occurs; then it processes -the first event found (in the order given above) and returns. -The normal return value is 1 to signify that some event or callback -was processed. -.PP -If the \fIflags\fR argument to \fBTk_DoOneEvent\fR is non-zero then -.VS -it restricts the kinds of events that will be processed by -\fBTk_DoOneEvent\fR. -\fIFlags\fR may be an OR-ed combination of any of the following bits: -.TP 24 -\fBTK_X_EVENTS\fR \- -Process X events. -.TP 24 -\fBTK_FILE_EVENTS\fR \- -Process file events. -.TP 24 -\fBTK_TIMER_EVENTS\fR \- -Process timer events. -.TP 24 -\fBTK_IDLE_EVENTS\fR \- -Process \fBTk_DoWhenIdle\fR callbacks. -.TP 24 -\fBTK_ALL_EVENTS\fR \- -Process all kinds of events: equivalent to OR-ing together all of the -above flags or specifying none of them. -.TP 24 -\fBTK_DONT_WAIT\fR \- -Don't sleep: process only events that are ready at the time of the -call. -.LP -If any of the flags \fBTK_X_EVENTS\fR, \fBTK_FILE_EVENTS\fR, -\fBTK_TIMER_EVENTS\fR, or \fBTK_IDLE_EVENTS\fR is set, then the only -events that will be considered are those for which flags are set. -Setting none of these flags is equivalent to the value -\fBTK_ALL_EVENTS\fR, which causes all event types to be processed. -.PP -The \fBTK_DONT_WAIT\fR flag causes \fBTk_DoWhenIdle\fR not to put -the process to sleep: it will check for events but if none are found -then it returns immediately with a return value of 0 to indicate -that no work was done. -\fBTk_DoOneEvent\fR will also return 0 without doing anything if -\fIflags\fR is \fBTK_IDLE_EVENTS\fR and there are no -\fBTk_DoWhenIdle\fR callbacks pending. -.VE -.PP -\fBTk_MainLoop\fR is a procedure that loops repeatedly -calling \fBTk_DoOneEvent\fR. It returns only when there -are no applications left in this process (i.e. no main windows -exist anymore). Most X applications will -call \fBTk_MainLoop\fR after initialization; the main -execution of the application will consist entirely of -callbacks invoked by \fBTk_DoOneEvent\fR. -.PP -\fBTk_HandleEvent\fR is a lower-level procedure invoked -by \fBTk_DoOneEvent\fR. It makes callbacks to any event -handlers (created by calls to \fBTk_CreateEventHandler\fR) -that match \fIeventPtr\fR and then returns. In some cases -it may be useful for an application to read events directly -from X and dispatch them by calling \fBTk_HandleEvent\fR, -without going through the additional mechanism provided -by \fBTk_DoOneEvent\fR. -.PP -These procedures may be invoked recursively. For example, -it is possible to invoke \fBTk_DoOneEvent\fR recursively -from a handler called by \fBTk_DoOneEvent\fR. This sort -of operation is useful in some modal situations, such -as when a -notifier has been popped up and an application wishes to -wait for the user to click a button in the notifier before -doing anything else. - -.SH KEYWORDS -callback, event, handler, idle, timer diff --git a/tk3.6/doc/DoWhenIdle.3 b/tk3.6/doc/DoWhenIdle.3 deleted file mode 100644 index 9a92711..0000000 --- a/tk3.6/doc/DoWhenIdle.3 +++ /dev/null @@ -1,98 +0,0 @@ -'\" -'\" Copyright (c) 1990 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/wish/man/RCS/DoWhenIdle.3,v 1.8 93/04/01 09:41:19 ouster Exp $ SPRITE (Berkeley) -'\" -.so man.macros -.HS Tk_DoWhenIdle tkc -.BS -.SH NAME -Tk_DoWhenIdle, Tk_CancelIdleCall \- invoke a procedure when there are no pending events -.SH SYNOPSIS -.nf -\fB#include \fR -.sp -\fBTk_DoWhenIdle\fR(\fIproc, clientData\fR) -.sp -.VS -\fBTk_CancelIdleCall\fR(\fIproc, clientData\fR) -.VE -.SH ARGUMENTS -.AS Tk_IdleProc clientData -.AP Tk_IdleProc *proc in -Procedure to invoke. -.AP ClientData clientData in -Arbitrary one-word value to pass to \fIproc\fR. -.BE - -.SH DESCRIPTION -.PP -\fBTk_DoWhenIdle\fR arranges for \fIproc\fR to be invoked -when the application becomes idle. The application is -considered to be idle when \fBTk_DoOneEvent\fR has been -called, it couldn't find any events to handle, and it is about -to go to sleep waiting for an event to occur. At this -point all pending \fBTk_DoWhenIdle\fR handlers are -invoked. For each call to \fBTk_DoWhenIdle\fR there will -be a single call to \fIproc\fR; after \fIproc\fR is -invoked the handler is automatically removed. -\fBTk_DoWhenIdle\fR is only useable in programs that -use \fBTk_DoOneEvent\fR to dispatch events. -.PP -\fIProc\fP should have arguments and result that match the -type \fBTk_IdleProc\fR: -.nf -.RS -typedef void Tk_IdleProc(ClientData \fIclientData\fR); -.RE -.fi -The \fIclientData\fP parameter to \fIproc\fR is a copy of the \fIclientData\fP -argument given to \fBTk_DoWhenIdle\fR. Typically, \fIclientData\fR -points to a data structure containing application-specific information about -what \fIproc\fR should do. -.PP -\fBTk_CancelIdleCall\fR -.VS -may be used to cancel one or more previous -calls to \fBTk_DoWhenIdle\fR: if there is a \fBTk_DoWhenIdle\fR -handler registered for \fIproc\fR and \fIclientData\fR, then it -is removed without invoking it. If there is more than one -handler on the idle list that refers to \fIproc\fR and \fIclientData\fR, -all of the handlers are removed. If no existing handlers match -\fIproc\fR and \fIclientData\fR then nothing happens. -.VE -.PP -\fBTk_DoWhenIdle\fR is most useful in situations where -(a) a piece of work will have to be done but (b) it's -possible that something will happen in the near future -that will change what has to be done, or require something -different to be done. \fBTk_DoWhenIdle\fR allows the -actual work to be deferred until all pending events have -been processed. At this point the exact work to be done -will presumably be known and it can be done exactly once. -.PP -For example, \fBTk_DoWhenIdle\fR might be used by an editor -to defer display updates until all pending commands have -been processed. Without this feature, redundant redisplays -might occur in some situations, such as the processing of -a command file. - -.SH KEYWORDS -callback, defer, handler, idle diff --git a/tk3.6/doc/FileHndlr.3 b/tk3.6/doc/FileHndlr.3 deleted file mode 100644 index ceafbcd..0000000 --- a/tk3.6/doc/FileHndlr.3 +++ /dev/null @@ -1,110 +0,0 @@ -'\" -'\" Copyright (c) 1990 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/wish/man/RCS/FileHndlr.3,v 1.7 93/04/01 09:41:21 ouster Exp $ SPRITE (Berkeley) -'\" -.so man.macros -.HS Tk_CreateFileHandler tkc -.BS -.SH NAME -Tk_CreateFileHandler, Tk_DeleteFileHandler \- associate procedure callback with a file or device -.SH SYNOPSIS -.nf -\fB#include \fR -.sp -\fBTk_CreateFileHandler\fR(\fIid, mask, proc, clientData\fR) -.sp -\fBTk_DeleteFileHandler\fR(\fIid\fR) -.SH ARGUMENTS -.AS Tk_FileProc clientData -.AP int id in -Integer identifier for an open file or device (such as returned by -\fBopen\fR system call). -.AP int mask in -Conditions under which \fIproc\fR should be called: -OR-ed combination of \fBTK_READABLE\fR, \fBTK_WRITABLE\fR, -and \fBTK_EXCEPTION\fR. -.AP Tk_FileProc *proc in -Procedure to invoke whenever the file or device indicated -by \fIid\fR meets the conditions specified by \fImask\fR. -.AP ClientData clientData in -Arbitrary one-word value to pass to \fIproc\fR. -.BE - -.SH DESCRIPTION -.PP -\fBTk_CreateFileHandler\fR arranges for \fIproc\fR to be -invoked in the future whenever I/O becomes possible on a file -or an exceptional condition exists for the file. The file -is indicated by \fIid\fR, and the conditions of interest -are indicated by \fImask\fR. For example, if \fImask\fR -is \fBTK_READABLE\fR, then \fIproc\fR will be called when -the file is readable. -The callback to \fIproc\fR is made by \fBTk_DoOneEvent\fR, so -\fBTk_CreateFileHandler\fR is only useful -in programs that dispatch events -through \fBTk_DoOneEvent\fR or through other Tk procedures that -call \fBTk_DoOneEvent\fR, such as \fBTk_MainLoop\fR. -.PP -\fIProc\fP should have arguments and result that match the -type \fBTk_FileProc\fR: -.nf -.RS -typedef void Tk_FileProc( -.RS -ClientData \fIclientData\fR, -int \fImask\fR); -.RE -.RE -.fi -The \fIclientData\fP parameter to \fIproc\fR is a copy -of the \fIclientData\fP -argument given to \fBTcl_CreateFileHandler\fR when the callback -was created. Typically, \fIclientData\fR points to a data -structure containing application-specific information about -the file. \fIMask\fR is an integer mask indicating which -of the requested conditions actually exists for the file; it -will contain a subset of the bits in the \fImask\fR argument -to \fBTcl_CreateFileHandler\fR. -.PP -There may exist only one handler for a given file at a given -time. If \fBTk_CreateEventHandler\fR is called when a handler -already exists for \fIid\fR, then the \fImask\fR, \fIproc\fR, -and \fIclientData\fR for the new call to -\fBTk_CreateEventHandler\fR replace the information that was -previously recorded. -.PP -\fBTk_DeleteFileHandler\fR may be called to delete the -file handler for \fIid\fR; if no handler exists for the -file given by \fIid\fR then the procedure has no effect. -.PP -The purpose of file handlers is to enable an application to -respond to X events and other events while waiting for files -to become ready for I/O. For this to work correctly, the -application must use non-blocking I/O operations on the -files for which handlers are declared. Otherwise the application -may be put to sleep if it specifies too large an input or -output buffer; while waiting for the I/O to complete the -application won't be able to service other events. In BSD-based -UNIX systems, non-blocking I/O can be specified for a file using -the \fBfcntl\fR kernel call with the \fBFNDELAY\fR flag. - -.SH KEYWORDS -callback, file, handler diff --git a/tk3.6/doc/GetRootCrd.3 b/tk3.6/doc/GetRootCrd.3 deleted file mode 100644 index da318a2..0000000 --- a/tk3.6/doc/GetRootCrd.3 +++ /dev/null @@ -1,56 +0,0 @@ -'\" -'\" Copyright (c) 1990 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/wish/man/RCS/GetRootCrd.3,v 1.5 93/04/01 09:41:38 ouster Exp $ SPRITE (Berkeley) -'\" -.so man.macros -.HS Tk_GetRootCoords tkc -.BS -.SH NAME -Tk_GetRootCoords \- Compute root-window coordinates of window -.SH SYNOPSIS -.nf -\fB#include \fR -.sp -\fBTk_GetRootCoords\fR(\fItkwin, xPtr, yPtr\fR) -.SH ARGUMENTS -.AS Tk_Window tkwin -.AP Tk_Window tkwin in -Token for window. -.AP int *xPtr out -Pointer to location in which to store root-window x-coordinate -corresponding to left edge of \fItkwin\fR's border. -.AP int *yPtr out -Pointer to location in which to store root-window y-coordinate -corresponding to top edge of \fItkwin\fR's border. -.BE - -.SH DESCRIPTION -.PP -This procedure scans through the structural information maintained -by Tk to compute the root-window coordinates corresponding to -the upper-left corner of \fItkwin\fR's border. If \fItkwin\fR has -no border, then \fBTk_GetRootCoords\fR returns the root-window -coordinates corresponding to location (0,0) in \fItkwin\fR. -\fBTk_GetRootCoords\fR is relatively efficient, since it doesn't have to -communicate with the X server. - -.SH KEYWORDS -coordinates, root window diff --git a/tk3.6/doc/GetSelect.3 b/tk3.6/doc/GetSelect.3 deleted file mode 100644 index 236984a..0000000 --- a/tk3.6/doc/GetSelect.3 +++ /dev/null @@ -1,93 +0,0 @@ -'\" -'\" Copyright (c) 1990 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/wish/man/RCS/GetSelect.3,v 1.6 93/04/01 09:41:39 ouster Exp $ SPRITE (Berkeley) -'\" -.so man.macros -.HS Tk_GetSelection tkc -.BS -.SH NAME -Tk_GetSelection \- retrieve the contents of the selection -.SH SYNOPSIS -.nf -\fB#include \fR -.sp -int -\fBTk_GetSelection\fR(\fIinterp, tkwin, target, proc, clientData\fR) -.SH ARGUMENTS -.AS Tk_GetSelProc clientData -.AP Tcl_Interp *interp in -Interpreter to use for reporting errors. -.AP Tk_Window tkwin in -Window on whose behalf to retrieve the selection (determines -display from which to retrieve). -.AP Atom target in -Form in which to retrieve selection. -.AP Tk_GetSelProc *proc in -Procedure to invoke to process pieces of the selection as they -are retrieved. -.AP ClientData clientData in -Arbitrary one-word value to pass to \fIproc\fR. -.BE - -.SH DESCRIPTION -.PP -\fBTk_GetSelection\fR retrieves the selection in the format -specified by \fItarget\fR. The selection may actually be -retrieved in several pieces; as each piece is retrieved, -\fIproc\fR is called to process the piece. \fIProc\fR should -have arguments and result that match the type \fBTk_GetSelProc\fR: -.nf -.RS -typedef int Tk_GetSelProc( -.RS -ClientData \fIclientData\fR, -Tcl_Interp *\fIinterp\fR, -char *\fIportion\fR); -.RE -.RE -.fi -The \fIclientData\fP and \fIinterp\fR parameters to \fIproc\fR -will be copies of the corresponding arguments to -\fBTk_GetSelection\fR. \fIPortion\fR will be a pointer to -a string containing part or all of the selection. For large -selections, \fIproc\fR will be called several times with sucessive -portions of the selection. The X Inter-Client Communication -Conventions Manual allows the selection to be returned in formats -other than strings, e.g. as an array of atoms or integers. If -this happens, Tk converts the selection back into a string -before calling \fIproc\fR. If the selection is returned as an -array of atoms, Tk converts it to a string containing the atom names -separated by white space. For any other format besides string, -Tk converts the selection to a string containing hexadecimal -values separated by white space. -.PP -\fBTk_GetSelection\fR returns to its caller when the selection has -been completely retrieved and processed by \fIproc\fR, or when a -fatal error has occurred (e.g. the selection owner didn't respond -promptly). \fBTk_GetSelection\fR normally returns TCL_OK; if -an error occurs, it returns TCL_ERROR and leaves an error message -in \fIinterp->result\fR. \fIProc\fR should also return either -TCL_OK or TCL_ERROR. If \fIproc\fR encounters an error in dealing with the -selection, it should leave an error message in \fIinterp->result\fR -and return TCL_ERROR; this will abort the selection retrieval. - -.SH KEYWORDS -format, get, selection retrieval diff --git a/tk3.6/doc/MainWin.3 b/tk3.6/doc/MainWin.3 deleted file mode 100644 index 5551d92..0000000 --- a/tk3.6/doc/MainWin.3 +++ /dev/null @@ -1,49 +0,0 @@ -'\" -'\" Copyright (c) 1990 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/wish/man/RCS/MainWin.3,v 1.1 93/07/23 08:58:01 ouster Exp $ SPRITE (Berkeley) -'\" -.so man.macros -.HS Tk_MainWindow tkc 7.0 -.BS -.SH NAME -Tk_MainWindow \- find the main window for an application -.SH SYNOPSIS -.nf -\fB#include \fR -.sp -Tk_Window -\fBTk_MainWindow\fR(\fIinterp\fR) -.SH ARGUMENTS -.AS Tcl_Interp *pathName -.AP Tcl_Interp *interp in/out -Interpreter associated with the application. -.BE - -.SH DESCRIPTION -.PP -If \fIinterp\fR is associated with a Tk application then \fBTk_MainWindow\fR -returns the application's main window. -If there is no Tk application associated with \fIinterp\fR then -\fBTk_MainWindow\fR returns NULL and leaves an error message -in \fIinterp->result\fR. - -.SH KEYWORDS -application, main window diff --git a/tk3.6/doc/ManageGeom.3 b/tk3.6/doc/ManageGeom.3 deleted file mode 100644 index 96663b4..0000000 --- a/tk3.6/doc/ManageGeom.3 +++ /dev/null @@ -1,93 +0,0 @@ -'\" -'\" Copyright (c) 1990 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/wish/man/RCS/ManageGeom.3,v 1.5 93/04/01 09:41:43 ouster Exp $ SPRITE (Berkeley) -'\" -.so man.macros -.HS Tk_ManageGeometry tkc -.BS -.SH NAME -Tk_ManageGeometry \- arrange to handle geometry requests for a window -.SH SYNOPSIS -.nf -\fB#include \fR -.sp -\fBTk_ManageGeometry\fR(\fItkwin, proc, clientData\fR) -.SH ARGUMENTS -.AS Tk_GeometryProc clientData -.AP Tk_Window tkwin in -Token for window to be managed. -.AP Tk_GeometryProc *proc in -Procedure to invoke to handle geometry requests on \fItkwin\fR, or -NULL to indicate that \fItkwin\fR's geometry shouldn't be managed -anymore. -.AP ClientData clientData in -Arbitrary one-word value to pass to \fIproc\fR. -.BE - -.SH DESCRIPTION -.PP -\fBTk_ManageGeometry\fR arranges for \fIproc\fR to be invoked -whenever \fBTk_GeometryRequest\fR is called to change the desired -geometry for \fItkwin\fR. \fBTk_ManageGeometry\fR is typically -invoked by geometry managers when they take control of a window's -geometry. -.PP -\fIProc\fP should have arguments and results that match the -type \fBTk_GeometryProc\fR: -.nf -.RS -typedef void Tk_GeometryProc( -.RS -ClientData \fIclientData\fR, -Tk_Window \fItkwin\fR); -.RE -.RE -.fi -The parameters to \fIproc\fR will be identical to the -corresponding parameters passed to \fBTk_ManageGeometry\fR. -Typically, \fIclientData\fR points to a data -structure containing application-specific information about -how to manage \fItkwin\fR's geometry. -.PP -\fIProc\fR will be called during each call to \fBTk_GeometryRequest\fR -for \fItkwin\fR. \fIProc\fR can use macros like \fBTk_ReqWidth\fR -to retrieve the arguments passed to \fBTk_GeometryRequest\fR. It -should do what it can to meet the request, subject to the space -available in \fItkwin\fR's parent and its own policies for managing geometry. -If \fIproc\fR can meet the request, it should call procedures like -\fBTk_ResizeWindow\fR or \fBTk_MoveWindow\fR to carry out the actual -geometry change. In some cases it may make sense for \fIproc\fR not -to process the geometry request immediately, but rather to schedule a -procedure to do it later, using \fBTk_DoWhenIdle\fR. This approach -is likely to be more efficient in situations where several geometry -requests occur simultaneously: only a single geometry change will -be made, after all the requests have been registered. -.PP -If \fIproc\fR is specified as NULL, then the geometry handler for -\fItkwin\fR will be eliminated, leaving \fItkwin\fR unmanaged. -Calls to \fBTk_GeometryRequest\fR have no effect for unmanaged -windows except to store the requested size in a structure where -they can be retrieved by macros like \fBTk_ReqWidth\fR. If -\fBTk_GeometryRequest\fR has never been invoked for a window then -it is unmanaged. - -.SH KEYWORDS -callback, geometry, managed, request, unmanaged diff --git a/tk3.6/doc/OwnSelect.3 b/tk3.6/doc/OwnSelect.3 deleted file mode 100644 index f4e1ec5..0000000 --- a/tk3.6/doc/OwnSelect.3 +++ /dev/null @@ -1,69 +0,0 @@ -'\" -'\" Copyright (c) 1990 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/wish/man/RCS/OwnSelect.3,v 1.6 93/04/01 09:41:47 ouster Exp $ SPRITE (Berkeley) -'\" -.so man.macros -.HS Tk_OwnSelection tkc -.BS -.SH NAME -Tk_OwnSelection \- make a window the owner of the primary selection -.SH SYNOPSIS -.nf -\fB#include \fR -.sp -\fBTk_OwnSelection\fR(\fItkwin, proc, clientData\fR) -.SH ARGUMENTS -.AS Tk_LostSelProc clientData -.AP Tk_Window tkwin in -Window that is to become new selection owner. -.AP Tk_LostSelProc *proc in -Procedure to invoke when \fItkwin\fR loses selection ownership later. -.AP ClientData clientData in -Arbitrary one-word value to pass to \fIproc\fR. -.BE - -.SH DESCRIPTION -.PP -\fBTk_OwnSelection\fR arranges for \fItkwin\fR to become the -new owner of the primary selection. After this call completes, future requests -for the selection will be directed to handlers created for -\fItkwin\fR using \fBTk_CreateSelHandler\fR. When \fItkwin\fR -eventually loses the selection ownership, \fIproc\fR will be -invoked so that the window can clean itself up (e.g. by -unhighlighting the selection). \fIProc\fR should have arguments and -result that match the type \fBTk_LostSelProc\fR: -.nf -.RS -typedef void Tk_LostSelProc(ClientData \fIclientData\fR); -.RE -.fi -The \fIclientData\fP parameter to \fIproc\fR is a copy of the -\fIclientData\fP argument given to \fBTk_OwnSelection\fR, and is -usually a pointer to a data structure containing application-specific -information about \fItkwin\fR. -.PP -Once a window has become selection owner, it will remain owner until -either the window is deleted or until some other window claims -ownership. There is no way for a window to disavow ownership of the -selection once it has received it. - -.SH KEYWORDS -own, selection owner diff --git a/tk3.6/doc/RegInterp.3 b/tk3.6/doc/RegInterp.3 deleted file mode 100644 index 026a11e..0000000 --- a/tk3.6/doc/RegInterp.3 +++ /dev/null @@ -1,72 +0,0 @@ -'\" -'\" Copyright (c) 1990 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/wish/man/RCS/RegInterp.3,v 1.5 93/04/01 09:41:55 ouster Exp $ SPRITE (Berkeley) -'\" -.so man.macros -.HS Tk_RegisterInterp tkc -.BS -.SH NAME -Tk_RegisterInterp \- make an interpreter accessible with ``send'' command -.SH SYNOPSIS -.nf -\fB#include \fR -.sp -int -\fBTk_RegisterInterp\fR(\fIinterp, name, tkwin\fR) -.SH ARGUMENTS -.AS Tk_Window parent -.AP Tcl_Interp *interp in -Interpreter to register in display associated with \fItkwin\fR. -Also used to return errors if registration failed. -.AP char *name in -Name under which to register interpreter. Must be unique among -all registered interpreters for \fItkwin\fR's display. May not -contain the character ``|''. -.AP Tk_Window tkwin in -Token for window. Used only to find a display in which to -register \fIinterp\fR. -.BE - -.SH DESCRIPTION -.PP -\fBTk_RegisterInterp\fR is invoked to associate a name (\fIname\fR) with a -Tcl interpreter (\fIinterp\fR) and record that association in a well-known -property of a particular display (the one containing \fItkwin\fR). -After this procedure has been invoked, other interpreters in the -display will be able to use the \fBsend\fR command to invoke operations -remotely in \fIinterp\fR. The procedure returns TCL_OK if the -registration completed successfully and TCL_ERROR if the interpreter -could not be registered (e.g. because \fIname\fR is already in use). -In the event of an error, \fIinterp->result\fR is modified to point -to a message describing the error. -.PP -This procedure also adds a \fBsend\fR command to \fIinterp\fR, so -that commands may be sent from \fIinterp\fR to other interpreters. -.PP -The registration persists until the interpreter is deleted or the -\fBsend\fR command is deleted from \fIinterp\fR, at which -point \fIinterp\fR is automatically unregistered. -.PP -\fBTk_RegisterInterp\fR is called automatically by \fBTk_CreateMainWindow\fR, -so applications don't normally need to call it explicitly. - -.SH KEYWORDS -interpreter, name, register, send command diff --git a/tk3.6/doc/RestrictEv.3 b/tk3.6/doc/RestrictEv.3 deleted file mode 100644 index 8aa1f5d..0000000 --- a/tk3.6/doc/RestrictEv.3 +++ /dev/null @@ -1,90 +0,0 @@ -'\" -'\" Copyright (c) 1990 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/wish/man/RCS/RestrictEv.3,v 1.6 93/04/01 09:41:55 ouster Exp $ SPRITE (Berkeley) -'\" -.so man.macros -.HS Tk_RestrictEvents tkc -.BS -.SH NAME -Tk_RestrictEvents \- filter and selectively delay X events -.SH SYNOPSIS -.nf -\fB#include \fR -.sp -Tk_RestrictProc * -\fBTk_RestrictEvents\fR(\fIproc, arg, prevArgPtr\fR) -.SH ARGUMENTS -.AS Tk_RestrictProc **prevArgPtr -.AP Tk_RestrictProc *proc in -Predicate procedure to call to filter incoming X events. -NULL means do not restrict events at all. -.AP char *arg in -Arbitrary argument to pass to \fIproc\fR. -.AP char **prevArgPtr in/out -Pointer to place to save argument to previous restrict procedure. -.BE - -.SH DESCRIPTION -.PP -This procedure is useful in certain situations where applications -are only prepared to receive certain X events. After -\fBTk_RestrictEvents\fR is called, \fBTk_DoOneEvent\fR (and -hence \fBTk_MainLoop\fR) will filter X input events through -\fIproc\fR. \fIProc\fR indicates whether a -given event is to be processed immediately or deferred until some -later time (e.g. when the event restriction is lifted). \fIProc\fR -is a standard X predicate procedure, of the sort passed to -\fBXCheckIfEvent\fR. It must have arguments and result that match -the type \fBTk_RestrictProc\fR: -.nf -.RS -typedef Bool Tk_RestrictProc( -.RS -Display *\fIdisplay\fR, -XEvent *\fIeventPtr\fR, -char *\fIarg\fR); -.RE -.RE -.fi -The \fIdisplay\fR argument to \fIproc\fR is the display from which -\fIeventPtr\fR was received, and \fIeventPtr\fR points to an event -under consideration. The \fIarg\fR argument is a copy of the \fIarg\fR -passed to \fBTk_RestrictEvents\fR; it may be used to provide -\fIproc\fR with information it needs to filter events. \fIProc\fR -must return \fBTrue\fR or \fBFalse\fR. \fBTrue\fR means the event -should be processed immediately and \fBFalse\fR means the event -should not be processed now, but should be saved for some later -time. -.PP -\fBTk_RestrictEvents\fR uses its return value and \fIprevArgPtr\fR -to return information about the current event restriction procedure -(a NULL return value means there are currently no restrictions). -These values may be used to restore the previous restriction state -when there is no longer any need for the current restriction. -.PP -There are very few places where \fBTk_RestrictEvents\fR is needed. -Please use it only where it is absolutely necessary. -If only a local restriction is needed, it can probably -be achieved more cleanly by changing event-to-Tcl bindings or by -calling \fBTk_DeleteEventHandler\fR. - -.SH KEYWORDS -delay, event, filter, restriction diff --git a/tk3.6/doc/SetCModel.3 b/tk3.6/doc/SetCModel.3 deleted file mode 100644 index d547cbf..0000000 --- a/tk3.6/doc/SetCModel.3 +++ /dev/null @@ -1,61 +0,0 @@ -'\" -'\" Copyright (c) 1992 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/wish/man/RCS/SetCModel.3,v 1.3 93/04/01 09:41:56 ouster Exp $ SPRITE (Berkeley) -'\" -.so man.macros -.HS Tk_SetColorModel tkc -.BS -.SH NAME -Tk_SetColorModel, Tk_GetColorModel \- access color model for screen -.SH SYNOPSIS -.nf -\fB#include \fR -.sp -\fBTk_SetColorModel\fR(\fItkwin\fR, \fImodel\fB)\fR -.sp -Tk_ColorModel -\fBTk_GetColorModel\fR(\fItkwin\fB)\fR -.SH ARGUMENTS -.AS "Tk_ColorModel" model -.AP Tk_Window tkwin in -Token for window. -.AP Tk_ColorModel model in -New model to use for \fIwindow\fR's screen. -.BE - -.SH DESCRIPTION -.PP -These procedures allow the color model for a screen -to be read and written. -See the documentation for the \fBtk colormodel\fR command for details -on the color model and how it is used. -\fBTk_SetColorModel\fR sets the color model for the screen -associated with \fItkwin\fR to \fImodel\fR. \fIModel\fR must be -either \fBTK_COLOR\fR or \fBTK_MONO\fR. -In contrast to the \fBtk colormodel\fR command, there are no -restrictions on the value passed to \fBTk_SetColorModel\fR (you can -set the model to \fBTK_COLOR\fR even if the screen only has one -bit plane). -\fBTk_GetColorModel\fR returns the current color model for the -screen associated with \fItkwin\fR. - -.SH KEYWORDS -color model, screen diff --git a/tk3.6/doc/SetGrid.3 b/tk3.6/doc/SetGrid.3 deleted file mode 100644 index 2811796..0000000 --- a/tk3.6/doc/SetGrid.3 +++ /dev/null @@ -1,68 +0,0 @@ -'\" -'\" Copyright (c) 1990 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/wish/man/RCS/SetGrid.3,v 1.4 93/04/01 09:41:57 ouster Exp $ SPRITE (Berkeley) -'\" -.so man.macros -.HS Tk_SetGrid tkc -.BS -.SH NAME -Tk_SetGrid \- control the grid for interactive resizing -.SH SYNOPSIS -.nf -\fB#include \fR -.sp -\fBTk_SetGrid\fR(\fItkwin, reqWidth, reqHeight, widthInc, heightInc\fR) -.SH ARGUMENTS -.AS Tk_Window heightInc -.AP Tk_Window tkwin in -Token for window. -.AP int reqWidth in -Width in grid units that corresponds to the pixel dimension \fItkwin\fR -has requested via \fBTk_GeometryRequest\fR. -.AP int reqHeight in -Height in grid units that corresponds to the pixel dimension \fItkwin\fR -has requested via \fBTk_GeometryRequest\fR. -.AP int widthInc in -Width of one grid unit, in pixels. -.AP int heightInc in -Height of one grid unit, in pixels. -.BE - -.SH DESCRIPTION -.PP -\fBTk_SetGrid\fR is typically invoked by a widget when its \fBsetGrid\fR -option is true. -This procedure allows a widget to control interactive resizing of its -top-level window so that the space allocated to the widget is equal to -the space requested by the widget using \fBTk_GeometryRequest\fR, plus -or minus even multiples of \fIwidthInc\fR and \fIheightInc\fR. -\fBTk_SetGrid\fR turns on gridded geometry management for the top-level -window associated with \fItkwin\fR, and records the relationship between -pixel sizes and grid sizes as defined by \fIreqWidth\fR, \fIreqHeight\fR, -\fIwidthInc\fR, and \fIheightInc\fR. -.PP -See the \fBwm\fR manual entry for complete details on gridded geometry -management. -There is currently no way to turn off gridded geometry management using -a C procedure call; instead, invoke the ``\fBwm grid\fR'' command. - -.SH KEYWORDS -grid, window, window manager diff --git a/tk3.6/doc/Sleep.3 b/tk3.6/doc/Sleep.3 deleted file mode 100644 index 14b3c7f..0000000 --- a/tk3.6/doc/Sleep.3 +++ /dev/null @@ -1,50 +0,0 @@ -'\" -'\" Copyright (c) 1990 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/wish/man/RCS/Sleep.3,v 1.4 93/04/01 09:41:59 ouster Exp $ SPRITE (Berkeley) -'\" -.so man.macros -.HS Tk_Sleep tkc -.BS -.SH NAME -Tk_Sleep \- delay execution for a given number of milliseconds -.SH SYNOPSIS -.nf -\fB#include \fR -.sp -\fBTk_Sleep\fR(\fIms\fR) -.SH ARGUMENTS -.AP int ms in -Number of milliseconds to sleep. -.BE - -.SH DESCRIPTION -.PP -This procedure delays the calling process by the number of -milliseconds given by the \fIms\fR parameter, and returns -after that time has elapsed. It is typically used for things -like flashing a button, where the delay is short and the -application needn't do anything while it waits. For longer -delays where the application needs to respond to other events -during the delay, the procedure \fBTk_CreateTimerHandler\fR -should be used instead of \fBTk_Sleep\fR. - -.SH KEYWORDS -sleep, time, wait diff --git a/tk3.6/doc/TimerHndlr.3 b/tk3.6/doc/TimerHndlr.3 deleted file mode 100644 index 1000a0b..0000000 --- a/tk3.6/doc/TimerHndlr.3 +++ /dev/null @@ -1,89 +0,0 @@ -'\" -'\" Copyright (c) 1990 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/wish/man/RCS/TimerHndlr.3,v 1.6 93/04/01 09:41:59 ouster Exp $ SPRITE (Berkeley) -'\" -.so man.macros -.HS Tk_CreateTimerHandler tkc -.BS -.SH NAME -Tk_CreateTimerHandler, Tk_DeleteTimerHandler \- call a procedure at a -given time -.SH SYNOPSIS -.nf -\fB#include \fR -.sp -Tk_TimerToken -\fBTk_CreateTimerHandler\fR(\fImilliseconds, proc, clientData\fR) -.sp -\fBTk_DeleteTimerHandler\fR(\fItoken\fR) -.SH ARGUMENTS -.AS Tk_TimerToken milliseconds -.AP int milliseconds in -How many milliseconds to wait before invoking \fIproc\fR. -.AP Tk_TimerProc *proc in -Procedure to invoke after \fImilliseconds\fR have elapsed. -.AP ClientData clientData in -Arbitrary one-word value to pass to \fIproc\fR. -.AP Tk_TimerToken token in -Token for previously-created timer handler (the return value -from some previous call to \fBTk_CreateTimerHandler). -.BE - -.SH DESCRIPTION -.PP -\fBTk_CreateTimerHandler\fR arranges for \fIproc\fR to be -invoked at a time \fImilliseconds\fR milliseconds in the -future. -The callback to \fIproc\fR will be made by \fBTk_DoOneEvent\fR, -so \fBTk_CreateTimerHandler\fR is only useful in -programs that dispatch events -through \fBTk_DoOneEvent\fR or through other Tk procedures that -call \fBTk_DoOneEvent\fR, such as \fBTk_MainLoop\fR. The call -to \fIproc\fR may not be made at the exact time given by -\fImilliseconds\fR: it will be made at the next opportunity -after that time. For example, if \fBTk_DoOneEvent\fR isn't -called until long after the time has elapsed, or if there -are other pending events to process before the call to -\fIproc\fR, then the call to \fIproc\fR will be delayed. -.PP -\fIProc\fP should have arguments and return value that match -the type \fBTk_TimerProc\fR: -.nf -.RS -typedef void Tk_TimerProc(ClientData \fIclientData\fR); -.RE -.fi -The \fIclientData\fP parameter to \fIproc\fR is a -copy of the \fIclientData\fP argument given to -\fBTcl_CreateTimerHandler\fR when the callback -was created. Typically, \fIclientData\fR points to a data -structure containing application-specific information about -what to do in \fIproc\fR. -.PP -\fBTk_DeleteTimerHandler\fR may be called to delete a -previously-created timer handler. It deletes the handler -indicated by \fItoken\fR so that no call to \fIproc\fR -will be made; if that handler no longer exists -(e.g. because the time period has already elapsed and \fIproc\fR -has been invoked) then \fBTk_DeleteTimerHandler\fR does nothing. - -.SH KEYWORDS -callback, clock, handler, timer diff --git a/tk3.6/doc/after.n b/tk3.6/doc/after.n deleted file mode 100644 index 91d40fd..0000000 --- a/tk3.6/doc/after.n +++ /dev/null @@ -1,63 +0,0 @@ -'\" -'\" Copyright (c) 1990 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/wish/man/RCS/after.n,v 1.11 93/04/01 09:52:08 ouster Exp $ SPRITE (Berkeley) -'\" -.so man.macros -.HS after tk -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -after \- Execute a command after a time delay -.SH SYNOPSIS -\fBafter \fIms \fR?\fIarg1 arg2 arg3 ...\fR? -.BE - -.SH DESCRIPTION -.PP -This command is used to delay execution of the program or to execute -a command in background after a delay. The \fIms\fR argument gives -a time in milliseconds. -If \fIms\fR is the only argument to \fBafter\fR -then the command sleeps for \fIms\fR milliseconds and returns. -.VS -While the command is sleeping the application does not respond to -X events and other events. -.VE -.PP -If additional arguments are -present after \fIms\fR, then a Tcl command is formed by concatenating -all the additional arguments in the same fashion as the \fBconcat\fR -command. \fBAfter\fR returns immediately but arranges for the command -to be executed \fIms\fR milliseconds later in background. -.VS -The command will be executed at global level (outside the context -of any Tcl procedure). -.VE -If an error occurs while executing the delayed command then the -\fBtkerror\fR mechanism is used to report the error. -.PP -The \fBafter\fR command always returns an empty string. - -.SH "SEE ALSO" -tkerror - -.SH KEYWORDS -delay, sleep, time diff --git a/tk3.6/doc/bind.n b/tk3.6/doc/bind.n deleted file mode 100644 index 0c6e7b4..0000000 --- a/tk3.6/doc/bind.n +++ /dev/null @@ -1,453 +0,0 @@ -'\" -'\" Copyright (c) 1990 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/wish/man/RCS/bind.n,v 1.20 93/08/20 08:37:02 ouster Exp $ SPRITE (Berkeley) -'/" -.so man.macros -.HS bind tk -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -bind \- Arrange for X events to invoke Tcl commands -.SH SYNOPSIS -\fBbind\fI windowSpec\fR -.br -\fBbind\fI windowSpec sequence\fR -.br -\fBbind\fI windowSpec sequence command\fR -.br -\fBbind\fI windowSpec sequence \fB+\fIcommand\fR -.BE - -.SH DESCRIPTION -.PP -If all three arguments are specified, \fBbind\fR will -arrange for \fIcommand\fR (a Tcl -command) to be executed whenever the sequence of events given -.VS -by \fIsequence\fR occurs in the window(s) identified by \fIwindowSpec\fR. -.VE -If \fIcommand\fR is prefixed with a ``+'', then it is appended to -any existing binding for \fIsequence\fR; otherwise \fIcommand\fR replaces -the existing binding, if any. If \fIcommand\fR -is an empty string then the current binding for \fIsequence\fR -is destroyed, leaving \fIsequence\fR unbound. In all of the cases -where a \fIcommand\fR argument is provided, \fBbind\fR returns -an empty string. -.PP -If \fIsequence\fR is specified without a \fIcommand\fR, then the -command currently bound to \fIsequence\fR is returned, or -an empty string if there is no binding for \fIsequence\fR. If -neither \fIsequence\fR nor \fIcommand\fR is specified, then the -return value is a list whose elements are all the sequences -.VS -for which there exist bindings for \fIwindowSpec\fR. -.PP -The \fIwindowSpec\fR argument selects which window(s) the binding -applies to. -It may have one of three forms. -If \fIwindowSpec\fR is the path name for a window, then the binding -applies to that particular window. -If \fIwindowSpec\fR is the name of a class of widgets, then the -binding applies to all widgets in that class. -Lastly, \fIwindowSpec\fR may have the value \fBall\fR, in which case -the binding applies to all windows in the application. -.VE -.PP -The \fIsequence\fR argument specifies a sequence of one or more -event patterns, with optional white space between the patterns. Each -event pattern may -take either of two forms. In the simplest case it is a single -printing ASCII character, such as \fBa\fR or \fB[\fR. The character -may not be a space character or the character \fB<\fR. This form of -pattern matches a \fBKeyPress\fR event for the particular -character. The second form of pattern is longer but more general. -It has the following syntax: -.DS C -\fB<\fImodifier-modifier-type-detail\fB>\fR -.DE -The entire event pattern is surrounded by angle brackets. -Inside the angle brackets are zero or more modifiers, an event -type, and an extra piece of information (\fIdetail\fR) identifying -a particular button or keysym. Any of the fields may be omitted, -as long as at least one of \fItype\fR and \fIdetail\fR is present. -The fields must be separated by white space or dashes. -.LP -Modifiers may consist of any of the values in the following list: -.DS -.ta 6c -\fBControl\fR \fBAny\fR -\fBShift\fR \fBDouble\fR -\fBLock\fR \fBTriple\fR -.VS -\fBButton1, B1\fR \fBMod1, M1, Meta, M\fR -\fBButton2, B2\fR \fBMod2, M2, Alt\fR -.VE -\fBButton3, B3\fR \fBMod3, M3\fR -\fBButton4, B4\fR \fBMod4, M4\fR -\fBButton5, B5\fR \fBMod5, M5\fR -.DE -Where more than one value is listed, separated by commas, the values -are equivalent. All of the modifiers except \fBAny\fR, -\fBDouble\fR, and \fBTriple\fR have -the obvious X meanings. For example, \fBButton1\fR requires that -button 1 be depressed when the event occurs. Under normal conditions -the button and modifier state at the time of the event must -match exactly those specified in the \fBbind\fR command. If -no modifiers are specified, then events will match only if no modifiers -are present. If the \fBAny\fR modifier is specified, then additional -modifiers may be present besides those specified explicitly. For -example, if button 1 is pressed while the shift and control keys -are down, the specifier \fB\fR will match -the event, but the specifier \fB\fR will not. -.LP -The \fBDouble\fR and \fBTriple\fR modifiers are a convenience -for specifying double mouse clicks and other repeated -events. They cause a particular event pattern to be -repeated 2 or 3 times, and also place a time and space requirement -on the sequence: for a sequence of events to match a \fBDouble\fR -or \fBTriple\fR pattern, all of the events must occur close together -in time and without substantial mouse motion in between. -For example, \fB\fR -is equivalent to \fB\fR with the extra -time and space requirement. -.LP -The \fItype\fR field may be any of the standard X event types, with a -few extra abbreviations. Below is a list of all the valid types; -where two name appear together, they are synonyms. -.DS C -.ta 5c 10c -\fBButtonPress, Button Expose Leave -ButtonRelease FocusIn Map -Circulate FocusOut Property -CirculateRequest Gravity Reparent -Colormap Keymap ResizeRequest -Configure KeyPress, Key Unmap -.VS -.VE -ConfigureRequest KeyRelease Visibility -Destroy MapRequest -Enter Motion\fR -.DE -.LP -The last part of a long event specification is \fIdetail\fR. In the -case of a \fBButtonPress\fR or \fBButtonRelease\fR event, it is the -number of a button (1-5). If a button number is given, then only an -event on that particular button will match; if no button number is -given, then an event on any button will match. Note: giving a -specific button number is different than specifying a button modifier; -in the first case, it refers to a button being pressed or released, -while in the second it refers to some other button that is already -depressed when the matching event occurs. If a button -number is given then \fItype\fR may be omitted: if will default -to \fBButtonPress\fR. For example, the specifier \fB<1>\fR -is equivalent to \fB\fR. -.LP -If the event type is \fBKeyPress\fR or \fBKeyRelease\fR, then -\fIdetail\fR may be specified in the form of an X keysym. Keysyms -are textual specifications for particular keys on the keyboard; -they include all the alphanumeric ASCII characters (e.g. ``a'' is -the keysym for the ASCII character ``a''), plus descriptions for -non-alphanumeric characters (``comma'' is the keysym for the comma -character), plus descriptions for all the non-ASCII keys on the -keyboard (``Shift_L'' is the keysm for the left shift key, and -``F1'' is the keysym for the F1 function key, if it exists). The -complete list of keysyms is not presented here; it should be -available in other X documentation. If necessary, you can use the -\fB%K\fR notation described below to print out the keysym name for -an arbitrary key. If a keysym \fIdetail\fR is given, then the -\fItype\fR field may be omitted; it will default to \fBKeyPress\fR. -For example, \fB\fR is equivalent to -\fB\fR. If a keysym \fIdetail\fR is specified -then the \fBShift\fR modifier need not be specified and will be -ignored if specified: each keysym already implies a particular -state for the shift key. -.LP -The \fIcommand\fR argument to \fBbind\fR is a Tcl command string, -which will be executed whenever the given event sequence occurs. -\fICommand\fR will be executed in the same interpreter that the -\fBbind\fR command was executed in. If \fIcommand\fR contains -any \fB%\fR characters, then the command string will not be -executed directly. Instead, a new command string will be -generated by replacing each \fB%\fR, and the character following -it, with information from the current event. The replacement -depends on the character following the \fB%\fR, as defined in the -list below. Unless otherwise indicated, the -.VS -replacement string is the decimal value of the given field from -the current event. -.VE -Some of the substitutions are only valid for -certain types of events; if they are used for other types of events -the value substituted is undefined. -.TP -\fB%%\fR -Replaced with a single percent. -.TP -\fB%#\fR -The number of the last client request processed by the server -(the \fIserial\fR field from the event). Valid for all event -types. -.TP -\fB%a\fR -The \fIabove\fR field from the event. -Valid only for \fBConfigureNotify\fR events. -.TP -\fB%b\fR -The number of the button that was pressed or released. Valid only -for \fBButtonPress\fR and \fBButtonRelease\fR events. -.TP -\fB%c\fR -The \fIcount\fR field from the event. Valid only for \fBExpose\fR, -\fBGraphicsExpose\fR, and \fBMappingNotify\fR events. -.TP -\fB%d\fR -The \fIdetail\fR field from the event. The \fB%d\fR is replaced by -a string identifying the detail. For \fBEnterNotify\fR, -\fBLeaveNotify\fR, \fBFocusIn\fR, and \fBFocusOut\fR events, -the string will be one of the following: -.RS -.DS -.ta 6c -\fBNotifyAncestor NotifyNonlinearVirtual -NotifyDetailNone NotifyPointer -NotifyInferior NotifyPointerRoot -NotifyNonlinear NotifyVirtual\fR -.DE -For \fBConfigureRequest\fR events, the substituted string will be -one of the following: -.DS -.ta 6c -\fBAbove Opposite -Below TopIf -BottomIf\fR -.DE -For events other than these, the substituted string is undefined. -.RE -.TP -\fB%f\fR -The \fIfocus\fR field from the event (\fB0\fR or \fB1\fR). Valid only -for \fBEnterNotify\fR and \fBLeaveNotify\fR events. -.TP -\fB%h\fR -The \fIheight\fR field from the event. Valid only for \fBConfigure\fR, -\fBConfigureNotify\fR, \fBExpose\fR, \fBGraphicsExpose\fR, and -\fBResizeRequest\fR events. -.TP -\fB%k\fR -The \fIkeycode\fR field from the event. Valid only for \fBKeyPress\fR -and \fBKeyRelease\fR events. -.TP -\fB%m\fR -The \fImode\fR field from the event. The substituted string is one of -\fBNotifyNormal\fR, \fBNotifyGrab\fR, \fBNotifyUngrab\fR, or -\fBNotifyWhileGrabbed\fR. Valid only for \fBEnterWindow\fR, -\fBFocusIn\fR, \fBFocusOut\fR, and \fBLeaveWindow\fR events. -.TP -\fB%o\fR -The \fIoverride_redirect\fR field from the event. Valid only for -\fBCreateNotify\fR, \fBMapNotify\fR, \fBReparentNotify\fR, -and \fBConfigureNotify\fR events. -.TP -\fB%p\fR -The \fIplace\fR field from the event, substituted as one of the -strings \fBPlaceOnTop\fR or \fBPlaceOnBottom\fR. Valid only -for \fBCirculateNotify\fR and \fBCirculateRequest\fR events. -.TP -\fB%s\fR -The \fIstate\fR field from the event. For \fBButtonPress\fR, -\fBButtonRelease\fR, \fBEnterNotify\fR, \fBKeyPress\fR, \fBKeyRelease\fR, -\fBLeaveNotify\fR, and \fBMotionNotify\fR events, -.VS -a decimal string -.VE -is substituted. For \fBVisibilityNotify\fR, one of the strings -\fBVisibilityUnobscured\fR, \fBVisibilityPartiallyObscured\fR, -and \fBVisibilityFullyObscured\fR is substituted. -.TP -\fB%t\fR -The \fItime\fR field from the event. Valid only for events that -contain a \fItime\fR field. -.TP -\fB%v\fR -The \fIvalue_mask\fR field from the event. Valid only for -\fBConfigureRequest\fR events. -.TP -\fB%w\fR -The \fIwidth\fR field from the event. Valid only for -\fBConfigure\fR, \fBConfigureRequest\fR, \fBExpose\fR, -\fBGraphicsExpose\fR, and \fBResizeRequest\fR events. -.TP -\fB%x\fR -The \fIx\fR field from the event. Valid only for events containing -an \fIx\fR field. -.TP -\fB%y\fR -The \fIy\fR field from the event. Valid only for events containing -a \fIy\fR field. -.TP -\fB%A\fR -Substitutes the ASCII character corresponding to the event, or -the empty string if the event doesn't correspond to an ASCII character -(e.g. the shift key was pressed). \fBXLookupString\fR does all the -work of translating from the event to an ASCII character. -Valid only for \fBKeyPress\fR and \fBKeyRelease\fR events. -.TP -\fB%B\fR -The \fIborder_width\fR field from the event. Valid only for -\fBConfigureNotify\fR and \fBCreateWindow\fR events. -.TP -\fB%D\fR -The \fIdisplay\fR field from the event. Valid for all event types. -.TP -\fB%E\fR -The \fIsend_event\fR field from the event. Valid for all event types. -.TP -\fB%K\fR -The keysym corresponding to the event, substituted as a textual -string. Valid only for \fBKeyPress\fR and \fBKeyRelease\fR events. -.TP -\fB%N\fR -The keysym corresponding to the event, substituted as -.VS -a decimal -.VE -number. Valid only for \fBKeyPress\fR and \fBKeyRelease\fR events. -.TP -\fB%R\fR -The \fIroot\fR window identifier from the event. Valid only for -events containing a \fIroot\fR field. -.TP -\fB%S\fR -The \fIsubwindow\fR window identifier from the event. Valid only for -events containing a \fIsubwindow\fR field. -.TP -\fB%T\fR -The \fItype\fR field from the event. Valid for all event types. -.TP -\fB%W\fR -The path name of the window to which the event was reported (the -\fIwindow\fR field from the event). Valid for all event types. -.TP -\fB%X\fR -The \fIx_root\fR field from the event. -.VS -If a virtual-root window manager is being used then the substituted -value is the corresponding x-coordinate in the virtual root. -.VE -Valid only for -\fBButtonPress\fR, \fBButtonRelease\fR, \fBKeyPress\fR, \fBKeyRelease\fR, -and \fBMotionNotify\fR events. -.TP -\fB%Y\fR -The \fIy_root\fR field from the event. -.VS -If a virtual-root window manager is being used then the substituted -value is the corresponding y-coordinate in the virtual root. -.VE -Valid only for -\fBButtonPress\fR, \fBButtonRelease\fR, \fBKeyPress\fR, \fBKeyRelease\fR, -and \fBMotionNotify\fR events. -.LP -If the replacement string -.VS -for a %-replacement contains characters that are interpreted -specially by the Tcl parser (such as backslashes or square -brackets or spaces) additional backslashes are added -during replacement so that the result after parsing is the original -replacement string. -For example, if \fIcommand\fR is -.DS -\fBinsert\0%A\fR -.DE -and the character typed is an open square bracket, then the command -actually executed will be -.DS -\fBinsert\0\e[\fR -.DE -This will cause the \fBinsert\fR to receive the original replacement -string (open square bracket) as its first argument. -If the extra backslash hadn't been added, Tcl would not have been -able to parse the command correctly. -.VE -.LP -At most one binding will trigger for any given X event. -If several bindings match the recent events, the most specific binding -is chosen and its command will be executed. -The following tests are applied, in order, to determine which of -several matching sequences is more specific: -.VS -(a) a binding whose \fIwindowSpec\fR names a particular window is -more specific than a binding for a class, -which is more specific than a binding whose \fIwindowSpec\fR is -\fBall\fR; -.VE -(b) a longer sequence (in terms of number -of events matched) is more specific than a shorter sequence; -(c) an event pattern that specifies a specific button or key is more specific -than one that doesn't; (e) an event pattern that requires a particular -modifier is more specific than one that doesn't require the modifier; -(e) an event pattern specifying the \fBAny\fR modifier is less specific -than one that doesn't. If the matching sequences contain more than -one event, then tests (c)-(e) are applied in order from the most -recent event to the least recent event in the sequences. If these -tests fail to determine a winner, then the most recently registered -sequence is the winner. -.LP -If an X event does not match any of the existing bindings, then the -event is ignored (an unbound event is not considered to be an error). -.LP -When a \fIsequence\fR specified in a \fBbind\fR command contains -more than one event pattern, then its command is executed whenever -the recent events (leading up to and including the current event) -match the given sequence. This means, for example, that if button 1 is -clicked repeatedly the sequence \fB\fR will match -each button press but the first. -.VS -If extraneous events that would prevent a match occur in the middle -of an event sequence then the extraneous events are -ignored unless they are \fBKeyPress\fR or \fBButtonPress\fR events. -For example, \fB\fR will match a sequence of -presses of button 1, even though there will be \fBButtonRelease\fR -events (and possibly \fBMotionNotify\fR events) between the -\fBButtonPress\fR events. -Furthermore, a \fBKeyPress\fR event may be preceded by any number -of other \fBKeyPress\fR events for modifier keys without the -modifier keys preventing a match. -For example, the event sequence \fBaB\fR will match a press of the -\fBa\fR key, a release of the \fBa\fR key, a press of the \fBShift\fR -key, and a press of the \fBb\fR key: the press of \fBShift\fR is -ignored because it is a modifier key. -.VE -Finally, if several \fBMotionNotify\fR events occur in a row, only -the last one is used for purposes of matching binding sequences. -.LP -If an error occurs in executing the command for a binding then the -\fBtkerror\fR mechanism is used to report the error. -.VS -The command will be executed at global level (outside the context -of any Tcl procedure). -.VE - -.SH "SEE ALSO" -tkerror - -.SH KEYWORDS -form, manual diff --git a/tk3.6/doc/checkbutton.n b/tk3.6/doc/checkbutton.n deleted file mode 100644 index 8c16491..0000000 --- a/tk3.6/doc/checkbutton.n +++ /dev/null @@ -1,298 +0,0 @@ -'\" -'\" Copyright (c) 1990 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/wish/man/RCS/checkbutton.n,v 1.22 93/04/01 09:52:35 ouster Exp $ SPRITE (Berkeley) -'/" -.so man.macros -.HS checkbutton tk -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -checkbutton \- Create and manipulate check-button widgets -.SH SYNOPSIS -\fBcheckbutton\fI pathName \fR?\fIoptions\fR? -.SH "STANDARD OPTIONS" -.LP -.nf -.ta 4c 8c 12c -.VS -\fBactiveBackground\fR \fBbitmap\fR \fBfont\fR \fBrelief\fR -\fBactiveForeground\fR \fBborderWidth\fR \fBforeground\fR \fBtext\fR -\fBanchor\fR \fBcursor\fR \fBpadX\fR \fBtextVariable\fR -\fBbackground\fR \fBdisabledForeground\fR \fBpadY\fR -.VE -.fi -.LP -See the ``options'' manual entry for details on the standard options. -.SH "WIDGET-SPECIFIC OPTIONS" -.ta 4c -.LP -.nf -Name: \fBcommand\fR -Class: \fBCommand\fR -Command-Line Switch: \fB\-command\fR -.fi -.IP -Specifies a Tcl command to associate with the button. This command -is typically invoked when mouse button 1 is released over the button -window. The button's global variable (\fB\-variable\fR option) will -be updated before the command is invoked. -.LP -.nf -.VS -Name: \fBheight\fR -Class: \fBHeight\fR -Command-Line Switch: \fB\-height\fR -.fi -.IP -Specifies a desired height for the button. -If a bitmap is being displayed in the button then the value is in -screen units (i.e. any of the forms acceptable to \fBTk_GetPixels\fR); -for text it is in lines of text. -If this option isn't specified, the button's desired height is computed -from the size of the bitmap or text being displayed in it. -.VE -.LP -.nf -Name: \fBoffValue\fR -Class: \fBValue\fR -Command-Line Switch: \fB\-offvalue\fR -.fi -.IP -Specifies value to store in the button's associated variable whenever -this button is deselected. Defaults to ``0''. -.LP -.nf -Name: \fBonValue\fR -Class: \fBValue\fR -Command-Line Switch: \fB\-onvalue\fR -.fi -.IP -Specifies value to store in the button's associated variable whenever -this button is selected. Defaults to ``1''. -.LP -.nf -Name: \fBselector\fR -Class: \fBForeground\fR -Command-Line Switch: \fB\-selector\fR -.fi -.IP -Specifies the color to draw in the selector when this button is -selected. -.VS -If specified as an empty string then no selector is -drawn for the button. -.LP -.nf -Name: \fBstate\fR -Class: \fBState\fR -Command-Line Switch: \fB\-state\fR -.fi -.IP -Specifies one of three states for the check button: \fBnormal\fR, \fBactive\fR, -or \fBdisabled\fR. In normal state the check button is displayed using the -\fBforeground\fR and \fBbackground\fR options. The active state is -typically used when the pointer is over the check button. In active state -the check button is displayed using the \fBactiveForeground\fR and -\fBactiveBackground\fR options. Disabled state means that the check button -is insensitive: it doesn't activate and doesn't respond to mouse -button presses. In this state the \fBdisabledForeground\fR and -\fBbackground\fR options determine how the check button is displayed. -.VE -.LP -.nf -Name: \fBvariable\fR -Class: \fBVariable\fR -Command-Line Switch: \fB\-variable\fR -.fi -.IP -Specifies name of global variable to set to indicate whether -or not this button is selected. Defaults to the name of the -button within its parent (i.e. the last element of the button -window's path name). -.LP -.nf -.VS -Name: \fBwidth\fR -Class: \fBWidth\fR -Command-Line Switch: \fB\-width\fR -.fi -.IP -Specifies a desired width for the button. -If a bitmap is being displayed in the button then the value is in -screen units (i.e. any of the forms acceptable to \fBTk_GetPixels\fR); -for text it is in characters. -If this option isn't specified, the button's desired width is computed -from the size of the bitmap or text being displayed in it. -.VE -.BE - -.SH DESCRIPTION -.PP -The \fBcheckbutton\fR command creates a new window (given by the -\fIpathName\fR argument) and makes it into a check-button widget. -Additional -options, described above, may be specified on the command line -or in the option database -to configure aspects of the check button such as its colors, font, -text, and initial relief. The \fBcheckbutton\fR command returns its -\fIpathName\fR argument. At the time this command is invoked, -there must not exist a window named \fIpathName\fR, but -\fIpathName\fR's parent must exist. -.PP -A check button is a widget -.VS -that displays a textual string or bitmap -and a square called a \fIselector\fR. -A check button has -all of the behavior of a simple button, including the -following: it can display itself in either of three different -ways, according to the \fBstate\fR option; -.VE -it can be made to appear -raised, sunken, or flat; it can be made to flash; and it invokes -a Tcl command whenever mouse button 1 is clicked over the -check button. -.PP -In addition, check buttons can be \fIselected\fR. If a check button is -selected then a special highlight appears in the selector, and -a Tcl variable associated with the check button is set to a particular -value (normally 1). If the check button is not selected, then -the selector is drawn in a different fashion and the associated -variable is set to a different value (typically 0). By default, -the name of the variable associated with a check button is the -same as the \fIname\fR used to create the check button. The -variable name, and the ``on'' and ``off'' values stored in it, -may be modified with options on the command line or in the option -database. By default a check button is configured to select and deselect -itself on alternate button clicks. -.VS -In addition, each check button monitors its associated variable and -automatically selects and deselects itself when the variables value -changes to and from the button's ``on'' value. -.VE - -.SH "WIDGET COMMAND" -.PP -The \fBcheckbutton\fR command creates a new Tcl command whose -name is \fIpathName\fR. This -command may be used to invoke various -operations on the widget. It has the following general form: -.DS C -\fIpathName option \fR?\fIarg arg ...\fR? -.DE -\fIOption\fR and the \fIarg\fRs -determine the exact behavior of the command. The following -commands are possible for check button widgets: -.TP -\fIpathName \fBactivate\fR -Change the check button's state to \fBactive\fR and redisplay the button -using its active foreground and background colors instead of normal -colors. -.VS -This command is ignored if the check button's state is \fBdisabled\fR. -This command is obsolete and will eventually be removed; -use ``\fIpathName \fBconfigure \-state active\fR'' instead. -.VE -.TP -\fIpathName \fBconfigure\fR ?\fIoption\fR? ?\fIvalue option value ...\fR? -Query or modify the configuration options of the widget. -If no \fIoption\fR is specified, returns a list describing all of -the available options for \fIpathName\fR (see \fBTk_ConfigureInfo\fR for -information on the format of this list). If \fIoption\fR is specified -with no \fIvalue\fR, then the command returns a list describing the -one named option (this list will be identical to the corresponding -sublist of the value returned if no \fIoption\fR is specified). If -one or more \fIoption\-value\fR pairs are specified, then the command -modifies the given widget option(s) to have the given value(s); in -this case the command returns an empty string. -\fIOption\fR may have any of the values accepted by the \fBcheckbutton\fR -command. -.TP -\fIpathName \fBdeactivate\fR -Change the check button's state to \fBnormal\fR and redisplay the button -using its normal foreground and background colors. -.VS -This command is ignored if the check button's state is \fBdisabled\fR. -This command is obsolete and will eventually be removed; -use ``\fIpathName \fBconfigure \-state normal\fR'' instead. -.VE -.TP -\fIpathName \fBdeselect\fR -Deselect the check button: redisplay it without a highlight in -the selector and set the associated variable to its ``off'' -value. -.TP -\fIpathName \fBflash\fR -Flash the check button. This is accomplished by redisplaying the check button -several times, alternating between active and normal colors. At -the end of the flash the check button is left in the same normal/active -state as when the command was invoked. -.VS -This command is ignored if the check button's state is \fBdisabled\fR. -.VE -.TP -\fIpathName \fBinvoke\fR -.VS -Does just what would have happened if the user invoked the check button -with the mouse: toggle the selection state of the button and invoke -the Tcl command associated with the check button, if there is one. -The return value is the return value from the Tcl command, or an -empty string if there is no command associated with the check button. -This command is ignored if the check button's state is \fBdisabled\fR. -.VE -.TP -\fIpathName \fBselect\fR -Select the check button: display it with a highlighted -selector and set the associated variable to its ``on'' -value. -.TP -\fIpathName \fBtoggle\fR -Toggle the selection state of the button, redisplaying it and -modifying its associated variable to reflect the new state. - -.SH BINDINGS -.PP -.VS -Tk automatically creates class bindings for check buttons that give them -the following default behavior: -.IP [1] -The check button activates whenever the mouse passes over it and deactivates -whenever the mouse leaves the check button. -.IP [2] -The check button's relief is changed to sunken whenever mouse button 1 is -pressed over it, and the relief is restored to its original -value when button 1 is later released. -.IP [3] -If mouse button 1 is pressed over the check button and later released over -the check button, the check button is invoked (i.e. its selection -state toggles and the command associated with the button is invoked, -if there is one). However, if the mouse is not -over the check button when button 1 is released, then no invocation occurs. -.PP -If the check button's state is \fBdisabled\fR then none of the above -actions occur: the check button is completely non-responsive. -.PP -The behavior of check buttons can be changed by defining new bindings for -individual widgets or by redefining the class bindings. -.VE - -.SH KEYWORDS -check button, widget diff --git a/tk3.6/doc/destroy.n b/tk3.6/doc/destroy.n deleted file mode 100644 index 45b7444..0000000 --- a/tk3.6/doc/destroy.n +++ /dev/null @@ -1,48 +0,0 @@ -'\" -'\" Copyright (c) 1990 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/wish/man/RCS/destroy.n,v 1.7 93/05/09 14:52:11 ouster Exp $ SPRITE (Berkeley) -'/" -.so man.macros -.HS destroy tk -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -destroy \- Destroy one or more windows -.SH SYNOPSIS -\fBdestroy \fR?\fIwindow window ...\fR? -.VS -.VE -.BE - -.SH DESCRIPTION -.PP -This command deletes the windows given by the -.VS -\fIwindow\fR arguments, plus all of their descendants. -.VE -If a \fIwindow\fR ``.'' is deleted then the entire application -will be destroyed. -The \fIwindow\fRs are destroyed in order, and if an error occurs -in destroying a window the command aborts without destroying the -remaining windows. - -.SH KEYWORDS -application, destroy, window diff --git a/tk3.6/doc/entry.n b/tk3.6/doc/entry.n deleted file mode 100644 index f642e13..0000000 --- a/tk3.6/doc/entry.n +++ /dev/null @@ -1,299 +0,0 @@ -'\" -'\" Copyright (c) 1990 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/wish/man/RCS/entry.n,v 1.13 93/04/01 09:52:37 ouster Exp $ SPRITE (Berkeley) -'/" -.so man.macros -.HS entry tk -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -entry \- Create and manipulate entry widgets -.SH SYNOPSIS -\fBentry\fI \fIpathName \fR?\fIoptions\fR? -.SH "STANDARD OPTIONS" -.LP -.nf -.ta 4c 8c 12c -.VS -\fBbackground\fR \fBforeground\fR \fBinsertWidth\fR \fBselectForeground\fR -\fBborderWidth\fR \fBinsertBackground\fR \fBrelief\fR \fBtextVariable\fR -\fBcursor\fR \fBinsertBorderWidth\fR \fBscrollCommand\fR -\fBexportSelection\fR \fBinsertOffTime\fR \fBselectBackground\fR -\fBfont\fR \fBinsertOnTime\fR \fBselectBorderWidth\fR -.VE -.fi -.LP -See the ``options'' manual entry for details on the standard options. -.SH "WIDGET-SPECIFIC OPTIONS" -.ta 4c -.LP -.nf -.VS -Name: \fBstate\fR -Class: \fBState\fR -Command-Line Switch: \fB\-state\fR -.fi -.IP -Specifies one of two states for the entry: \fBnormal\fR or \fBdisabled\fR. -If the entry is disabled then the value may not be changed using widget -commands and no insertion cursor will be displayed, even if the input focus is -in the widget. -.VE -.LP -.nf -Name: \fBwidth\fR -Class: \fBWidth\fR -Command-Line Switch: \fB\-width\fR -.fi -.IP -Specifies an integer value indicating the desired width of the entry window, -in average-size characters of the widget's font. -.BE - -.SH DESCRIPTION -.PP -The \fBentry\fR command creates a new window (given by the -\fIpathName\fR argument) and makes it into an entry widget. -Additional options, described above, may be specified on the -command line or in the option database -to configure aspects of the entry such as its colors, font, -and relief. The \fBentry\fR command returns its -\fIpathName\fR argument. At the time this command is invoked, -there must not exist a window named \fIpathName\fR, but -\fIpathName\fR's parent must exist. -.PP -An entry is a widget that displays a one-line text string and -allows that string to be edited using widget commands described below, which -are typically bound to keystrokes and mouse actions. -When first created, an entry's string is empty. -A portion of the entry may be selected as described below. -.VS -If an entry is exporting its selection (see the \fBexportSelection\fR -option), then it will observe the standard X11 protocols for handling the -.VE -selection; entry selections are available as type \fBSTRING\fR. -Entries also observe the standard Tk rules for dealing with the -input focus. When an entry has the input focus it displays an -\fIinsertion cursor\fR to indicate where new characters will be -inserted. -.PP -Entries are capable of displaying strings that are too long to -fit entirely within the widget's window. In this case, only a -portion of the string will be displayed; commands described below -may be used to change the view in the window. Entries use -the standard \fBscrollCommand\fR mechanism for interacting with -scrollbars (see the description of the \fBscrollCommand\fR option -for details). They also support scanning, as described below. - -.SH "WIDGET COMMAND" -.PP -The \fBentry\fR command creates a new Tcl command whose -name is \fIpathName\fR. This -command may be used to invoke various -operations on the widget. It has the following general form: -.DS C -\fIpathName option \fR?\fIarg arg ...\fR? -.DE -\fIOption\fR and the \fIarg\fRs -determine the exact behavior of the command. -.PP -Many of the widget commands for entries take one or more indices as -arguments. An index specifies a particular character in the entry's -string, in any of the following ways: -.TP 12 -\fInumber\fR -Specifies the character as a numerical index, where 0 corresponds -to the first character in the string. -.TP 12 -\fBend\fR -Indicates the character just after the last one in the entry's string. -This is equivalent to specifying a numerical index equal to the length -of the entry's string. -.TP 12 -\fBinsert\fR -.VS -.VE -Indicates the character adjacent to and immediately following the -insertion cursor. -.TP 12 -\fBsel.first\fR -Indicates the first character in the selection. It is an error to -use this form if the selection isn't in the entry window. -.TP 12 -\fBsel.last\fR -Indicates the last character in the selection. It is an error to -use this form if the selection isn't in the entry window. -.TP 12 -\fB@\fInumber\fR -In this form, \fInumber\fR is treated as an x-coordinate in the -entry's window; the character spanning that x-coordinate is used. -For example, ``\fB@0\fR'' indicates the left-most character in the -window. -.LP -Abbreviations may be used for any of the forms above, e.g. ``\fBe\fR'' -or ``\fBsel.f\fR''. In general, out-of-range indices are automatically -rounded to the nearest legal value. -.PP -The following commands are possible for entry widgets: -.TP -\fIpathName \fBconfigure\fR ?\fIoption\fR? ?\fIvalue option value ...\fR? -Query or modify the configuration options of the widget. -If no \fIoption\fR is specified, returns a list describing all of -the available options for \fIpathName\fR (see \fBTk_ConfigureInfo\fR for -information on the format of this list). If \fIoption\fR is specified -with no \fIvalue\fR, then the command returns a list describing the -one named option (this list will be identical to the corresponding -sublist of the value returned if no \fIoption\fR is specified). If -one or more \fIoption\-value\fR pairs are specified, then the command -modifies the given widget option(s) to have the given value(s); in -this case the command returns an empty string. -\fIOption\fR may have any of the values accepted by the \fBentry\fR -command. -.TP -\fIpathName \fBdelete \fIfirst \fR?\fIlast\fR? -Delete one or more elements of the entry. \fIFirst\fR and \fIlast\fR -are indices of of the first and last characters in the range to -be deleted. If \fIlast\fR isn't specified it defaults to -\fIfirst\fR, i.e. a single character is deleted. This command -returns an empty string. -.TP -\fIpathName \fBget\fR -Returns the entry's string. -.TP -\fIpathName \fBicursor \fIindex\fR -.VS -Arrange for the insertion cursor to be displayed just before the character -given by \fIindex\fR. Returns an empty string. -.VE -.TP -\fIpathName \fBindex\fI index\fR -Returns the numerical index corresponding to \fIindex\fR. -.TP -\fIpathName \fBinsert \fIindex string\fR -Insert the characters of \fIstring\fR just before the character -indicated by \fIindex\fR. Returns an empty string. -.TP -\fIpathName \fBscan\fR \fIoption args\fR -This command is used to implement scanning on entries. It has -two forms, depending on \fIoption\fR: -.RS -.TP -\fIpathName \fBscan mark \fIx\fR -Records \fIx\fR and the current view in the entry window; used in -conjunction with later \fBscan dragto\fR commands. Typically this -command is associated with a mouse button press in the widget. It -returns an empty string. -.TP -\fIpathName \fBscan dragto \fIx\fR -This command computes the difference between its \fIx\fR argument -and the \fIx\fR argument to the last \fBscan mark\fR command for -the widget. It then adjusts the view left or right by 10 times the -difference in x-coordinates. This command is typically associated -with mouse motion events in the widget, to produce the effect of -dragging the entry at high speed through the window. The return -value is an empty string. -.RE -.TP -\fIpathName \fBselect \fIoption arg\fR -This command is used to adjust the selection within an entry. It -has several forms, depending on \fIoption\fR: -.RS -.TP -\fIpathName \fBselect adjust \fIindex\fR -Locate the end of the selection nearest to the character given by -\fIindex\fR, and adjust that end of the selection to be at \fIindex\fR -(i.e including but not going beyond \fIindex\fR). The other -end of the selection is made the anchor point for future -\fBselect to\fR commands. If the selection -isn't currently in the entry, then a new selection is created to -include the characters between \fIindex\fR and the most recent -selection anchor point, inclusive. -Returns an empty string. -.TP -\fIpathName \fBselect clear\fR -Clear the selection if it is currently in this widget. If the -selection isn't in this widget then the command has no effect. -Returns an empty string. -.TP -\fIpathName \fBselect from \fIindex\fR -Set the selection anchor point to just before the character -given by \fIindex\fR. Doesn't change the selection. -Returns an empty string. -.TP -\fIpathName \fBselect to \fIindex\fR -Set the selection to consist of the elements from the anchor -point to element \fIindex\fR, inclusive. The anchor point is -determined by the most recent \fBselect from\fR or \fBselect adjust\fR -command in this widget. If the selection isn't in this widget -then a new selection is created using the most recent anchor point -specified for the widget. Returns an empty string. -.RE -.TP -\fIpathName \fBview \fIindex\fR -Adjust the view in the entry so that element \fIindex\fR is -at the left edge of the window. Returns an empty string. - -.SH "DEFAULT BINDINGS" -.PP -.VS -Tk automatically creates class bindings for entries that give them -the following default behavior: -.IP [1] -Clicking mouse button 1 in an entry positions the insertion cursor -just before the character underneath the mouse cursor and sets the -input focus to this widget. -.IP [2] -Dragging with mouse button 1 strokes out a selection between -the insertion cursor and the character under the mouse. -.IP [3] -The ends of the selection can be adjusted by dragging with mouse -button 1 while the shift key is down; this will adjust the end -of the selection that was nearest to the mouse cursor when button -1 was pressed. -.IP [4] -The view in the entry can be adjusted by dragging with mouse button 2. -.IP [5] -If the input focus is in an entry widget and characters are typed on the -keyboard, the characters are inserted just before the insertion cursor. -.IP [6] -Control-h and the Backspace and Delete keys erase the character just -before the insertion cursor. -.IP [7] -Control-w erases the word just before the insertion cursor. -.IP [8] -Control-u clears the entry to an empty string. -.IP [9] -Control-v inserts the current selection just before the insertion cursor. -.IP [10] -Control-d deletes the selected characters; an error occurs if the selection -is not in this widget. -.PP -If the entry is disabled using the \fBstate\fR option, then the entry's -view can still be adjusted and text in the entry can still be selected, -but no insertion cursor will be displayed and no text modifications will -take place. -.PP -The behavior of entries can be changed by defining new bindings for -individual widgets or by redefining the class bindings. -.VE - -.SH KEYWORDS -entry, widget diff --git a/tk3.6/doc/exit.n b/tk3.6/doc/exit.n deleted file mode 100644 index 92de5b8..0000000 --- a/tk3.6/doc/exit.n +++ /dev/null @@ -1,47 +0,0 @@ -'\" -'\" 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/wish/man/RCS/exit.n,v 1.1 93/07/07 13:22:38 ouster Exp $ SPRITE (Berkeley) -'\" -.so man.macros -.HS exit tk -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -exit \- Exit the process -.SH SYNOPSIS -\fBexit \fR?\fIreturnCode\fR? -.BE - -.SH DESCRIPTION -.PP -Terminate the process, returning \fIreturnCode\fR (an integer) to the -system as the exit status. -If \fIreturnCode\fR isn't specified then it defaults -to 0. -This command replaces the Tcl command by the same name. -It is identical to Tcl's \fBexit\fR command except that -before exiting it destroys all the windows managed by -the process. -This allows various cleanup operations to be performed, such -as removing application names from the global registry of applications. - -.SH KEYWORDS -exit, process diff --git a/tk3.6/doc/focus.n b/tk3.6/doc/focus.n deleted file mode 100644 index 219daf1..0000000 --- a/tk3.6/doc/focus.n +++ /dev/null @@ -1,138 +0,0 @@ -'\" -'\" Copyright (c) 1990-1992 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/wish/man/RCS/focus.n,v 1.9 93/04/01 09:52:39 ouster Exp $ SPRITE (Berkeley) -'/" -.so man.macros -.HS focus tk -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -focus \- Direct keyboard events to a particular window -.SH SYNOPSIS -\fBfocus\fR -.br -\fBfocus \fIwindow\fR -.br -\fBfocus \fIoption\fR ?\fIarg arg ...\fR? -.BE - -.SH DESCRIPTION -.PP -.VS -The \fBfocus\fR command is used to manage the Tk input focus. -At any given time, one window in an application is designated as -the focus window for that application; any key press or key release -events directed to any window in the application will be redirected -instead to the focus window. If there is no focus window for an -application then keyboard events are discarded. -Typically, windows that are prepared to deal with the focus -(e.g. entries and other widgets that display editable text) will -claim the focus when mouse button 1 is pressed in them. -When an application is created its main window is initially given -the focus. -.PP -The \fBfocus\fR command can take any of the following forms: -.TP -\fBfocus\fR -If invoked with no arguments, \fBfocus\fR returns the path name of -the current focus window, or \fBnone\fR if there is no focus window. -.TP -\fBfocus \fIwindow\fR -If invoked with a single argument consisting of a window's path -name, \fBfocus\fR sets the input focus to that window. -The return value is an empty string. -.TP -\fBfocus default \fR?\fIwindow\fR? -If \fIwindow\fR is specified, it becomes the default focus window -(the window that receives the focus whenever the focus window is -deleted) and the command returns an empty string. -If \fIwindow\fR isn't specified, the command returns the path name -of the current default focus window, or \fBnone\fR if there is no -default. -\fIWindow\fR may be specified as \fBnone\fR to clear its existing -value. -The default window is initially \fBnone\fR. -.TP -\fBfocus none\fR -Clears the focus window, so that keyboard input to this application -will be discarded. - -.SH "FOCUS EVENTS" -.PP -Tk's model of the input focus is different than X's model, and the -focus window set with the \fBfocus\fR command is not usually the -same as the X focus window. -Tk never explicitly changes the official X focus window. -It waits for the window manager to direct the X input focus to -and from the application's top-level windows, and it intercepts -\fBFocusIn\fR and \fBFocusOut\fR events coming from the X -server to detect these changes. -All of the focus events received from X are discarded by Tk; they -never reach the application. -Instead, Tk generates a different stream of \fBFocusIn\fR and -\fBFocusOut\fR for the application. -This means that \fBFocusIn\fR and -and \fBFocusOut\fR events seen by the application will not obey the -conventions described in the documentation for Xlib. -.PP -Tk applications receive two kinds of \fBFocusIn\fR and \fBFocusOut\fR -events, which can be distinguished by their \fIdetail\fR fields. -Events with a \fIdetail\fR of \fBNotifyAncestor\fR are directed -to the current focus window when it becomes active or inactive. -A window is the active focus whenever two conditions are -simultaneously true: (a) the window is the focus window for its -application, and (b) some top-level window in the application has -received the X focus. -When this happens Tk generates a \fBFocusIn\fR event for the focus -window with detail \fBNotifyAncestor\fR. -When a window loses the active focus (either because the window manager -removed the focus from the application or because the focus window changed -within the application) then it receives a \fBFocusOut\fR event -with detail \fBNotifyAncestor\fR. -.PP -The events described above are directed to the application's focus -window regardless of which top-level window within the application -has received the focus. -The second kind of focus event is provided for applications that -need to know which particular top-level window has the X focus. -Tk generates \fBFocusIn\fR and \fBFocusOut\fR events with detail -\fBNotifyVirtual\fR for top-level windows whenever they receive or -lose the X focus. -These events are generated regardless of which window in the -application has the Tk input focus. -They do not imply that keystrokes will be directed to the window -that receives the event; they simply indicate which top-level -window is active as far as the window manager is concerned. -If a top-level window is also the application's focus window, -then it will receive both \fBNotifyVirtual\fR and \fBNotifyAncestor\fR -events when it receives or loses the X focus. -.PP -Tk does not generate the hierarchical chains of \fBFocusIn\fR and -\fBFocusOut\fR events described in the Xlib documentation (e.g. -a window can get a \fBFocusIn\fR or \fBFocusOut\fR event without -all of its ancestors getting events too). -Furthermore, the \fImode\fR field in focus events is always -\fBNotifyNormal\fR and the only values ever present in the -\fIdetail\fR field are \fBNotifyAncestor\fR and \fBNotifyVirtual\fR. -.VE - -.SH KEYWORDS -events, focus, keyboard, top-level, window manager diff --git a/tk3.6/doc/frame.n b/tk3.6/doc/frame.n deleted file mode 100644 index 73b3000..0000000 --- a/tk3.6/doc/frame.n +++ /dev/null @@ -1,139 +0,0 @@ -'\" -'\" Copyright (c) 1990 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/wish/man/RCS/frame.n,v 1.9 93/04/01 09:52:40 ouster Exp $ SPRITE (Berkeley) -'/" -.so man.macros -.HS frame tk -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -frame \- Create and manipulate frame widgets -.SH SYNOPSIS -\fBframe\fI \fIpathName \fR?\fB\-class \fIclassName\fR? ?\fIoptions\fR? -.SH "STANDARD OPTIONS" -.LP -.nf -.ta 4c 8c 12c -.VS -\fBbackground\fR \fBcursor\fR \fBrelief\fR -.VE -\fBborderWidth\fR \fBgeometry\fR -.fi -.LP -See the ``options'' manual entry for details on the standard options. -.SH "WIDGET-SPECIFIC OPTIONS" -.LP -.nf -.VS -Name: \fBheight\fR -Class: \fBHeight\fR -Command-Line Switch: \fB\-height\fR -.fi -.IP -Specifies the desired height for the window in any of the forms -acceptable to \fBTk_GetPixels\fR. -This option is only used if the \fB\-geometry\fR option is -unspecified. -If this option is less than or equal to zero (and \fB\-geometry\fR -is not specified) then the window will not request any size at -all. -.LP -.nf -Name: \fBwidth\fR -Class: \fBWidth\fR -Command-Line Switch: \fB\-width\fR -.fi -.IP -Specifies the desired width for the window in any of the forms -acceptable to \fBTk_GetPixels\fR. -This option is only used if the \fB\-geometry\fR option is -unspecified. -If this option is less than or equal to zero (and \fB\-geometry\fR -is not specified) then the window will not request any size at -all. -.VE -.BE - -.SH DESCRIPTION -.PP -The \fBframe\fR command creates a new window (given by the -\fIpathName\fR argument) and makes it into a frame widget. -Additional -options, described above, may be specified on the command line -or in the option database -to configure aspects of the frame such as its background color -and relief. The \fBframe\fR command returns the -path name of the new window. -.PP -A frame is a simple widget. Its primary purpose is to act as a -spacer or container for complex window layouts. The only features -of a frame are its background color and an optional 3-D border to make the -frame appear raised or sunken. -.PP -In addition to the standard options listed above, a \fB\-class\fR -option may be specified on the command line. If it is specified, then -the new widget's class will be set to \fIclassName\fR instead of -\fBFrame\fR. Changing the class of a frame widget may be useful -in order to use a special class name in database options referring -to this widget and its children. Note: \fB\-class\fR is handled -differently than other command-line options and cannot be specified -using the option database (it has to be processed -before the other options are even looked up, since the new class -name will affect the lookup of the other options). In addition, -the \fB\-class\fR option may not be queried or changed using the -\fBconfig\fR command described below. - -.SH "WIDGET COMMAND" -.PP -The \fBframe\fR command creates a new Tcl command whose -name is the same as the path name of the frame's window. This -command may be used to invoke various -operations on the widget. It has the following general form: -.DS C -\fIpathName option \fR?\fIarg arg ...\fR? -.DE -\fIPathName\fR is the name of the command, which is the same as -the frame widget's path name. \fIOption\fR and the \fIarg\fRs -determine the exact behavior of the command. The following -commands are possible for frame widgets: -.TP -\fIpathName \fBconfigure\fR ?\fIoption\fR? \fI?value option value ...\fR? -Query or modify the configuration options of the widget. -If no \fIoption\fR is specified, returns a list describing all of -the available options for \fIpathName\fR (see \fBTk_ConfigureInfo\fR for -information on the format of this list). If \fIoption\fR is specified -with no \fIvalue\fR, then the command returns a list describing the -one named option (this list will be identical to the corresponding -sublist of the value returned if no \fIoption\fR is specified). If -one or more \fIoption\-value\fR pairs are specified, then the command -modifies the given widget option(s) to have the given value(s); in -this case the command returns an empty string. -\fIOption\fR may have any of the values accepted by the \fBframe\fR -command. - -.SH BINDINGS -.PP -When a new frame is created, it has no default event bindings: -frames are not intended to be interactive. - -.SH KEYWORDS -frame, widget diff --git a/tk3.6/doc/lbSingSel.n b/tk3.6/doc/lbSingSel.n deleted file mode 100644 index b131a8f..0000000 --- a/tk3.6/doc/lbSingSel.n +++ /dev/null @@ -1,47 +0,0 @@ -'\" -'\" Copyright (c) 1992 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/wish/man/RCS/lbSingSel.n,v 1.3 93/04/01 09:52:43 ouster Exp $ SPRITE (Berkeley) -'/" -.so man.macros -.HS tk_listboxSingleSelect tk -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -tk_listboxSingleSelect \- Allow only one selected element in listbox(es) -.SH SYNOPSIS -\fBtk_listboxSingleSelect \fIarg \fR?\fIarg arg ...\fR? -.BE - -.SH DESCRIPTION -.PP -This command is a Tcl procedure provided as part of the Tk script library. -It takes as arguments the path names of one or more listbox widgets, -or the value \fBListbox\fR. -For each named widget, \fBtk_listboxSingleSelect\fR modifies the -bindings of the widget so that only a single element may be selected -at a time (the normal configuration allows multiple elements to be -selected). -If the keyword \fBListbox\fR is among the \fIwindow\fR arguments, -then the class bindings for listboxes are changed so that all -listboxes have the one-selection-at-a-time behavior. - -.SH KEYWORDS -listbox, selection diff --git a/tk3.6/doc/listbox.n b/tk3.6/doc/listbox.n deleted file mode 100644 index a579c47..0000000 --- a/tk3.6/doc/listbox.n +++ /dev/null @@ -1,248 +0,0 @@ -'\" -'\" Copyright (c) 1990 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/wish/man/RCS/listbox.n,v 1.15 93/04/15 08:26:00 ouster Exp $ SPRITE (Berkeley) -'/" -.so man.macros -.HS listbox tk -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -listbox \- Create and manipulate listbox widgets -.SH SYNOPSIS -\fBlistbox\fI \fIpathName \fR?\fIoptions\fR? -.SH "STANDARD OPTIONS" -.LP -.nf -.ta 4c 8c 12c -.VS -\fBbackground\fR \fBforeground\fR \fBselectBackground\fR \fBxScrollCommand\fR -\fBborderWidth\fR \fBfont\fR \fBselectBorderWidth\fR \fByScrollCommand\fR -\fBcursor\fR \fBgeometry\fR \fBselectForeground\fR -\fBexportSelection\fR \fBrelief\fR \fBsetGrid\fR -.VE -.fi -.LP -See the ``options'' manual entry for details on the standard options. -.SH "WIDGET-SPECIFIC OPTIONS" -.ta 4c -.LP -None. -.BE - -.SH DESCRIPTION -.PP -The \fBlistbox\fR command creates a new window (given by the -\fIpathName\fR argument) and makes it into a listbox widget. -Additional -options, described above, may be specified on the command line -or in the option database -to configure aspects of the listbox such as its colors, font, -text, and relief. The \fBlistbox\fR command returns its -\fIpathName\fR argument. At the time this command is invoked, -there must not exist a window named \fIpathName\fR, but -\fIpathName\fR's parent must exist. -.PP -A listbox is a widget that displays a list of strings, one per line. -When first created, a new listbox has no elements in its list. -Elements may be added or deleted using widget commands described -below. In addition, one or more elements may be selected as described -below. -.VS -If a listbox is exporting its selection (see \fBexportSelection\fR -option), then it will observe the standard X11 protocols -.VE -for handling the selection; listbox selections are available -as type \fBSTRING\fR, consisting of a Tcl list with one entry -for each selected element. -.PP -For large lists only a subset of the list elements will be -displayed in the listbox window at once; commands described below -may be used to change the view in the window. Listboxes allow -.VS -scrolling in both directions using the standard \fBxScrollCommand\fR -and \fByScrollCommand\fR options. -.VE -They also support scanning, as described below. - -.SH "WIDGET COMMAND" -.PP -The \fBlistbox\fR command creates a new Tcl command whose -name is \fIpathName\fR. This -command may be used to invoke various -operations on the widget. It has the following general form: -.DS C -\fIpathName option \fR?\fIarg arg ...\fR? -.DE -\fIOption\fR and the \fIarg\fRs -determine the exact behavior of the command. The following -commands are possible for listbox widgets: -.TP -\fIpathName \fBconfigure\fR ?\fIoption\fR? ?\fIvalue option value ...\fR? -Query or modify the configuration options of the widget. -If no \fIoption\fR is specified, returns a list describing all of -the available options for \fIpathName\fR (see \fBTk_ConfigureInfo\fR for -information on the format of this list). If \fIoption\fR is specified -with no \fIvalue\fR, then the command returns a list describing the -one named option (this list will be identical to the corresponding -sublist of the value returned if no \fIoption\fR is specified). If -one or more \fIoption\-value\fR pairs are specified, then the command -modifies the given widget option(s) to have the given value(s); in -this case the command returns an empty string. -\fIOption\fR may have any of the values accepted by the \fBlistbox\fR -command. -.TP -\fIpathName \fBcurselection\fR -.VS -Returns a list containing the indices of -all of the elements in the listbox that are currently selected. -If there are no elements selected in the listbox then an empty -string is returned. -.VE -.TP -\fIpathName \fBdelete \fIfirst \fR?\fIlast\fR? -Delete one or more elements of the listbox. \fIFirst\fR and \fIlast\fR -give the integer indices of the first and last elements in the range -to be deleted. If \fIlast\fR isn't specified it defaults to -\fIfirst\fR, i.e. a single element is deleted. An index of -\fB0\fR corresponds to the first element in the listbox. Either -\fIfirst\fR or \fIlast\fR may be specified as \fBend\fR, in which -case it refers to the last element of the listbox. This command -returns an empty string -.TP -\fIpathName \fBget \fIindex\fR -Return the contents of the listbox element indicated by \fIindex\fR. -\fIIndex\fR must be a non-negative integer (0 corresponds to -the first element in the listbox), or it may also be specified as -\fBend\fR to indicate the last element in the listbox. -.TP -\fIpathName \fBinsert \fIindex \fR?\fIelement element ...\fR? -Insert zero or more new elements in the list just before the -element given by \fIindex\fR. If \fIindex\fR is specified as -\fBend\fR then the new elements are added to the end of the -list. Returns an empty string. -.TP -\fIpathName \fBnearest \fIy\fR -Given a y-coordinate within the listbox window, this command returns -the index of the (visible) listbox element nearest to that y-coordinate. -.TP -\fIpathName \fBscan\fR \fIoption args\fR -This command is used to implement scanning on listboxes. It has -two forms, depending on \fIoption\fR: -.RS -.TP -\fIpathName \fBscan mark \fIx y\fR -.VS -Records \fIx\fR and \fIy\fR and the current view in the listbox -window; used in conjunction with later \fBscan dragto\fR commands. -Typically this command is associated with a mouse button press in -the widget. It returns an empty string. -.TP -\fIpathName \fBscan dragto \fIx y\fR. -This command computes the difference between its \fIx\fR and \fIy\fR -arguments and the \fIx\fR and \fIy\fR arguments to the last -\fBscan mark\fR command for the widget. -It then adjusts the view by 10 times the -difference in coordinates. This command is typically associated -.VE -with mouse motion events in the widget, to produce the effect of -dragging the list at high speed through the window. The return -value is an empty string. -.RE -.TP -\fIpathName \fBselect \fIoption arg\fR -This command is used to adjust the selection within a listbox. It -has several forms, depending on \fIoption\fR. In all of the forms -the index \fBend\fR refers to the last element in the listbox. -.RS -.TP -\fIpathName \fBselect adjust \fIindex\fR -Locate the end of the selection nearest to the element given by -\fIindex\fR, and adjust that end of the selection to be at \fIindex\fR -(i.e including but not going beyond \fIindex\fR). The other -end of the selection is made the anchor point for future -\fBselect to\fR commands. If the selection -isn't currently in the listbox, then this command is identical to -the \fBselect from\fR widget command. -Returns an empty string. -.TP -\fIpathName \fBselect clear\fR -.VS -If the selection is in this listbox then it is cleared so that -none of the listbox's elements are selected anymore. -.VE -.TP -\fIpathName \fBselect from \fIindex\fR -Set the selection to consist of element \fIindex\fR, and make -\fIindex\fR the anchor point for future \fBselect to\fR widget -commands. Returns an empty string. -.TP -\fIpathName \fBselect to \fIindex\fR -Set the selection to consist of the elements from the anchor -point to element \fIindex\fR, inclusive. The anchor point is -determined by the most recent \fBselect from\fR or \fBselect adjust\fR -command in this widget. If the selection isn't in this widget, -this command is identical to \fBselect from\fR. -Returns an empty string. -.RE -.TP -\fIpathName \fBsize\fR -Returns a decimal string indicating the total number of elements -in the listbox. -.TP -\fIpathName \fBxview \fIindex\fR -.VS -Adjust the view in the listbox so that character position \fIindex\fR -is displayed at the left edge of the widget. -Returns an empty string. -.TP -\fIpathName \fByview \fIindex\fR -Adjust the view in the listbox so that element \fIindex\fR is -displayed at the top of the widget. -If \fIindex\fR is specified as \fBend\fR it indicates the last -element of the listbox. Returns an empty string. -.VE - -.SH "DEFAULT BINDINGS" -.PP -.VS -Tk automatically creates class bindings for listboxes that give them -the following default behavior: -.IP [1] -When button 1 is pressed over a listbox, the element underneath the -mouse cursor is selected. The mouse can be dragged to select a -range of elements. -.IP [2] -The ends of the selection can be adjusted by dragging with mouse -button 1 while the shift key is down; this will adjust the end -of the selection that was nearest to the mouse cursor when button -1 was pressed. -.IP [3] -The view in the listbox can be adjusted by dragging with mouse button 2. -.PP -The behavior of listboxes can be changed by defining new bindings for -individual widgets or by redefining the class bindings. -In addition, the procedure \fBtk_listboxSingleSelect\fR may be -invoked to change listbox behavior so that only a single element -may be selected at once. -.VE - -.SH KEYWORDS -listbox, widget diff --git a/tk3.6/doc/lower.n b/tk3.6/doc/lower.n deleted file mode 100644 index e03cb8d..0000000 --- a/tk3.6/doc/lower.n +++ /dev/null @@ -1,48 +0,0 @@ -'\" -'\" Copyright (c) 1990 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/wish/man/RCS/lower.n,v 1.2 93/07/07 16:27:47 ouster Exp $ SPRITE (Berkeley) -'/" -.so man.macros -.HS lower tk 3.3 -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -lower \- Change a window's position in the stacking order -.SH SYNOPSIS -\fBlower \fIwindow \fR?\fIbelowThis\fR? -.BE - -.SH DESCRIPTION -.PP -If the \fIbelowThis\fR argument is omitted then the command lowers -\fIwindow\fR so that it is below all of its siblings in the stacking -order (it will be obscured by any siblings that overlap it and -will not obscure any siblings). -If \fIbelowThis\fR is specified then it must be the path name of -a window that is either a sibling of \fIwindow\fR or the descendant -of a sibling of \fIwindow\fR. -In this case the \fBlower\fR command will insert -\fIwindow\fR into the stacking order just below \fIbelowThis\fR -(or the ancestor of \fIbelowThis\fR that is a sibling of \fIwindow\fR); -this could end up either raising or lowering \fIwindow\fR. - -.SH KEYWORDS -lower, obscure, stacking order diff --git a/tk3.6/doc/man.macros b/tk3.6/doc/man.macros deleted file mode 100644 index f45afa8..0000000 --- a/tk3.6/doc/man.macros +++ /dev/null @@ -1,182 +0,0 @@ -.\" 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/tk3.6/doc/menu.n b/tk3.6/doc/menu.n deleted file mode 100644 index b2ad81a..0000000 --- a/tk3.6/doc/menu.n +++ /dev/null @@ -1,510 +0,0 @@ -'\" -'\" Copyright (c) 1990-1992 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/wish/man/RCS/menu.n,v 1.17 93/10/23 16:50:39 ouster Exp $ SPRITE (Berkeley) -'/" -.so man.macros -.HS menu tk -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -menu \- Create and manipulate menu widgets -.SH SYNOPSIS -\fBmenu\fI \fIpathName \fR?\fIoptions\fR? -.SH "STANDARD OPTIONS" -.LP -.nf -.ta 4c 8c 12c -.VS -\fBactiveBackground\fR \fBbackground\fR \fBdisabledForeground\fR -\fBactiveBorderWidth\fR \fBborderWidth\fR \fBfont\fR -\fBactiveForeground\fR \fBcursor\fR \fBforeground\fR -.VE -.fi -.LP -See the ``options'' manual entry for details on the standard options. -.SH "WIDGET-SPECIFIC OPTIONS" -.ta 4c -.LP -.nf -Name: \fBpostCommand\fR -.VS -Class: \fBCommand\fR -Command-Line Switch: \fB\-postcommand\fR -.fi -.IP -If this option is specified then it provides a Tcl command to execute -each time the menu is posted. The command is invoked by the \fBpost\fR -widget command before posting the menu. -.VE -.LP -.nf -Name: \fBselector\fR -Class: \fBForeground\fR -Command-Line Switch: \fB\-selector\fR -.fi -.IP -For menu entries that are check buttons or radio buttons, this option -specifies the color to display in the selector when the check button -or radio button is selected. -.BE - -.SH INTRODUCTION -.PP -The \fBmenu\fR command creates a new top-level window (given -by the \fIpathName\fR argument) and makes it into a menu widget. -Additional -options, described above, may be specified on the command line -or in the option database -to configure aspects of the menu such as its colors and font. -The \fBmenu\fR command returns its -\fIpathName\fR argument. At the time this command is invoked, -there must not exist a window named \fIpathName\fR, but -\fIpathName\fR's parent must exist. -.PP -A menu is a widget that displays a collection of one-line entries arranged -in a column. There exist several different types of entries, -each with different properties. Entries of different types may be -combined in a single menu. Menu entries are not the same as -entry widgets. In fact, menu entries are not even distinct widgets; -the entire menu is one widget. -.PP -Menu entries are displayed with up to three -separate fields. The main field is a label in the form of text or -a bitmap, which is determined by the \fB\-label\fR or \fB\-bitmap\fR -option for the entry. -If the \fB\-accelerator\fR option is specified for an entry then a second -textual field is displayed to the right of the label. The accelerator -typically describes a keystroke sequence that may be typed in the -application to cause the same result as invoking the menu entry. -The third field is a \fIselector\fR. The selector is present only for -check-button or radio-button entries. It indicates whether the entry -is selected or not, and is displayed to the left of the entry's -string. -.PP -In normal use, an entry becomes active (displays itself differently) -whenever the mouse pointer is over the entry. If a mouse -button is released over the entry then the entry is \fIinvoked\fR. -The effect of invocation is different for each type of entry; -these effects are described below in the sections on individual -entries. -.PP -Entries may be \fIdisabled\fR, which causes their labels -and accelerators to be displayed -with dimmer colors. A disabled entry cannot be activated or invoked. -Disabled entries may be re-enabled, at which point it becomes -possible to activate and invoke them again. - -.SH "COMMAND ENTRIES" -.PP -The most common kind of menu entry is a command entry, which -behaves much like a button widget. When a command entry is -invoked, a Tcl command is executed. The Tcl -command is specified with the \fB\-command\fR option. - -.SH "SEPARATOR ENTRIES" -.PP -A separator is an entry that is displayed as a horizontal dividing -line. A separator may not be activated or invoked, and it has -no behavior other than its display appearance. - -.SH "CHECK-BUTTON ENTRIES" -.PP -A check-button menu entry behaves much like a check-button widget. -When it is invoked it toggles back and forth between the selected -and deselected states. When the entry is selected, a particular -value is stored in a particular global variable (as determined by -the \fB\-onvalue\fR and \fB\-variable\fR options for the entry); when -the entry is deselected another value (determined by the -\fB\-offvalue\fR option) is stored in the global variable. -A selector box is displayed to the left of the label in a check-button -entry. If the entry is selected then the box's center is displayed -in the color given by the \fBselector\fR option for the menu; -otherwise the box's center is displayed in the background color for -the menu. If a \fB\-command\fR option is specified for a check-button -entry, then its value is evaluated as a Tcl command each time the entry -is invoked; this happens after toggling the entry's -selected state. - -.SH "RADIO-BUTTON ENTRIES" -.PP -A radio-button menu entry behaves much like a radio-button widget. -Radio-button entries are organized in groups of which only one -entry may be selected at a time. Whenever a particular entry -becomes selected it stores a particular value into a particular -global variable (as determined by the \fB\-value\fR and -\fB\-variable\fR options for the entry). This action -causes any previously-selected entry in the same group -to deselect itself. -Once an entry has become selected, any change to the entry's -associated variable will cause the entry to deselect itself. -Grouping of radio-button entries is determined by their -associated variables: if two entries have the same associated -variable then they are in the same group. -A selector diamond is displayed to the left of the label in each -radio-button entry. If the entry is selected then the diamond's -center is displayed in the color given by the \fBselector\fR option -for the menu; -otherwise the diamond's center is displayed in the background color for -the menu. If a \fB\-command\fR option is specified for a radio-button -entry, then its value is evaluated as a Tcl command each time the entry -is invoked; this happens after selecting the entry. - -.SH "CASCADE ENTRIES" -.PP -A cascade entry is one with an associated menu (determined -by the \fB\-menu\fR option). Cascade entries allow the construction -of cascading menus. When the entry is activated, the -associated menu is posted just to the right of the entry; -that menu remains posted until the higher-level menu is unposted or -until some other entry is activated in the higher-level menu. -The associated menu should normally be a child of the menu containing -the cascade entry, in order for menu traversal to work correctly. -.PP -A cascade entry posts its associated menu by invoking a -Tcl command of the form -.RS -.IP -\fImenu\fB post \fIx y\fR -.RE -.LP -where \fImenu\fR is the path name of the associated menu, \fIx\fR -and \fIy\fR are the root-window coordinates of the upper-right -corner of the cascade entry, and \fIgroup\fR is the name of the -menu's group (as determined in its last \fBpost\fR widget command). -The lower-level menu is unposted by executing a Tcl command with -the form -.RS -.IP -\fImenu\fB unpost\fR -.RE -.LP -where \fImenu\fR is the name of the associated menu. -.LP -If a \fB\-command\fR option is specified for a cascade entry then it is -.VS -evaluated as a Tcl command each time the associated menu is posted (the -evaluation occurs before the menu is posted). -.VE - -.SH "WIDGET COMMAND" -.PP -The \fBmenu\fR command creates a new Tcl command whose -name is \fIpathName\fR. This -command may be used to invoke various -operations on the widget. It has the following general form: -.DS C -\fIpathName option \fR?\fIarg arg ...\fR? -.DE -\fIOption\fR and the \fIarg\fRs -determine the exact behavior of the command. -.PP -Many of the widget commands for a menu take as one argument an -indicator of which entry of the menu to operate on. These -indicators are called \fIindex\fRes and may be specified in -any of the following forms: -.TP 12 -\fInumber\fR -Specifies the entry numerically, where 0 corresponds -to the top-most entry of the menu, 1 to the entry below it, and -so on. -.TP 12 -\fBactive\fR -Indicates the entry that is currently active. If no entry is -active then this form is equivalent to \fBnone\fR. This form may -not be abbreviated. -.TP 12 -\fBlast\fR -Indicates the bottommost entry in the menu. If there are no -entries in the menu then this form is equivalent to \fBnone\fR. -This form may not be abbreviated. -.TP 12 -\fBnone\fR -Indicates ``no entry at all''; this is used most commonly with -the \fBactivate\fR option to deactivate all the entries in the -menu. In most cases the specification of \fBnone\fR causes -nothing to happen in the widget command. -This form may not be abbreviated. -.TP 12 -\fB@\fInumber\fR -In this form, \fInumber\fR is treated as a y-coordinate in the -menu's window; the entry spanning that y-coordinate is used. -For example, ``\fB@0\fR'' indicates the top-most entry in the -window. If \fInumber\fR is outside the range of the window -then this form is equivalent to \fBnone\fR. -.TP 12 -\fIpattern\fR -If the index doesn't satisfy one of the above forms then this -form is used. \fIPattern\fR is pattern-matched against the label of -each entry in the menu, in order from the top down, until a -matching entry is found. The rules of \fBTcl_StringMatch\fR -are used. -.PP -The following widget commands are possible for menu widgets: -.TP -\fIpathName \fBactivate \fIindex\fR -Change the state of the entry indicated by \fIindex\fR to \fBactive\fR -and redisplay it using its active colors. -Any previously-active entry is deactivated. If \fIindex\fR -is specified as \fBnone\fR, or if the specified entry is -disabled, then the menu ends up with no active entry. -Returns an empty string. -.TP -\fIpathName \fBadd \fItype \fR?\fIoption value option value ...\fR? -Add a new entry to the bottom of the menu. The new entry's type -is given by \fItype\fR and must be one of \fBcascade\fR, -\fBcheckbutton\fR, \fBcommand\fR, \fBradiobutton\fR, or \fBseparator\fR, -or a unique abbreviation of one of the above. If additional arguments -are present, they specify any of the following options: -.RS -.TP -\fB\-activebackground \fIvalue\fR -.VS -Specifies a background color to use for displaying this entry when it -is active. -If this option is specified as an empty string (the default), then the -\fBactiveBackground\fR option for the overall menu is used. -This option is not available for separator entries. -.VE -.TP -\fB\-accelerator \fIvalue\fR -Specifies a string to display at the right side of the menu entry. -Normally describes an accelerator keystroke sequence that may be -typed to invoke the same function as the menu entry. This option -is not available for separator entries. -.TP -\fB\-background \fIvalue\fR -.VS -Specifies a background color to use for displaying this entry when it -is in the normal state (neither active nor disabled). -If this option is specified as an empty string (the default), then the -\fBbackground\fR option for the overall menu is used. -This option is not available for separator entries. -.VE -.TP -\fB\-bitmap \fIvalue\fR -Specifies a bitmap to display in the menu instead of a textual -label, in any of the forms accepted by \fBTk_GetBitmap\fR. -This option overrides the \fB\-label\fR option but may be reset -to an empty string to enable a textual label to be displayed. -This option is not available for separator entries. -.TP -\fB\-command \fIvalue\fR -For command, checkbutton, and radiobutton entries, specifies a -.VS -Tcl command to execute when the menu entry is invoked. -For cascade entries, specifies a Tcl command to execute -when the entry is activated (i.e. just before its submenu is -posted). -.VE -Not available for separator entries. -.TP -\fB\-font \fIvalue\fR -.VS -Specifies the font to use when drawing the label or accelerator -string in this entry. -If this option is specified as an empty string (the default) then -the \fBfont\fR option for the overall menu is used. -This option is not available for separator entries. -.VE -.TP -\fB\-label \fIvalue\fR -Specifies a string to display as an identifying label in the menu -entry. Not available for separator entries. -.TP -\fB\-menu \fIvalue\fR -Available only for cascade entries. Specifies the path name of -the menu associated with this entry. -.TP -\fB\-offvalue \fIvalue\fR -Available only for check-button entries. Specifies the value to -store in the entry's associated variable when the entry is -deselected. -.TP -\fB\-onvalue \fIvalue\fR -Available only for check-button entries. Specifies the value to -store in the entry's associated variable when the entry is selected. -.TP -\fB\-state \fIvalue\fR -.VS -Specifies one of three states for the entry: \fBnormal\fR, \fBactive\fR, -or \fBdisabled\fR. In normal state the entry is displayed using the -\fBforeground\fR option for the menu and the \fBbackground\fR -option from the entry or the menu. -The active state is typically used when the pointer is over the entry. -In active state the entry is displayed using the \fBactiveForeground\fR -option for the menu along with the \fBactivebackground\fR option from -the entry. -Disabled state means that the entry is insensitive: it doesn't activate -and doesn't respond to mouse button presses or releases. -In this state the entry is displayed according to the -\fBdisabledForeground\fR option for the menu and the -\fBbackground\fR option from the entry. -This option is not available for separator entries. -.TP -\fB\-underline \fIvalue\fR -Specifies the integer index of a character to underline in the entry. -This option is typically used to indicate keyboard traversal characters. -0 corresponds to the first character of the text displayed in the entry, -1 to the next character, and so on. -If a bitmap is displayed in the entry then this option is ignored. -This option is not available for separator entries. -.VE -.TP -\fB\-value \fIvalue\fR -Available only for radio-button entries. Specifies the value to -store in the entry's associated variable when the entry is selected. -.TP -\fB\-variable \fIvalue\fR -Available only for check-button and radio-button entries. Specifies -the name of a global value to set when the entry is selected. -For check-button entries the variable is also set when the entry -is deselected. For radio-button entries, changing the variable -causes the currently-selected entry to deselect itself. -.LP -The \fBadd\fR widget command returns an empty string. -.RE -.TP -\fIpathName \fBconfigure\fR ?\fIoption\fR? ?\fIvalue option value ...\fR? -Query or modify the configuration options of the widget. -If no \fIoption\fR is specified, returns a list describing all of -the available options for \fIpathName\fR (see \fBTk_ConfigureInfo\fR for -information on the format of this list). If \fIoption\fR is specified -with no \fIvalue\fR, then the command returns a list describing the -one named option (this list will be identical to the corresponding -sublist of the value returned if no \fIoption\fR is specified). If -one or more \fIoption\-value\fR pairs are specified, then the command -modifies the given widget option(s) to have the given value(s); in -this case the command returns an empty string. -\fIOption\fR may have any of the values accepted by the \fBmenu\fR -command. -.TP -\fIpathName \fBdelete \fIindex1\fR ?\fIindex2\fR? -Delete all of the menu entries between \fIindex1\fR and -.VS -\fIindex2\fR inclusive. -If \fIindex2\fR is omitted then it defaults to \fIindex1\fR. -.VE -Returns an empty string. -.TP -\fIpathName \fBdisable \fIindex\fR -.VS -Change the state of the entry given by \fIindex\fR to \fBdisabled\fR -and redisplay the entry using its disabled colors. -Returns an empty string. -This command is obsolete and will eventually be removed; -use ``\fIpathName \fBentryconfigure \fIindex\fR \-state disabled\fR'' instead. -.VE -.TP -\fIpathName \fBenable \fIindex\fR -.VS -Change the state of the entry given by \fIindex\fR to \fBnormal\fR -and redisplay the entry using its normal colors. -Returns an empty string. -This command is obsolete and will eventually be removed; -use ``\fIpathName \fBentryconfigure \fIindex\fR \-state normal\fR'' instead. -.VE -.TP -\fIpathName \fBentryconfigure \fIindex\fR \fR?\fIoptions\fR? -This command is similar to the \fBconfigure\fR command, except that -it applies to the options for an individual entry, whereas \fBconfigure\fR -applies to the options for the menu as a whole. -\fIOptions\fR may have any of the values accepted by the \fBadd\fR -widget command. If \fIoptions\fR are specified, options are modified -as indicated -in the command and the command returns an empty string. -If no \fIoptions\fR are specified, returns a list describing -the current options for entry \fIindex\fR (see \fBTk_ConfigureInfo\fR for -information on the format of this list). -.TP -\fIpathName \fBindex \fIindex\fR -Returns the numerical index corresponding to \fIindex\fR, or -\fBnone\fR if \fIindex\fR was specified as \fBnone\fR. -.TP -\fIpathName \fBinvoke \fIindex\fR -Invoke the action of the menu entry. See the sections on the -individual entries above for details on what happens. If the -menu entry is disabled then nothing happens. If the -entry has a command associated with it then the result of that -command is returned as the result of the \fBinvoke\fR widget -command. Otherwise the result is an empty string. Note: invoking -a menu entry does not automatically unpost the menu. Normally -the associated menubutton will take care of unposting the menu. -.TP -\fIpathName \fBpost \fIx y\fR -Arrange for the menu to be displayed on the screen at the root-window -coordinates given by \fIx\fR and \fIy\fR. These coordinates are -adjusted if necessary to guarantee that the entire menu is visible on -the screen. This command normally returns an empty string. -.VS -If the \fB\-postcommand\fR option has been specified, then its value is -executed as a Tcl script before posting the menu and the result of -that script is returned as the result of the \fBpost\fR widget -command. -If an error returns while executing the command, then the error is -returned without posting the menu. -.VE -.TP -\fIpathName \fBunpost\fR -Unmap the window so that it is no longer displayed. If a -lower-level cascaded menu is posted, unpost that menu. Returns an -empty string. -.TP -\fIpathName \fByposition \fIindex\fR -Returns a decimal string giving the y-coordinate within the menu -window of the topmost pixel in the entry specified by \fIindex\fR. - - -.SH "DEFAULT BINDINGS" -.PP -.VS -Tk automatically creates class bindings for menus that give them -the following default behavior: -.IP [1] -When the mouse cursor enters a menu, the entry underneath the mouse -cursor is activated; as the mouse moves around the menu, the active -entry changes to track the mouse. -.IP [2] -When button 1 is released over a menu, the active entry (if any) is invoked. -.IP [3] -A menu can be repositioned on the screen by dragging it with mouse -button 2. -.IP [4] -A number of other bindings are created to support keyboard menu traversal. -See the manual entry for \fBtk_bindForTraversal\fR for details on these -bindings. -.PP -Disabled menu entries are non-responsive: they don't activate and -ignore mouse button presses and releases. -.PP -The behavior of menus can be changed by defining new bindings for -individual widgets or by redefining the class bindings. -.VE - -.SH BUGS -.PP -.VS -At present it isn't possible to use the -option database to specify values for the options to individual -entries. -.VE - -.SH KEYWORDS -menu, widget diff --git a/tk3.6/doc/menubar.n b/tk3.6/doc/menubar.n deleted file mode 100644 index 47efb4e..0000000 --- a/tk3.6/doc/menubar.n +++ /dev/null @@ -1,152 +0,0 @@ -'\" -'\" Copyright (c) 1992 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/wish/man/RCS/menubar.n,v 1.4 93/09/04 17:03:40 ouster Exp $ SPRITE (Berkeley) -'/" -.so man.macros -.HS tk_menuBar tk -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -tk_menuBar, tk_bindForTraversal \- Support for menu bars -.SH SYNOPSIS -\fBtk_menuBar \fIframe \fR?\fImenu menu ...\fR? -.sp -\fBtk_bindForTraversal \fIarg arg ... \fR -.BE - -.SH DESCRIPTION -.PP -These two commands are Tcl procedures in the Tk script library. -They provide support for menu bars. -A menu bar is a frame that contains a collection of menu buttons that -work together, so that the user can scan from one menu to another with -the mouse: if the mouse button is pressed over one menubutton (causing it -to post its menu) and the mouse is moved over another menubutton -in the same menu bar without releasing the mouse button, then the -menu of the first menubutton is unposted and the menu of the -new menubutton is posted instead. -Menus in a menu bar can also be accessed using keyboard traversal (i.e. -by typing keystrokes instead of using the mouse). -In order for an application to use these procedures, it must do three -things, which are described in the paragraphs below. -.PP -First, each application must call \fBtk_menuBar\fR to provide information -about the menubar. -The \fIframe\fR argument gives the path name of the frame that contains -all of the menu buttons, and the \fImenu\fR arguments give path names -for all of the menu buttons associated with the menu bar. -Normally \fIframe\fR is the parent of each of the \fImenu\fR's. -This need not be the case, but \fIframe\fR must be an ancestor of -each of the \fImenu\fR's in order for grabs to work correctly when -the mouse is used to pull down menus. -The order of the \fImenu\fR arguments determines the traversal order -for the menu buttons. -If \fBtk_menuBar\fR is called without any \fImenu\fR arguments, it -returns a list containing the current menu buttons for \fIframe\fR, -or an empty string if \fIframe\fR isn't currently set up as a menu bar. -If \fBtk_menuBar\fR is called with a single \fImenu\fR argument -consisting of an empty string, any menubar information for \fIframe\fR -is removed; from now on the menu buttons will function independently -without keyboard traversal. -Only one menu bar may be defined at a time within each top-level window. -.PP -The second thing an application must do is to identify the traversal -characters for menu buttons and menu entries. -This is done by underlining those characters using the -\fB\-underline\fR options for the widgets. -The menu traversal system uses this information to traverse the -menus under keyboard control (see below). -.PP -The third thing that an application must do -is to make sure that the input focus is always in a window that -has been configured to support menu traversal. -If the input focus is \fBnone\fR then input characters will -be discarded and no menu traversal will be possible. -.VS -If you have no other place to set the focus, set it to the menubar -widget: \fBtk_menuBar\fR creates bindings for its \fIframe\fR argument to -support menu traversal. -.PP -The Tk startup scripts configure all the Tk widget classes with -bindings to support menu traversal, so menu traversal will be possible -regardless of which widget has the focus. -.VE -If your application defines new classes of widgets that support the -input focus, then you should call \fBtk_bindForTraversal\fR for -each of these classes. -\fBTk_bindForTraversal\fR takes any number of arguments, each of -which is a widget path name or widget class name. -It sets up bindings for all the named widgets and -classes so that the menu traversal system will be invoked when -appropriate keystrokes are typed in those widgets or classes. - -.SH "MENU TRAVERSAL BINDINGS" -.PP -Once an application has made the three arrangements described -above, menu traversal will be available. -At any given time, the only menus available for traversal -are those associated with the top-level window containing the -input focus. -Menu traversal is initiated by one of the following actions: -.IP [1] -If is typed, then the first menu button in the list for the -top-level window is posted and the first entry within that -menu is selected. -.IP [2] -If is pressed, then the menu button that has \fIkey\fR -as its underlined character is posted -and the first entry within that menu is selected. -The comparison between \fIkey\fR and the underlined characters -ignores case differences. -If no menu button matches \fIkey\fR then the keystroke has no -effect. -.IP [3] -Clicking mouse button 1 on a menu button posts that menu and selects -its first entry. -.PP -Once a menu has been posted, the input focus is switched to that -menu and the following actions are possible: -.IP [1] -Typing or clicking mouse button 1 outside the menu button or -its menu will abort the menu traversal. -.IP [2] -If is pressed, then the entry in the posted menu -whose underlined character is \fIkey\fR is invoked. -This causes the menu to be unposted, the entry's action to be -taken, and the menu traversal to end. -The comparison between \fIkey\fR and underlined characters ignores -case differences. -If no menu entry matches \fIkey\fR then the keystroke is ignored. -.IP [3] -The arrow keys may be used to move among entries and menus. -The left and right arrow keys move circularly among the available -menus and the up and down arrow keys move circularly among the -entries in the current menu. -.IP [4] -If is pressed, the selected entry in the posted menu is -invoked, which causes the menu to be unposted, the entry's action -to be taken, and the menu traversal to end. -.PP -When a menu traversal completes, the input focus reverts to the -window that contained it when the traversal started. - -.SH KEYWORDS -keyboard traversal, menu, menu bar, post diff --git a/tk3.6/doc/menubutton.n b/tk3.6/doc/menubutton.n deleted file mode 100644 index 13c16d4..0000000 --- a/tk3.6/doc/menubutton.n +++ /dev/null @@ -1,235 +0,0 @@ -'\" -'\" Copyright (c) 1990-1992 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/wish/man/RCS/menubutton.n,v 1.15 93/04/01 09:52:46 ouster Exp $ SPRITE (Berkeley) -'/" -.so man.macros -.HS menubutton tk -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -menubutton \- Create and manipulate menubutton widgets -.SH SYNOPSIS -\fBmenubutton\fI \fIpathName \fR?\fIoptions\fR? -.SH "STANDARD OPTIONS" -.LP -.nf -.VS -.ta 4c 8c 12c -\fBactiveBackground\fR \fBbitmap\fR \fBfont\fR \fBrelief\fR -\fBactiveForeground\fR \fBborderWidth\fR \fBforeground\fR \fBtext\fR -\fBanchor\fR \fBcursor\fR \fBpadX\fR \fBtextVariable\fR -\fBbackground\fR \fBdisabledForeground\fR \fBpadY\fR \fBunderline\fR -.VE -.fi -.LP -See the ``options'' manual entry for details on the standard options. -.SH "WIDGET-SPECIFIC OPTIONS" -.ta 4c -.LP -.nf -.VS -Name: \fBheight\fR -Class: \fBHeight\fR -Command-Line Switch: \fB\-height\fR -.fi -.IP -Specifies a desired height for the menu button. -If a bitmap is being displayed in the menu button then the value is in -screen units (i.e. any of the forms acceptable to \fBTk_GetPixels\fR); -for text it is in lines of text. -If this option isn't specified, the menu button's desired height is computed -from the size of the bitmap or text being displayed in it. -.VE -.LP -.nf -Name: \fBmenu\fR -Class: \fBMenuName\fR -Command-Line Switch: \fB\-menu\fR -.fi -.IP -Specifies the path name of the menu associated with this menubutton. -.VS -The menu must be a descendant of the menubutton in order for normal pull-down -operation to work via the mouse. -.VE -.LP -.nf -Name: \fBstate\fR -Class: \fBState\fR -Command-Line Switch: \fB\-state\fR -.fi -.IP -Specifies one of three states for the menu button: \fBnormal\fR, \fBactive\fR, -or \fBdisabled\fR. In normal state the menu button is displayed using the -\fBforeground\fR and \fBbackground\fR options. The active state is -typically used when the pointer is over the menu button. In active state -the menu button is displayed using the \fBactiveForeground\fR and -\fBactiveBackground\fR options. Disabled state means that the menu button -is insensitive: it doesn't activate and doesn't respond to mouse -button presses. In this state the \fBdisabledForeground\fR and -\fBbackground\fR options determine how the button is displayed. -.LP -.nf -.VS -Name: \fBwidth\fR -Class: \fBWidth\fR -Command-Line Switch: \fB\-width\fR -.fi -.IP -Specifies a desired width for the menu button. -If a bitmap is being displayed in the menu button then the value is in -screen units (i.e. any of the forms acceptable to \fBTk_GetPixels\fR); -for text it is in characters. -If this option isn't specified, the menu button's desired width is computed -from the size of the bitmap or text being displayed in it. -.VE -.BE - -.SH INTRODUCTION -.PP -The \fBmenubutton\fR command creates a new window (given by the -\fIpathName\fR argument) and makes it into a menubutton widget. -Additional -options, described above, may be specified on the command line -or in the option database -to configure aspects of the menubutton such as its colors, font, -text, and initial relief. The \fBmenubutton\fR command returns its -\fIpathName\fR argument. At the time this command is invoked, -there must not exist a window named \fIpathName\fR, but -\fIpathName\fR's parent must exist. -.PP -A menubutton is a widget that displays a -.VS -textual string or bitmap -.VE -and is associated with a menu widget. In normal usage, pressing -mouse button 1 over the menubutton causes the associated menu to -be posted just underneath the menubutton. If the mouse is moved over -the menu before releasing the mouse button, the button release -causes the underlying menu entry to be invoked. When the button -is released, the menu is unposted. -.PP -.VS -Menubuttons are typically organized into groups called menu bars -that allow scanning: -if the mouse button is pressed over one menubutton (causing it -to post its menu) and the mouse is moved over another menubutton -in the same menu bar without releasing the mouse button, then the -menu of the first menubutton is unposted and the menu of the -new menubutton is posted instead. -The \fBtk_menuBar\fR procedure is used to set up menu bars for -scanning; see that procedure for more details. -.VE - -.SH "WIDGET COMMAND" -.PP -The \fBmenubutton\fR command creates a new Tcl command whose -name is \fIpathName\fR. This -command may be used to invoke various -operations on the widget. It has the following general form: -.DS C -\fIpathName option \fR?\fIarg arg ...\fR? -.DE -\fIOption\fR and the \fIarg\fRs -determine the exact behavior of the command. The following -commands are possible for menubutton widgets: -.TP -\fIpathName \fBactivate\fR -Change the menu button's state to \fBactive\fR and redisplay the menu -button using its active foreground and background colors instead of normal -colors. -The command returns an empty string. -.VS -This command is ignored if the menu button's state is \fBdisabled\fR. -This command is obsolete and will eventually be removed; -use ``\fIpathName \fBconfigure \-state active\fR'' instead. -.VE -.TP -\fIpathName \fBconfigure\fR ?\fIoption\fR? ?\fIvalue option value ...\fR? -Query or modify the configuration options of the widget. -If no \fIoption\fR is specified, returns a list describing all of -the available options for \fIpathName\fR (see \fBTk_ConfigureInfo\fR for -information on the format of this list). If \fIoption\fR is specified -with no \fIvalue\fR, then the command returns a list describing the -one named option (this list will be identical to the corresponding -sublist of the value returned if no \fIoption\fR is specified). If -one or more \fIoption\-value\fR pairs are specified, then the command -modifies the given widget option(s) to have the given value(s); in -this case the command returns an empty string. -\fIOption\fR may have any of the values accepted by the \fBmenubutton\fR -command. -.TP -\fIpathName \fBdeactivate\fR -Change the menu button's state to \fBnormal\fR and redisplay the menu -button using its normal foreground and background colors. -The command returns an empty string. -.VS -This command is ignored if the menu button's state is \fBdisabled\fR. -This command is obsolete and will eventually be removed; -use ``\fIpathName \fBconfigure \-state normal\fR'' instead. -.VE - -.SH "DEFAULT BINDINGS" -.PP -.VS -Tk automatically creates class bindings for menu buttons that give them -the following default behavior: -.IP [1] -A menu button activates whenever the mouse passes over it and deactivates -whenever the mouse leaves it. -.IP [2] -A menu button's relief is changed to raised whenever mouse button 1 is -pressed over it, and the relief is restored to its original value -when button 1 is later released or the mouse is dragged into another -menu button in the same menu bar. -.IP [3] -When mouse button 1 is pressed over a menu button, or when the mouse -is dragged into a menu button with mouse button 1 pressed, the associated -menu is posted; the mouse can be dragged across the menu and released -over an entry in the menu to invoke that entry. The menu is unposted -when button 1 is released outside either the menu or the menu button. -The menu is also unposted when the mouse is dragged into another -menu button in the same menu bar. -.IP [4] -If mouse button 1 is pressed and released within the menu button, -then the menu stays posted and keyboard traversal is possible as -described in the manual entry for \fBtk_menuBar\fR. -.IP [5] -Menubuttons may also be posted by typing characters on the keyboard. -See the manual entry for \fBtk_menuBar\fR for full details on keyboard -menu traversal. -.IP [6] -If mouse button 2 is pressed over a menu button then the associated -menu is posted and also \fItorn off\fR: it can then be dragged around on -the screen with button 2 and the menu will not automatically unpost when -entries in it are invoked. -To close a torn off menu, click mouse button 1 over the associated -menu button. -.PP -If the menu button's state is \fBdisabled\fR then none of the above -actions occur: the menu button is completely non-responsive. -.PP -The behavior of menu buttons can be changed by defining new bindings for -individual widgets or by redefining the class bindings. -.VE - -.SH KEYWORDS -menubutton, widget diff --git a/tk3.6/doc/radiobutton.n b/tk3.6/doc/radiobutton.n deleted file mode 100644 index d24d221..0000000 --- a/tk3.6/doc/radiobutton.n +++ /dev/null @@ -1,285 +0,0 @@ -'\" -'\" Copyright (c) 1990 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/wish/man/RCS/radiobutton.n,v 1.21 93/04/01 09:52:52 ouster Exp $ SPRITE (Berkeley) -'/" -.so man.macros -.HS radiobutton tk -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -radiobutton \- Create and manipulate radio-button widgets -.SH SYNOPSIS -\fBradiobutton\fI \fIpathName \fR?\fIoptions\fR? -.SH "STANDARD OPTIONS" -.LP -.nf -.ta 4c 8c 12c -.VS -\fBactiveBackground\fR \fBbitmap\fR \fBfont\fR \fBrelief\fR -\fBactiveForeground\fR \fBborderWidth\fR \fBforeground\fR \fBtext\fR -\fBanchor\fR \fBcursor\fR \fBpadX\fR \fBtextVariable\fR -\fBbackground\fR \fBdisabledForeground\fR \fBpadX\fR -.VE -.fi -.LP -See the ``options'' manual entry for details on the standard options. -.SH "WIDGET-SPECIFIC OPTIONS" -.ta 4c -.LP -.nf -Name: \fBcommand\fR -Class: \fBCommand\fR -Command-Line Switch: \fB\-command\fR -.fi -.IP -Specifies a Tcl command to associate with the button. This command -is typically invoked when mouse button 1 is released over the button -window. The button's global variable (\fB\-variable\fR option) will -be updated before the command is invoked. -.LP -.nf -.VS -Name: \fBheight\fR -Class: \fBHeight\fR -Command-Line Switch: \fB\-height\fR -.fi -.IP -Specifies a desired height for the button. -If a bitmap is being displayed in the button then the value is in -screen units (i.e. any of the forms acceptable to \fBTk_GetPixels\fR); -for text it is in lines of text. -If this option isn't specified, the button's desired height is computed -from the size of the bitmap or text being displayed in it. -.VE -.LP -.nf -Name: \fBselector\fR -Class: \fBForeground\fR -Command-Line Switch: \fB\-selector\fR -.fi -.IP -Specifies the color to draw in the selector when this button is -selected. -.VS -If specified as an empty string then no selector is drawn for the button. -.LP -.nf -Name: \fBstate\fR -Class: \fBState\fR -Command-Line Switch: \fB\-state\fR -.fi -.IP -Specifies one of three states for the radio button: \fBnormal\fR, \fBactive\fR, -or \fBdisabled\fR. In normal state the radio button is displayed using the -\fBforeground\fR and \fBbackground\fR options. The active state is -typically used when the pointer is over the radio button. In active state -the radio button is displayed using the \fBactiveForeground\fR and -\fBactiveBackground\fR options. Disabled state means that the radio button -is insensitive: it doesn't activate and doesn't respond to mouse -button presses. In this state the \fBdisabledForeground\fR and -\fBbackground\fR options determine how the radio button is displayed. -.VE -.LP -.nf -Name: \fBvalue\fR -Class: \fBValue\fR -Command-Line Switch: \fB\-value\fR -.fi -.IP -Specifies value to store in the button's associated variable whenever -this button is selected. Defaults to the name of the radio button. -.LP -.nf -Name: \fBvariable\fR -Class: \fBVariable\fR -Command-Line Switch: \fB\-variable\fR -.fi -.IP -Specifies name of global variable to set whenever this button is -selected. Changes in this variable also cause the button to select -or deselect itself. -Defaults to the value \fBselectedButton\fR. -.LP -.nf -.VS -Name: \fBwidth\fR -Class: \fBWidth\fR -Command-Line Switch: \fB\-width\fR -.fi -.IP -Specifies a desired width for the button. -If a bitmap is being displayed in the button then the value is in -screen units (i.e. any of the forms acceptable to \fBTk_GetPixels\fR); -for text it is in characters. -If this option isn't specified, the button's desired width is computed -from the size of the bitmap or text being displayed in it. -.VE -.BE - -.SH DESCRIPTION -.PP -The \fBradiobutton\fR command creates a new window (given by the -\fIpathName\fR argument) and makes it into a radiobutton widget. -Additional -options, described above, may be specified on the command line -or in the option database -to configure aspects of the radio button such as its colors, font, -text, and initial relief. The \fBradiobutton\fR command returns its -\fIpathName\fR argument. At the time this command is invoked, -there must not exist a window named \fIpathName\fR, but -\fIpathName\fR's parent must exist. -.PP -A radio button is a widget -.VS -that displays a textual string or bitmap -and a diamond called a \fIselector\fR. -A radio button has -all of the behavior of a simple button: it can display itself in either -of three different ways, according to the \fBstate\fR option; -.VE -it can be made to appear -raised, sunken, or flat; it can be made to flash; and it invokes -a Tcl command whenever mouse button 1 is clicked over the -check button. -.PP -In addition, radio buttons can be \fIselected\fR. -If a radio button is selected then a special highlight appears -in the selector and a Tcl variable associated with the radio button -is set to a particular value. -If the radio button is not selected then the selector is drawn -in a different fashion. -Typically, several radio buttons share a single variable and the -value of the variable indicates which radio button is to be selected. -.VS -When a radio button is selected it sets the value of the variable to -indicate that fact; each radio button also monitors the value of -the variable and automatically selects and deselects itself when the -variable's value changes. -.VE -By default the variable \fBselectedButton\fR -is used; its contents give the name of the button that is -selected, or the empty string if no button associated with that -variable is selected. -The name of the variable for a radio button, -plus the variable to be stored into it, may be modified with options -on the command line or in the option database. By default a radio -button is configured to select itself on button clicks. - -.SH "WIDGET COMMAND" -.PP -The \fBradiobutton\fR command creates a new Tcl command whose -name is \fIpathName\fR. This -command may be used to invoke various -operations on the widget. It has the following general form: -.DS C -\fIpathName option \fR?\fIarg arg ...\fR? -.DE -\fIOption\fR and the \fIarg\fRs -determine the exact behavior of the command. The following -commands are possible for radio-button widgets: -.TP -\fIpathName \fBactivate\fR -Change the radio button's state to \fBactive\fR and redisplay the button -using its active foreground and background colors instead of normal -colors. -.VS -This command is ignored if the radio button's state is \fBdisabled\fR. -This command is obsolete and will eventually be removed; -use ``\fIpathName \fBconfigure \-state active\fR'' instead. -.TP -\fIpathName \fBconfigure\fR ?\fIoption\fR? ?\fIvalue option value ...\fR? -Query or modify the configuration options of the widget. -If no \fIoption\fR is specified, returns a list describing all of -the available options for \fIpathName\fR (see \fBTk_ConfigureInfo\fR for -information on the format of this list). If \fIoption\fR is specified -with no \fIvalue\fR, then the command returns a list describing the -one named option (this list will be identical to the corresponding -sublist of the value returned if no \fIoption\fR is specified). If -one or more \fIoption\-value\fR pairs are specified, then the command -modifies the given widget option(s) to have the given value(s); in -this case the command returns an empty string. -\fIOption\fR may have any of the values accepted by the \fBradiobutton\fR -command. -.TP -\fIpathName \fBdeactivate\fR -Change the radio button's state to \fBnormal\fR and redisplay the button -using its normal foreground and background colors. -.VS -This command is ignored if the radio button's state is \fBdisabled\fR. -This command is obsolete and will eventually be removed; -use ``\fIpathName \fBconfigure \-state normal\fR'' instead. -.VE -.TP -\fIpathName \fBdeselect\fR -Deselect the radio button: redisplay it without a highlight in -the selector and set the associated variable to an empty string. If -this radio button was not currently selected, then the command has -no effect. -.TP -\fIpathName \fBflash\fR -Flash the radio button. This is accomplished by redisplaying the radio button -several times, alternating between active and normal colors. At -the end of the flash the radio button is left in the same normal/active -state as when the command was invoked. -.VS -This command is ignored if the radio button's state is \fBdisabled\fR. -.VE -.TP -\fIpathName \fBinvoke\fR -.VS -Does just what would have happened if the user invoked the radio button -with the mouse: select the button and invoke -its associated Tcl command, if there is one. -The return value is the return value from the Tcl command, or an -empty string if there is no command associated with the radio button. -This command is ignored if the radio button's state is \fBdisabled\fR. -.VE -.TP -\fIpathName \fBselect\fR -Select the radio button: display it with a highlighted -selector and set the associated variable to the value corresponding -to this widget. - -.SH BINDINGS -.PP -.VS -Tk automatically creates class bindings for radio buttons that give them -the following default behavior: -.IP [1] -The radio button activates whenever the mouse passes over it and deactivates -whenever the mouse leaves the radio button. -.IP [2] -The radio button's relief is changed to sunken whenever mouse button 1 is -pressed over it, and the relief is restored to its original -value when button 1 is later released. -.IP [3] -If mouse button 1 is pressed over the radio button and later released over -the radio button, the radio button is invoked (i.e. it is selected -and the command associated with the button is invoked, -if there is one). However, if the mouse is not -over the radio button when button 1 is released, then no invocation occurs. -.PP -The behavior of radio buttons can be changed by defining new bindings for -individual widgets or by redefining the class bindings. -.VE - -.SH KEYWORDS -radio button, widget diff --git a/tk3.6/doc/raise.n b/tk3.6/doc/raise.n deleted file mode 100644 index 97615a1..0000000 --- a/tk3.6/doc/raise.n +++ /dev/null @@ -1,48 +0,0 @@ -'\" -'\" Copyright (c) 1990 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/wish/man/RCS/raise.n,v 1.2 93/07/07 16:27:38 ouster Exp $ SPRITE (Berkeley) -'/" -.so man.macros -.HS raise tk 3.3 -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -raise \- Change a window's position in the stacking order -.SH SYNOPSIS -\fBraise \fIwindow \fR?\fIaboveThis\fR? -.BE - -.SH DESCRIPTION -.PP -If the \fIaboveThis\fR argument is omitted then the command raises -\fIwindow\fR so that it is above all of its siblings in the stacking -order (it will not be obscured by any siblings and will obscure -any siblings that overlap it). -If \fIaboveThis\fR is specified then it must be the path name of -a window that is either a sibling of \fIwindow\fR or the descendant -of a sibling of \fIwindow\fR. -In this case the \fBraise\fR command will insert -\fIwindow\fR into the stacking order just above \fIaboveThis\fR -(or the ancestor of \fIaboveThis\fR that is a sibling of \fIwindow\fR); -this could end up either raising or lowering \fIwindow\fR. - -.SH KEYWORDS -obscure, raise, stacking order diff --git a/tk3.6/doc/scale.n b/tk3.6/doc/scale.n deleted file mode 100644 index 042a213..0000000 --- a/tk3.6/doc/scale.n +++ /dev/null @@ -1,259 +0,0 @@ -'\" -'\" Copyright (c) 1990 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/wish/man/RCS/scale.n,v 1.10 93/04/01 09:52:53 ouster Exp $ SPRITE (Berkeley) -'/" -.so man.macros -.HS scale tk -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -scale \- Create and manipulate scale widgets -.SH SYNOPSIS -\fBscale\fI \fIpathName \fR?\fIoptions\fR? -.SH "STANDARD OPTIONS" -.LP -.nf -.ta 4c 8c 12c -.VS -\fBactiveForeground\fR \fBborderWidth\fR \fBfont\fR \fBorient\fR -\fBbackground\fR \fBcursor\fR \fBforeground\fR \fBrelief\fR -.VE -.fi -.LP -See the ``options'' manual entry for details on the standard options. -.SH "WIDGET-SPECIFIC OPTIONS" -.ta 4c -.LP -.nf -Name: \fBcommand\fR -Class: \fBCommand\fR -Command-Line Switch: \fB\-command\fR -.fi -.IP -Specifies the prefix of a Tcl command to invoke whenever the value of -the scale is changed interactively. The actual command consists -of this option followed by -a space and a number. The number indicates the new value of the -scale. -.LP -.nf -Name: \fBfrom\fR -Class: \fBFrom\fR -Command-Line Switch: \fB\-from\fR -.fi -.IP -Specifies the value corresponding to the left or top end of the -scale. Must be an integer. -.LP -.nf -Name: \fBlabel\fR -Class: \fBLabel\fR -Command-Line Switch: \fB\-label\fR -.fi -.IP -Specifies a string to displayed as a label for the scale. For -vertical scales the label is displayed just to the right of the -top end of the scale. For horizontal scales the label is displayed -just above the left end of the scale. -.LP -.nf -Name: \fBlength\fR -Class: \fBLength\fR -Command-Line Switch: \fB\-length\fR -.fi -.IP -.VS -Specifies the desired long dimension of the scale in screen units -(i.e. any of the forms acceptable to \fBTk_GetPixels\fR). -.VE -For vertical scales this is the scale's height; for horizontal scales -it is the scale's width. -.LP -.nf -Name: \fBshowValue\fR -Class: \fBShowValue\fR -Command-Line Switch: \fB\-showvalue\fR -.fi -.IP -Specifies a boolean value indicating whether or not the current -value of the scale is to be displayed. -.LP -.nf -Name: \fBsliderForeground\fR -Class: \fBsliderForeground\fR -Command-Line Switch: \fB\-sliderforeground\fR -.fi -.IP -Specifies the color to use for drawing the slider under normal conditions. -When the mouse is in the slider window then the slider's color is -determined by the \fBactiveForeground\fR option. -.LP -.nf -Name: \fBsliderLength\fR -Class: \fBSliderLength\fR -Command-Line Switch: \fB\-sliderlength\fR -.fi -.IP -.VS -Specfies the size of the slider, measured in screen units along the slider's -long dimension. The value may be specified in any of the forms acceptable -to \fBTk_GetPixels\fR. -.LP -.nf -.VS -Name: \fBstate\fR -Class: \fBState\fR -Command-Line Switch: \fB\-state\fR -.fi -.IP -Specifies one of two states for the scale: \fBnormal\fR or \fBdisabled\fR. -If the scale is disabled then the value may not be changed and the scale -won't activate when the mouse enters it. -.VE -.LP -.nf -Name: \fBtickInterval\fR -Class: \fBTickInterval\fR -Command-Line Switch: \fB\-tickinterval\fR -.fi -.IP -Must be an integer value. Determines the spacing between numerical -tick-marks displayed below or to the left of the slider. If specified -as 0, then no tick-marks will be displayed. -.LP -.nf -Name: \fBto\fR -Class: \fBTo\fR -Command-Line Switch: \fB\-to\fR -.fi -.IP -Specifies the value corresponding to the right or bottom end of the -scale. Must be an integer. This value may be either less than or -greater than the \fBfrom\fR option. -.LP -.nf -Name: \fBwidth\fR -Class: \fBWidth\fR -Command-Line Switch: \fB\-width\fR -.fi -.IP -.VS -Specifies the desired narrow dimension of the scale in screen units -(i.e. any of the forms acceptable to \fBTk_GetPixels\fR). -.VE -For vertical scales this is the scale's width; for horizontal scales -this is the scale's height. -.BE - -.SH DESCRIPTION -.PP -The \fBscale\fR command creates a new window (given by the -\fIpathName\fR argument) and makes it into a scale widget. -Additional -options, described above, may be specified on the command line -or in the option database -to configure aspects of the scale such as its colors, orientation, -and relief. The \fBscale\fR command returns its -\fIpathName\fR argument. At the time this command is invoked, -there must not exist a window named \fIpathName\fR, but -\fIpathName\fR's parent must exist. -.PP -A scale is a widget that displays a rectangular region and a -small \fIslider\fR. The rectangular region corresponds to a range -of integer values (determined by the \fBfrom\fR and \fBto\fR options), -and the position of the slider selects a particular integer value. -The slider's position (and hence the scale's value) may be adjusted -by clicking or dragging with the mouse as described in the BINDINGS -section below. Whenever the scale's value is changed, a Tcl -command is invoked (using the \fBcommand\fR option) to notify -other interested widgets of the change. -.PP -Three annotations may be displayed in a scale widget: a label -appearing at the top-left of the widget (top-right for vertical -scales), a number displayed just underneath the slider -(just to the left of the slider for vertical scales), and a collection -of numerical tick-marks just underneath the current value (just to the left of -the current value for vertical scales). Each of these three -annotations may be selectively enabled or disabled using the -configuration options. - -.SH "WIDGET COMMAND" -.PP -The \fBscale\fR command creates a new Tcl command whose -name is \fIpathName\fR. This -command may be used to invoke various -operations on the widget. It has the following general form: -.DS C -\fIpathName option \fR?\fIarg arg ...\fR? -.DE -\fIOption\fR and the \fIarg\fRs -determine the exact behavior of the command. The following -commands are possible for scale widgets: -.TP -\fIpathName \fBconfigure\fR ?\fIoption\fR? ?\fIvalue option value ...\fR? -Query or modify the configuration options of the widget. -If no \fIoption\fR is specified, returns a list describing all of -the available options for \fIpathName\fR (see \fBTk_ConfigureInfo\fR for -information on the format of this list). If \fIoption\fR is specified -with no \fIvalue\fR, then the command returns a list describing the -one named option (this list will be identical to the corresponding -sublist of the value returned if no \fIoption\fR is specified). If -one or more \fIoption\-value\fR pairs are specified, then the command -modifies the given widget option(s) to have the given value(s); in -this case the command returns an empty string. -\fIOption\fR may have any of the values accepted by the \fBscale\fR -command. -.TP -\fIpathName \fBget\fR -Returns a decimal string giving the current value of the scale. -.TP -\fIpathName \fBset\fR \fIvalue\fR -This command is invoked to change the current value of the scale, -and hence the position at which the slider is displayed. \fIValue\fR -gives the new value for the scale. - -.SH BINDINGS -.PP -When a new scale is created, it is given the following initial -behavior by default: -.TP 20 -\fB\fR -Change the slider display to use \fBactiveForeground\fR instead of -\fBsliderForeground\fR. -.TP 20 -\fB\fR -Reset the slider display to use \fBsliderForeground\fR instead of -\fBactiveForeground\fR. -.TP 20 -\fB\fR -Change the slider display so that the slider appears sunken rather -than raised. Move the slider (and adjust the scale's value) -to correspond to the current mouse position. -.TP 20 -\fB\fR -Move the slider (and adjust the scale's value) to correspond to -the current mouse position. -.TP 20 -\fB\fR -Reset the slider display so that the slider appears raised again. - -.SH KEYWORDS -scale, widget diff --git a/tk3.6/doc/scrollbar.n b/tk3.6/doc/scrollbar.n deleted file mode 100644 index 5062a23..0000000 --- a/tk3.6/doc/scrollbar.n +++ /dev/null @@ -1,202 +0,0 @@ -'\" -'\" Copyright (c) 1990 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/wish/man/RCS/scrollbar.n,v 1.10 93/04/01 09:52:54 ouster Exp $ SPRITE (Berkeley) -'/" -.so man.macros -.HS scrollbar tk -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -scrollbar \- Create and manipulate scrollbar widgets -.SH SYNOPSIS -\fBscrollbar\fI pathName \fR?\fIoptions\fR? -.SH "STANDARD OPTIONS" -.LP -.nf -.ta 4c 8c 12c -.VS -\fBactiveForeground\fR \fBcursor\fR \fBrelief\fR -.VE -\fBbackground\fR \fBforeground\fR \fBrepeatDelay\fR -\fBborderWidth\fR \fBorient\fR \fBrepeatInterval\fR -.fi -.LP -See the ``options'' manual entry for details on the standard options. -.SH "WIDGET-SPECIFIC OPTIONS" -.ta 4c -.LP -.nf -Name: \fBcommand\fR -Class: \fBCommand\fR -Command-Line Switch: \fB\-command\fR -.fi -.IP -Specifies the prefix of a Tcl command to invoke to change the view -in the widget associated with the scrollbar. When a user requests -a view change by manipulating the scrollbar, a Tcl command is -invoked. The actual command consists of this option followed by -a space and a number. The number indicates the logical unit that -should appear at the top of the associated window. -.LP -.nf -Name: \fBwidth\fR -Class: \fBWidth\fR -Command-Line Switch: \fB\-width\fR -.fi -.IP -Specifies the desired narrow dimension of the scrollbar window, -not including 3-D border, if any. For vertical -scrollbars this will be the width and for horizontal scrollbars -this will be the height. -.VS -The value may have any of the forms acceptable to \fBTk_GetPixels\fR. -.VE -.BE - -.SH DESCRIPTION -.PP -The \fBscrollbar\fR command creates a new window (given by the -\fIpathName\fR argument) and makes it into a scrollbar widget. -Additional -options, described above, may be specified on the command line -or in the option database -to configure aspects of the scrollbar such as its colors, orientation, -and relief. The \fBscrollbar\fR command returns its -\fIpathName\fR argument. At the time this command is invoked, -there must not exist a window named \fIpathName\fR, but -\fIpathName\fR's parent must exist. -.PP -A scrollbar is a widget that displays two arrows, one at each end of -the scrollbar, and a \fIslider\fR in the middle portion of the -scrollbar. A scrollbar is used to provide information about what -is visible in an \fIassociated window\fR that displays an object -of some sort (such as a file being edited or a drawing). -The position and size of the slider indicate which portion of the -object is visible in the associated window. For example, if the -slider in a vertical scrollbar covers the top third of the area -between the two arrows, it means that the associated window displays -the top third of its object. -.PP -Scrollbars can be used to adjust the view in the associated window -by clicking or dragging with the mouse. See the BINDINGS section -below for details. - -.SH "WIDGET COMMAND" -.PP -The \fBscrollbar\fR command creates a new Tcl command whose -name is \fIpathName\fR. This -command may be used to invoke various -operations on the widget. It has the following general form: -.DS C -\fIpathName option \fR?\fIarg arg ...\fR? -.DE -\fIOption\fR and the \fIarg\fRs -determine the exact behavior of the command. The following -commands are possible for scrollbar widgets: -.TP -\fIpathName \fBconfigure\fR ?\fIoption\fR? ?\fIvalue option value ...\fR? -Query or modify the configuration options of the widget. -If no \fIoption\fR is specified, returns a list describing all of -the available options for \fIpathName\fR (see \fBTk_ConfigureInfo\fR for -information on the format of this list). If \fIoption\fR is specified -with no \fIvalue\fR, then the command returns a list describing the -one named option (this list will be identical to the corresponding -sublist of the value returned if no \fIoption\fR is specified). If -one or more \fIoption\-value\fR pairs are specified, then the command -modifies the given widget option(s) to have the given value(s); in -this case the command returns an empty string. -\fIOption\fR may have any of the values accepted by the \fBscrollbar\fR -command. -.TP -\fIpathName \fBget\fR -Returns a Tcl list containing four decimal values, which are -the current \fItotalUnits\fR, \fIwidnowUnits\fR, \fIfirstUnit\fR, -and \fIlastUnit\fR values for the scrollbar. These are the values -from the most recent \fBset\fR widget command on the scrollbar. -.TP -\fIpathName \fBset\fR \fItotalUnits windowUnits firstUnit lastUnit\fR -This command is invoked to give the scrollbar information about the -widget associated with the scrollbar. \fITotalUnits\fR is an integer -value giving the total size of the object being displayed in the -associated widget. The meaning of one unit depends on the associated -widget; for example, in a text editor widget units might -correspond to lines of -text. \fIWindowUnits\fR indicates the total number of units that -can fit in the associated window at one time. \fIFirstUnit\fR -and \fIlastUnit\fR give the indices of the first and last units -currently visible in the associated window (zero corresponds to the -first unit of the object). This command should -be invoked by the associated widget whenever its object or window -changes size and whenever it changes the view in its window. - -.SH BINDINGS -.PP -The description below assumes a vertically-oriented scrollbar. -For a horizontally-oriented scrollbar replace the words ``up'', ``down'', -``top'', and ``bottom'' with ``left'', ``right'', ``left'', -and ``right'', respectively -.PP -A scrollbar widget is divided into five distinct areas. From top -to bottom, they are: the top arrow, the top gap (the empty space -between the arrow and the slider), the slider, the bottom gap, -and the bottom arrow. Pressing mouse button 1 in each area has -a different effect: -.TP 20 -\fBtop arrow\fR -Causes the view in the associated window to shift up by one unit -(i.e. the object appears to move down one unit in its window). -If the button is held down the action will auto-repeat. -.TP 20 -\fBtop gap\fR -Causes the view in the associated window to shift up by one -less than the number of units in the window -(i.e. the portion of the object that used to appear at the very -top of the window will now appear at the very bottom). -If the button is held down the action will auto-repeat. -.TP 20 -\fBslider\fR -Pressing button 1 in this area has no immediate effect except to -cause the slider to appear sunken rather than raised. However, -if the mouse is moved with the button down then the slider will -be dragged, adjusting the view as the mouse is moved. -.TP 20 -\fBbottom gap\fR -Causes the view in the associated window to shift down by one -less than the number of units in the window -(i.e. the portion of the object that used to appear at the very -bottom of the window will now appear at the very top). -If the button is held down the action will auto-repeat. -.TP 20 -\fBbottom arrow\fR -Causes the view in the associated window to shift down by one unit -(i.e. the object appears to move up one unit in its window). -If the button is held down the action will auto-repeat. -.PP -Note: none of the actions described above has an immediate impact -on the position of the slider in the scrollbar. It simply invokes -the command specified in the \fBcommand\fR option to notify the -associated widget that a change in view is desired. If the view is -actually changed then the associated widget must invoke the -scrollbar's \fBset\fR widget command to change what is displayed in -the scrollbar. - -.SH KEYWORDS -scrollbar, widget diff --git a/tk3.6/doc/selection.n b/tk3.6/doc/selection.n deleted file mode 100644 index 60c805d..0000000 --- a/tk3.6/doc/selection.n +++ /dev/null @@ -1,139 +0,0 @@ -'\" -'\" Copyright (c) 1990-1992 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/wish/man/RCS/selection.n,v 1.8 93/04/01 09:52:55 ouster Exp $ SPRITE (Berkeley) -'/" -.so man.macros -.HS selection tk -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -selection \- Manipulate the X selection -.SH SYNOPSIS -\fBselection \fIoption\fR ?\fIarg arg ...\fR? -.BE - -.SH DESCRIPTION -.PP -This command provides a Tcl interface to the X selection mechanism and -implements the full selection functionality described in the -X Inter-Client Communication Conventions Manual (ICCCM), except that it -supports only the primary selection. -.PP -The first argument to \fBselection\fR determines the format of the -rest of the arguments and the behavior of the command. The following -forms are currently supported: -.TP -\fBselection clear \fIwindow\fR -.VS -If there is a selection anywhere on \fIwindow\fR's display, clear it -so that no window owns the selection anymore. Returns an empty string. -.VE -.TP -\fBselection get \fR?\fItype\fR? -Retrieves the value -of the primary selection and returns it as a result. -\fBType\fR specifies the form in which the selection is to be -returned (the desired ``target'' for conversion, in ICCCM -terminology), and should be an -atom name such as STRING or FILE_NAME; see the Inter-Client -Communication Conventions Manual for complete details. -\fBType\fR defaults to STRING. The selection owner may choose to -return the selection in any of several different representation -formats, such as STRING, ATOM, INTEGER, etc. (this format is -different than the selection type; see the ICCCM for all the -confusing details). If the selection is returned in -a non-string format, such as INTEGER or ATOM, the \fBselection\fR -command converts it to string format as a collection of fields -separated by spaces: atoms are converted to their -textual names, and anything else is converted to hexadecimal -integers. -.TP -\fBselection handle \fIwindow command \fR?\fItype\fR? ?\fIformat\fR? -Creates a handler for selection requests, such that \fIcommand\fR will -be executed whenever the primary selection is -owned by \fIwindow\fR and someone attempts to retrieve it in the form -given by \fItype\fR (e.g. \fItype\fR is specified in the \fBselection get\fR -command). \fIType\fR defaults to STRING. -.VS -If \fIcommand\fR is an empty string then any existing handler for -\fIwindow\fR and \fItype\fR is removed. -.VE -.RS -.PP -When the selection is requested and \fIwindow\fR is the selection owner -and \fItype\fR is the requested type, \fIcommand\fR will be executed -as a Tcl command with two additional numbers appended to it -(with space separators). The two additional numbers -are \fIoffset\fR and \fImaxBytes\fR: \fIoffset\fR specifies a starting -character position in the selection and \fImaxBytes\fR gives the maximum -number of bytes to retrieve. The command should return a value consisting -of at most \fImaxBytes\fR of the selection, starting at position -\fIoffset\fR. For very large selections (larger than \fImaxBytes\fR) -the selection will be retrieved using several invocations of \fIcommand\fR -with increasing \fIoffset\fR values. If \fIcommand\fR returns a string -whose length is less than \fImaxBytes\fR, the return value is assumed to -include all of the remainder of the selection; if the length of -\fIcommand\fR's result is equal to \fImaxBytes\fR then -\fIcommand\fR will be invoked again, until it eventually -returns a result shorter than \fImaxBytes\fR. The value of \fImaxBytes\fR -will always be relatively large (thousands of bytes). -.PP -If \fIcommand\fR returns an error then the selection retrieval is rejected -.VS -just as if the selection didn't exist at all. -.VE -.PP -The \fIformat\fR argument specifies the representation that should be -used to transmit the selection to the requester (the second column of -Table 2 of the ICCCM), and defaults to STRING. If \fIformat\fR is -STRING, the selection is transmitted as 8-bit ASCII characters (i.e. -just in the form returned by \fIcommand\fR). If \fIformat\fR is -ATOM, then the return value from \fIcommand\fR is divided into fields -separated by white space; each field is converted to its atom value, -and the 32-bit atom value is transmitted instead of the atom name. -For any other \fIformat\fR, the return value from \fIcommand\fR is -divided into fields separated by white space and each field is -converted to a 32-bit integer; an array of integers is transmitted -to the selection requester. -.PP -The \fIformat\fR argument is needed only for compatibility with -selection requesters that don't use Tk. If the Tk toolkit is being -used to retrieve the selection then the value is converted back to -a string at the requesting end, so \fIformat\fR is -irrelevant. -.RE -.TP -\fBselection own \fR?\fIwindow\fR? ?\fIcommand\fR? -.VS -If \fIwindow\fR is specified, then it becomes the new selection owner -and the command returns an empty string as result. -The existing owner, if any, is notified that it has lost the selection. -If \fIcommand\fR is specified, it is a Tcl script to execute when -some other window claims ownership of the selection away from -\fIwindow\fR. -If neither \fIwindow\fR nor \fIcommand\fR is specified then -the command returns the path name of the window in this application -that owns the selection, or an empty string if no window in this -application owns the selection. -.VE - -.SH KEYWORDS -clear, format, handler, ICCCM, own, selection, target, type diff --git a/tk3.6/doc/send.n b/tk3.6/doc/send.n deleted file mode 100644 index 90ec917..0000000 --- a/tk3.6/doc/send.n +++ /dev/null @@ -1,69 +0,0 @@ -'\" -'\" Copyright (c) 1990 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/wish/man/RCS/send.n,v 1.6 93/04/26 16:32:07 ouster Exp $ SPRITE (Berkeley) -'/" -.so man.macros -.HS send tk -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -send \- Execute a command in a different interpreter -.SH SYNOPSIS -\fBsend \fIinterp cmd \fR?\fIarg arg ...\fR? -.BE - -.SH DESCRIPTION -.PP -This command arranges for \fIcmd\fR (and \fIarg\fRs) to be executed in the -interpreter named by \fIinterp\fR. It returns the result or -error from that command execution. \fIInterp\fR must be the -name of an interpreter registered on the display associated with -the interpreter in which the command is invoked; it need not -be within the same process or application. If no \fIarg\fR -arguments are present, then the command to be executed is -contained entirely within the \fIcmd\fR argument. If one or -more \fIarg\fRs are present, they are concatenated to form the -command to be executed, just as for the \fBeval\fR Tcl command. - -.SH SECURITY -.PP -.VS -The \fBsend\fR command is potentially a serious security loophole, -since any application that can connect to your X server can send -scripts to your applications. -These incoming scripts can use Tcl to read and -write your files and invoke subprocesses under your name. -Host-based access control such as that provided by \fBxhost\fR -is particularly insecure, since it allows anyone with an account -on particular hosts to connect to your server, and if disabled it -allows anyone anywhere to connect to your server. -In order to provide at least a small amount of -security, Tk checks the access control being used by the server -and rejects incoming sends unless (a) \fBxhost\fR-style access control -is enabled (i.e. only certain hosts can establish connections) and (b) the -list of enabled hosts is empty. -This means that applications cannot connect to your server unless -they use some other form of authorization -such as that provide by \fBxauth\fR. -.VE - -.SH KEYWORDS -interpreter, remote execution, security, send diff --git a/tk3.6/doc/text.n b/tk3.6/doc/text.n deleted file mode 100644 index 40eca9b..0000000 --- a/tk3.6/doc/text.n +++ /dev/null @@ -1,816 +0,0 @@ -'\" -'\" Copyright (c) 1992 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/wish/man/RCS/text.n,v 1.12 93/10/23 16:30:35 ouster Exp $ SPRITE (Berkeley) -'/" -.so man.macros -.HS text tk -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -text \- Create and manipulate text widgets -.SH SYNOPSIS -\fBtext\fI \fIpathName \fR?\fIoptions\fR? -.SH "STANDARD OPTIONS" -.LP -.nf -.ta 4c 8c 12c -\fBbackground\fR \fBforeground\fR \fBinsertWidth\fR \fBselectBorderWidth\fR -\fBborderWidth\fR \fBinsertBackground\fR \fBpadX\fR \fBselectForeground\fR -\fBcursor\fR \fBinsertBorderWidth\fR \fBpadY\fR \fBsetGrid\fR -\fBexportSelection\fR \fBinsertOffTime\fR \fBrelief\fR \fByScrollCommand\fR -\fBfont\fR \fBinsertOnTime\fR \fBselectBackground\fR -.fi -.LP -See the ``options'' manual entry for details on the standard options. -.SH "WIDGET-SPECIFIC OPTIONS" -.LP -.nf -Name: \fBheight\fR -Class: \fBHeight\fR -Command-Line Switch: \fB\-height\fR -.fi -.IP -Specifies the desired height for the window, in units of characters. -Must be at least one. -.LP -.nf -Name: \fBstate\fR -Class: \fBState\fR -Command-Line Switch: \fB\-state\fR -.fi -.IP -Specifies one of two states for the text: \fBnormal\fR or \fBdisabled\fR. -If the text is disabled then characters may not be inserted or deleted -and no insertion cursor will be displayed, even if the input focus is -in the widget. -.LP -.nf -Name: \fBwidth\fR -Class: \fBWidth\fR -Command-Line Switch: \fB\-width\fR -.fi -.IP -Specifies the desired width for the window in units of characters. -If the font doesn't have a uniform width then the width of the -character ``0'' is used in translating from character units to -screen units. -.LP -.nf -Name: \fBwrap\fR -Class: \fBWrap\fR -Command-Line Switch: \fB\-wrap\fR -.fi -.IP -Specifies how to handle lines in the text that are too long to be -displayed in a single line of the text's window. -The value must be \fBnone\fR or \fBchar\fR or \fBword\fR. -A wrap mode of \fBnone\fR means that each line of text appears as -exactly one line on the screen; extra characters that don't fit -on the screen are not displayed. -In the other modes each line of text will be broken up into several -screen lines if necessary to keep all the characters visible. -In \fBchar\fR mode a screen line break may occur after any character; -in \fBword\fR mode a line break will only be made at word boundaries. -.BE - -.SH DESCRIPTION -.PP -The \fBtext\fR command creates a new window (given by the -\fIpathName\fR argument) and makes it into a text widget. -Additional -options, described above, may be specified on the command line -or in the option database -to configure aspects of the text such as its default background color -and relief. The \fBtext\fR command returns the -path name of the new window. -.PP -A text widget displays one or more lines of text and allows that -text to be edited. -Text widgets support three different kinds of annotations on the -text, called tags, marks, and windows. -Tags allow different portions of the text -to be displayed with different fonts and colors. -In addition, Tcl commands can be associated with tags so -that commands are invoked when particular actions such as keystrokes -and mouse button presses occur in particular ranges of the text. -See TAGS below for more details. -.PP -The second form of annotation consists of marks, which are floating -markers in the text. -Marks are used to keep track of various interesting positions in the -text as it is edited. -See MARKS below for more details. -.PP -The third form of annotation allows arbitrary windows to be displayed -in the text widget. -See WINDOWS below for more details. - -.SH INDICES -.PP -Many of the widget commands for texts take one or more indices -as arguments. -An index is a string used to indicate a particular place within -a text, such as a place to insert characters or one endpoint of a -range of characters to delete. -Indices have the syntax -.IP -\fIbase modifier modifier modifier ...\fR -.LP -Where \fIbase\fR gives a starting point and the \fImodifier\fRs -adjust the index from the starting point (e.g. move forward or -backward one character). Every index must contain a \fIbase\fR, -but the \fImodifier\fRs are optional. -.LP -The \fIbase\fR for an index must have one of the following forms: -.TP 12 -\fIline\fB.\fIchar\fR -Indicates \fIchar\fR'th character on line \fIline\fR. -Lines are numbered from 1 for consistency with other UNIX programs -that use this numbering scheme. -Within a line, characters are numbered from 0. -.TP 12 -\fB@\fIx\fB,\fIy\fR -Indicates the character that covers the pixel whose x and y coordinates -within the text's window are \fIx\fR and \fIy\fR. -.TP 12 -\fBend\fR -Indicates the last character in the text, which is always a newline -character. -.TP 12 -\fImark\fR -Indicates the character just after the mark whose name is \fImark\fR. -.TP 12 -\fItag\fB.first\fR -Indicates the first character in the text that has been tagged with -\fItag\fR. -This form generates an error if no characters are currently tagged -with \fItag\fR. -.TP 12 -\fItag\fB.last\fR -Indicates the character just after the last one in the text that has -been tagged with \fItag\fR. -This form generates an error if no characters are currently tagged -with \fItag\fR. -.LP -If modifiers follow the base index, each one of them must have one -of the forms listed below. Keywords such as \fBchars\fR and \fBwordend\fR -may be abbreviated as long as the abbreviation is unambiguous. -.TP -\fB+ \fIcount\fB chars\fR -Adjust the index forward by \fIcount\fR characters, moving to later -lines in the text if necessary. If there are fewer than \fIcount\fR -characters in the text after the current index, then set the index -to the last character in the text. -Spaces on either side of \fIcount\fR are optional. -.TP -\fB\- \fIcount\fB chars\fR -Adjust the index backward by \fIcount\fR characters, moving to earlier -lines in the text if necessary. If there are fewer than \fIcount\fR -characters in the text before the current index, then set the index -to the first character in the text. -Spaces on either side of \fIcount\fR are optional. -.TP -\fB+ \fIcount\fB lines\fR -Adjust the index forward by \fIcount\fR lines, retaining the same -character position within the line. If there are fewer than \fIcount\fR -lines after the line containing the current index, then set the index -to refer to the same character position on the last line of the text. -Then, if the line is not long enough to contain a character at the indicated -character position, adjust the character position to refer to the last -character of the line (the newline). -Spaces on either side of \fIcount\fR are optional. -.TP -\fB\- \fIcount\fB lines\fR -Adjust the index backward by \fIcount\fR lines, retaining the same -character position within the line. If there are fewer than \fIcount\fR -lines before the line containing the current index, then set the index -to refer to the same character position on the first line of the text. -Then, if the line is not long enough to contain a character at the indicated -character position, adjust the character position to refer to the last -character of the line (the newline). -Spaces on either side of \fIcount\fR are optional. -.TP -\fBlinestart\fR -Adjust the index to refer to the first character on the line. -.TP -\fBlineend\fR -Adjust the index to refer to the last character on the line (the newline). -.TP -\fBwordstart\fR -Adjust the index to refer to the first character of the word containing -the current index. A word consists of any number of adjacent characters -that are letters, digits, or underscores, or a single character that -is not one of these. -.TP -\fBwordend\fR -Adjust the index to refer to the character just after the last one of the -word containing the current index. If the current index refers to the last -character of the text then it is not modified. -.LP -If more than one modifier is present then they are applied in -left-to-right order. For example, the index ``\fBend \- 1 chars\fR'' -refers to the next-to-last character in the text and -``\fBinsert wordstart \- 1 c\fR'' refers to the character just before -the first one in the word containing the insertion cursor. - -.SH TAGS -.PP -The first form of annotation in text widgets is a tag. -A tag is a textual string that is associated with some of the characters -in a text. -There may be any number of tags associated with characters in a -text. -Each tag may refer to a single character, a range of characters, or -several ranges of characters. -An individual character may have any number of tags associated with it. -.PP -A priority order is defined among tags, and this order is used in -implementing some of the tag-related functions described below. -When a tag is defined (by associating it with characters or setting -its display options or binding commands to it), it is given -a priority higher than any existing tag. -The priority order of tags may be redefined using the -``\fIpathName \fBtag raise\fR'' and ``\fIpathName \fBtag lower\fR'' -widget commands. -.PP -Tags serve three purposes in text widgets. -First, they control the way information is displayed on the screen. -By default, characters are displayed as determined by the -\fBbackground\fR, \fBfont\fR, and \fBforeground\fR options for the -text widget. -However, display options may be associated with individual tags -using the ``\fIpathName \fBtag configure\fR'' widget command. -If a character has been tagged, then the display options associated -with the tag override the default display style. -The following options are currently supported for tags: -.TP -\fB\-background \fIcolor\fR -\fIColor\fR specifies the background color to use for characters -associated with the tag. -It may have any of the forms accepted by \fBTk_GetColor\fR. -.TP -\fB\-bgstipple \fIbitmap\fR -\fIBitmap\fR specifies a bitmap that is used as a stipple pattern -for the background. -It may have any of the forms accepted by \fBTk_GetBitmap\fR. -If \fIbitmap\fR hasn't been specified, or if it is specified -as an empty string, then a solid fill will be used for the -background. -.TP -\fB\-borderwidth \fIpixels\fR -\fIPixels\fR specifies the width of a 3-D border to draw around -the background. -It may have any of the forms accepted by \fBTk_GetPixels\fR. -This option is used in conjunction with the \fB\-relief\fR -option to give a 3-D appearance to the background for characters; -it is ignored unless the \fB\-background\fR option -has been set for the tag. -.TP -\fB\-fgstipple \fIbitmap\fR -\fIBitmap\fR specifies a bitmap that is used as a stipple pattern -when drawing text and other foreground information such as -underlines. -It may have any of the forms accepted by \fBTk_GetBitmap\fR. -If \fIbitmap\fR hasn't been specified, or if it is specified -as an empty string, then a solid fill will be used. -.TP -\fB\-font \fIfontName\fR -\fIFontName\fR is the name of a font to use for drawing characters. -It may have any of the forms accepted by \fBTk_GetFontStruct\fR. -.TP -\fB\-foreground \fIcolor\fR -\fIColor\fR specifies the color to use when drawing text and other -foreground information such as underlines. -It may have any of the forms accepted by \fBTk_GetColor\fR. -.TP -\fB\-relief \fIrelief\fR -\fIRelief specifies the 3-D relief to use for drawing backgrounds, -in any of the forms accepted by \fBTk_GetRelief\fR. -This option is used in conjunction with the \fB\-borderwidth\fR -option to give a 3-D appearance to the background for characters; -it is ignored unless the \fB\-background\fR option -has been set for the tag. -.TP -\fB\-underline \fIboolean\fR -\fIBoolean\fR specifies whether or not to draw an underline underneath -characters. -It may have any of the forms accepted by \fBTk_GetBoolean\fR. -.PP -If a character has several tags associated with it, and if their -display options conflict, then the options of the highest priority -tag are used. -If a particular display option hasn't been specified for a -particular tag, or if it is specified as an empty string, then -that option will never be used; the next-highest-priority -tag's option will used instead. -If no tag specifies a particular display optionl, then the default -style for the widget will be used. -.PP -The second purpose for tags is event bindings. -You can associate bindings with a tag in much the same way you can -associate bindings with a widget class: whenever particular X -events occur on characters with the given tag, a given -Tcl command will be executed. -Tag bindings can be used to give behaviors to ranges of characters; -among other things, this allows hypertext-like -features to be implemented. -For details, see the description of the \fBtag bind\fR widget -command below. -.PP -The third use for tags is in managing the selection. -See THE SELECTION below. - -.SH MARKS -.PP -The second form of annotation in text widgets is a mark. -Marks are used for remembering particular places in a text. -They are something like tags, in that they have names and -they refer to places in the file, but a mark isn't associated -with particular characters. -Instead, a mark is associated with the gap between two characters. -Only a single position may be associated with a mark at any given -time. -If the characters around a mark are deleted the mark will still -remain; it will just have new neighbor characters. -In contrast, if the characters containing a tag are deleted then -the tag will no longer have an association with characters in -the file. -Marks may be manipulated with the ``\fIpathName \fBmark\fR'' widget -command, and their current locations may be determined by using the -mark name as an index in widget commands. -.PP -The name space for marks is different from that for tags: the -same name may be used for both a mark and a tag, but they will refer -to different things. -.PP -Two marks have special significance. -First, the mark \fBinsert\fR is associated with the insertion cursor, -as described under THE INSERTION CURSOR below. -Second, the mark \fBcurrent\fR is associated with the character -closest to the mouse and is adjusted automatically to track the -mouse position and any changes to the text in the widget (one -exception: \fBcurrent\fR is not updated in response to mouse -motions if a mouse button is down; the update will be deferred -until all mouse buttons have been released). -Neither of these special marks may be unset. - -.SH WINDOWS -.PP -The third form of annotation in text widgets is a window. -Window support isn't implemented yet, but when it is it will be -described here. - -.SH THE SELECTION -.PP -Text widgets support the standard X selection. -Selection support is implemented via tags. -If the \fBexportSelection\fR option for the text widget is true -then the \fBsel\fR tag will be associated with the selection: -.IP [1] -Whenever characters are tagged with \fBsel\fR the text widget -will claim ownership of the selection. -.IP [2] -Attempts to retrieve the -selection will be serviced by the text widget, returning all the -charaters with the \fBsel\fR tag. -.IP [3] -If the selection is claimed away by another application or by another -window within this application, then the \fBsel\fR tag will be removed -from all characters in the text. -.PP -The \fBsel\fR tag is automatically defined when a text widget is -created, and it may not be deleted with the ``\fIpathName \fBtag delete\fR'' -widget command. Furthermore, the \fBselectBackground\fR, -\fBselectBorderWidth\fR, and \fBselectForeground\fR options for -the text widget are tied to the \fB\-background\fR, -\fB\-borderwidth\fR, and \fB\-foreground\fR options for the \fBsel\fR -tag: changes in either will automatically be reflected in the -other. - -.SH THE INSERTION CURSOR -.PP -The mark named \fBinsert\fR has special significance in text widgets. -It is defined automatically when a text widget is created and it -may not be unset with the ``\fIpathName \fBmark unset\fR'' widget -command. -The \fBinsert\fR mark represents the position of the insertion -cursor, and the insertion cursor will automatically be drawn at -this point whenever the text widget has the input focus. - -.SH "WIDGET COMMAND" -.PP -The \fBtext\fR command creates a new Tcl command whose -name is the same as the path name of the text's window. This -command may be used to invoke various -operations on the widget. It has the following general form: -.DS C -\fIpathName option \fR?\fIarg arg ...\fR? -.DE -\fIPathName\fR is the name of the command, which is the same as -the text widget's path name. \fIOption\fR and the \fIarg\fRs -determine the exact behavior of the command. The following -commands are possible for text widgets: -.TP -\fIpathName \fBcompare\fR \fIindex1 op index2\fR -Compares the indices given by \fIindex1\fR and \fIindex2\fR according -to the relational operator given by \fIop\fR, and returns 1 if -the relationship is satisfied and 0 if it isn't. -\fIOp\fR must be one of the operators <, <=, ==, >=, >, or !=. -If \fIop\fR is == then 1 is returned if the two indices refer to -the same character, if \fIop\fR is < then 1 is returned if \fIindex1\fR -refers to an earlier character in the text than \fIindex2\fR, and -so on. -.TP -\fIpathName \fBconfigure\fR ?\fIoption\fR? \fI?value option value ...\fR? -Query or modify the configuration options of the widget. -If no \fIoption\fR is specified, returns a list describing all of -the available options for \fIpathName\fR (see \fBTk_ConfigureInfo\fR for -information on the format of this list). If \fIoption\fR is specified -with no \fIvalue\fR, then the command returns a list describing the -one named option (this list will be identical to the corresponding -sublist of the value returned if no \fIoption\fR is specified). If -one or more \fIoption\-value\fR pairs are specified, then the command -modifies the given widget option(s) to have the given value(s); in -this case the command returns an empty string. -\fIOption\fR may have any of the values accepted by the \fBtext\fR -command. -.TP -\fIpathName \fBdebug \fR?\fIboolean\fR? -If \fIboolean\fR is specified, then it must have one of the true or -false values accepted by Tcl_GetBoolean. -If the value is a true one then internal consistency checks will be -turned on in the B-tree code associated with text widgets. -If \fIboolean\fR has a false value then the debugging checks will -be turned off. -In either case the command returns an empty string. -If \fIboolean\fR is not specified then the command returns \fBon\fR -or \fBoff\fR to indicate whether or not debugging is turned on. -There is a single debugging switch shared by all text widgets: turning -debugging on or off in any widget turns it on or off for all widgets. -For widgets with large amounts of text, the consistency checks may -cause a noticeable slow-down. -.TP -\fIpathName \fBdelete \fIindex1 \fR?\fIindex2\fR? -Delete a range of characters from the text. -If both \fIindex1\fR and \fIindex2\fR are specified, then delete -all the characters starting with the one given by \fIindex1\fR -and stopping just before \fIindex2\fR (i.e. the character at -\fIindex2\fR is not deleted). -If \fIindex2\fR doesn't specify a position later in the text -than \fIindex1\fR then no characters are deleted. -If \fIindex2\fR isn't specified then the single character at -\fIindex1\fR is deleted. -It is not allowable to delete characters in a way that would leave -the text without a newline as the last character. -The command returns an empty string. -.TP -\fIpathName \fBget \fIindex1 \fR?\fIindex2\fR? -Return a range of characters from the text. -The return value will be all the characters in the text starting -with the one whose index is \fIindex1\fR and ending just before -the one whose index is \fIindex2\fR (the character at \fIindex2\fR -will not be returned). -If \fIindex2\fR is omitted then the single character at \fIindex1\fR -is returned. -If there are no characters in the specified range (e.g. \fIindex1\fR -is past the end of the file or \fIindex2\fR is less than or equal -to \fIindex1\fR) then an empty string is returned. -.TP -\fIpathName \fBindex \fIindex\fR -Returns the position corresponding to \fIindex\fR in the form -\fIline.char\fR where \fIline\fR is the line number and \fIchar\fR -is the character number. -\fIIndex\fR may have any of the forms described under INDICES above. -.TP -\fIpathName \fBinsert \fIindex chars -Inserts \fIchars\fR into the text just before the character at -\fIindex\fR and returns an empty string. -It is not possible to insert characters after the last newline -of the text. -.TP -\fIpathName \fBmark \fIoption \fR?\fIarg arg ...\fR? -This command is used to manipulate marks. The exact behavior of -the command depends on the \fIoption\fR argument that follows -the \fBmark\fR argument. The following forms of the command -are currently supported: -.RS -.TP -\fIpathName \fBmark names\fR -Returns a list whose elements are the names of all the marks that -are currently set. -.TP -\fIpathName \fBmark set \fImarkName index\fR -Sets the mark named \fImarkName\fR to a position just before the -character at \fIindex\fR. -If \fImarkName\fR already exists, it is moved from its old position; -if it doesn't exist, a new mark is created. -This command returns an empty string. -.TP -\fIpathName \fBmark unset \fImarkName \fR?\fImarkName markName ...\fR? -Remove the mark corresponding to each of the \fImarkName\fR arguments. -The removed marks will not be usable in indices and will not be -returned by future calls to ``\fIpathName \fBmark names\fR''. -This command returns an empty string. -.RE -.TP -\fIpathName \fBscan\fR \fIoption args\fR -This command is used to implement scanning on texts. It has -two forms, depending on \fIoption\fR: -.RS -.TP -\fIpathName \fBscan mark \fIy\fR -Records \fIy\fR and the current view in the text window; used in -conjunction with later \fBscan dragto\fR commands. Typically this -command is associated with a mouse button press in the widget. It -returns an empty string. -.TP -\fIpathName \fBscan dragto \fIy\fR -This command computes the difference between its \fIy\fR argument -and the \fIy\fR argument to the last \fBscan mark\fR command for -the widget. It then adjusts the view up or down by 10 times the -difference in y-coordinates. This command is typically associated -with mouse motion events in the widget, to produce the effect of -dragging the text at high speed through the window. The return -value is an empty string. -.RE -.TP -\fIpathName \fBtag \fIoption \fR?\fIarg arg ...\fR? -This command is used to manipulate tags. The exact behavior of the -command depends on the \fIoption\fR argument that follows the -\fBtag\fR argument. The following forms of the command are currently -supported: -.RS -.TP -\fIpathName \fBtag add \fItagName index1 \fR?\fIindex2\fR? -Associate the tag \fItagName\fR with all of the characters starting -with \fIindex1\fR and ending just before -\fIindex2\fR (the character at \fIindex2\fR isn't tagged). -If \fIindex2\fR is omitted then the single character at -\fIindex1\fR is tagged. -If there are no characters in the specified range (e.g. \fIindex1\fR -is past the end of the file or \fIindex2\fR is less than or equal -to \fIindex1\fR) then the command has no effect. -This command returns an empty string. -.TP -\fIpathName \fBtag bind \fItagName\fR ?\fIsequence\fR? ?\fIcommand\fR? -This command associates \fIcommand\fR with the tag given by -\fItagName\fR. -Whenever the event sequence given by \fIsequence\fR occurs for a -character that has been tagged with \fItagName\fR, -the command will be invoked. -This widget command is similar to the \fBbind\fR command except that -it operates on characters in a text rather than entire widgets. -See the \fBbind\fR manual entry for complete details -on the syntax of \fIsequence\fR and the substitutions performed -on \fIcommand\fR before invoking it. -If all arguments are specified then a new binding is created, replacing -any existing binding for the same \fIsequence\fR and \fItagName\fR -(if the first character of \fIcommand\fR is ``+'' then \fIcommand\fR -augments an existing binding rather than replacing it). -In this case the return value is an empty string. -If \fIcommand\fR is omitted then the command returns the \fIcommand\fR -associated with \fItagName\fR and \fIsequence\fR (an error occurs -if there is no such binding). -If both \fIcommand\fR and \fIsequence\fR are omitted then the command -returns a list of all the sequences for which bindings have been -defined for \fItagName\fR. -.RS -.LP -The only events for which bindings may be specified are those related -to the mouse and keyboard, such as \fBEnter\fR, \fBLeave\fR, -\fBButtonPress\fR, \fBMotion\fR, and \fBKeyPress\fR. -Event bindings for a text widget use the \fBcurrent\fR mark -described under MARKS above. -\fBEnter\fR events trigger for a character when it -becomes the current character (i.e. the \fBcurrent\fR mark moves -to just in front of that character). -\fBLeave\fR events trigger for a character when it ceases to be -the current item (i.e. the \fBcurrent\fR mark moves away from -that character, or the character is deleted). -These events are different than \fBEnter\fR and \fBLeave\fR -events for windows. -Mouse and keyboard events are directed to the current character. -.LP -It is possible for the current character to have multiple tags, -and for each of them to have a binding for a particular event -sequence. -When this occurs, the binding from the highest priority tag is -used. -If a particular tag doesn't have a binding that matches an -event, then the tag is ignored and tags with lower priority -will be checked. -.LP -If bindings are created for the widget as a whole using the -\fBbind\fR command, then those bindings will supplement the -tag bindings. -This means that a single event can trigger two Tcl scripts, -one for a widget-level binding and one for a tag-level -binding. -.RE -.TP -\fIpathName \fBtag configure \fItagName\fR ?\fIoption\fR? ?\fIvalue\fR? ?\fIoption value ...\fR? -This command is similar to the \fBconfigure\fR widget command except -that it modifies options associated with the tag given by \fItagName\fR -instead of modifying options for the overall text widget. -If no \fIoption\fR is specified, the command returns a list describing -all of the available options for \fItagName\fR (see \fBTk_ConfigureInfo\fR -for information on the format of this list). -If \fIoption\fR is specified with no \fIvalue\fR, then the command returns -a list describing the one named option (this list will be identical to -the corresponding sublist of the value returned if no \fIoption\fR -is specified). -If one or more \fIoption\-value\fR pairs are specified, then the command -modifies the given option(s) to have the given value(s) in \fItagName\fR; -in this case the command returns an empty string. -See TAGS above for details on the options available for tags. -.TP -\fIpathName \fBtag delete \fItagName \fR?\fItagName ...\fR? -Deletes all tag information for each of the \fItagName\fR -arguments. -The command removes the tags from all characters in the file -and also deletes any other information associated with the tags, -such as bindings and display information. -The command returns an empty string. -.TP -\fIpathName\fBtag lower \fItagName \fR?\fIbelowThis\fR? -Changes the priority of tag \fItagName\fR so that it is just lower -in priority than the tag whose name is \fIbelowThis\fR. -If \fIbelowThis\fR is omitted, then \fItagName\fR's priority -is changed to make it lowest priority of all tags. -.TP -\fIpathName \fBtag names \fR?\fIindex\fR? -Returns a list whose elements are the names of all the tags that -are active at the character position given by \fIindex\fR. -If \fIindex\fR is omitted, then the return value will describe -all of the tags that exist for the text (this includes all tags -that have been named in a ``\fIpathName \fBtag\fR'' widget -command but haven't been deleted by a ``\fIpathName \fBtag delete\fR'' -widget command, even if no characters are currently marked with -the tag). -The list will be sorted in order from lowest priority to highest -priority. -.TP -\fIpathName \fBtag nextrange \fItagName index1 \fR?\fIindex2\fR? -This command searches the text for a range of characters tagged -with \fItagName\fR where the first character of the range is -no earlier than the character at \fIindex1\fR and no later than -the character just before \fIindex2\fR (a range starting at -\fIindex2\fR will not be considered). -If several matching ranges exist, the first one is chosen. -The command's return value is a list containing -two elements, which are the index of the first character of the -range and the index of the character just after the last one in -the range. -If no matching range is found then the return value is an -empty string. -If \fIindex2\fR is not given then it defaults to the end of the text. -.TP -\fIpathName\fBtag raise \fItagName \fR?\fIaboveThis\fR? -Changes the priority of tag \fItagName\fR so that it is just higher -in priority than the tag whose name is \fIaboveThis\fR. -If \fIaboveThis\fR is omitted, then \fItagName\fR's priority -is changed to make it highest priority of all tags. -.TP -\fIpathName \fBtag ranges \fItagName\fR -Returns a list describing all of the ranges of text that have been -tagged with \fItagName\fR. -The first two elements of the list describe the first tagged range -in the text, the next two elements describe the second range, and -so on. -The first element of each pair contains the index of the first -character of the range, and the second element of the pair contains -the index of the character just after the last one in the -range. -If there are no characters tagged with \fItag\fR then an -empty string is returned. -.TP -\fIpathName \fBtag remove \fItagName index1 \fR?\fIindex2\fR? -Remove the tag \fItagName\fR from all of the characters starting -at \fIindex1\fR and ending just before -\fIindex2\fR (the character at \fIindex2\fR isn't affected). -If \fIindex2\fR is omitted then the single character at -\fIindex1\fR is untagged. -If there are no characters in the specified range (e.g. \fIindex1\fR -is past the end of the file or \fIindex2\fR is less than or equal -to \fIindex1\fR) then the command has no effect. -This command returns an empty string. -.RE -.TP -\fIpathName \fByview \fR?\fB\-pickplace\fR? \fIwhat\fR -This command changes the view in the widget's window so that the line -given by \fIwhat\fR is visible in the window. -\fIWhat\fR may be either an absolute line number, where 0 corresponds -to the first line of the file, or an index with any of the forms -described under INDICES above. -The first form (absolute line number) is used in the commands issued -by scrollbars to control the widget's view. -If the \fB\-pickplace\fR option isn't specified then \fIwhat\fR will -appear at the top of the window. -If \fB\-pickplace\fR is specified then the widget chooses where -\fIwhat\fR appears in the window: -.RS -.IP [1] -If \fIwhat\fR is already visible somewhere in the window then the -command does nothing. -.IP [2] -If \fIwhat\fR is only a few lines off-screen above the window then -it will be positioned at the top of the window. -.IP [3] -If \fIwhat\fR is only a few lines off-screen below the window then -it will be positioned at the bottom of the window. -.IP [4] -Otherwise, \fIwhat\fR will be centered in the window. -.LP -The \fB\-pickplace\fR option is typically used after inserting text -to make sure that the insertion cursor is still visible on the screen. -This command returns an empty string. -.RE - -.SH BINDINGS -.PP -Tk automatically creates class bindings for texts that give them -the following default behavior: -.IP [1] -Pressing mouse button 1 in an text positions the insertion cursor -just before the character underneath the mouse cursor and sets the -input focus to this widget. -.IP [2] -Dragging with mouse button 1 strokes out a selection between -the insertion cursor and the character under the mouse. -.IP [3] -If you double-press mouse button 1 then the word under the mouse cursor -will be selected, the insertion cursor will be positioned at the -beginning of the word, and dragging the mouse will stroke out a selection -whole words at a time. -.IP [4] -If you triple-press mouse button 1 then the line under the mouse cursor -will be selected, the insertion cursor will be positioned at the -beginning of the line, and dragging the mouse will stroke out a selection -whole line at a time. -.IP [5] -The ends of the selection can be adjusted by dragging with mouse -button 1 while the shift key is down; this will adjust the end -of the selection that was nearest to the mouse cursor when button -1 was pressed. If the selection was made in word or line mode then -it will be adjusted in this same mode. -.IP [6] -The view in the text can be adjusted by dragging with mouse button 2. -.IP [7] -If the input focus is in a text widget and characters are typed on the -keyboard, the characters are inserted just before the insertion cursor. -.IP [8] -Control+h and the Backspace and Delete keys erase the character just -before the insertion cursor. -.IP [9] -Control+v inserts the current selection just before the insertion cursor. -.IP [10] -Control+d deletes the selected characters; an error occurs if the selection -is not in this widget. -.PP -If the text is disabled using the \fBstate\fR option, then the text's -view can still be adjusted and text in the text can still be selected, -but no insertion cursor will be displayed and no text modifications will -take place. -.PP -The behavior of texts can be changed by defining new bindings for -individual widgets or by redefining the class bindings. - -.SH "PERFORMANCE ISSUES" -.PP -Text widgets should run efficiently under a variety -of conditions. The text widget uses about 2-3 bytes of -main memory for each byte of text, so texts containing a megabyte -or more should be practical on most workstations. -Text is represented internally with a modified B-tree structure -that makes operations relatively efficient even with large texts. -Tags are included in the B-tree structure in a way that allows -tags to span large ranges or have many disjoint smaller ranges -without loss of efficiency. -Marks are also implemented in a way that allows large numbers of -marks. -The only known mode of operation where a text widget may not run -efficiently is if it has a very large number of different tags. -Hundreds of tags should be fine, or even a thousand, -but tens of thousands of tags will make texts consume a lot of -memory and run slowly. - -.SH KEYWORDS -text, widget diff --git a/tk3.6/doc/tk.n b/tk3.6/doc/tk.n deleted file mode 100644 index 65b9451..0000000 --- a/tk3.6/doc/tk.n +++ /dev/null @@ -1,70 +0,0 @@ -'\" -'\" Copyright (c) 1992 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/wish/man/RCS/tk.n,v 1.3 93/04/01 09:52:58 ouster Exp $ SPRITE (Berkeley) -'/" -.so man.macros -.HS tk tk -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -tk \- Manipulate Tk internal state -.SH SYNOPSIS -\fBtk\fR \fIoption \fR?\fIarg arg ...\fR? -.BE - -.SH DESCRIPTION -.PP -The \fBtk\fR command provides access to miscellaneous -elements of Tk's internal state. -Most of the information manipulated by this command pertains to the -application as a whole, or to a screen or display, rather than to a -particular window. -The command can take any of a number of different forms -depending on the \fIoption\fR argument. The legal forms are: -.TP -\fBtk colormodel \fIwindow\fR ?\fInewValue\fR? -If \fInewValue\fR isn't specified, this command returns the current -color model in use for \fIwindow\fR's screen, which will be either -\fBcolor\fR or \fBmonochrome\fR. -If \fInewValue\fR is specified, then it must be either \fBcolor\fR -or \fBmonochrome\fR or an abbreviation of one of them; -the color model for \fIwindow\fR's screen is set to this value. -.RS -.LP -The color model is used by Tk and its widgets to determine whether -it should display in black and white only or use colors. -A single color model is shared by all of the windows managed by one -process on a given screen. -The color model for a screen is set initially by Tk to \fBmonochrome\fR -if the display has four or fewer bit planes and to \fBcolor\fR otherwise. -The color model will automatically be changed from \fBcolor\fR to -\fBmonochrome\fR if Tk fails to allocate a color because all entries -in the colormap were in use. -An application can change its own color model at any time (e.g. it -might change the model to \fBmonochrome\fR in order to conserve -colormap entries, or it might set the model to \fBcolor\fR -to use color on a four-bit display in special circumstances), but -an application is not allowed to change the color model to \fBcolor\fR -unless the screen has at least two bit planes. -.RE - -.SH KEYWORDS -color model, internal state diff --git a/tk3.6/doc/tkerror.n b/tk3.6/doc/tkerror.n deleted file mode 100644 index a3d6f4d..0000000 --- a/tk3.6/doc/tkerror.n +++ /dev/null @@ -1,70 +0,0 @@ -'\" -'\" Copyright (c) 1990 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/wish/man/RCS/tkerror.n,v 1.6 93/07/09 11:36:38 ouster Exp $ SPRITE (Berkeley) -'/" -.so man.macros -.HS tkerror tk 7.0 -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -tkerror \- Command invoked to process background errors -.SH SYNOPSIS -\fBtkerror \fImessage\fR -.BE - -.SH DESCRIPTION -.PP -The \fBtkerror\fR command doesn't exist as built-in part of Tk. Instead, -individual applications or users can define a \fBtkerror\fR -command (e.g. as a Tcl procedure) if they wish to handle background -errors. -.PP -A background error is one that occurs in a command that didn't -originate with the application. For example, if an error occurs -while executing a command specified with a \fBbind\fR of \fBafter\fR -command, then it is a background error. For a non-background error, -the error can simply be returned up through nested Tcl command -evaluations until it reaches the top-level code in the application; -then the application can report the error in whatever way it -wishes. When a background error occurs, the unwinding ends in -the Tk library and there is no obvious way for Tk to report -the error. -.PP -When Tk detects a background error, it invokes the \fBtkerror\fR -command, passing it the error message as its only argument. -Tk assumes that the application has implemented the \fBtkerror\fR -command, and that the command will report the error in a way that -makes sense for the application. Tk will ignore any result returned -by the \fBtkerror\fR command. -.PP -If another Tcl error occurs within the \fBtkerror\fR command -then Tk reports the error itself by writing a message -to stderr. -.PP -.VS -The Tk script library includes a default \fBtkerror\fR procedure -that posts a dialog box containing the error message and offers -the user a chance to see a stack trace that shows where the -error occurred. -.VE - -.SH KEYWORDS -background error, reporting diff --git a/tk3.6/doc/toplevel.n b/tk3.6/doc/toplevel.n deleted file mode 100644 index 110bb47..0000000 --- a/tk3.6/doc/toplevel.n +++ /dev/null @@ -1,117 +0,0 @@ -'\" -'\" Copyright (c) 1990 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/wish/man/RCS/toplevel.n,v 1.7 93/04/01 09:53:01 ouster Exp $ SPRITE (Berkeley) -'/" -.so man.macros -.HS toplevel tk -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -toplevel \- Create and manipulate toplevel widgets -.SH SYNOPSIS -\fBtoplevel\fI \fIpathName \fR?\fB\-screen \fIscreenName\fR? ?\fB\-class \fIclassName\fR? ?\fIoptions\fR? -.SH "STANDARD OPTIONS" -.LP -.nf -.ta 4c 8c 12c -\fBbackground\fR \fBgeometry\fR -\fBborderWidth\fR \fBrelief\fR -.fi -.LP -See the ``options'' manual entry for details on the standard options. -.SH "WIDGET-SPECIFIC OPTIONS" -.BE - -.SH DESCRIPTION -.PP -The \fBtoplevel\fR command creates a new toplevel widget (given -by the \fIpathName\fR argument). Additional -options, described above, may be specified on the command line -or in the option database -to configure aspects of the toplevel such as its background color -and relief. The \fBtoplevel\fR command returns the -path name of the new window. -.PP -A toplevel is similar to a frame except that it is created as a -top-level window: its X parent is the root window of a screen -rather than the logical parent from its path name. The primary -purpose of a toplevel is to serve as a container for dialog boxes -and other collections of widgets. The only features -of a toplevel are its background color and an optional 3-D border -to make the toplevel appear raised or sunken. -.PP -Two special command-line options may be provided to the \fBtoplevel\fR -command: \fB\-class\fR and \fB\-screen\fR. If \fB\-class\fR -is specified, then the new widget's class will be set to -\fIclassName\fR instead of \fBToplevel\fR. Changing the class of -a toplevel widget may be useful -in order to use a special class name in database options referring -to this widget and its children. The \fB\-screen\fR option -may be used to place the window on a different screen than the -window's logical parent. Any valid screen name may be used, even -one associated with a different display. -.PP -Note: \fB\-class\fR and \fB\-screen\fR are handled -differently than other command-line options. They may not be specified -using the option database (these options must have been processed -before the new window has been created enough to use the option database; -in particular, the new class name will affect the lookup of options -in the database). In addition, \fB\-class\fR and \fB\-screen\fR -may not be queried or changed using the \fBconfig\fR command described -below. However, the \fBwinfo class\fR command may be used to query -the class of a window, and \fBwinfo screen\fR may be used to query -its screen. - -.SH "WIDGET COMMAND" -.PP -The \fBtoplevel\fR command creates a new Tcl command whose -name is the same as the path name of the toplevel's window. This -command may be used to invoke various -operations on the widget. It has the following general form: -.DS C -\fIpathName option \fR?\fIarg arg ...\fR? -.DE -\fIPathName\fR is the name of the command, which is the same as -the toplevel widget's path name. \fIOption\fR and the \fIarg\fRs -determine the exact behavior of the command. The following -commands are possible for toplevel widgets: -.TP -\fIpathName \fBconfigure\fR ?\fIoption\fR? ?\fIvalue option value ...\fR? -Query or modify the configuration options of the widget. -If no \fIoption\fR is specified, returns a list describing all of -the available options for \fIpathName\fR (see \fBTk_ConfigureInfo\fR for -information on the format of this list). If \fIoption\fR is specified -with no \fIvalue\fR, then the command returns a list describing the -one named option (this list will be identical to the corresponding -sublist of the value returned if no \fIoption\fR is specified). If -one or more \fIoption\-value\fR pairs are specified, then the command -modifies the given widget option(s) to have the given value(s); in -this case the command returns an empty string. -\fIOption\fR may have any of the values accepted by the \fBtoplevel\fR -command. - -.SH BINDINGS -.PP -When a new toplevel is created, it has no default event bindings: -toplevels are not intended to be interactive. - -.SH KEYWORDS -toplevel, widget diff --git a/tk3.6/doc/update.n b/tk3.6/doc/update.n deleted file mode 100644 index 1c9bfb5..0000000 --- a/tk3.6/doc/update.n +++ /dev/null @@ -1,65 +0,0 @@ -'\" -'\" Copyright (c) 1990-1992 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/wish/man/RCS/update.n,v 1.5 93/04/01 09:53:02 ouster Exp $ SPRITE (Berkeley) -'/" -.so man.macros -.HS update tk -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -.VS -update \- Process pending events and/or when-idle handlers -.SH SYNOPSIS -\fBupdate\fR ?\fBidletasks\fR? -.VE -.BE - -.SH DESCRIPTION -.PP -This command is used to bring the entire application world -``up to date.'' -It flushes all pending output to the display, waits for the -server to process that output and return errors or events, -handles all pending events of any sort (including when-idle handlers), -and repeats this set of operations until there are no pending -events, no pending when-idle handlers, no pending output to the server, -and no operations still outstanding at the server. -.PP -If the \fBidletasks\fR keyword is specified as an argument to the -.VS -command, then no new events or errors are processed; only when-idle -idlers are invoked. -This causes operations that are normally deferred, such as display -updates and window layout calculations, to be performed immediately. -.PP -The \fBupdate idletasks\fR command is useful in scripts where -changes have been made to the application's state and you want those -changes to appear on the display immediately, rather than waiting -for the script to complete. -The \fBupdate\fR command with no options is useful in scripts where -you are performing a long-running computation but you still want -the application to respond to user interactions; if you occasionally -call \fBupdate\fR then user input will be processed during the -next call to \fBupdate\fR. -.VE - -.SH KEYWORDS -event, flush, handler, idle, update diff --git a/tk3.6/doc/wish.1 b/tk3.6/doc/wish.1 deleted file mode 100644 index c9bbf1e..0000000 --- a/tk3.6/doc/wish.1 +++ /dev/null @@ -1,131 +0,0 @@ -'\" -'\" 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 -'\" 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/wish/man/RCS/wish.1,v 1.11 93/08/26 15:07:01 ouster Exp $ SPRITE (Berkeley) -'/" -.so man.macros -.HS wish tkcmds 3.3 -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -wish \- Simple windowing shell -.SH SYNOPSIS -\fBwish\fR ?\fIoptions\fR? ?\fIarg arg ...\fR? -.SH OPTIONS -.IP "\fB\-display \fIdisplay\fR" 15 -Display (and screen) on which to display window. -.IP "\fB\-file \fIfileName\fR" 15 -Read commands from \fIfileName\fR rather than standard input. The -last element in \fIfileName\fR will be used as the title for the -application and name of its interpreter for \fBsend\fR -commands (unless overridden by the \fB\-name\fR option\fR). -.IP "\fB\-geometry \fIgeometry\fR" 15 -Initial geometry to use for window. -.IP "\fB\-name \fIname\fR" 15 -Use \fIname\fR as the title to be displayed in the window, and -as the name of the interpreter for \fBsend\fR commands. -.IP "\fB\-sync\fR" 15 -Execute all X server commands synchronously, so that errors -are reported immediately. This will result in much slower -execution, but it is useful for debugging. -.IP "\fB\-help\fR" 15 -Print a summary of the command-line options and exit. -.BE - -.SH DESCRIPTION -.PP -\fBWish\fR is a simple program consisting of the Tcl command -language, the Tk toolkit, and a main program that reads commands -from standard input or from a file. -It creates a main window and then processes Tcl commands. -If \fBwish\fR is invoked with no \fB\-f\fR option then it -reads Tcl commands interactively from standard input. -It will continue processing commands until all windows have been -deleted or until end-of-file is reached on standard input. -.VS -If there exists a file \fB.wishrc\fR in the home directory of -the user, \fBwish\fR evaluates the file as a Tcl script -just before reading the first command from standard input. -.VE -.PP -If the \fB\-file\fR option is provided to Tk, then \fBwish\fR reads Tcl -commands from the file named in the \fB\-file\fR option. These -commands will normally create an interactive interface consisting -of one or more widgets. When the end of the command file is -reached, \fBwish\fR will continue to respond to X events until -all windows have been deleted. -.VS -There is no automatic evaluation of \fB.wishrc\fR in this -case, but the script file can always \fBsource\fR it if desired. -.VE - -.SH "VARIABLES" -.PP -\fBWish\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 options described above. -.TP 15 -\fBargv\fR -Contains a Tcl list whose elements are the \fIarg\fR arguments (not -including the options described above), in order, or an empty string -if there are no \fIarg\fR arguments. -.TP 15 -\fBargv0\fR -.VS -Contains \fIfileName\fR if it was specified. -Otherwise, contains the name by which \fBwish\fR was invoked. -.TP 15 -\fBtcl_interactive\fR -Contains 1 if \fBwish\fR is reading commands interactively (no -\fB\-file\fR option was specified and standard input is a terminal-like -device), 0 otherwise. -.VE - -.SH "SCRIPT FILES" -.PP -If you create a Tcl script in a file whose first line is -.DS -\fB#!/usr/local/bin/wish -f -.DE -then you can invoke the script file directly from your shell if -you mark it as executable. -This assumes that \fBwish\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 PROMPTS -.PP -.VS -When \fBwish\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 \fBwish\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. -.VE - -.SH KEYWORDS -shell, toolkit diff --git a/tk3.6/library/button.tcl b/tk3.6/library/button.tcl deleted file mode 100644 index d94afcf..0000000 --- a/tk3.6/library/button.tcl +++ /dev/null @@ -1,85 +0,0 @@ -# button.tcl -- -# -# This file contains Tcl procedures used to manage Tk buttons. -# -# $Header: /user6/ouster/wish/library/RCS/button.tcl,v 1.9 93/07/01 13:41:53 ouster Exp $ SPRITE (Berkeley) -# -# 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. -# - -# The procedure below is invoked when the mouse pointer enters a -# button widget. It records the button we're in and changes the -# state of the button to active unless the button is disabled. - -proc tk_butEnter w { - global tk_priv tk_strictMotif - if {[lindex [$w config -state] 4] != "disabled"} { - if {!$tk_strictMotif} { - $w config -state active - } - set tk_priv(window) $w - } -} - -# The procedure below is invoked when the mouse pointer leaves a -# button widget. It changes the state of the button back to -# inactive. - -proc tk_butLeave w { - global tk_priv tk_strictMotif - if {[lindex [$w config -state] 4] != "disabled"} { - if {!$tk_strictMotif} { - $w config -state normal - } - } - set tk_priv(window) "" -} - -# The procedure below is invoked when the mouse button is pressed in -# a button/radiobutton/checkbutton widget. It records information -# (a) to indicate that the mouse is in the button, and -# (b) to save the button's relief so it can be restored later. - -proc tk_butDown w { - global tk_priv - set tk_priv(relief) [lindex [$w config -relief] 4] - set tk_priv(buttonWindow) $w - if {[lindex [$w config -state] 4] != "disabled"} { - $w config -relief sunken - } -} - -# The procedure below is invoked when the mouse button is released -# for a button/radiobutton/checkbutton widget. It restores the -# button's relief and invokes the command as long as the mouse -# hasn't left the button. - -proc tk_butUp w { - global tk_priv - if {$w == $tk_priv(buttonWindow)} { - $w config -relief $tk_priv(relief) - if {($w == $tk_priv(window)) - && ([lindex [$w config -state] 4] != "disabled")} { - uplevel #0 [list $w invoke] - } - set tk_priv(buttonWindow) "" - } -} diff --git a/tk3.6/library/demos/bitmaps/grey.5 b/tk3.6/library/demos/bitmaps/grey.5 deleted file mode 100644 index 3768889..0000000 --- a/tk3.6/library/demos/bitmaps/grey.5 +++ /dev/null @@ -1,6 +0,0 @@ -#define grey_width 16 -#define grey_height 16 -static char grey_bits[] = { - 0x55, 0x55, 0xaa, 0xaa, 0x55, 0x55, 0xaa, 0xaa, 0x55, 0x55, 0xaa, 0xaa, - 0x55, 0x55, 0xaa, 0xaa, 0x55, 0x55, 0xaa, 0xaa, 0x55, 0x55, 0xaa, 0xaa, - 0x55, 0x55, 0xaa, 0xaa, 0x55, 0x55, 0xaa, 0xaa}; diff --git a/tk3.6/library/demos/color b/tk3.6/library/demos/color deleted file mode 100644 index 82ff35e..0000000 --- a/tk3.6/library/demos/color +++ /dev/null @@ -1,32 +0,0 @@ -#!/usr/local/bin/wish -f -# -# Simple script to change colors of a window. - -if "$argc < 3" {error "Usage: color appName window option"} -set appName [lindex $argv 0] -set widget [lindex $argv 1] -set option [lindex $argv 2] -set red 0 -set green 0 -set blue 0 - -option add *Scale.sliderForeground "#cdb79e" -option add *Scale.activeForeground "#ffe4c4" -scale .red -command "color red" -label "Red Intensity" -from 0 -to 255 \ - -orient horizontal -bg "#ffaeb9" -length 250 -scale .green -command "color green" -label "Green Intensity" -from 0 -to 255 \ - -orient horizontal -bg "#43cd80" -scale .blue -command "color blue" -label "Blue Intensity" -from 0 -to 255 \ - -orient horizontal -bg "#7ec0ee" -pack .red .green .blue -side top -expand yes -fill both - -proc color {which intensity} { - global red green blue appName widget option - set $which $intensity - send $appName $widget config $option \ - [format #%02x%02x%02x $red $green $blue] -} - -bind . {destroy .} -bind . {destroy .} -focus . diff --git a/tk3.6/library/demos/dialog b/tk3.6/library/demos/dialog deleted file mode 100644 index 35b0648..0000000 --- a/tk3.6/library/demos/dialog +++ /dev/null @@ -1,53 +0,0 @@ -#!/usr/local/bin/wish -f -# -# This script generates a sample dialog box that waits for one of three -# buttons to be pressed, then prints a message and exits. - -# Create two frames in the main window. The top frame will hold the -# message and the bottom one will hold the buttons. Arrange them -# on above the other, with any extra vertical space split between -# them. - -frame .top -relief raised -border 1 -frame .bot -relief raised -border 1 -pack .top .bot -side top -fill both -expand yes - -# Create the message widget and arrange for it to be centered in the -# top frame. - -message .top.msg -text "File main.c hasn't been saved to disk since \ -it was last modified. What should I do?" -justify center \ --font -Adobe-helvetica-medium-r-normal--*-240* -aspect 200 -pack .top.msg -padx 5 -pady 5 -expand yes - -# Create the buttons and arrange them from left to right in the bottom -# frame. Embed the left button in an additional sunken frame to indicate -# that it is the default button. - -frame .bot.left -relief sunken -border 1 -pack .bot.left -side left -expand yes -padx 10 -pady 10 -button .bot.left.button -text "Save File" -command "quit save" -pack .bot.left.button -expand yes -padx 6 -pady 6 -button .bot.middle -text "Quit Anyway" -command "quit quit" -button .bot.right -text "Return To Editor" -command "quit return" -pack .bot.middle .bot.right -side left -expand yes -padx 10 - -# The procedure below is invoked as the action for each of the buttons. -# It prints a message and exits by destroying the application's main -# window. - -proc quit button { - puts stdout "You pressed the \"$button\" button; bye-bye!" - destroy . -} - -bind .top {.bot.left.button activate} -bind .top.msg {.bot.left.button activate} -bind .bot {.bot.left.button activate} -bind .top {.bot.left.button deactivate} -bind .top.msg {.bot.left.button deactivate} -bind .bot {.bot.left.button deactivate} -bind . <1> {.bot.left.button config -relief sunken} -bind . {quit save} -focus . -bind . {quit save} diff --git a/tk3.6/library/demos/mkArrow.tcl b/tk3.6/library/demos/mkArrow.tcl deleted file mode 100644 index 8204471..0000000 --- a/tk3.6/library/demos/mkArrow.tcl +++ /dev/null @@ -1,203 +0,0 @@ -# mkArrow w -# -# Create a top-level window containing a canvas demonstration that -# allows the user to experiment with arrow shapes. -# -# Arguments: -# w - Name to use for new top-level window. - -# This file implements a canvas widget that displays a large line with -# an arrowhead and allows the shape of the arrowhead to be edited -# interactively. The only procedure that should be invoked from outside -# the file is the first one, which creates the canvas. - -proc mkArrow {{w .arrow}} { - global tk_library - upvar #0 demo_arrowInfo v - catch {destroy $w} - toplevel $w - dpos $w - wm title $w "Arrowhead Editor Demonstration" - wm iconname $w "Arrow" - set c $w.c - - frame $w.frame1 -relief raised -bd 2 - canvas $c -width 500 -height 350 -relief raised - button $w.ok -text "OK" -command "destroy $w" - pack $w.frame1 -side top -fill both - pack $w.ok -side bottom -pady 5 - pack $c -expand yes -fill both - message $w.frame1.m -font -Adobe-Times-Medium-R-Normal-*-180-* -aspect 300 \ - -text "This widget allows you to experiment with different widths and arrowhead shapes for lines in canvases. To change the line width or the shape of the arrowhead, drag any of the three boxes attached to the oversized arrow. The arrows on the right give examples at normal scale. The text at the bottom shows the configuration options as you'd enter them for a line." - pack $w.frame1.m - - set v(a) 8 - set v(b) 10 - set v(c) 3 - set v(width) 2 - set v(motionProc) arrowMoveNull - set v(x1) 40 - set v(x2) 350 - set v(y) 150 - set v(smallTips) {5 5 2} - set v(count) 0 - if {[tk colormodel $c] == "color"} { - set v(bigLineStyle) "-fill SkyBlue1" - set v(boxStyle) "-fill {} -outline black -width 1" - set v(activeStyle) "-fill red -outline black -width 1" - } else { - set v(bigLineStyle) "-fill black -stipple @$tk_library/demos/bitmaps/grey.25" - set v(boxStyle) "-fill {} -outline black -width 1" - set v(activeStyle) "-fill black -outline black -width 1" - } - arrowSetup $c - $c bind box "$c itemconfigure current $v(activeStyle)" - $c bind box "$c itemconfigure current $v(boxStyle)" - $c bind box1 <1> {set demo_arrowInfo(motionProc) arrowMove1} - $c bind box2 <1> {set demo_arrowInfo(motionProc) arrowMove2} - $c bind box3 <1> {set demo_arrowInfo(motionProc) arrowMove3} - $c bind box "\$demo_arrowInfo(motionProc) $c %x %y" - bind $c "arrowSetup $c" -} - -# The procedure below completely regenerates all the text and graphics -# in the canvas window. It's called when the canvas is initially created, -# and also whenever any of the parameters of the arrow head are changed -# interactively. The argument is the name of the canvas widget to be -# regenerated, and also the name of a global variable containing the -# parameters for the display. - -proc arrowSetup c { - upvar #0 demo_arrowInfo v - $c delete all - - # Create the arrow and outline. - - eval "$c create line $v(x1) $v(y) $v(x2) $v(y) -width [expr 10*$v(width)] \ - -arrowshape {[expr 10*$v(a)] [expr 10*$v(b)] [expr 10*$v(c)]} \ - -arrow last $v(bigLineStyle)" - set xtip [expr $v(x2)-10*$v(b)] - set deltaY [expr 10*$v(c)+5*$v(width)] - $c create line $v(x2) $v(y) $xtip [expr $v(y)+$deltaY] \ - [expr $v(x2)-10*$v(a)] $v(y) $xtip [expr $v(y)-$deltaY] \ - $v(x2) $v(y) -width 2 -capstyle round -joinstyle round - - # Create the boxes for reshaping the line and arrowhead. - - eval "$c create rect [expr $v(x2)-10*$v(a)-5] [expr $v(y)-5] \ - [expr $v(x2)-10*$v(a)+5] [expr $v(y)+5] $v(boxStyle) \ - -tags {box1 box}" - eval "$c create rect [expr $xtip-5] [expr $v(y)-$deltaY-5] \ - [expr $xtip+5] [expr $v(y)-$deltaY+5] $v(boxStyle) \ - -tags {box2 box}" - eval "$c create rect [expr $v(x1)-5] [expr $v(y)-5*$v(width)-5] \ - [expr $v(x1)+5] [expr $v(y)-5*$v(width)+5] $v(boxStyle) \ - -tags {box3 box}" - - # Create three arrows in actual size with the same parameters - - $c create line [expr $v(x2)+50] 0 [expr $v(x2)+50] 1000 \ - -width 2 - set tmp [expr $v(x2)+100] - $c create line $tmp [expr $v(y)-125] $tmp [expr $v(y)-75] \ - -width $v(width) \ - -arrow both -arrowshape "$v(a) $v(b) $v(c)" - $c create line [expr $tmp-25] $v(y) [expr $tmp+25] $v(y) \ - -width $v(width) \ - -arrow both -arrowshape "$v(a) $v(b) $v(c)" - $c create line [expr $tmp-25] [expr $v(y)+75] [expr $tmp+25] \ - [expr $v(y)+125] -width $v(width) \ - -arrow both -arrowshape "$v(a) $v(b) $v(c)" - - # Create a bunch of other arrows and text items showing the - # current dimensions. - - set tmp [expr $v(x2)+10] - $c create line $tmp [expr $v(y)-5*$v(width)] \ - $tmp [expr $v(y)-$deltaY] \ - -arrow both -arrowshape $v(smallTips) - $c create text [expr $v(x2)+15] [expr $v(y)-$deltaY+5*$v(c)] \ - -text $v(c) -anchor w - set tmp [expr $v(x1)-10] - $c create line $tmp [expr $v(y)-5*$v(width)] \ - $tmp [expr $v(y)+5*$v(width)] \ - -arrow both -arrowshape $v(smallTips) - $c create text [expr $v(x1)-15] $v(y) -text $v(width) -anchor e - set tmp [expr $v(y)+5*$v(width)+10*$v(c)+10] - $c create line [expr $v(x2)-10*$v(a)] $tmp $v(x2) $tmp \ - -arrow both -arrowshape $v(smallTips) - $c create text [expr $v(x2)-5*$v(a)] [expr $tmp+5] \ - -text $v(a) -anchor n - set tmp [expr $tmp+25] - $c create line [expr $v(x2)-10*$v(b)] $tmp $v(x2) $tmp \ - -arrow both -arrowshape $v(smallTips) - $c create text [expr $v(x2)-5*$v(b)] [expr $tmp+5] \ - -text $v(b) -anchor n - - $c create text $v(x1) 310 -text "-width $v(width)" \ - -anchor w -font -Adobe-Helvetica-Medium-R-Normal-*-180-* - $c create text $v(x1) 330 -text "-arrowshape {$v(a) $v(b) $v(c)}" \ - -anchor w -font -Adobe-Helvetica-Medium-R-Normal-*-180-* - - incr v(count) -} - -# The procedures below are called in response to mouse motion for one -# of the three items used to change the line width and arrowhead shape. -# Each procedure updates one or more of the controlling parameters -# for the line and arrowhead, and recreates the display if that is -# needed. The arguments are the name of the canvas widget, and the -# x and y positions of the mouse within the widget. - -proc arrowMove1 {c x y} { - upvar #0 demo_arrowInfo v - set newA [expr ($v(x2)+5-[$c canvasx $x])/10] - if {$newA < 1} { - set newA 1 - } - if {$newA > 25} { - set newA 25 - } - if {$newA != $v(a)} { - $c move box1 [expr 10*($v(a)-$newA)] 0 - set v(a) $newA - } -} - -proc arrowMove2 {c x y} { - upvar #0 demo_arrowInfo v - set newB [expr ($v(x2)+5-[$c canvasx $x])/10] - if {$newB < 1} { - set newB 1 - } - if {$newB > 25} { - set newB 25 - } - set newC [expr ($v(y)+5-[$c canvasy $y]-5*$v(width))/10] - if {$newC < 1} { - set newC 1 - } - if {$newC > 20} { - set newC 20 - } - if {($newB != $v(b)) || ($newC != $v(c))} { - $c move box2 [expr 10*($v(b)-$newB)] [expr 10*($v(c)-$newC)] - set v(b) $newB - set v(c) $newC - } -} - -proc arrowMove3 {c x y} { - upvar #0 demo_arrowInfo v - set newWidth [expr ($v(y)+5-[$c canvasy $y])/5] - if {$newWidth < 1} { - set newWidth 1 - } - if {$newWidth > 20} { - set newWidth 20 - } - if {$newWidth != $v(width)} { - $c move box3 0 [expr 5*($v(width)-$newWidth)] - set v(width) $newWidth - } -} diff --git a/tk3.6/library/demos/mkBasic.tcl b/tk3.6/library/demos/mkBasic.tcl deleted file mode 100644 index 28a13af..0000000 --- a/tk3.6/library/demos/mkBasic.tcl +++ /dev/null @@ -1,61 +0,0 @@ -# mkBasic w -# -# Create a top-level window that displays a basic text widget. -# -# Arguments: -# w - Name to use for new top-level window. - -proc mkBasic {{w .basic}} { - catch {destroy $w} - toplevel $w - dpos $w - wm title $w "Text Demonstration - Basic Facilities" - wm iconname $w "Text Basics" - button $w.ok -text OK -command "destroy $w" - text $w.t -relief raised -bd 2 -yscrollcommand "$w.s set" -setgrid true - scrollbar $w.s -relief flat -command "$w.t yview" - pack $w.ok -side bottom -fill x - pack $w.s -side right -fill y - pack $w.t -expand yes -fill both - $w.t insert 0.0 {\ -This window is a text widget. It displays one or more lines of text -and allows you to edit the text. Here is a summary of the things you -can do to a text widget: - -1. Scrolling. Use the scrollbar to adjust the view in the text window. - -2. Scanning. Press mouse button 2 in the text window and drag up or down. -This will drag the text at high speed to allow you to scan its contents. - -3. Insert text. Press mouse button 1 to set the insertion cursor, then -type text. What you type will be added to the widget. You can backspace -over what you've typed using either the backspace key, the delete key, -or Control+h. - -4. Select. Press mouse button 1 and drag to select a range of characters. -Once you've released the button, you can adjust the selection by pressing -button 1 with the shift key down. This will reset the end of the -selection nearest the mouse cursor and you can drag that end of the -selection by dragging the mouse before releasing the mouse button. -You can double-click to select whole words, or triple-click to select -whole lines. - -5. Delete. To delete text, select the characters you'd like to delete -and type Control+d. - -6. Copy the selection. To copy the selection either from this window -or from any other window or application, select what you want, click -button 1 to set the insertion cursor, then type Control+v to copy the -selection to the point of the insertion cursor. - -7. Resize the window. This widget has been configured with the "setGrid" -option on, so that if you resize the window it will always resize to an -even number of characters high and wide. Also, if you make the window -narrow you can see that long lines automatically wrap around onto -additional lines so that all the information is always visible. - -When you're finished with this demonstration, press the "OK" button -below.} - $w.t mark set insert 0.0 - bind $w "focus $w.t" -} diff --git a/tk3.6/library/demos/mkBitmaps.tcl b/tk3.6/library/demos/mkBitmaps.tcl deleted file mode 100644 index f8994a6..0000000 --- a/tk3.6/library/demos/mkBitmaps.tcl +++ /dev/null @@ -1,46 +0,0 @@ -# mkBitmaps w -# -# Create a top-level window that displays all of Tk's built-in bitmaps. -# -# Arguments: -# w - Name to use for new top-level window. - -proc mkBitmaps {{w .bitmaps}} { - global tk_library - catch {destroy $w} - toplevel $w - dpos $w - wm title $w "Bitmap Demonstration" - wm iconname $w "Bitmaps" - message $w.msg -font -Adobe-times-medium-r-normal--*-180* -width 4i \ - -text "This window displays all of Tk's built-in bitmaps, along with the names you can use for them in Tcl scripts. Click the \"OK\" button when you've seen enough." - frame $w.frame - bitmapRow $w.frame.0 error gray25 gray50 hourglass - bitmapRow $w.frame.1 info question questhead warning - button $w.ok -text OK -command "destroy $w" - pack $w.msg -side top -anchor center - pack $w.frame -side top -expand yes -fill both - pack $w.ok -side bottom -fill both -} - -# The procedure below creates a new row of bitmaps in a window. Its -# arguments are: -# -# w - The window that is to contain the row. -# args - The names of one or more bitmaps, which will be displayed -# in a new row across the bottom of w along with their -# names. - -proc bitmapRow {w args} { - frame $w - pack $w -side top -fill both - set i 0 - foreach bitmap $args { - frame $w.$i - pack $w.$i -side left -fill both -pady .25c -padx .25c - label $w.$i.bitmap -bitmap $bitmap - label $w.$i.label -text $bitmap -width 9 - pack $w.$i.label $w.$i.bitmap -side bottom - incr i - } -} diff --git a/tk3.6/library/demos/mkButton.tcl b/tk3.6/library/demos/mkButton.tcl deleted file mode 100644 index e112b8f..0000000 --- a/tk3.6/library/demos/mkButton.tcl +++ /dev/null @@ -1,33 +0,0 @@ -# mkButton w -# -# Create a top-level window that displays a bunch of buttons. -# -# Arguments: -# w - Name to use for new top-level window. - -proc mkButton {{w .b1}} { - catch {destroy $w} - toplevel $w - dpos $w - wm title $w "Button Demonstration" - wm iconname $w "Buttons" - message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ - -text "Four buttons are displayed below. If you click on a button, it will change the background of the button area to the color indicated in the button. Click the \"OK\" button when you've seen enough." - frame $w.frame -borderwidth 10 - button $w.ok -text OK -command "destroy $w" - - pack $w.msg -side top -fill both - pack $w.frame -side top -expand yes -fill both - pack $w.ok -side bottom -fill both - - button $w.frame.b1 -text "Peach Puff" \ - -command "$w.frame config -bg PeachPuff1" - button $w.frame.b2 -text "Light Blue" \ - -command "$w.frame config -bg LightBlue1" - button $w.frame.b3 -text "Sea Green" \ - -command "$w.frame config -bg SeaGreen2" - button $w.frame.b4 -text "Yellow" \ - -command "$w.frame config -bg Yellow1" - pack $w.frame.b1 $w.frame.b2 $w.frame.b3 $w.frame.b4 -side top \ - -expand yes -pady 2 -} diff --git a/tk3.6/library/demos/mkCanvText.tcl b/tk3.6/library/demos/mkCanvText.tcl deleted file mode 100644 index 4bd28b1..0000000 --- a/tk3.6/library/demos/mkCanvText.tcl +++ /dev/null @@ -1,110 +0,0 @@ -# mkCanvText w -# -# Create a top-level window containing a canvas displaying a text -# string and allowing the string to be edited and re-anchored. -# -# Arguments: -# w - Name to use for new top-level window. - -proc mkCanvText {{w .ctext}} { - catch {destroy $w} - toplevel $w - dpos $w - wm title $w "Canvas Text Demonstration" - wm iconname $w "Text" - set c $w.c - - message $w.msg -font -Adobe-Times-Medium-R-Normal-*-180-* -width 420 \ - -relief raised -bd 2 -text "This window displays a string of text to demonstrate the text facilities of canvas widgets. You can point, click, and type. You can also select and then delete with Control-d. You can copy the selection with Control-v. You can click in the boxes to adjust the position of the text relative to its positioning point or change its justification." - canvas $c -relief raised -width 500 -height 400 - button $w.ok -text "OK" -command "destroy $w" - pack $w.msg -side top -fill both - pack $w.c -side top -expand yes -fill both - pack $w.ok -side bottom -pady 5 -anchor center - - set font -Adobe-helvetica-medium-r-*-240-* - - $c create rectangle 245 195 255 205 -outline black -fill red - - # First, create the text item and give it bindings so it can be edited. - - $c addtag text withtag [$c create text 250 200 -text "This is just a string of text to demonstrate the text facilities of canvas widgets. You can point, click, and type. You can also select and then delete with Control-d." -width 440 -anchor n -font $font -justify left] - $c bind text <1> "textB1Press $c %x %y" - $c bind text "textB1Move $c %x %y" - $c bind text "$c select adjust current @%x,%y" - $c bind text "textB1Move $c %x %y" - $c bind text "$c insert text insert %A" - $c bind text "$c insert text insert %A" - $c bind text "$c insert text insert \\n" - $c bind text "textBs $c" - $c bind text "textBs $c" - $c bind text "$c dchars text sel.first sel.last" - $c bind text "$c insert text insert \[selection get\]" - - # Next, create some items that allow the text's anchor position - # to be edited. - - set x 50 - set y 50 - set color LightSkyBlue1 - mkTextConfig $c $x $y -anchor se $color - mkTextConfig $c [expr $x+30] [expr $y] -anchor s $color - mkTextConfig $c [expr $x+60] [expr $y] -anchor sw $color - mkTextConfig $c [expr $x] [expr $y+30] -anchor e $color - mkTextConfig $c [expr $x+30] [expr $y+30] -anchor center $color - mkTextConfig $c [expr $x+60] [expr $y+30] -anchor w $color - mkTextConfig $c [expr $x] [expr $y+60] -anchor ne $color - mkTextConfig $c [expr $x+30] [expr $y+60] -anchor n $color - mkTextConfig $c [expr $x+60] [expr $y+60] -anchor nw $color - set item [$c create rect [expr $x+40] [expr $y+40] [expr $x+50] [expr $y+50] \ - -outline black -fill red] - $c bind $item <1> "$c itemconf text -anchor center" - $c create text [expr $x+45] [expr $y-5] -text {Text Position} -anchor s \ - -font -Adobe-times-medium-r-normal--*-240-* -fill brown - - # Lastly, create some items that allow the text's justification to be - # changed. - - set x 350 - set y 50 - set color SeaGreen2 - mkTextConfig $c $x $y -justify left $color - mkTextConfig $c [expr $x+30] [expr $y] -justify center $color - mkTextConfig $c [expr $x+60] [expr $y] -justify right $color - $c create text [expr $x+45] [expr $y-5] -text {Justification} -anchor s \ - -font -Adobe-times-medium-r-normal--*-240-* -fill brown - - $c bind config "textEnter $c" - $c bind config "$c itemconf current -fill \$textConfigFill" -} - -proc mkTextConfig {w x y option value color} { - set item [$w create rect [expr $x] [expr $y] [expr $x+30] [expr $y+30] \ - -outline black -fill $color -width 1] - $w bind $item <1> "$w itemconf text $option $value" - $w addtag config withtag $item -} - -set textConfigFill {} - -proc textEnter {w} { - global textConfigFill - set textConfigFill [lindex [$w itemconfig current -fill] 4] - $w itemconfig current -fill black -} - -proc textB1Press {w x y} { - $w icursor current @$x,$y - $w focus current - focus $w - $w select from current @$x,$y -} - -proc textB1Move {w x y} { - $w select to current @$x,$y -} - -proc textBs {w} { - set char [expr {[$w index text insert] - 1}] - if {$char >= 0} {$w dchar text $char} -} diff --git a/tk3.6/library/demos/mkCheck.tcl b/tk3.6/library/demos/mkCheck.tcl deleted file mode 100644 index 42451ce..0000000 --- a/tk3.6/library/demos/mkCheck.tcl +++ /dev/null @@ -1,33 +0,0 @@ -# mkCheck w -# -# Create a top-level window that displays a bunch of check buttons. -# -# Arguments: -# w - Name to use for new top-level window. - -proc mkCheck {{w .c1}} { - catch {destroy $w} - toplevel $w - dpos $w - wm title $w "Checkbutton demonstration" - wm iconname $w "Checkbuttons" - message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ - -text "Three checkbuttons are displayed below. If you click on a button, it will toggle the button's selection state and set a Tcl variable to a value indicating the state of the checkbutton. Click the \"See Variables\" button to see the current values of the variables. Click the \"OK\" button when you've seen enough." - frame $w.frame -borderwidth 10 - frame $w.frame2 - - pack $w.msg -side top -fill both - pack $w.frame -side top -expand yes -fill both - pack $w.frame2 -side bottom -fill both - - checkbutton $w.frame.b1 -text "Wipers OK" -variable wipers -relief flat - checkbutton $w.frame.b2 -text "Brakes OK" -variable brakes -relief flat - checkbutton $w.frame.b3 -text "Driver Sober" -variable sober -relief flat - pack $w.frame.b1 $w.frame.b2 $w.frame.b3 -side top -pady 2 -expand yes \ - -anchor w - - button $w.frame2.ok -text OK -command "destroy $w" - button $w.frame2.vars -text "See Variables" \ - -command "showVars $w.dialog wipers brakes sober" - pack $w.frame2.ok $w.frame2.vars -side left -expand yes -fill both -} diff --git a/tk3.6/library/demos/mkDialog.tcl b/tk3.6/library/demos/mkDialog.tcl deleted file mode 100644 index ce34202..0000000 --- a/tk3.6/library/demos/mkDialog.tcl +++ /dev/null @@ -1,63 +0,0 @@ -# mkDialog w msgArgs list list ... -# -# Create a dialog box with a message and any number of buttons at -# the bottom. -# -# Arguments: -# w - Name to use for new top-level window. -# msgArgs - List of arguments to use when creating the message of the -# dialog box (e.g. text, justifcation, etc.) -# list - A two-element list that describes one of the buttons that -# will appear at the bottom of the dialog. The first element -# gives the text to be displayed in the button and the second -# gives the command to be invoked when the button is invoked. - -proc mkDialog {w msgArgs args} { - catch {destroy $w} - toplevel $w -class Dialog - wm title $w "Dialog box" - wm iconname $w "Dialog" - - # Create two frames in the main window. The top frame will hold the - # message and the bottom one will hold the buttons. Arrange them - # one above the other, with any extra vertical space split between - # them. - - frame $w.top -relief raised -border 1 - frame $w.bot -relief raised -border 1 - pack $w.top $w.bot -side top -fill both -expand yes - - # Create the message widget and arrange for it to be centered in the - # top frame. - - eval message $w.top.msg -justify center \ - -font -Adobe-times-medium-r-normal--*-180* $msgArgs - pack $w.top.msg -side top -expand yes -padx 3 -pady 3 - - # Create as many buttons as needed and arrange them from left to right - # in the bottom frame. Embed the left button in an additional sunken - # frame to indicate that it is the default button, and arrange for that - # button to be invoked as the default action for clicks and returns in - # the dialog. - - if {[llength $args] > 0} { - set arg [lindex $args 0] - frame $w.bot.0 -relief sunken -border 1 - pack $w.bot.0 -side left -expand yes -padx 10 -pady 10 - button $w.bot.0.button -text [lindex $arg 0] \ - -command "[lindex $arg 1]; destroy $w" - pack $w.bot.0.button -expand yes -padx 6 -pady 6 - bind $w "[lindex $arg 1]; destroy $w" - focus $w - - set i 1 - foreach arg [lrange $args 1 end] { - button $w.bot.$i -text [lindex $arg 0] \ - -command "[lindex $arg 1]; destroy $w" - pack $w.bot.$i -side left -expand yes -padx 10 - set i [expr $i+1] - } - } - bind $w [list focus $w] - focus $w -} diff --git a/tk3.6/library/demos/mkEntry.tcl b/tk3.6/library/demos/mkEntry.tcl deleted file mode 100644 index da0266c..0000000 --- a/tk3.6/library/demos/mkEntry.tcl +++ /dev/null @@ -1,29 +0,0 @@ -# mkEntry w -# -# Create a top-level window that displays a bunch of entries. -# -# Arguments: -# w - Name to use for new top-level window. - -proc mkEntry {{w .e1}} { - catch {destroy $w} - toplevel $w - dpos $w - wm title $w "Entry Demonstration" - wm iconname $w "Entries" - message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 200 \ - -text "Three different entries are displayed below. You can add characters by pointing, clicking and typing. You can delete by selecting and typing Control-d. Backspace, Control-h, and Delete may be typed to erase the character just before the insertion point, Control-W erases the word just before the insertion point, and Control-u clears the entry. For entries that are too large to fit in the window all at once, you can scan through the entries by dragging with mouse button 2 pressed. Click the \"OK\" button when you've seen enough." - frame $w.frame -borderwidth 10 - button $w.ok -text OK -command "destroy $w" - pack $w.msg $w.frame $w.ok -side top -fill both - - entry $w.frame.e1 -relief sunken - entry $w.frame.e2 -relief sunken - entry $w.frame.e3 -relief sunken - pack $w.frame.e1 $w.frame.e2 $w.frame.e3 -side top -pady 5 -fill x - - $w.frame.e1 insert 0 "Initial value" - $w.frame.e2 insert end "This entry contains a long value, much too long " - $w.frame.e2 insert end "to fit in the window at one time, so long in fact " - $w.frame.e2 insert end "that you'll have to scan or scroll to see the end." -} diff --git a/tk3.6/library/demos/mkEntry2.tcl b/tk3.6/library/demos/mkEntry2.tcl deleted file mode 100644 index bfc5c55..0000000 --- a/tk3.6/library/demos/mkEntry2.tcl +++ /dev/null @@ -1,39 +0,0 @@ -# mkEntry2 - -# -# Create a top-level window that displays a bunch of entries with -# scrollbars. -# -# Arguments: -# w - Name to use for new top-level window. - -proc mkEntry2 {{w .e2}} { - catch {destroy $w} - toplevel $w - dpos $w - wm title $w "Entry Demonstration" - wm iconname $w "Entries" - message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 200 \ - -text "Three different entries are displayed below, with a scrollbar for each entry. You can add characters by pointing, clicking and typing. You can delete by selecting and typing Control-d. Backspace, Control-h, and Delete may be typed to erase the character just before the insertion point, Control-W erases the word just before the insertion point, and Control-u clears the entry. For entries that are too large to fit in the window all at once, you can scan through the entries using the scrollbars, or by dragging with mouse button 2 pressed. Click the \"OK\" button when you've seen enough." - frame $w.frame -borderwidth 10 - button $w.ok -text OK -command "destroy $w" - pack $w.msg $w.frame $w.ok -side top -fill both - - entry $w.frame.e1 -relief sunken -scroll "$w.frame.s1 set" - scrollbar $w.frame.s1 -relief sunken -orient horiz -command \ - "$w.frame.e1 view" - frame $w.frame.f1 -geometry 20x10 - entry $w.frame.e2 -relief sunken -scroll "$w.frame.s2 set" - scrollbar $w.frame.s2 -relief sunken -orient horiz -command \ - "$w.frame.e2 view" - frame $w.frame.f2 -geometry 20x10 - entry $w.frame.e3 -relief sunken -scroll "$w.frame.s3 set" - scrollbar $w.frame.s3 -relief sunken -orient horiz -command \ - "$w.frame.e3 view" - pack $w.frame.e1 $w.frame.s1 $w.frame.f1 $w.frame.e2 $w.frame.s2 \ - $w.frame.f2 $w.frame.e3 $w.frame.s3 -side top -fill x - - $w.frame.e1 insert 0 "Initial value" - $w.frame.e2 insert end "This entry contains a long value, much too long " - $w.frame.e2 insert end "to fit in the window at one time, so long in fact " - $w.frame.e2 insert end "that you'll have to scan or scroll to see the end." -} diff --git a/tk3.6/library/demos/mkForm.tcl b/tk3.6/library/demos/mkForm.tcl deleted file mode 100644 index a8971f0..0000000 --- a/tk3.6/library/demos/mkForm.tcl +++ /dev/null @@ -1,52 +0,0 @@ -# mkForm w -# -# Create a top-level window that displays a bunch of entries with -# tabs set up to move between them. -# -# Arguments: -# w - Name to use for new top-level window. - -proc mkForm {{w .form}} { - global tabList - catch {destroy $w} - toplevel $w - dpos $w - wm title $w "Form Demonstration" - wm iconname $w "Form" - message $w.msg -font -Adobe-times-medium-r-normal--*-180* -width 4i \ - -text "This window contains a simple form where you can type in the various entries and use tabs to move circularly between the entries. Click the \"OK\" button or type return when you're done." - foreach i {f1 f2 f3 f4 f5} { - frame $w.$i -bd 1m - entry $w.$i.entry -relief sunken -width 40 - bind $w.$i.entry "Tab \$tabList" - bind $w.$i.entry "destroy $w" - label $w.$i.label - pack $w.$i.entry -side right - pack $w.$i.label -side left - } - $w.f1.label config -text Name: - $w.f2.label config -text Address: - $w.f5.label config -text Phone: - button $w.ok -text OK -command "destroy $w" - pack $w.msg $w.f1 $w.f2 $w.f3 $w.f4 $w.f5 $w.ok -side top -fill x - set tabList "$w.f1.entry $w.f2.entry $w.f3.entry $w.f4.entry $w.f5.entry" -} - -# The procedure below is invoked in response to tabs in the entry -# windows. It moves the focus to the next window in the tab list. -# Arguments: -# -# list - Ordered list of windows to receive focus - -proc Tab {list} { - set i [lsearch $list [focus]] - if {$i < 0} { - set i 0 - } else { - incr i - if {$i >= [llength $list]} { - set i 0 - } - } - focus [lindex $list $i] -} diff --git a/tk3.6/library/demos/mkHScale.tcl b/tk3.6/library/demos/mkHScale.tcl deleted file mode 100644 index c1eee83..0000000 --- a/tk3.6/library/demos/mkHScale.tcl +++ /dev/null @@ -1,35 +0,0 @@ -# mkHScale w -# -# Create a top-level window that displays a horizontal scale. -# -# Arguments: -# w - Name to use for new top-level window. - -proc mkHScale {{w .scale2}} { - catch {destroy $w} - toplevel $w - dpos $w - wm title $w "Horizontal Scale Demonstration" - wm iconname $w "Scale" - message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ - -text "A bar and a horizontal scale are displayed below. If you click or drag mouse button 1 in the scale, you can change the width of the bar. Click the \"OK\" button when you're finished." - frame $w.frame -borderwidth 10 - button $w.ok -text OK -command "destroy $w" - pack $w.msg $w.frame $w.ok -side top -fill x - - frame $w.frame.top -borderwidth 15 - scale $w.frame.scale -orient horizontal -length 280 -from 0 -to 250 \ - -command "setWidth $w.frame.top.inner" -tickinterval 50 \ - -bg Bisque1 - pack $w.frame.top -side top -expand yes -anchor sw - pack $w.frame.scale -side bottom -expand yes -anchor nw - - frame $w.frame.top.inner -geometry 20x40 -relief raised -borderwidth 2 \ - -bg SteelBlue1 - pack $w.frame.top.inner -expand yes -anchor sw - $w.frame.scale set 20 -} - -proc setWidth {w width} { - $w config -geometry ${width}x40 -} diff --git a/tk3.6/library/demos/mkIcon.tcl b/tk3.6/library/demos/mkIcon.tcl deleted file mode 100644 index 247e2fe..0000000 --- a/tk3.6/library/demos/mkIcon.tcl +++ /dev/null @@ -1,43 +0,0 @@ -# mkIcon w -# -# Create a top-level window that displays a bunch of iconic -# buttons. -# -# Arguments: -# w - Name to use for new top-level window. - -proc mkIcon {{w .icon}} { - global tk_library - catch {destroy $w} - toplevel $w - dpos $w - wm title $w "Iconic Button Demonstration" - wm iconname $w "Icons" - message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ - -text "This window shows three buttons that display bitmaps instead of text. On the left is a regular button, which changes its bitmap when you click on it. On the right are two radio buttons. Click the \"OK\" button when you're done." - frame $w.frame -borderwidth 10 - button $w.ok -text OK -command "destroy $w" - pack $w.msg -side top - pack $w.frame $w.ok -side top -fill x - - button $w.frame.b1 -bitmap @$tk_library/demos/bitmaps/flagdown \ - -command "iconCmd $w.frame.b1" - frame $w.frame.right - pack $w.frame.b1 $w.frame.right -side left -expand yes - - radiobutton $w.frame.right.b2 -bitmap @$tk_library/demos/bitmaps/letters \ - -variable letters - radiobutton $w.frame.right.b3 -bitmap @$tk_library/demos/bitmaps/noletters \ - -variable letters - pack $w.frame.right.b2 $w.frame.right.b3 -side top -expand yes -} - -proc iconCmd {w} { - global tk_library - set bitmap [lindex [$w config -bitmap] 4] - if {$bitmap == "@$tk_library/demos/bitmaps/flagdown"} { - $w config -bitmap @$tk_library/demos/bitmaps/flagup - } else { - $w config -bitmap @$tk_library/demos/bitmaps/flagdown - } -} diff --git a/tk3.6/library/demos/mkItems.tcl b/tk3.6/library/demos/mkItems.tcl deleted file mode 100644 index 80e1e06..0000000 --- a/tk3.6/library/demos/mkItems.tcl +++ /dev/null @@ -1,271 +0,0 @@ -# mkItems w -# -# Create a top-level window containing a canvas that displays the -# various item types and allows them to be selected and moved. This -# demo can be used to test out the point-hit and rectangle-hit code -# for items. -# -# Arguments: -# w - Name to use for new top-level window. - -proc mkItems {{w .citems}} { - global c tk_library - catch {destroy $w} - toplevel $w - dpos $w - wm title $w "Canvas Item Demonstration" - wm iconname $w "Items" - wm minsize $w 100 100 - set c $w.frame2.c - - message $w.msg -font -Adobe-Times-Medium-R-Normal--*-180-* -width 13c \ - -bd 2 -relief raised -text "This window contains a canvas widget with examples of the various kinds of items supported by canvases. The following operations are supported:\n Button-1 drag:\tmoves item under pointer.\n Button-2 drag:\trepositions view.\n Button-3 drag:\tstrokes out area.\n Ctrl+f:\t\tprints items under area." - frame $w.frame2 -relief raised -bd 2 - button $w.ok -text "OK" -command "destroy $w" - pack $w.msg -side top -fill x - pack $w.frame2 -side top -fill both -expand yes - pack $w.ok -side bottom -pady 5 -anchor center - - canvas $c -scrollregion {0c 0c 30c 24c} -width 15c -height 10c \ - -xscroll "$w.frame2.hscroll set" -yscroll "$w.frame2.vscroll set" - scrollbar $w.frame2.vscroll -relief sunken -command "$c yview" - scrollbar $w.frame2.hscroll -orient horiz -relief sunken -command "$c xview" - pack $w.frame2.hscroll -side bottom -fill x - pack $w.frame2.vscroll -side right -fill y - pack $c -in $w.frame2 -expand yes -fill both - - # Display a 3x3 rectangular grid. - - $c create rect 0c 0c 30c 24c -width 2 - $c create line 0c 8c 30c 8c -width 2 - $c create line 0c 16c 30c 16c -width 2 - $c create line 10c 0c 10c 24c -width 2 - $c create line 20c 0c 20c 24c -width 2 - - set font1 -Adobe-Helvetica-Medium-R-Normal--*-120-* - set font2 -Adobe-Helvetica-Bold-R-Normal--*-240-* - if {[tk colormodel $c] == "color"} { - set blue DeepSkyBlue3 - set red red - set bisque bisque3 - set green SeaGreen3 - } else { - set blue black - set red black - set bisque black - set green black - } - - # Set up demos within each of the areas of the grid. - - $c create text 5c .2c -text Lines -anchor n - $c create line 1c 1c 3c 1c 1c 4c 3c 4c -width 2m -fill $blue \ - -cap butt -join miter -tags item - $c create line 4.67c 1c 4.67c 4c -arrow last -tags item - $c create line 6.33c 1c 6.33c 4c -arrow both -tags item - $c create line 5c 6c 9c 6c 9c 1c 8c 1c 8c 4.8c 8.8c 4.8c 8.8c 1.2c \ - 8.2c 1.2c 8.2c 4.6c 8.6c 4.6c 8.6c 1.4c 8.4c 1.4c 8.4c 4.4c \ - -width 3 -fill $red -tags item - $c create line 1c 5c 7c 5c 7c 7c 9c 7c -width .5c \ - -stipple @$tk_library/demos/bitmaps/grey.25 \ - -arrow both -arrowshape {15 15 7} -tags item - $c create line 1c 7c 1.75c 5.8c 2.5c 7c 3.25c 5.8c 4c 7c -width .5c \ - -cap round -join round -tags item - - $c create text 15c .2c -text "Curves (smoothed lines)" -anchor n - $c create line 11c 4c 11.5c 1c 13.5c 1c 14c 4c -smooth on \ - -fill $blue -tags item - $c create line 15.5c 1c 19.5c 1.5c 15.5c 4.5c 19.5c 4c -smooth on \ - -arrow both -width 3 -tags item - $c create line 12c 6c 13.5c 4.5c 16.5c 7.5c 18c 6c \ - 16.5c 4.5c 13.5c 7.5c 12c 6c -smooth on -width 3m -cap round \ - -stipple @$tk_library/demos/bitmaps/grey.25 -fill $red -tags item - - $c create text 25c .2c -text Polygons -anchor n - $c create polygon 21c 1.0c 22.5c 1.75c 24c 1.0c 23.25c 2.5c \ - 24c 4.0c 22.5c 3.25c 21c 4.0c 21.75c 2.5c -fill $green -tags item - $c create polygon 25c 4c 25c 4c 25c 1c 26c 1c 27c 4c 28c 1c \ - 29c 1c 29c 4c 29c 4c -fill $red -smooth on -tags item - $c create polygon 22c 4.5c 25c 4.5c 25c 6.75c 28c 6.75c \ - 28c 5.25c 24c 5.25c 24c 6.0c 26c 6c 26c 7.5c 22c 7.5c \ - -stipple @$tk_library/demos/bitmaps/grey.25 -tags item - - $c create text 5c 8.2c -text Rectangles -anchor n - $c create rectangle 1c 9.5c 4c 12.5c -outline $red -width 3m -tags item - $c create rectangle 0.5c 13.5c 4.5c 15.5c -fill $green -tags item - $c create rectangle 6c 10c 9c 15c -outline {} \ - -stipple @$tk_library/demos/bitmaps/grey.25 -fill $blue -tags item - - $c create text 15c 8.2c -text Ovals -anchor n - $c create oval 11c 9.5c 14c 12.5c -outline $red -width 3m -tags item - $c create oval 10.5c 13.5c 14.5c 15.5c -fill $green -tags item - $c create oval 16c 10c 19c 15c -outline {} \ - -stipple @$tk_library/demos/bitmaps/grey.25 -fill $blue -tags item - - $c create text 25c 8.2c -text Text -anchor n - $c create rectangle 22.4c 8.9c 22.6c 9.1c - $c create text 22.5c 9c -anchor n -font $font1 -width 4c \ - -text "A short string of text, word-wrapped, justified left, and anchored north (at the top). The rectangles show the anchor points for each piece of text." -tags item - $c create rectangle 25.4c 10.9c 25.6c 11.1c - $c create text 25.5c 11c -anchor w -font $font1 -fill $blue \ - -text "Several lines,\n each centered\nindividually,\nand all anchored\nat the left edge." \ - -justify center -tags item - $c create rectangle 24.9c 13.9c 25.1c 14.1c - $c create text 25c 14c -font $font2 -anchor c -fill $red \ - -stipple @$tk_library/demos/bitmaps/grey.5 \ - -text "Stippled characters" -tags item - - $c create text 5c 16.2c -text Arcs -anchor n - $c create arc 0.5c 17c 7c 20c -fill $green -outline black \ - -start 45 -extent 270 -style pieslice -tags item - $c create arc 6.5c 17c 9.5c 20c -width 4m -style arc \ - -fill $blue -start -135 -extent 270 \ - -stipple @$tk_library/demos/bitmaps/grey.25 -tags item - $c create arc 0.5c 20c 9.5c 24c -width 4m -style pieslice \ - -fill {} -outline $red -start 225 -extent -90 -tags item - $c create arc 5.5c 20.5c 9.5c 23.5c -width 4m -style chord \ - -fill $blue -outline {} -start 45 -extent 270 -tags item - - $c create text 15c 16.2c -text Bitmaps -anchor n - $c create bitmap 13c 20c -bitmap @$tk_library/demos/bitmaps/face -tags item - $c create bitmap 17c 18.5c \ - -bitmap @$tk_library/demos/bitmaps/noletters -tags item - $c create bitmap 17c 21.5c \ - -bitmap @$tk_library/demos/bitmaps/letters -tags item - - $c create text 25c 16.2c -text Windows -anchor n - button $c.button -text "Press Me" -command "butPress $c $red" - $c create window 21c 18c -window $c.button -anchor nw -tags item - entry $c.entry -width 20 -relief sunken - $c.entry insert end "Edit this text" - $c create window 21c 21c -window $c.entry -anchor nw -tags item - scale $c.scale -from 0 -to 100 -length 6c -sliderlength .4c \ - -width .5c -tickinterval 0 - $c create window 28.5c 17.5c -window $c.scale -anchor n -tags item - $c create text 21c 17.9c -text Button: -anchor sw - $c create text 21c 20.9c -text Entry: -anchor sw - $c create text 28.5c 17.4c -text Scale: -anchor s - - # Set up event bindings for canvas: - - $c bind item "itemEnter $c" - $c bind item "itemLeave $c" - bind $c <2> "$c scan mark %x %y" - bind $c "$c scan dragto %x %y" - bind $c <3> "itemMark $c %x %y" - bind $c "itemStroke $c %x %y" - bind $c "itemsUnderArea $c" - bind $c <1> "itemStartDrag $c %x %y" - bind $c "itemDrag $c %x %y" - bind $w "focus $c" -} - -# Utility procedures for highlighting the item under the pointer: - -proc itemEnter {c} { - global restoreCmd - - if {[tk colormodel $c] != "color"} { - set restoreCmd {} - return - } - set type [$c type current] - if {$type == "window"} { - set restoreCmd {} - return - } - if {$type == "bitmap"} { - set bg [lindex [$c itemconf current -background] 4] - set restoreCmd [list $c itemconfig current -background $bg] - $c itemconfig current -background SteelBlue2 - return - } - set fill [lindex [$c itemconfig current -fill] 4] - if {(($type == "rectangle") || ($type == "oval") || ($type == "arc")) - && ($fill == "")} { - set outline [lindex [$c itemconfig current -outline] 4] - set restoreCmd "$c itemconfig current -outline $outline" - $c itemconfig current -outline SteelBlue2 - } else { - set restoreCmd "$c itemconfig current -fill $fill" - $c itemconfig current -fill SteelBlue2 - } -} - -proc itemLeave {c} { - global restoreCmd - - eval $restoreCmd -} - -# Utility procedures for stroking out a rectangle and printing what's -# underneath the rectangle's area. - -proc itemMark {c x y} { - global areaX1 areaY1 - set areaX1 [$c canvasx $x] - set areaY1 [$c canvasy $y] - $c delete area -} - -proc itemStroke {c x y} { - global areaX1 areaY1 areaX2 areaY2 - set x [$c canvasx $x] - set y [$c canvasy $y] - if {($areaX1 != $x) && ($areaY1 != $y)} { - $c delete area - $c addtag area withtag [$c create rect $areaX1 $areaY1 $x $y \ - -outline black] - set areaX2 $x - set areaY2 $y - } -} - -proc itemsUnderArea {c} { - global areaX1 areaY1 areaX2 areaY2 - set area [$c find withtag area] - set items "" - foreach i [$c find enclosed $areaX1 $areaY1 $areaX2 $areaY2] { - if {[lsearch [$c gettags $i] item] != -1} { - lappend items $i - } - } - puts stdout "Items enclosed by area: $items" - set items "" - foreach i [$c find overlapping $areaX1 $areaY1 $areaX2 $areaY2] { - if {[lsearch [$c gettags $i] item] != -1} { - lappend items $i - } - } - puts stdout "Items overlapping area: $items" -} - -set areaX1 0 -set areaY1 0 -set areaX2 0 -set areaY2 0 - -# Utility procedures to support dragging of items. - -proc itemStartDrag {c x y} { - global lastX lastY - set lastX [$c canvasx $x] - set lastY [$c canvasy $y] -} - -proc itemDrag {c x y} { - global lastX lastY - set x [$c canvasx $x] - set y [$c canvasy $y] - $c move current [expr $x-$lastX] [expr $y-$lastY] - set lastX $x - set lastY $y -} - -# Procedure that's invoked when the button embedded in the canvas -# is invoked. - -proc butPress {w color} { - set i [$w create text 25c 18.1c -text "Ouch!!" -fill $color -anchor n] - after 500 "$w delete $i" -} diff --git a/tk3.6/library/demos/mkLabel.tcl b/tk3.6/library/demos/mkLabel.tcl deleted file mode 100644 index 33514df..0000000 --- a/tk3.6/library/demos/mkLabel.tcl +++ /dev/null @@ -1,34 +0,0 @@ -# mkLabel w -# -# Create a top-level window that displays a bunch of labels. -# -# Arguments: -# w - Name to use for new top-level window. - -proc mkLabel {{w .l1}} { - global tk_library - catch {destroy $w} - toplevel $w - dpos $w - wm title $w "Label Demonstration" - wm iconname $w "Labels" - message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ - -text "Five labels are displayed below: three textual ones on the left, and a bitmap label and a text label on the right. Labels are pretty boring because you can't do anything with them. Click the \"OK\" button when you've seen enough." - frame $w.left - frame $w.right - button $w.ok -text OK -command "destroy $w" - pack $w.msg -side top - pack $w.ok -side bottom -fill x - pack $w.left $w.right -side left -expand yes -padx 10 -pady 10 -fill both - - label $w.left.l1 -text "First label" - label $w.left.l2 -text "Second label, raised just for fun" -relief raised - label $w.left.l3 -text "Third label, sunken" -relief sunken - pack $w.left.l1 $w.left.l2 $w.left.l3 \ - -side top -expand yes -pady 2 -anchor w - - label $w.right.bitmap -bitmap @$tk_library/demos/bitmaps/face \ - -borderwidth 2 -relief sunken - label $w.right.caption -text "Tcl/Tk Proprietor" - pack $w.right.bitmap $w.right.caption -side top -} diff --git a/tk3.6/library/demos/mkListbox.tcl b/tk3.6/library/demos/mkListbox.tcl deleted file mode 100644 index a116170..0000000 --- a/tk3.6/library/demos/mkListbox.tcl +++ /dev/null @@ -1,41 +0,0 @@ -# mkListbox w -# -# Create a top-level window that displays a listbox with the names of the -# 50 states. -# -# Arguments: -# w - Name to use for new top-level window. - -proc mkListbox {{w .l1}} { - catch {destroy $w} - toplevel $w - dpos $w - wm title $w "Listbox Demonstration (50 states)" - wm iconname $w "Listbox" - wm minsize $w 1 1 - - message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ - -text "A listbox containing the 50 states is displayed below, along with a scrollbar. You can scan the list either using the scrollbar or by dragging in the listbox window with button 2 pressed. Click the \"OK\" button when you've seen enough." - frame $w.frame -borderwidth 10 - button $w.ok -text OK -command "destroy $w" - pack $w.msg -side top - pack $w.frame -side top -expand yes -fill y - pack $w.ok -side bottom -fill x - - scrollbar $w.frame.scroll -relief sunken -command "$w.frame.list yview" - listbox $w.frame.list -yscroll "$w.frame.scroll set" -relief sunken \ - -setgrid 1 - pack $w.frame.scroll -side right -fill y - pack $w.frame.list -side left -expand yes -fill both - - $w.frame.list insert 0 Alabama Alaska Arizona Arkansas California \ - Colorado Connecticut Delaware Florida Georgia Hawaii Idaho Illinois \ - Indiana Iowa Kansas Kentucky Louisiana Maine Maryland \ - Massachusetts Michigan Minnesota Mississippi Missouri \ - Montana Nebraska Nevada "New Hampshire" "New Jersey" "New Mexico" \ - "New York" "North Carolina" "North Dakota" \ - Ohio Oklahoma Oregon Pennsylvania "Rhode Island" \ - "South Carolina" "South Dakota" \ - Tennessee Texas Utah Vermont Virginia Washington \ - "West Virginia" Wisconsin Wyoming -} diff --git a/tk3.6/library/demos/mkListbox2.tcl b/tk3.6/library/demos/mkListbox2.tcl deleted file mode 100644 index baa4fe9..0000000 --- a/tk3.6/library/demos/mkListbox2.tcl +++ /dev/null @@ -1,95 +0,0 @@ -# mkListbox2 w -# -# Create a top-level window containing a listbox showing a bunch of -# colors from the X color database. -# -# Arguments: -# w - Name to use for new top-level window. - -proc mkListbox2 {{w .l2}} { - catch {destroy $w} - toplevel $w - dpos $w - wm title $w "Listbox Demonstration (colors)" - wm iconname $w "Listbox" - wm minsize $w 1 1 - - message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ - -text "A listbox containing several color values is displayed below, along with a scrollbar. You can scan the list either using the scrollbar or by dragging in the listbox window with button 2 pressed. If you double-click button 1 on a color, then the background for the window will be changed to that color. Click the \"OK\" button when you've seen enough." - frame $w.frame -borderwidth 10 - button $w.ok -text OK -command "destroy $w" - pack $w.msg -side top - pack $w.ok -side bottom -fill x - pack $w.frame -side top -expand yes -fill y - - scrollbar $w.frame.scroll -relief sunken -command "$w.frame.list yview" - listbox $w.frame.list -yscroll "$w.frame.scroll set" -relief sunken \ - -geometry 20x20 -setgrid 1 - pack $w.frame.list $w.frame.scroll -side left -fill y - - $w.frame.list insert 0 snow1 snow2 snow3 snow4 seashell1 seashell2 \ - seashell3 seashell4 AntiqueWhite1 AntiqueWhite2 AntiqueWhite3 \ - AntiqueWhite4 bisque1 bisque2 bisque3 bisque4 PeachPuff1 \ - PeachPuff2 PeachPuff3 PeachPuff4 NavajoWhite1 NavajoWhite2 \ - NavajoWhite3 NavajoWhite4 LemonChiffon1 LemonChiffon2 \ - LemonChiffon3 LemonChiffon4 cornsilk1 cornsilk2 cornsilk3 \ - cornsilk4 ivory1 ivory2 ivory3 ivory4 honeydew1 honeydew2 \ - honeydew3 honeydew4 LavenderBlush1 LavenderBlush2 \ - LavenderBlush3 LavenderBlush4 MistyRose1 MistyRose2 \ - MistyRose3 MistyRose4 azure1 azure2 azure3 azure4 \ - SlateBlue1 SlateBlue2 SlateBlue3 SlateBlue4 RoyalBlue1 \ - RoyalBlue2 RoyalBlue3 RoyalBlue4 blue1 blue2 blue3 blue4 \ - DodgerBlue1 DodgerBlue2 DodgerBlue3 DodgerBlue4 SteelBlue1 \ - SteelBlue2 SteelBlue3 SteelBlue4 DeepSkyBlue1 DeepSkyBlue2 \ - DeepSkyBlue3 DeepSkyBlue4 SkyBlue1 SkyBlue2 SkyBlue3 \ - SkyBlue4 LightSkyBlue1 LightSkyBlue2 LightSkyBlue3 \ - LightSkyBlue4 SlateGray1 SlateGray2 SlateGray3 SlateGray4 \ - LightSteelBlue1 LightSteelBlue2 LightSteelBlue3 \ - LightSteelBlue4 LightBlue1 LightBlue2 LightBlue3 \ - LightBlue4 LightCyan1 LightCyan2 LightCyan3 LightCyan4 \ - PaleTurquoise1 PaleTurquoise2 PaleTurquoise3 PaleTurquoise4 \ - CadetBlue1 CadetBlue2 CadetBlue3 CadetBlue4 turquoise1 \ - turquoise2 turquoise3 turquoise4 cyan1 cyan2 cyan3 cyan4 \ - DarkSlateGray1 DarkSlateGray2 DarkSlateGray3 \ - DarkSlateGray4 aquamarine1 aquamarine2 aquamarine3 \ - aquamarine4 DarkSeaGreen1 DarkSeaGreen2 DarkSeaGreen3 \ - DarkSeaGreen4 SeaGreen1 SeaGreen2 SeaGreen3 SeaGreen4 \ - PaleGreen1 PaleGreen2 PaleGreen3 PaleGreen4 SpringGreen1 \ - SpringGreen2 SpringGreen3 SpringGreen4 green1 green2 \ - green3 green4 chartreuse1 chartreuse2 chartreuse3 \ - chartreuse4 OliveDrab1 OliveDrab2 OliveDrab3 OliveDrab4 \ - DarkOliveGreen1 DarkOliveGreen2 DarkOliveGreen3 \ - DarkOliveGreen4 khaki1 khaki2 khaki3 khaki4 \ - LightGoldenrod1 LightGoldenrod2 LightGoldenrod3 \ - LightGoldenrod4 LightYellow1 LightYellow2 LightYellow3 \ - LightYellow4 yellow1 yellow2 yellow3 yellow4 gold1 gold2 \ - gold3 gold4 goldenrod1 goldenrod2 goldenrod3 goldenrod4 \ - DarkGoldenrod1 DarkGoldenrod2 DarkGoldenrod3 DarkGoldenrod4 \ - RosyBrown1 RosyBrown2 RosyBrown3 RosyBrown4 IndianRed1 \ - IndianRed2 IndianRed3 IndianRed4 sienna1 sienna2 sienna3 \ - sienna4 burlywood1 burlywood2 burlywood3 burlywood4 wheat1 \ - wheat2 wheat3 wheat4 tan1 tan2 tan3 tan4 chocolate1 \ - chocolate2 chocolate3 chocolate4 firebrick1 firebrick2 \ - firebrick3 firebrick4 brown1 brown2 brown3 brown4 salmon1 \ - salmon2 salmon3 salmon4 LightSalmon1 LightSalmon2 \ - LightSalmon3 LightSalmon4 orange1 orange2 orange3 orange4 \ - DarkOrange1 DarkOrange2 DarkOrange3 DarkOrange4 coral1 \ - coral2 coral3 coral4 tomato1 tomato2 tomato3 tomato4 \ - OrangeRed1 OrangeRed2 OrangeRed3 OrangeRed4 red1 red2 red3 \ - red4 DeepPink1 DeepPink2 DeepPink3 DeepPink4 HotPink1 \ - HotPink2 HotPink3 HotPink4 pink1 pink2 pink3 pink4 \ - LightPink1 LightPink2 LightPink3 LightPink4 PaleVioletRed1 \ - PaleVioletRed2 PaleVioletRed3 PaleVioletRed4 maroon1 \ - maroon2 maroon3 maroon4 VioletRed1 VioletRed2 VioletRed3 \ - VioletRed4 magenta1 magenta2 magenta3 magenta4 orchid1 \ - orchid2 orchid3 orchid4 plum1 plum2 plum3 plum4 \ - MediumOrchid1 MediumOrchid2 MediumOrchid3 MediumOrchid4 \ - DarkOrchid1 DarkOrchid2 DarkOrchid3 DarkOrchid4 purple1 \ - purple2 purple3 purple4 MediumPurple1 MediumPurple2 \ - MediumPurple3 MediumPurple4 thistle1 thistle2 thistle3 \ - thistle4 - bind $w.frame.list \ - "$w config -bg \[lindex \[selection get\] 0\] - $w.frame config -bg \[lindex \[selection get\] 0\] - $w.msg config -bg \[lindex \[selection get\] 0\]" -} diff --git a/tk3.6/library/demos/mkListbox3.tcl b/tk3.6/library/demos/mkListbox3.tcl deleted file mode 100644 index f18357d..0000000 --- a/tk3.6/library/demos/mkListbox3.tcl +++ /dev/null @@ -1,34 +0,0 @@ -# mkListbox3 w -# -# Create a top-level window containing a listbox with a bunch of well-known -# sayings. The listbox can be scrolled or scanned in two dimensions. -# -# Arguments: -# w - Name to use for new top-level window. - -proc mkListbox3 {{w .l3}} { - catch {destroy $w} - toplevel $w - dpos $w - wm title $w "Listbox Demonstration (well-known sayings)" - wm iconname $w "Listbox" - wm minsize $w 1 1 - message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ - -text "The listbox below contains a collection of well-known sayings. You can scan the list using either of the scrollbars or by dragging in the listbox window with button 2 pressed. Click the \"OK\" button when you're done." - frame $w.frame -borderwidth 10 - button $w.ok -text OK -command "destroy $w" - pack $w.msg -side top - pack $w.ok -side bottom -fill x - pack $w.frame -side top -expand yes -fill y - - scrollbar $w.frame.yscroll -relief sunken -command "$w.frame.list yview" - scrollbar $w.frame.xscroll -relief sunken -orient horizontal \ - -command "$w.frame.list xview" - listbox $w.frame.list -geometry 20x10 -yscroll "$w.frame.yscroll set" \ - -xscroll "$w.frame.xscroll set" -relief sunken -setgrid 1 - pack $w.frame.yscroll -side right -fill y - pack $w.frame.xscroll -side bottom -fill x - pack $w.frame.list -expand yes -fill y - - $w.frame.list insert 0 "Waste not, want not" "Early to bed and early to rise makes a man healthy, wealthy, and wise" "Ask not what your country can do for you, ask what you can do for your country" "I shall return" "NOT" "A picture is worth a thousand words" "User interfaces are hard to build" "Thou shalt not steal" "A penny for your thoughts" "Fool me once, shame on you; fool me twice, shame on me" "Every cloud has a silver lining" "Where there's smoke there's fire" "It takes one to know one" "Curiosity killed the cat" "Take this job and shove it" "Up a creek without a paddle" "I'm mad as hell and I'm not going to take it any more" "An apple a day keeps the doctor away" "Don't look a gift horse in the mouth" -} diff --git a/tk3.6/library/demos/mkPlot.tcl b/tk3.6/library/demos/mkPlot.tcl deleted file mode 100644 index 6cecea6..0000000 --- a/tk3.6/library/demos/mkPlot.tcl +++ /dev/null @@ -1,75 +0,0 @@ -# mkPlot w -# -# Create a top-level window containing a canvas displaying a simple -# graph with data points that can be moved interactively. -# -# Arguments: -# w - Name to use for new top-level window. - -proc mkPlot {{w .plot}} { - catch {destroy $w} - toplevel $w - dpos $w - wm title $w "Plot Demonstration" - wm iconname $w "Plot" - set c $w.c - - message $w.msg -font -Adobe-Times-Medium-R-Normal-*-180-* -width 400 \ - -bd 2 -relief raised -text "This window displays a canvas widget containing a simple 2-dimensional plot. You can doctor the data by dragging any of the points with mouse button 1." - canvas $c -relief raised -width 450 -height 300 - button $w.ok -text "OK" -command "destroy $w" - pack $w.msg $w.c -side top -fill x - pack $w.ok -side bottom -pady 5 - - set font -Adobe-helvetica-medium-r-*-180-* - - $c create line 100 250 400 250 -width 2 - $c create line 100 250 100 50 -width 2 - $c create text 225 20 -text "A Simple Plot" -font $font -fill brown - - for {set i 0} {$i <= 10} {incr i} { - set x [expr {100 + ($i*30)}] - $c create line $x 250 $x 245 -width 2 - $c create text $x 254 -text [expr 10*$i] -anchor n -font $font - } - for {set i 0} {$i <= 5} {incr i} { - set y [expr {250 - ($i*40)}] - $c create line 100 $y 105 $y -width 2 - $c create text 96 $y -text [expr $i*50].0 -anchor e -font $font - } - - foreach point {{12 56} {20 94} {33 98} {32 120} {61 180} - {75 160} {98 223}} { - set x [expr {100 + (3*[lindex $point 0])}] - set y [expr {250 - (4*[lindex $point 1])/5}] - set item [$c create oval [expr $x-6] [expr $y-6] \ - [expr $x+6] [expr $y+6] -width 1 -outline black \ - -fill SkyBlue2] - $c addtag point withtag $item - } - - $c bind point "$c itemconfig current -fill red" - $c bind point "$c itemconfig current -fill SkyBlue2" - $c bind point <1> "plotDown $c %x %y" - $c bind point "$c dtag selected" - bind $c "plotMove $c %x %y" -} - -set plot(lastX) 0 -set plot(lastY) 0 - -proc plotDown {w x y} { - global plot - $w dtag selected - $w addtag selected withtag current - $w raise current - set plot(lastX) $x - set plot(lastY) $y -} - -proc plotMove {w x y} { - global plot - $w move selected [expr $x-$plot(lastX)] [expr $y-$plot(lastY)] - set plot(lastX) $x - set plot(lastY) $y -} diff --git a/tk3.6/library/demos/mkPuzzle.tcl b/tk3.6/library/demos/mkPuzzle.tcl deleted file mode 100644 index d2ac960..0000000 --- a/tk3.6/library/demos/mkPuzzle.tcl +++ /dev/null @@ -1,59 +0,0 @@ -# mkPuzzle w -# -# Create a top-level window containing a 15-puzzle game. -# -# Arguments: -# w - Name to use for new top-level window. - -proc mkPuzzle {{w .p1}} { - global xpos ypos - catch {destroy $w} - toplevel $w - dpos $w - wm title $w "15-Puzzle Demonstration" - wm iconname $w "15-Puzzle" - - message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ - -text "A 15-puzzle appears below as a collection of buttons. Click on any of the pieces next to the space, and that piece will slide over the space. Continue this until the pieces are arranged in numerical order from upper-left to lower-right. Click the \"OK\" button when you've finished playing." - frame $w.frame -geometry 120x120 -borderwidth 2 -relief sunken \ - -bg Bisque3 - button $w.ok -text OK -command "destroy $w" - pack $w.msg -side top - pack $w.frame -side top -padx 5 -pady 5 - pack $w.ok -side bottom -fill x - - set order {3 1 6 2 5 7 15 13 4 11 8 9 14 10 12} - for {set i 0} {$i < 15} {set i [expr $i+1]} { - set num [lindex $order $i] - set xpos($num) [expr ($i%4)*.25] - set ypos($num) [expr ($i/4)*.25] - button $w.frame.$num -relief raised -text $num \ - -command "puzzle.switch $w $num" - place $w.frame.$num -relx $xpos($num) -rely $ypos($num) \ - -relwidth .25 -relheight .25 - } - set xpos(space) .75 - set ypos(space) .75 -} - -# Procedure invoked by buttons in the puzzle to resize the puzzle entries: - -proc puzzle.switch {w num} { - global xpos ypos - if {(($ypos($num) >= ($ypos(space) - .01)) - && ($ypos($num) <= ($ypos(space) + .01)) - && ($xpos($num) >= ($xpos(space) - .26)) - && ($xpos($num) <= ($xpos(space) + .26))) - || (($xpos($num) >= ($xpos(space) - .01)) - && ($xpos($num) <= ($xpos(space) + .01)) - && ($ypos($num) >= ($ypos(space) - .26)) - && ($ypos($num) <= ($ypos(space) + .26)))} { - set tmp $xpos(space) - set xpos(space) $xpos($num) - set xpos($num) $tmp - set tmp $ypos(space) - set ypos(space) $ypos($num) - set ypos($num) $tmp - place $w.frame.$num -relx $xpos($num) -rely $ypos($num) - } -} diff --git a/tk3.6/library/demos/mkRadio.tcl b/tk3.6/library/demos/mkRadio.tcl deleted file mode 100644 index 0087fef..0000000 --- a/tk3.6/library/demos/mkRadio.tcl +++ /dev/null @@ -1,58 +0,0 @@ -# mkRadio w -# -# Create a top-level window that displays a bunch of radio buttons. -# -# Arguments: -# w - Name to use for new top-level window. - -proc mkRadio {{w .r1}} { - catch {destroy $w} - toplevel $w - dpos $w - wm title $w "Radiobutton Demonstration" - wm iconname $w "Radiobuttons" - message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ - -text "Two groups of radiobuttons are displayed below. If you click on a button then the button will become selected exclusively among all the buttons in its group. A Tcl variable is associated with each group to indicate which of the group's buttons is selected. Click the \"See Variables\" button to see the current values of the variables. Click the \"OK\" button when you've seen enough." - frame $w.frame -borderwidth 10 - frame $w.frame2 - pack $w.msg -side top - pack $w.msg -side top - pack $w.frame -side top -fill x -pady 10 - pack $w.frame2 -side bottom -fill x - - frame $w.frame.left - frame $w.frame.right - pack $w.frame.left $w.frame.right -side left -expand yes - - radiobutton $w.frame.left.b1 -text "Point Size 10" -variable size \ - -relief flat -value 10 - radiobutton $w.frame.left.b2 -text "Point Size 12" -variable size \ - -relief flat -value 12 - radiobutton $w.frame.left.b3 -text "Point Size 18" -variable size \ - -relief flat -value 18 - radiobutton $w.frame.left.b4 -text "Point Size 24" -variable size \ - -relief flat -value 24 - pack $w.frame.left.b1 $w.frame.left.b2 $w.frame.left.b3 $w.frame.left.b4 \ - -side top -pady 2 -anchor w - - radiobutton $w.frame.right.b1 -text "Red" -variable color \ - -relief flat -value red - radiobutton $w.frame.right.b2 -text "Green" -variable color \ - -relief flat -value green - radiobutton $w.frame.right.b3 -text "Blue" -variable color \ - -relief flat -value blue - radiobutton $w.frame.right.b4 -text "Yellow" -variable color \ - -relief flat -value yellow - radiobutton $w.frame.right.b5 -text "Orange" -variable color \ - -relief flat -value orange - radiobutton $w.frame.right.b6 -text "Purple" -variable color \ - -relief flat -value purple - pack $w.frame.right.b1 $w.frame.right.b2 $w.frame.right.b3 \ - $w.frame.right.b4 $w.frame.right.b5 $w.frame.right.b6 \ - -side top -pady 2 -anchor w - - button $w.frame2.ok -text OK -command "destroy $w" -width 12 - button $w.frame2.vars -text "See Variables" -width 12\ - -command "showVars $w.dialog size color" - pack $w.frame2.ok $w.frame2.vars -side left -expand yes -fill x -} diff --git a/tk3.6/library/demos/mkRuler.tcl b/tk3.6/library/demos/mkRuler.tcl deleted file mode 100644 index 3ab8dbe..0000000 --- a/tk3.6/library/demos/mkRuler.tcl +++ /dev/null @@ -1,125 +0,0 @@ -# mkRuler w -# -# Create a canvas demonstration consisting of a ruler. -# -# Arguments: -# w - Name to use for new top-level window. -# This file implements a canvas widget that displays a ruler with tab stops -# that can be set individually. The only procedure that should be invoked -# from outside the file is the first one, which creates the canvas. - -proc mkRuler {{w .ruler}} { - global tk_library - upvar #0 demo_rulerInfo v - catch {destroy $w} - toplevel $w - dpos $w - wm title $w "Ruler Demonstration" - wm iconname $w "Ruler" - set c $w.c - - message $w.msg -font -Adobe-Times-Medium-R-Normal-*-180-* -width 13c \ - -relief raised -bd 2 -text "This canvas widget shows a mock-up of a ruler. You can create tab stops by dragging them out of the well to the right of the ruler. You can also drag existing tab stops. If you drag a tab stop far enough up or down so that it turns dim, it will be deleted when you release the mouse button." - canvas $c -width 14.8c -height 2.5c -relief raised - button $w.ok -text "OK" -command "destroy $w" - pack $w.msg $w.c -side top -fill x - pack $w.ok -side bottom -pady 5 - - set v(grid) .25c - set v(left) [winfo fpixels $c 1c] - set v(right) [winfo fpixels $c 13c] - set v(top) [winfo fpixels $c 1c] - set v(bottom) [winfo fpixels $c 1.5c] - set v(size) [winfo fpixels $c .2c] - set v(normalStyle) "-fill black" - if {[tk colormodel $c] == "color"} { - set v(activeStyle) "-fill red -stipple {}" - set v(deleteStyle) "-stipple @$tk_library/demos/bitmaps/grey.25 \ - -fill red" - } else { - set v(activeStyle) "-fill black -stipple {}" - set v(deleteStyle) "-stipple @$tk_library/demos/bitmaps/grey.25 \ - -fill black" - } - - $c create line 1c 0.5c 1c 1c 13c 1c 13c 0.5c -width 1 - for {set i 0} {$i < 12} {incr i} { - set x [expr $i+1] - $c create line ${x}c 1c ${x}c 0.6c -width 1 - $c create line $x.25c 1c $x.25c 0.8c -width 1 - $c create line $x.5c 1c $x.5c 0.7c -width 1 - $c create line $x.75c 1c $x.75c 0.8c -width 1 - $c create text $x.15c .75c -text $i -anchor sw - } - $c addtag well withtag [$c create rect 13.2c 1c 13.8c 0.5c \ - -outline black -fill [lindex [$c config -bg] 4]] - $c addtag well withtag [rulerMkTab $c [winfo pixels $c 13.5c] \ - [winfo pixels $c .65c]] - - $c bind well <1> "rulerNewTab $c %x %y" - $c bind tab <1> "demo_selectTab $c %x %y" - bind $c "rulerMoveTab $c %x %y" - bind $c "rulerReleaseTab $c" -} - -proc rulerMkTab {c x y} { - upvar #0 demo_rulerInfo v - $c create polygon $x $y [expr $x+$v(size)] [expr $y+$v(size)] \ - [expr $x-$v(size)] [expr $y+$v(size)] -} - -proc rulerNewTab {c x y} { - upvar #0 demo_rulerInfo v - $c addtag active withtag [rulerMkTab $c $x $y] - $c addtag tab withtag active - set v(x) $x - set v(y) $y - rulerMoveTab $c $x $y -} - -proc rulerMoveTab {c x y} { - upvar #0 demo_rulerInfo v - if {[$c find withtag active] == ""} { - return - } - set cx [$c canvasx $x $v(grid)] - set cy [$c canvasy $y] - if {$cx < $v(left)} { - set cx $v(left) - } - if {$cx > $v(right)} { - set cx $v(right) - } - if {($cy >= $v(top)) && ($cy <= $v(bottom))} { - set cy [expr $v(top)+2] - eval "$c itemconf active $v(activeStyle)" - } else { - set cy [expr $cy-$v(size)-2] - eval "$c itemconf active $v(deleteStyle)" - } - $c move active [expr $cx-$v(x)] [expr $cy-$v(y)] - set v(x) $cx - set v(y) $cy -} - -proc demo_selectTab {c x y} { - upvar #0 demo_rulerInfo v - set v(x) [$c canvasx $x $v(grid)] - set v(y) [expr $v(top)+2] - $c addtag active withtag current - eval "$c itemconf active $v(activeStyle)" - $c raise active -} - -proc rulerReleaseTab c { - upvar #0 demo_rulerInfo v - if {[$c find withtag active] == {}} { - return - } - if {$v(y) != [expr $v(top)+2]} { - $c delete active - } else { - eval "$c itemconf active $v(normalStyle)" - $c dtag active - } -} diff --git a/tk3.6/library/demos/mkScroll.tcl b/tk3.6/library/demos/mkScroll.tcl deleted file mode 100644 index 0956d3b..0000000 --- a/tk3.6/library/demos/mkScroll.tcl +++ /dev/null @@ -1,84 +0,0 @@ -# mkScroll w -# -# Create a top-level window containing a simple canvas that can -# be scrolled in two dimensions. -# -# Arguments: -# w - Name to use for new top-level window. - -proc mkScroll {{w .cscroll}} { - catch {destroy $w} - toplevel $w - dpos $w - wm title $w "Scrollable Canvas Demonstration" - wm iconname $w "Canvas" - wm minsize $w 100 100 - set c $w.frame.c - - message $w.msg -font -Adobe-Times-Medium-R-Normal-*-180-* -aspect 300 \ - -relief raised -bd 2 -text "This window displays a canvas widget that can be scrolled either using the scrollbars or by dragging with button 2 in the canvas. If you click button 1 on one of the rectangles, its indices will be printed on stdout." - frame $w.frame -relief raised -bd 2 - button $w.ok -text "OK" -command "destroy $w" - pack $w.msg -side top -fill x - pack $w.ok -side bottom -pady 5 - pack $w.frame -side top -expand yes -fill both - - canvas $c -scrollregion {-10c -10c 50c 20c} \ - -xscroll "$w.frame.hscroll set" -yscroll "$w.frame.vscroll set" - scrollbar $w.frame.vscroll -relief sunken -command "$c yview" - scrollbar $w.frame.hscroll -orient horiz -relief sunken -command "$c xview" - pack $w.frame.vscroll -side right -fill y - pack $w.frame.hscroll -side bottom -fill x - pack $c -expand yes -fill both - - set bg [lindex [$c config -bg] 4] - for {set i 0} {$i < 20} {incr i} { - set x [expr {-10 + 3*$i}] - for {set j 0; set y -10} {$j < 10} {incr j; incr y 3} { - $c create rect ${x}c ${y}c [expr $x+2]c [expr $y+2]c \ - -outline black -fill $bg -tags rect - $c create text [expr $x+1]c [expr $y+1]c -text "$i,$j" \ - -anchor center -tags text - } - } - - $c bind all "scrollEnter $c" - $c bind all "scrollLeave $c" - $c bind all <1> "scrollButton $c" - bind $c <2> "$c scan mark %x %y" - bind $c "$c scan dragto %x %y" -} - -proc scrollEnter canvas { - global oldFill - set id [$canvas find withtag current] - if {[lsearch [$canvas gettags current] text] >= 0} { - set id [expr $id-1] - } - set oldFill [lindex [$canvas itemconfig $id -fill] 4] - if {[tk colormodel $canvas] == "color"} { - $canvas itemconfigure $id -fill SeaGreen1 - } else { - $canvas itemconfigure $id -fill black - $canvas itemconfigure [expr $id+1] -fill white - } -} - -proc scrollLeave canvas { - global oldFill - set id [$canvas find withtag current] - if {[lsearch [$canvas gettags current] text] >= 0} { - set id [expr $id-1] - } - $canvas itemconfigure $id -fill $oldFill - $canvas itemconfigure [expr $id+1] -fill black -} - -proc scrollButton canvas { - global oldFill - set id [$canvas find withtag current] - if {[lsearch [$canvas gettags current] text] < 0} { - set id [expr $id+1] - } - puts stdout "You buttoned at [lindex [$canvas itemconf $id -text] 4]" -} diff --git a/tk3.6/library/demos/mkSearch.tcl b/tk3.6/library/demos/mkSearch.tcl deleted file mode 100644 index 9117914..0000000 --- a/tk3.6/library/demos/mkSearch.tcl +++ /dev/null @@ -1,140 +0,0 @@ -# mkTextSearch w -# -# Create a top-level window containing a text widget that allows you -# to load a file and highlight all instances of a given string. -# -# Arguments: -# w - Name to use for new top-level window. - -proc mkTextSearch {{w .search}} { - catch {destroy $w} - toplevel $w - dpos $w - wm title $w "Text Demonstration - Search and Highlight" - wm iconname $w "Text Search" - - frame $w.file - label $w.file.label -text "File name:" -width 13 -anchor w - entry $w.file.entry -width 40 -relief sunken -bd 2 -textvariable fileName - button $w.file.button -text "Load File" \ - -command "TextLoadFile $w.t \$fileName" - pack $w.file.label $w.file.entry -side left - pack $w.file.button -side left -pady 5 -padx 10 - bind $w.file.entry " - TextLoadFile $w.t \$fileName - focus $w.string.entry - " - - frame $w.string - label $w.string.label -text "Search string:" -width 13 -anchor w - entry $w.string.entry -width 40 -relief sunken -bd 2 \ - -textvariable searchString - button $w.string.button -text "Highlight" \ - -command "TextSearch $w.t \$searchString search" - pack $w.string.label $w.string.entry -side left - pack $w.string.button -side left -pady 5 -padx 10 - bind $w.string.entry "TextSearch $w.t \$searchString search" - - button $w.ok -text OK -command "destroy $w" - text $w.t -relief raised -bd 2 -yscrollcommand "$w.s set" -setgrid true - scrollbar $w.s -relief flat -command "$w.t yview" - pack $w.file $w.string -side top -fill x - pack $w.ok -side bottom -fill x - pack $w.s -side right -fill y - pack $w.t -expand yes -fill both - - # Set up display styles for text highlighting. - - if {[tk colormodel $w] == "color"} { - TextToggle "$w.t tag configure search -background \ - SeaGreen4 -foreground white" 800 "$w.t tag configure \ - search -background {} -foreground {}" 200 - } else { - TextToggle "$w.t tag configure search -background \ - black -foreground white" 800 "$w.t tag configure \ - search -background {} -foreground {}" 200 - } - $w.t insert 0.0 {\ -This window demonstrates how to use the tagging facilities in text -widgets to implement a searching mechanism. First, type a file name -in the top entry, then type or click on "Load File". Then -type a string in the lower entry and type or click on -"Load File". This will cause all of the instances of the string to -be tagged with the tag "search", and it will arrange for the tag's -display attributes to change to make all of the strings blink. -} - $w.t mark set insert 0.0 - bind $w "focus $w.file.entry" -} -set fileName "" -set searchString "" - -# The utility procedure below loads a file into a text widget, -# discarding the previous contents of the widget. Tags for the -# old widget are not affected, however. -# Arguments: -# -# w - The window into which to load the file. Must be a -# text widget. -# file - The name of the file to load. Must be readable. - -proc TextLoadFile {w file} { - set f [open $file] - $w delete 1.0 end - while {![eof $f]} { - $w insert end [read $f 10000] - } - close $f -} - -# The utility procedure below searches for all instances of a -# given string in a text widget and applies a given tag to each -# instance found. -# Arguments: -# -# w - The window in which to search. Must be a text widget. -# string - The string to search for. The search is done using -# exact matching only; no special characters. -# tag - Tag to apply to each instance of a matching string. - -proc TextSearch {w string tag} { - $w tag remove search 0.0 end - scan [$w index end] %d numLines - set l [string length $string] - for {set i 1} {$i <= $numLines} {incr i} { - if {[string first $string [$w get $i.0 $i.1000]] == -1} { - continue - } - set line [$w get $i.0 $i.1000] - set offset 0 - while 1 { - set index [string first $string $line] - if {$index < 0} { - break - } - incr offset $index - $w tag add $tag $i.[expr $offset] $i.[expr $offset+$l] - incr offset $l - set line [string range $line [expr $index+$l] 1000] - } - } -} - -# The procedure below is invoked repeatedly to invoke two commands -# at periodic intervals. It normally reschedules itself after each -# execution but if an error occurs (e.g. because the window was -# deleted) then it doesn't reschedule itself. -# Arguments: -# -# cmd1 - Command to execute when procedure is called. -# sleep1 - Ms to sleep after executing cmd1 before executing cmd2. -# cmd2 - Command to execute in the *next* invocation of this -# procedure. -# sleep2 - Ms to sleep after executing cmd2 before executing cmd1 again. - -proc TextToggle {cmd1 sleep1 cmd2 sleep2} { - catch { - eval $cmd1 - after $sleep1 [list TextToggle $cmd2 $sleep2 $cmd1 $sleep1] - } -} diff --git a/tk3.6/library/demos/mkStyles.tcl b/tk3.6/library/demos/mkStyles.tcl deleted file mode 100644 index 688545c..0000000 --- a/tk3.6/library/demos/mkStyles.tcl +++ /dev/null @@ -1,128 +0,0 @@ -# mkStyles w -# -# Create a top-level window with a text widget that demonstrates the -# various display styles that are available in texts. -# -# Arguments: -# w - Name to use for new top-level window. - -proc mkStyles {{w .styles}} { - catch {destroy $w} - toplevel $w - dpos $w - wm title $w "Text Demonstration - Display Styles" - wm iconname $w "Text Styles" - - button $w.ok -text OK -command "destroy $w" - text $w.t -relief raised -bd 2 -yscrollcommand "$w.s set" -setgrid true \ - -width 70 -height 28 - scrollbar $w.s -relief flat -command "$w.t yview" - pack $w.ok -side bottom -fill x - pack $w.s -side right -fill y - pack $w.t -expand yes -fill both - - # Set up display styles - - $w.t tag configure bold -font -Adobe-Courier-Bold-O-Normal-*-120-* - $w.t tag configure big -font -Adobe-Courier-Bold-R-Normal-*-140-* - $w.t tag configure verybig -font -Adobe-Helvetica-Bold-R-Normal-*-240-* - if {[tk colormodel $w] == "color"} { - $w.t tag configure color1 -background #eed5b7 - $w.t tag configure color2 -foreground red - $w.t tag configure raised -background #eed5b7 -relief raised \ - -borderwidth 1 - $w.t tag configure sunken -background #eed5b7 -relief sunken \ - -borderwidth 1 - } else { - $w.t tag configure color1 -background black -foreground white - $w.t tag configure color2 -background black -foreground white - $w.t tag configure raised -background white -relief raised \ - -borderwidth 1 - $w.t tag configure sunken -background white -relief sunken \ - -borderwidth 1 - } - $w.t tag configure bgstipple -background black -borderwidth 0 \ - -bgstipple gray25 - $w.t tag configure fgstipple -fgstipple gray50 - $w.t tag configure underline -underline on - - $w.t insert 0.0 {\ -Text widgets like this one allow you to display information in a -variety of styles. Display styles are controlled using a mechanism -called } - insertWithTags $w.t tags bold - insertWithTags $w.t {. Tags are just textual names that you can apply to one -or more ranges of characters within a text widget. You can configure -tags with various display styles. If you do this, then the tagged -characters will be displayed with the styles you chose. The -available display styles are: -} - insertWithTags $w.t { -1. Font.} big - insertWithTags $w.t { You can choose any X font, } - insertWithTags $w.t large verybig - insertWithTags $w.t { or } - insertWithTags $w.t {small. -} - insertWithTags $w.t { -2. Color.} big - insertWithTags $w.t { You can change either the } - insertWithTags $w.t background color1 - insertWithTags $w.t { or } - insertWithTags $w.t foreground color2 - insertWithTags $w.t { -color, or } - insertWithTags $w.t both color1 color2 - insertWithTags $w.t {. -} - insertWithTags $w.t { -3. Stippling.} big - insertWithTags $w.t { You can cause either the } - insertWithTags $w.t background bgstipple - insertWithTags $w.t { or } - insertWithTags $w.t foreground fgstipple - insertWithTags $w.t { -information to be drawn with a stipple fill instead of a solid fill. -} - insertWithTags $w.t { -4. Underlining.} big - insertWithTags $w.t { You can } - insertWithTags $w.t underline underline - insertWithTags $w.t { ranges of text. -} - insertWithTags $w.t { -5. 3-D effects.} big - insertWithTags $w.t { You can arrange for the background to be drawn -with a border that makes characters appear either } - insertWithTags $w.t raised raised - insertWithTags $w.t { or } - insertWithTags $w.t sunken sunken - insertWithTags $w.t {. -} - insertWithTags $w.t { -6. Yet to come.} big - insertWithTags $w.t { More display effects will be coming soon, such -as the ability to change line justification and perhaps line spacing.} - - $w.t mark set insert 0.0 - bind $w "focus $w.t" -} - -# The procedure below inserts text into a given text widget and -# applies one or more tags to that text. The arguments are: -# -# w Window in which to insert -# text Text to insert (it's inserted at the "insert" mark) -# args One or more tags to apply to text. If this is empty -# then all tags are removed from the text. - -proc insertWithTags {w text args} { - set start [$w index insert] - $w insert insert $text - foreach tag [$w tag names $start] { - $w tag remove $tag $start insert - } - foreach i $args { - $w tag add $i $start insert - } -} diff --git a/tk3.6/library/demos/mkTear.tcl b/tk3.6/library/demos/mkTear.tcl deleted file mode 100644 index 5ba01ae..0000000 --- a/tk3.6/library/demos/mkTear.tcl +++ /dev/null @@ -1,19 +0,0 @@ -# mkTear w -# -# Create a top-level window that displays a help message on tear-off -# menus. -# -# Arguments: -# w - Name to use for new top-level window. - -proc mkTear {{w .t1}} { - catch {destroy $w} - toplevel $w - dpos $w - wm title $w "Information On Tear-Off Menus" - wm iconname $w "Info" - message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 250 \ - -text "To tear off a menu, press mouse button 2 over the menubutton for the menu, then drag the menu with button 2 held down. You can reposition a torn-off menu by pressing button 2 on it and dragging again. To unpost the menu, click mouse button 1 over the menu's menubutton. Click the \"OK\" button when you're finished with this window." - button $w.ok -text OK -command "destroy $w" - pack $w.msg $w.ok -pady 5 -} diff --git a/tk3.6/library/demos/mkTextBind.tcl b/tk3.6/library/demos/mkTextBind.tcl deleted file mode 100644 index 79ae0d5..0000000 --- a/tk3.6/library/demos/mkTextBind.tcl +++ /dev/null @@ -1,100 +0,0 @@ -# mkTextBind w -# -# Create a top-level window that illustrates how you can bind -# Tcl commands to regions of text in a text widget. -# -# Arguments: -# w - Name to use for new top-level window. - -proc mkTextBind {{w .bindings}} { - catch {destroy $w} - toplevel $w - dpos $w - wm title $w "Text Demonstration - Tag Bindings" - wm iconname $w "Text Bindings" - button $w.ok -text OK -command "destroy $w" - text $w.t -relief raised -bd 2 -yscrollcommand "$w.s set" -setgrid true \ - -width 60 -height 28 \ - -font "-Adobe-Helvetica-Bold-R-Normal-*-120-*" - scrollbar $w.s -relief flat -command "$w.t yview" - pack $w.ok -side bottom -fill x - pack $w.s -side right -fill y - pack $w.t -expand yes -fill both - - # Set up display styles - - if {[tk colormodel $w] == "color"} { - set bold "-foreground red" - set normal "-foreground {}" - } else { - set bold "-foreground white -background black" - set normal "-foreground {} -background {}" - } - $w.t insert 0.0 {\ -The same tag mechanism that controls display styles in text -widgets can also be used to associate Tcl commands with regions -of text, so that mouse or keyboard actions on the text cause -particular Tcl commands to be invoked. For example, in the -text below the descriptions of the canvas demonstrations have -been tagged. When you move the mouse over a demo description -the description lights up, and when you press button 3 over a -description then that particular demonstration is invoked. - -This demo package contains a number of demonstrations of Tk's -canvas widgets. Here are brief descriptions of some of the -demonstrations that are available: - -} - insertWithTags $w.t \ -{1. Samples of all the different types of items that can be -created in canvas widgets.} d1 - insertWithTags $w.t \n\n - insertWithTags $w.t \ -{2. A simple two-dimensional plot that allows you to adjust -the positions of the data points.} d2 - insertWithTags $w.t \n\n - insertWithTags $w.t \ -{3. Anchoring and justification modes for text items.} d3 - insertWithTags $w.t \n\n - insertWithTags $w.t \ -{4. An editor for arrow-head shapes for line items.} d4 - insertWithTags $w.t \n\n - insertWithTags $w.t \ -{5. A ruler with facilities for editing tab stops.} d5 - insertWithTags $w.t \n\n - insertWithTags $w.t \ -{6. A grid that demonstrates how canvases can be scrolled.} d6 - - foreach tag {d1 d2 d3 d4 d5 d6} { - $w.t tag bind $tag "$w.t tag configure $tag $bold" - $w.t tag bind $tag "$w.t tag configure $tag $normal" - } - $w.t tag bind d1 <3> mkItems - $w.t tag bind d2 <3> mkPlot - $w.t tag bind d3 <3> mkCanvText - $w.t tag bind d4 <3> mkArrow - $w.t tag bind d5 <3> mkRuler - $w.t tag bind d6 <3> mkScroll - - $w.t mark set insert 0.0 - bind $w "focus $w.t" -} - -# The procedure below inserts text into a given text widget and -# applies one or more tags to that text. The arguments are: -# -# w Window in which to insert -# text Text to insert (it's inserted at the "insert" mark) -# args One or more tags to apply to text. If this is empty -# then all tags are removed from the text. - -proc insertWithTags {w text args} { - set start [$w index insert] - $w insert insert $text - foreach tag [$w tag names $start] { - $w tag remove $tag $start insert - } - foreach i $args { - $w tag add $i $start insert - } -} diff --git a/tk3.6/library/demos/mkVScale.tcl b/tk3.6/library/demos/mkVScale.tcl deleted file mode 100644 index 6b0c31d..0000000 --- a/tk3.6/library/demos/mkVScale.tcl +++ /dev/null @@ -1,35 +0,0 @@ -# mkVScale w -# -# Create a top-level window that displays a vertical scale. -# -# Arguments: -# w - Name to use for new top-level window. - -proc mkVScale {{w .scale1}} { - catch {destroy $w} - toplevel $w - dpos $w - wm title $w "Vertical Scale Demonstration" - wm iconname $w "Scale" - message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ - -text "A bar and a vertical scale are displayed below. If you click or drag mouse button 1 in the scale, you can change the height of the bar. Click the \"OK\" button when you're finished." - frame $w.frame -borderwidth 10 - button $w.ok -text OK -command "destroy $w" - pack $w.msg $w.frame $w.ok - - scale $w.frame.scale -orient vertical -length 280 -from 0 -to 250 \ - -command "setHeight $w.frame.right.inner" -tickinterval 50 \ - -bg Bisque1 - frame $w.frame.right -borderwidth 15 - pack $w.frame.scale -side left -anchor ne - pack $w.frame.right -side left -anchor nw - $w.frame.scale set 20 - - frame $w.frame.right.inner -geometry 40x20 -relief raised \ - -borderwidth 2 -bg SteelBlue1 - pack $w.frame.right.inner -expand yes -anchor nw -} - -proc setHeight {w height} { - $w config -geometry 40x${height} -} diff --git a/tk3.6/library/demos/showVars.tcl b/tk3.6/library/demos/showVars.tcl deleted file mode 100644 index 69b4f92..0000000 --- a/tk3.6/library/demos/showVars.tcl +++ /dev/null @@ -1,26 +0,0 @@ -# showVars w var var var ... -# -# Create a top-level window that displays a bunch of global variable values -# and keeps the display up-to-date even when the variables change value -# -# Arguments: -# w - Name to use for new top-level window. -# var - Name of variable to monitor. - -proc showVars {w args} { - catch {destroy $w} - toplevel $w - wm title $w "Variable values" - label $w.title -text "Variable values:" -width 20 -anchor center \ - -font -Adobe-helvetica-medium-r-normal--*-180* - pack $w.title -side top -fill x - foreach i $args { - frame $w.$i - label $w.$i.name -text "$i: " - label $w.$i.value -textvar $i - pack $w.$i.name $w.$i.value -side left - pack $w.$i -side top -anchor w - } - button $w.ok -text OK -command "destroy $w" - pack $w.ok -side bottom -pady 2 -} diff --git a/tk3.6/library/demos/size b/tk3.6/library/demos/size deleted file mode 100644 index 9e3f4ec..0000000 --- a/tk3.6/library/demos/size +++ /dev/null @@ -1,16 +0,0 @@ -#!/usr/local/bin/wish -f -# -# Simple script to change size of something in a window. - -if "$argc < 3" {error "Usage: size appName window option"} -set appName [lindex $argv 0] -set widget [lindex $argv 1] -set option [lindex $argv 2] - -scale .scale -command {send $appName $widget config $option} -label "Pixels" \ - -length 250 -from 0 -to 100 -orient vertical -pack .scale - -bind . {destroy .} -bind . {destroy .} -focus . diff --git a/tk3.6/library/demos/tclIndex b/tk3.6/library/demos/tclIndex deleted file mode 100644 index 7cbc396..0000000 --- a/tk3.6/library/demos/tclIndex +++ /dev/null @@ -1,83 +0,0 @@ -# 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(mkIcon) "source $dir/mkIcon.tcl" -set auto_index(iconCmd) "source $dir/mkIcon.tcl" -set auto_index(mkRadio) "source $dir/mkRadio.tcl" -set auto_index(mkDialog) "source $dir/mkDialog.tcl" -set auto_index(mkBasic) "source $dir/mkBasic.tcl" -set auto_index(mkEntry) "source $dir/mkEntry.tcl" -set auto_index(mkCheck) "source $dir/mkCheck.tcl" -set auto_index(mkArrow) "source $dir/mkArrow.tcl" -set auto_index(arrowSetup) "source $dir/mkArrow.tcl" -set auto_index(arrowMove1) "source $dir/mkArrow.tcl" -set auto_index(arrowMove2) "source $dir/mkArrow.tcl" -set auto_index(arrowMove3) "source $dir/mkArrow.tcl" -set auto_index(mkStyles) "source $dir/mkStyles.tcl" -set auto_index(insertWithTags) "source $dir/mkStyles.tcl" -set auto_index(mkLabel) "source $dir/mkLabel.tcl" -set auto_index(mkItems) "source $dir/mkItems.tcl" -set auto_index(itemEnter) "source $dir/mkItems.tcl" -set auto_index(itemLeave) "source $dir/mkItems.tcl" -set auto_index(itemMark) "source $dir/mkItems.tcl" -set auto_index(itemStroke) "source $dir/mkItems.tcl" -set auto_index(itemsUnderArea) "source $dir/mkItems.tcl" -set auto_index(itemStartDrag) "source $dir/mkItems.tcl" -set auto_index(itemDrag) "source $dir/mkItems.tcl" -set auto_index(butPress) "source $dir/mkItems.tcl" -set auto_index(mkButton) "source $dir/mkButton.tcl" -set auto_index(mkForm) "source $dir/mkForm.tcl" -set auto_index(Tab) "source $dir/mkForm.tcl" -set auto_index(mkPlot) "source $dir/mkPlot.tcl" -set auto_index(plotDown) "source $dir/mkPlot.tcl" -set auto_index(plotMove) "source $dir/mkPlot.tcl" -set auto_index(mkPuzzle) "source $dir/mkPuzzle.tcl" -set auto_index(puzzle.switch) "source $dir/mkPuzzle.tcl" -set auto_index(mkListbox) "source $dir/mkListbox.tcl" -set auto_index(mkListbox2) "source $dir/mkListbox2.tcl" -set auto_index(mkListbox3) "source $dir/mkListbox3.tcl" -set auto_index(mkTear) "source $dir/mkTear.tcl" -set auto_index(mkTextBind) "source $dir/mkTextBind.tcl" -set auto_index(insertWithTags) "source $dir/mkTextBind.tcl" -set auto_index(showVars) "source $dir/showVars.tcl" -set auto_index(mkHScale) "source $dir/mkHScale.tcl" -set auto_index(setWidth) "source $dir/mkHScale.tcl" -set auto_index(mkEntry2) "source $dir/mkEntry2.tcl" -set auto_index(mkRuler) "source $dir/mkRuler.tcl" -set auto_index(rulerMkTab) "source $dir/mkRuler.tcl" -set auto_index(rulerNewTab) "source $dir/mkRuler.tcl" -set auto_index(rulerMoveTab) "source $dir/mkRuler.tcl" -set auto_index(demo_selectTab) "source $dir/mkRuler.tcl" -set auto_index(rulerReleaseTab) "source $dir/mkRuler.tcl" -set auto_index(mkBitmaps) "source $dir/mkBitmaps.tcl" -set auto_index(bitmapRow) "source $dir/mkBitmaps.tcl" -set auto_index(mkScroll) "source $dir/mkScroll.tcl" -set auto_index(scrollEnter) "source $dir/mkScroll.tcl" -set auto_index(scrollLeave) "source $dir/mkScroll.tcl" -set auto_index(scrollButton) "source $dir/mkScroll.tcl" -set auto_index(mkVScale) "source $dir/mkVScale.tcl" -set auto_index(setHeight) "source $dir/mkVScale.tcl" -set auto_index(mkCanvText) "source $dir/mkCanvText.tcl" -set auto_index(mkTextConfig) "source $dir/mkCanvText.tcl" -set auto_index(textEnter) "source $dir/mkCanvText.tcl" -set auto_index(textB1Press) "source $dir/mkCanvText.tcl" -set auto_index(textB1Move) "source $dir/mkCanvText.tcl" -set auto_index(textBs) "source $dir/mkCanvText.tcl" -set auto_index(mkFloor) "source $dir/mkFloor.tcl" -set auto_index(floorDisplay) "source $dir/mkFloor.tcl" -set auto_index(roomChanged) "source $dir/mkFloor.tcl" -set auto_index(bg1) "source $dir/mkFloor.tcl" -set auto_index(bg2) "source $dir/mkFloor.tcl" -set auto_index(bg3) "source $dir/mkFloor.tcl" -set auto_index(fg1) "source $dir/mkFloor.tcl" -set auto_index(fg2) "source $dir/mkFloor.tcl" -set auto_index(fg3) "source $dir/mkFloor.tcl" -set auto_index(mkTextSearch) "source $dir/mkSearch.tcl" -set auto_index(TextLoadFile) "source $dir/mkSearch.tcl" -set auto_index(TextSearch) "source $dir/mkSearch.tcl" -set auto_index(TextToggle) "source $dir/mkSearch.tcl" diff --git a/tk3.6/library/demos/widget b/tk3.6/library/demos/widget deleted file mode 100644 index 7511daf..0000000 --- a/tk3.6/library/demos/widget +++ /dev/null @@ -1,188 +0,0 @@ -#!/usr/local/bin/wish -f -# -# This script demonstrates the various widgets provided by Tk, -# along with many of the features of the Tk toolkit. This file -# only contains code to generate the main window for the -# application, which invokes individual demonstrations. The -# code for the actual demonstrations is contained in separate -# ".tcl" files is this directory, which are auto-loaded by Tcl -# when they are needed. To find the code for a particular -# demo, look below for the procedure that's invoked by its menu -# entry, then grep for the file that contains the procedure -# definition. - -set auto_path "$tk_library/demos $auto_path" -wm title . "Widget Demonstration" - -#------------------------------------------------------- -# The code below create the main window, consisting of a -# menu bar and a message explaining the basic operation -# of the program. -#------------------------------------------------------- - -frame .menu -relief raised -borderwidth 1 -message .msg -font -Adobe-times-medium-r-normal--*-180* -relief raised -width 500 \ --borderwidth 1 -text "This application demonstrates the widgets provided by the Tk toolkit. The menus above are organized by widget type: each menu contains one or more demonstrations of a particular type of widget. To invoke a demonstration, press mouse button 1 over one of the menu buttons above, drag the mouse to the desired entry in the menu, then release the mouse button. - -To exit this demonstration, invoke the \"Quit\" entry in the \"Misc\" menu." - -pack .menu -side top -fill x -pack .msg -side bottom -expand yes -fill both - -#------------------------------------------------------- -# The code below creates all the menus, which invoke procedures -# to create particular demonstrations of various widgets. -#------------------------------------------------------- - -menubutton .menu.button -text "Labels/Buttons" -menu .menu.button.m \ - -underline 7 -menu .menu.button.m -.menu.button.m add command -label "Labels" -command "mkLabel" -underline 0 -.menu.button.m add command -label "Buttons" -command "mkButton" -underline 0 -.menu.button.m add command -label "Checkbuttons" -command "mkCheck" \ - -underline 0 -.menu.button.m add command -label "Radiobuttons" -command "mkRadio" \ - -underline 0 -.menu.button.m add command -label "15-puzzle" -command "mkPuzzle" -underline 0 -.menu.button.m add command -label "Iconic buttons" -command "mkIcon" \ - -underline 0 - -menubutton .menu.listbox -text "Listboxes" -menu .menu.listbox.m \ - -underline 0 -menu .menu.listbox.m -.menu.listbox.m add command -label "States" -command mkListbox -underline 0 -.menu.listbox.m add command -label "Colors" -command mkListbox2 -underline 0 -.menu.listbox.m add command -label "Well-known sayings" -command mkListbox3 \ - -underline 0 - -menubutton .menu.entry -text "Entries" -menu .menu.entry.m \ - -underline 0 -menu .menu.entry.m -.menu.entry.m add command -label "Without scrollbars" -command mkEntry \ - -underline 4 -.menu.entry.m add command -label "With scrollbars" -command mkEntry2 \ - -underline 0 -.menu.entry.m add command -label "Simple form" -command mkForm \ - -underline 0 - -menubutton .menu.text -text "Text" -menu .menu.text.m -underline 0 -menu .menu.text.m -.menu.text.m add command -label "Basic text" -command mkBasic \ - -underline 0 -.menu.text.m add command -label "Display styles" -command mkStyles \ - -underline 0 -.menu.text.m add command -label "Command bindings" -command mkTextBind \ - -underline 0 -.menu.text.m add command -label Search -command mkTextSearch \ - -underline 0 - -menubutton .menu.scroll -text "Scrollbars" -menu .menu.scroll.m \ - -underline 0 -menu .menu.scroll.m -.menu.scroll.m add command -label "Vertical" -command mkListbox2 -underline 0 -.menu.scroll.m add command -label "Horizontal" -command mkEntry2 -underline 0 - -menubutton .menu.scale -text "Scales" -menu .menu.scale.m -underline 2 -menu .menu.scale.m -.menu.scale.m add command -label "Vertical" -command mkVScale -underline 0 -.menu.scale.m add command -label "Horizontal" -command mkHScale -underline 0 - -menubutton .menu.canvas -text "Canvases" -menu .menu.canvas.m \ - -underline 0 -menu .menu.canvas.m -.menu.canvas.m add command -label "Item types" -command mkItems -underline 0 -.menu.canvas.m add command -label "2-D plot" -command mkPlot -underline 0 -.menu.canvas.m add command -label "Text" -command mkCanvText -underline 0 -.menu.canvas.m add command -label "Arrow shapes" -command mkArrow -underline 0 -.menu.canvas.m add command -label "Ruler" -command mkRuler -underline 0 -.menu.canvas.m add command -label "Scrollable canvas" -command mkScroll \ - -underline 0 -.menu.canvas.m add command -label "Floor plan" -command mkFloor \ - -underline 0 - -menubutton .menu.menu -text "Menus" -menu .menu.menu.m -underline 0 -menu .menu.menu.m -.menu.menu.m add command -label "Print hello" -command {puts stdout "Hello"} \ - -accelerator Control+a -underline 6 -bind .msg {puts stdout "Hello"} -.menu.menu.m add command -label "Print goodbye" -command {\ - puts stdout "Goodbye"} -accelerator Control+b -underline 6 -bind .msg {puts stdout "Goodbye"} -.menu.menu.m add command -label "Light blue background" \ - -command {.msg config -bg "LightBlue1"} -underline 0 -.menu.menu.m add command -label "Info on tear-off menus" -command mkTear \ - -underline 0 -.menu.menu.m add cascade -label "Check buttons" -menu .menu.menu.m.check \ - -underline 0 -.menu.menu.m add cascade -label "Radio buttons" -menu .menu.menu.m.radio \ - -underline 0 -.menu.menu.m add command -bitmap @$tk_library/demos/bitmaps/pattern \ - -command { - mkDialog .pattern {-text {The menu entry you invoked displays a bitmap rather than a text string. Other than this, it is just like any other menu entry.} -aspect 250} {OK {}} - } - -menu .menu.menu.m.check -.menu.menu.m.check add check -label "Oil checked" -variable oil -.menu.menu.m.check add check -label "Transmission checked" -variable trans -.menu.menu.m.check add check -label "Brakes checked" -variable brakes -.menu.menu.m.check add check -label "Lights checked" -variable lights -.menu.menu.m.check add separator -.menu.menu.m.check add command -label "Show current values" \ - -command "showVars .menu.menu.dialog oil trans brakes lights" -.menu.menu.m.check invoke 1 -.menu.menu.m.check invoke 3 - -menu .menu.menu.m.radio -.menu.menu.m.radio add radio -label "10 point" -variable pointSize -value 10 -.menu.menu.m.radio add radio -label "14 point" -variable pointSize -value 14 -.menu.menu.m.radio add radio -label "18 point" -variable pointSize -value 18 -.menu.menu.m.radio add radio -label "24 point" -variable pointSize -value 24 -.menu.menu.m.radio add radio -label "32 point" -variable pointSize -value 32 -.menu.menu.m.radio add sep -.menu.menu.m.radio add radio -label "Roman" -variable style -value roman -.menu.menu.m.radio add radio -label "Bold" -variable style -value bold -.menu.menu.m.radio add radio -label "Italic" -variable style -value italic -.menu.menu.m.radio add sep -.menu.menu.m.radio add command -label "Show current values" -command \ - "showVars .menu.menu.dialog pointSize style" -.menu.menu.m.radio invoke 1 -.menu.menu.m.radio invoke 7 - -menubutton .menu.misc -text Misc -menu .menu.misc.m -underline 1 -menu .menu.misc.m -.menu.misc.m add command -label "Modal dialog (local grab)" -command { - mkDialog .modal {-text {This dialog box is a modal one. It uses Tk's "grab" command to create a "local grab" on the dialog box. The grab prevents any pointer-related events from getting to any other windows in the application. If you press the "OK" button below (or hit the Return key) then the dialog box will go away and things will return to normal.} -aspect 250 -justify left} {OK {}} - dpos .modal - tkwait visibility .modal - grab .modal - tkwait window .modal -} -underline 0 -.menu.misc.m add command -label "Modal dialog (global grab)" -command { - mkDialog .modal {-text {This is another modal dialog box. However, in this case a "global grab" is used, which locks up the display so you can't talk to any windows in any applications anywhere, except for the dialog. If you press the "OK" button below (or hit the Return key) then the dialog box will go away and things will return to normal.} -aspect 250 -justify left} {OK {}} - dpos .modal - tkwait visibility .modal - grab -global .modal - tkwait window .modal -} -underline 0 -.menu.misc.m add command -label "Built-in bitmaps" -command mkBitmaps \ - -underline 0 -.menu.misc.m add command -label "Quit" -command "destroy ." -underline 0 - -pack .menu.button .menu.listbox .menu.entry .menu.text .menu.scroll \ - .menu.scale .menu.canvas .menu.menu .menu.misc -side left - -# Set up for keyboard-based menu traversal - -bind . { - if {("%d" == "NotifyVirtual") && ("%m" == "NotifyNormal")} { - focus .menu - } -} -tk_menuBar .menu .menu.button .menu.listbox .menu.entry .menu.text \ - .menu.scroll .menu.scale .menu.canvas .menu.menu .menu.misc - -# Position a dialog box at a reasonable place on the screen. - -proc dpos w { - wm geometry $w +300+300 -} diff --git a/tk3.6/library/dialog.tcl b/tk3.6/library/dialog.tcl deleted file mode 100644 index d83a197..0000000 --- a/tk3.6/library/dialog.tcl +++ /dev/null @@ -1,115 +0,0 @@ -# dialog.tcl -- -# -# This file defines the procedure tk_dialog, which creates a dialog -# box containing a bitmap, a message, and one or more buttons. -# -# $Header: /user6/ouster/wish/library/RCS/dialog.tcl,v 1.4 93/08/16 16:59:52 ouster Exp $ SPRITE (Berkeley) -# -# 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. -# - -# -# tk_dialog: -# -# This procedure displays a dialog box, waits for a button in the dialog -# to be invoked, then returns the index of the selected button. -# -# Arguments: -# w - Window to use for dialog top-level. -# title - Title to display in dialog's decorative frame. -# text - Message to display in dialog. -# bitmap - Bitmap to display in dialog (empty string means none). -# default - Index of button that is to display the default ring -# (-1 means none). -# args - One or more strings to display in buttons across the -# bottom of the dialog box. - -proc tk_dialog {w title text bitmap default args} { - global tk_priv - - # 1. Create the top-level window and divide it into top - # and bottom parts. - - catch {destroy $w} - toplevel $w -class Dialog - wm title $w $title - wm iconname $w Dialog - frame $w.top -relief raised -bd 1 - pack $w.top -side top -fill both - frame $w.bot -relief raised -bd 1 - pack $w.bot -side bottom -fill both - - # 2. Fill the top part with bitmap and message. - - message $w.msg -width 3i -text $text \ - -font -Adobe-Times-Medium-R-Normal-*-180-* - pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 5m -pady 5m - if {$bitmap != ""} { - label $w.bitmap -bitmap $bitmap - pack $w.bitmap -in $w.top -side left -padx 5m -pady 5m - } - - # 3. Create a row of buttons at the bottom of the dialog. - - set i 0 - foreach but $args { - button $w.button$i -text $but -command "set tk_priv(button) $i" - if {$i == $default} { - frame $w.default -relief sunken -bd 1 - raise $w.button$i $w.default - pack $w.default -in $w.bot -side left -expand 1 -padx 3m -pady 2m - pack $w.button$i -in $w.default -padx 2m -pady 2m \ - -ipadx 2m -ipady 1m - bind $w "$w.button$i flash; set tk_priv(button) $i" - } else { - pack $w.button$i -in $w.bot -side left -expand 1 \ - -padx 3m -pady 3m -ipadx 2m -ipady 1m - } - incr i - } - - # 4. Withdraw the window, then update all the geometry information - # so we know how big it wants to be, then center the window in the - # display and de-iconify it. - - wm withdraw $w - update idletasks - set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \ - - [winfo vrootx [winfo parent $w]]] - set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \ - - [winfo vrooty [winfo parent $w]]] - wm geom $w +$x+$y - wm deiconify $w - - # 5. Set a grab and claim the focus too. - - set oldFocus [focus] - grab $w - focus $w - - # 6. Wait for the user to respond, then restore the focus and - # return the index of the selected button. - - tkwait variable tk_priv(button) - destroy $w - focus $oldFocus - return $tk_priv(button) -} diff --git a/tk3.6/library/entry.tcl b/tk3.6/library/entry.tcl deleted file mode 100644 index 6f7bc71..0000000 --- a/tk3.6/library/entry.tcl +++ /dev/null @@ -1,74 +0,0 @@ -# entry.tcl -- -# -# This file contains Tcl procedures used to manage Tk entries. -# -# $Header: /user6/ouster/wish/library/RCS/entry.tcl,v 1.7 93/10/18 17:15:23 ouster Exp $ SPRITE (Berkeley) -# -# 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. -# - -# The procedure below is invoked to backspace over one character -# in an entry widget. The name of the widget is passed as argument. - -proc tk_entryBackspace w { - set x [expr {[$w index insert] - 1}] - if {$x != -1} {$w delete $x} -} - -# The procedure below is invoked to backspace over one word in an -# entry widget. The name of the widget is passed as argument. - -proc tk_entryBackword w { - set string [$w get] - set curs [expr [$w index insert]-1] - if {$curs < 0} return - for {set x $curs} {$x > 0} {incr x -1} { - if {([string first [string index $string $x] " \t"] < 0) - && ([string first [string index $string [expr $x-1]] " \t"] - >= 0)} { - break - } - } - $w delete $x $curs -} - -# The procedure below is invoked after insertions. If the caret is not -# visible in the window then the procedure adjusts the entry's view to -# bring the caret back into the window again. Also, try to keep at -# least one character visible to the left of the caret. - -proc tk_entrySeeCaret w { - set c [$w index insert] - set left [$w index @0] - if {$left >= $c} { - if {$c > 0} { - $w view [expr $c-1] - } else { - $w view $c - } - return - } - set x [expr [winfo width $w] - [lindex [$w config -bd] 4] - 1] - while {([$w index @$x] < $c) && ($left < $c)} { - set left [expr $left+1] - $w view $left - } -} diff --git a/tk3.6/library/listbox.tcl b/tk3.6/library/listbox.tcl deleted file mode 100644 index 21eb7c7..0000000 --- a/tk3.6/library/listbox.tcl +++ /dev/null @@ -1,40 +0,0 @@ -# listbox.tcl -- -# -# This file contains Tcl procedures used to manage Tk listboxes. -# -# $Header: /user6/ouster/wish/library/RCS/listbox.tcl,v 1.3 93/07/01 13:42:05 ouster Exp $ SPRITE (Berkeley) -# -# 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. -# - -# The procedure below may be invoked to change the behavior of -# listboxes so that only a single item may be selected at once. -# The arguments give one or more windows whose behavior should -# be changed; if one of the arguments is "Listbox" then the default -# behavior is changed for all listboxes. - -proc tk_listboxSingleSelect args { - foreach w $args { - bind $w {%W select from [%W nearest %y]} - bind $w {%W select from [%W nearest %y]} - bind $w {%W select from [%W nearest %y]} - } -} diff --git a/tk3.6/library/menu.tcl b/tk3.6/library/menu.tcl deleted file mode 100644 index 598d5c5..0000000 --- a/tk3.6/library/menu.tcl +++ /dev/null @@ -1,352 +0,0 @@ -# menu.tcl -- -# -# This file contains Tcl procedures used to manage Tk menus and -# menubuttons. Most of the code here is dedicated to support for -# pulling down menus and menu traversal via the keyboard. -# -# $Header: /user6/ouster/wish/library/RCS/menu.tcl,v 1.23 93/09/17 14:02:28 ouster Exp $ SPRITE (Berkeley) -# -# 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. -# - -# The procedure below is publically available. It is used to identify -# a frame that serves as a menu bar and the menu buttons that lie inside -# the menu bar. This procedure establishes proper "menu bar" behavior -# for all of the menu buttons, including keyboard menu traversal. Only -# one menu bar may exist for a given top-level window at a time. -# Arguments: -# -# bar - The path name of the containing frame. Must -# be an ancestor of all of the menu buttons, -# since it will be be used in grabs. -# additional arguments - One or more menu buttons that are descendants -# of bar. The order of these arguments -# determines the order of keyboard traversal. -# If no extra arguments are named then all of -# the menu bar information for bar is cancelled. - -proc tk_menuBar {w args} { - global tk_priv - if {$args == ""} { - if [catch {set menus $tk_priv(menusFor$w)}] { - return "" - } - return $menus - } - if [info exists tk_priv(menusFor$w)] { - unset tk_priv(menusFor$w) - unset tk_priv(menuBarFor[winfo toplevel $w]) - } - if {$args == "{}"} { - return - } - set tk_priv(menusFor$w) $args - set tk_priv(menuBarFor[winfo toplevel $w]) $w - bind $w {tk_traverseToMenu %W %A} - bind $w {tk_firstMenu %W} - bind $w tk_mbUnpost -} - -proc tk_menus {w args} { - error "tk_menus is obsolete in Tk versions 3.0 and later; please change your scripts to use tk_menuBar instead" -} - -# The procedure below is publically available. It takes any number of -# arguments that are names of widgets or classes. It sets up bindings -# for the widgets or classes so that keyboard menu traversal is possible -# when the input focus is in those widgets or classes. - -proc tk_bindForTraversal args { - foreach w $args { - bind $w {tk_traverseToMenu %W %A} - bind $w {tk_firstMenu %W} - } -} - -# The procedure below does all of the work of posting a menu (including -# unposting any other menu that might currently be posted). The "w" -# argument is the name of the menubutton for the menu to be posted. -# Note: if $w is disabled then the procedure does nothing. - -proc tk_mbPost {w} { - global tk_priv tk_strictMotif - if {[lindex [$w config -state] 4] == "disabled"} { - return - } - if {$w == $tk_priv(posted)} { - grab -global $tk_priv(grab) - return - } - set menu [lindex [$w config -menu] 4] - if {$menu == ""} { - return - } - if ![string match $w* $menu] { - error "can't post $menu: it isn't a descendant of $w (this is a new requirement in Tk versions 3.0 and later)" - } - set cur $tk_priv(posted) - if {$cur != ""} tk_mbUnpost - set tk_priv(relief) [lindex [$w config -relief] 4] - $w config -relief raised - set tk_priv(posted) $w - if {$tk_priv(focus) == ""} { - set tk_priv(focus) [focus] - } - set tk_priv(activeBg) [lindex [$menu config -activebackground] 4] - set tk_priv(activeFg) [lindex [$menu config -activeforeground] 4] - if $tk_strictMotif { - $menu config -activebackground [lindex [$menu config -background] 4] - $menu config -activeforeground [lindex [$menu config -foreground] 4] - } - $menu activate none - focus $menu - $menu post [winfo rootx $w] [expr [winfo rooty $w]+[winfo height $w]] - if [catch {set grab $tk_priv(menuBarFor[winfo toplevel $w])}] { - set grab $w - } else { - if [lsearch $tk_priv(menusFor$grab) $w]<0 { - set grab $w - } - } - set tk_priv(cursor) [lindex [$grab config -cursor] 4] - $grab config -cursor arrow - set tk_priv(grab) $grab - grab -global $grab -} - -# The procedure below does all the work of unposting the menubutton that's -# currently posted. It takes no arguments. Special notes: -# 1. It's important to unpost the menu before releasing the grab, so -# that any Enter-Leave events (e.g. from menu back to main -# application) have mode NotifyGrab. -# 2. Be sure to enclose various groups of commands in "catch" so that -# the procedure will complete even if the menubutton or the menu -# or the grab window has been deleted. - -proc tk_mbUnpost {} { - global tk_priv - set w $tk_priv(posted) - if {$w != ""} { - catch { - set menu [lindex [$w config -menu] 4] - $menu unpost - $menu config -activebackground $tk_priv(activeBg) - $menu config -activeforeground $tk_priv(activeFg) - $w config -relief $tk_priv(relief) - } - catch {$tk_priv(grab) config -cursor $tk_priv(cursor)} - catch {focus $tk_priv(focus)} - grab release $tk_priv(grab) - set tk_priv(grab) "" - set tk_priv(focus) "" - set tk_priv(posted) {} - } -} - -# The procedure below is invoked to implement keyboard traversal to -# a menu button. It takes two arguments: the name of a window where -# a keystroke originated, and the ascii character that was typed. -# This procedure finds a menu bar by looking upward for a top-level -# window, then looking for a window underneath that named "menu". -# Then it searches through all the subwindows of "menu" for a menubutton -# with an underlined character matching char. If one is found, it -# posts that menu. - -proc tk_traverseToMenu {w char} { - global tk_priv - if {$char == ""} { - return - } - set char [string tolower $char] - - foreach mb [tk_getMenuButtons $w] { - if {[winfo class $mb] == "Menubutton"} { - set char2 [string index [lindex [$mb config -text] 4] \ - [lindex [$mb config -underline] 4]] - if {[string compare $char [string tolower $char2]] == 0} { - tk_mbPost $mb - [lindex [$mb config -menu] 4] activate 0 - return - } - } - } -} - -# The procedure below is used to implement keyboard traversal within -# the posted menu. It takes two arguments: the name of the menu to -# be traversed within, and an ASCII character. It searches for an -# entry in the menu that has that character underlined. If such an -# entry is found, it is invoked and the menu is unposted. - -proc tk_traverseWithinMenu {w char} { - if {$char == ""} { - return - } - set char [string tolower $char] - set last [$w index last] - if {$last == "none"} { - return - } - for {set i 0} {$i <= $last} {incr i} { - if [catch {set char2 [string index \ - [lindex [$w entryconfig $i -label] 4] \ - [lindex [$w entryconfig $i -underline] 4]]}] { - continue - } - if {[string compare $char [string tolower $char2]] == 0} { - tk_mbUnpost - $w invoke $i - return - } - } -} - -# The procedure below takes a single argument, which is the name of -# a window. It returns a list containing path names for all of the -# menu buttons associated with that window's top-level window, or an -# empty list if there are none. - -proc tk_getMenuButtons w { - global tk_priv - set top [winfo toplevel $w] - if [catch {set bar [set tk_priv(menuBarFor$top)]}] { - return "" - } - return $tk_priv(menusFor$bar) -} - -# The procedure below is used to traverse to the next or previous -# menu in a menu bar. It takes one argument, which is a count of -# how many menu buttons forward or backward (if negative) to move. -# If there is no posted menu then this procedure has no effect. - -proc tk_nextMenu count { - global tk_priv - if {$tk_priv(posted) == ""} { - return - } - set buttons [tk_getMenuButtons $tk_priv(posted)] - set length [llength $buttons] - for {set i 0} 1 {incr i} { - if {$i >= $length} { - return - } - if {[lindex $buttons $i] == $tk_priv(posted)} { - break - } - } - incr i $count - while 1 { - while {$i < 0} { - incr i $length - } - while {$i >= $length} { - incr i -$length - } - set mb [lindex $buttons $i] - if {[lindex [$mb configure -state] 4] != "disabled"} { - break - } - incr i $count - } - tk_mbUnpost - tk_mbPost $mb - [lindex [$mb config -menu] 4] activate 0 -} - -# The procedure below is used to traverse to the next or previous entry -# in the posted menu. It takes one argument, which is 1 to go to the -# next entry or -1 to go to the previous entry. Disabled entries are -# skipped in this process. - -proc tk_nextMenuEntry count { - global tk_priv - if {$tk_priv(posted) == ""} { - return - } - set menu [lindex [$tk_priv(posted) config -menu] 4] - if {[$menu index last] == "none"} { - return - } - set length [expr [$menu index last]+1] - set i [$menu index active] - if {$i == "none"} { - set i 0 - } else { - incr i $count - } - while 1 { - while {$i < 0} { - incr i $length - } - while {$i >= $length} { - incr i -$length - } - if {[catch {$menu entryconfigure $i -state} state] == 0} { - if {[lindex $state 4] != "disabled"} { - break - } - } - incr i $count - } - $menu activate $i -} - -# The procedure below invokes the active entry in the posted menu, -# if there is one. Otherwise it does nothing. - -proc tk_invokeMenu {menu} { - set i [$menu index active] - if {$i != "none"} { - tk_mbUnpost - update idletasks - $menu invoke $i - } -} - -# The procedure below is invoked to keyboard-traverse to the first -# menu for a given source window. The source window is passed as -# parameter. - -proc tk_firstMenu w { - set mb [lindex [tk_getMenuButtons $w] 0] - if {$mb != ""} { - tk_mbPost $mb - [lindex [$mb config -menu] 4] activate 0 - } -} - -# The procedure below is invoked when a button-1-down event is -# received by a menu button. If the mouse is in the menu button -# then it posts the button's menu. If the mouse isn't in the -# button's menu, then it deactivates any active entry in the menu. -# Remember, event-sharing can cause this procedure to be invoked -# for two different menu buttons on the same event. - -proc tk_mbButtonDown w { - global tk_priv - if {[lindex [$w config -state] 4] == "disabled"} { - return - } - if {$tk_priv(inMenuButton) == $w} { - tk_mbPost $w - } -} diff --git a/tk3.6/library/prolog.ps b/tk3.6/library/prolog.ps deleted file mode 100644 index 0c2b343..0000000 --- a/tk3.6/library/prolog.ps +++ /dev/null @@ -1,203 +0,0 @@ -% This file contains the standard Postscript prolog used when -% generating Postscript from canvas widgets. -% -% $Header: /user6/ouster/wish/library/RCS/prolog.ps,v 1.6 93/04/01 14:03:52 ouster Exp $ SPRITE (Berkeley); - -%%BeginProlog -50 dict begin - -% The definitions below just define all of the variables used in -% any of the procedures here. This is needed for obscure reasons -% explained on p. 716 of the Postscript manual (Section H.2.7, -% "Initializing Variables," in the section on Encapsulated Postscript). - -/baseline 0 def -/stipimage 0 def -/height 0 def -/justify 0 def -/maxwidth 0 def -/spacing 0 def -/stipple 0 def -/strings 0 def -/xoffset 0 def -/yoffset 0 def -/tmpstip null def -/encoding {ISOLatin1Encoding} def - -% Override setfont to automatically encode the font in the style defined by -% by 'encoding' (ISO Latin1 by default). - -systemdict /encodefont known { - /realsetfont /setfont load def - /setfont { - encoding encodefont realsetfont - } def -} if - -% desiredSize EvenPixels closestSize -% -% The procedure below is used for stippling. Given the optimal size -% of a dot in a stipple pattern in the current user coordinate system, -% compute the closest size that is an exact multiple of the device's -% pixel size. This allows stipple patterns to be displayed without -% aliasing effects. - -/EvenPixels { - % Compute exact number of device pixels per stipple dot. - dup 0 matrix currentmatrix dtransform - dup mul exch dup mul add sqrt - - % Round to an integer, make sure the number is at least 1, and compute - % user coord distance corresponding to this. - dup round dup 1 lt {pop 1} if - exch div mul -} bind def - -% width height string filled StippleFill -- -% -% Given a path and other graphics information already set up, this -% procedure will fill the current path in a stippled fashion. "String" -% contains a proper image description of the stipple pattern and -% "width" and "height" give its dimensions. If "filled" is true then -% it means that the area to be stippled is gotten by filling the -% current path (e.g. the interior of a polygon); if it's false, the -% area is gotten by stroking the current path (e.g. a wide line). -% Each stipple dot is assumed to be about one unit across in the -% current user coordinate system. - -/StippleFill { - % Turn the path into a clip region that we can then cover with - % lots of images corresponding to the stipple pattern. Warning: - % some Postscript interpreters get errors during strokepath for - % dashed lines. If this happens, turn off dashes and try again. - - 1 index /tmpstip exch def %% Works around NeWSprint bug - - gsave - {eoclip} - {{strokepath} stopped {grestore gsave [] 0 setdash strokepath} if clip} - ifelse - - % Change the scaling so that one user unit in user coordinates - % corresponds to the size of one stipple dot. - 1 EvenPixels dup scale - - % Compute the bounding box occupied by the path (which is now - % the clipping region), and round the lower coordinates down - % to the nearest starting point for the stipple pattern. - - pathbbox - 4 2 roll - 5 index div cvi 5 index mul 4 1 roll - 6 index div cvi 6 index mul 3 2 roll - - % Stack now: width height string y1 y2 x1 x2 - % Below is a doubly-nested for loop to iterate across this area - % in units of the stipple pattern size, going up columns then - % across rows, blasting out a stipple-pattern-sized rectangle at - % each position - - 6 index exch { - 2 index 5 index 3 index { - % Stack now: width height string y1 y2 x y - - gsave - 1 index exch translate - 5 index 5 index true matrix tmpstip imagemask - grestore - } for - pop - } for - pop pop pop pop pop - grestore - newpath -} bind def - -% -- AdjustColor -- -% Given a color value already set for output by the caller, adjusts -% that value to a grayscale or mono value if requested by the CL -% variable. - -/AdjustColor { - CL 2 lt { - currentgray - CL 0 eq { - .5 lt {0} {1} ifelse - } if - setgray - } if -} bind def - -% x y strings spacing xoffset yoffset justify stipple stipimage DrawText -- -% This procedure does all of the real work of drawing text. The -% color and font must already have been set by the caller, and the -% following arguments must be on the stack: -% -% x, y - Coordinates at which to draw text. -% strings - An array of strings, one for each line of the text item, -% in order from top to bottom. -% spacing - Spacing between lines. -% xoffset - Horizontal offset for text bbox relative to x and y: 0 for -% nw/w/sw anchor, -0.5 for n/center/s, and -1.0 for ne/e/se. -% yoffset - Vertical offset for text bbox relative to x and y: 0 for -% nw/n/ne anchor, +0.5 for w/center/e, and +1.0 for sw/s/se. -% justify - 0 for left justification, 0.5 for center, 1 for right justify. -% stipple - Boolean value indicating whether or not text is to be -% drawn in stippled fashion. -% stipimage - Image for stippling, if stipple is True. -% -% Also, when this procedure is invoked, the color and font must already -% have been set for the text. - -/DrawText { - /stipimage exch def - /stipple exch def - /justify exch def - /yoffset exch def - /xoffset exch def - /spacing exch def - /strings exch def - - % First scan through all of the text to find the widest line. - - /maxwidth 0 def - strings { - stringwidth pop - dup maxwidth gt {/maxwidth exch def} {pop} ifelse - newpath - } forall - - % Compute the baseline offset and the actual font height. - - 0 0 moveto (TXygqPZ) false charpath - pathbbox dup /baseline exch def - exch pop exch sub /height exch def pop - newpath - - % Translate coordinates first so that the origin is at the upper-left - % corner of the text's bounding box. Remember that x and y for - % positioning are still on the stack. - - translate - maxwidth xoffset mul - strings length 1 sub spacing mul height add yoffset mul translate - - % Now use the baseline and justification information to translate so - % that the origin is at the baseline and positioning point for the - % first line of text. - - justify maxwidth mul baseline neg translate - - % Iterate over each of the lines to output it. For each line, - % compute its width again so it can be properly justified, then - % display it. - - strings { - dup stringwidth pop - justify neg mul 0 moveto - show - 0 spacing neg translate - } forall -} bind def - -%%EndProlog diff --git a/tk3.6/library/tclIndex b/tk3.6/library/tclIndex deleted file mode 100644 index fcb92bf..0000000 --- a/tk3.6/library/tclIndex +++ /dev/null @@ -1,35 +0,0 @@ -# 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(tk_entryBackspace) "source $dir/entry.tcl" -set auto_index(tk_entryBackword) "source $dir/entry.tcl" -set auto_index(tk_entrySeeCaret) "source $dir/entry.tcl" -set auto_index(tk_butEnter) "source $dir/button.tcl" -set auto_index(tk_butLeave) "source $dir/button.tcl" -set auto_index(tk_butDown) "source $dir/button.tcl" -set auto_index(tk_butUp) "source $dir/button.tcl" -set auto_index(tk_menuBar) "source $dir/menu.tcl" -set auto_index(tk_menus) "source $dir/menu.tcl" -set auto_index(tk_bindForTraversal) "source $dir/menu.tcl" -set auto_index(tk_mbPost) "source $dir/menu.tcl" -set auto_index(tk_mbUnpost) "source $dir/menu.tcl" -set auto_index(tk_traverseToMenu) "source $dir/menu.tcl" -set auto_index(tk_traverseWithinMenu) "source $dir/menu.tcl" -set auto_index(tk_getMenuButtons) "source $dir/menu.tcl" -set auto_index(tk_nextMenu) "source $dir/menu.tcl" -set auto_index(tk_nextMenuEntry) "source $dir/menu.tcl" -set auto_index(tk_invokeMenu) "source $dir/menu.tcl" -set auto_index(tk_firstMenu) "source $dir/menu.tcl" -set auto_index(tk_mbButtonDown) "source $dir/menu.tcl" -set auto_index(tk_textSelectTo) "source $dir/text.tcl" -set auto_index(tk_textBackspace) "source $dir/text.tcl" -set auto_index(tk_textIndexCloser) "source $dir/text.tcl" -set auto_index(tk_textResetAnchor) "source $dir/text.tcl" -set auto_index(tkerror) "source $dir/tkerror.tcl" -set auto_index(tk_listboxSingleSelect) "source $dir/listbox.tcl" -set auto_index(tk_dialog) "source $dir/dialog.tcl" diff --git a/tk3.6/library/text.tcl b/tk3.6/library/text.tcl deleted file mode 100644 index 74fa693..0000000 --- a/tk3.6/library/text.tcl +++ /dev/null @@ -1,126 +0,0 @@ -# text.tcl -- -# -# This file contains Tcl procedures used to manage Tk entries. -# -# $Header: /user6/ouster/wish/library/RCS/text.tcl,v 1.4 93/10/23 16:21:12 ouster Exp $ SPRITE (Berkeley) -# -# 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. -# - -# The procedure below is invoked when dragging one end of the selection. -# The arguments are the text window name and the index of the character -# that is to be the new end of the selection. - -proc tk_textSelectTo {w index} { - global tk_priv - - if [catch {$w index anchor}] { - $w mark set anchor $index - } - case $tk_priv(selectMode) { - char { - if [$w compare $index < anchor] { - set first $index - set last anchor - } else { - set first anchor - set last [$w index $index+1c] - } - } - word { - if [$w compare $index < anchor] { - set first [$w index "$index wordstart"] - set last [$w index "anchor wordend"] - } else { - set first [$w index "anchor wordstart"] - set last [$w index "$index wordend"] - } - } - line { - if [$w compare $index < anchor] { - set first [$w index "$index linestart"] - set last [$w index "anchor lineend + 1c"] - } else { - set first [$w index "anchor linestart"] - set last [$w index "$index lineend + 1c"] - } - } - } - $w tag remove sel 0.0 $first - $w tag add sel $first $last - $w tag remove sel $last end -} - -# The procedure below is invoked to backspace over one character in -# a text widget. The name of the widget is passed as argument. - -proc tk_textBackspace w { - $w delete insert-1c insert -} - -# The procedure below compares three indices, a, b, and c. Index b must -# be less than c. The procedure returns 1 if a is closer to b than to c, -# and 0 otherwise. The "w" argument is the name of the text widget in -# which to do the comparison. - -proc tk_textIndexCloser {w a b c} { - set a [$w index $a] - set b [$w index $b] - set c [$w index $c] - if [$w compare $a <= $b] { - return 1 - } - if [$w compare $a >= $c] { - return 0 - } - scan $a "%d.%d" lineA chA - scan $b "%d.%d" lineB chB - scan $c "%d.%d" lineC chC - if {$chC == 0} { - incr lineC -1 - set chC [string length [$w get $lineC.0 $lineC.end]] - } - if {$lineB != $lineC} { - return [expr {($lineA-$lineB) < ($lineC-$lineA)}] - } - return [expr {($chA-$chB) < ($chC-$chA)}] -} - -# The procedure below is called to reset the selection anchor to -# whichever end is FARTHEST from the index argument. - -proc tk_textResetAnchor {w index} { - global tk_priv - if {[$w tag ranges sel] == ""} { - set tk_priv(selectMode) char - $w mark set anchor $index - return - } - if [tk_textIndexCloser $w $index sel.first sel.last] { - if {$tk_priv(selectMode) == "char"} { - $w mark set anchor sel.last - } else { - $w mark set anchor sel.last-1c - } - } else { - $w mark set anchor sel.first - } -} diff --git a/tk3.6/library/tk.tcl b/tk3.6/library/tk.tcl deleted file mode 100644 index 686fb29..0000000 --- a/tk3.6/library/tk.tcl +++ /dev/null @@ -1,315 +0,0 @@ -# tk.tcl -- -# -# Initialization script normally executed in the interpreter for each -# Tk-based application. Arranges class bindings for widgets. -# -# $Header: /user6/ouster/wish/library/RCS/tk.tcl,v 1.37 93/10/31 16:39:17 ouster Exp $ SPRITE (Berkeley) -# -# 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. - -# Insist on running with compatible versions of Tcl and Tk. - -scan [info tclversion] "%d.%d" a b -if {$a != 7} { - error "wrong version of Tcl loaded ([info tclversion]): need 7.x" -} -scan $tk_version "%d.%d" a b -if {($a != 3) || ($b < 4)} { - error "wrong version of Tk loaded ($tk_version): need 3.4 or later" -} -unset a b - -# Add Tk's directory to the end of the auto-load search path: - -lappend auto_path $tk_library - -# Turn off strict Motif look and feel as a default. - -set tk_strictMotif 0 - -# ---------------------------------------------------------------------- -# Class bindings for various flavors of button widgets. $tk_priv(window) -# keeps track of the button containing the mouse $tk_priv(relief) saves -# the original relief of the button so it can be restored when the mouse -# button is released, and $tk_priv(buttonWindow) keeps track of the -# window in which the mouse button was pressed. -# ---------------------------------------------------------------------- - -bind Button {tk_butEnter %W} -bind Button {tk_butLeave %W} -bind Button <1> {tk_butDown %W} -bind Button {tk_butUp %W} - -bind Checkbutton {tk_butEnter %W} -bind Checkbutton {tk_butLeave %W} -bind Checkbutton <1> {tk_butDown %W} -bind Checkbutton {tk_butUp %W} - -bind Radiobutton {tk_butEnter %W} -bind Radiobutton {tk_butLeave %W} -bind Radiobutton <1> {tk_butDown %W} -bind Radiobutton {tk_butUp %W} - -# ---------------------------------------------------------------------- -# Class bindings for entry widgets. -# ---------------------------------------------------------------------- - -bind Entry <1> { - %W icursor @%x - %W select from @%x - if {[lindex [%W config -state] 4] == "normal"} {focus %W} -} -bind Entry {%W select to @%x} -bind Entry {%W select adjust @%x} -bind Entry {%W select to @%x} -bind Entry <2> {%W scan mark %x} -bind Entry {%W scan dragto %x} -bind Entry { - if {"%A" != ""} { - %W insert insert %A - tk_entrySeeCaret %W - } -} -bind Entry {tk_entryBackspace %W; tk_entrySeeCaret %W} -bind Entry {tk_entryBackspace %W; tk_entrySeeCaret %W} -bind Entry {tk_entryBackspace %W; tk_entrySeeCaret %W} -bind Entry {%W delete sel.first sel.last; tk_entrySeeCaret %W} -bind Entry {%W delete 0 end} -bind Entry {%W insert insert [selection get]; tk_entrySeeCaret %W} -bind Entry {tk_entryBackword %W; tk_entrySeeCaret %W} -tk_bindForTraversal Entry - -# ---------------------------------------------------------------------- -# Class bindings for listbox widgets. -# ---------------------------------------------------------------------- - -bind Listbox <1> {%W select from [%W nearest %y]} -bind Listbox {%W select to [%W nearest %y]} -bind Listbox {%W select adjust [%W nearest %y]} -bind Listbox {%W select to [%W nearest %y]} -bind Listbox <2> {%W scan mark %x %y} -bind Listbox {%W scan dragto %x %y} - -# ---------------------------------------------------------------------- -# Class bindings for scrollbar widgets. When strict Motif is requested, -# the bindings use $tk_priv(buttons) and $tk_priv(activeFg) to set the -# -activeforeground color to -foreground when the mouse is in the window -# and restore it when the mouse leaves. -# ---------------------------------------------------------------------- - -bind Scrollbar { - if $tk_strictMotif { - set tk_priv(activeFg) [lindex [%W config -activeforeground] 4] - %W config -activeforeground [lindex [%W config -foreground] 4] - } -} -bind Scrollbar { - if {$tk_strictMotif && ($tk_priv(buttons) == 0)} { - %W config -activeforeground $tk_priv(activeFg) - } -} -bind Scrollbar {incr tk_priv(buttons)} -bind Scrollbar {incr tk_priv(buttons) -1} - -# ---------------------------------------------------------------------- -# Class bindings for scale widgets. When strict Motif is requested, -# the bindings use $tk_priv(buttons) and $tk_priv(activeFg) to set the -# -activeforeground color to -foreground when the mouse is in the window -# and restore it when the mouse leaves. -# ---------------------------------------------------------------------- - -bind Scale { - if $tk_strictMotif { - set tk_priv(activeFg) [lindex [%W config -activeforeground] 4] - %W config -activeforeground [lindex [%W config -sliderforeground] 4] - } -} -bind Scale { - if {$tk_strictMotif && ($tk_priv(buttons) == 0)} { - %W config -activeforeground $tk_priv(activeFg) - } -} -bind Scale {incr tk_priv(buttons)} -bind Scale {incr tk_priv(buttons) -1} - -# ---------------------------------------------------------------------- -# Class bindings for menubutton widgets. Variables used: -# $tk_priv(posted) - keeps track of the menubutton whose menu is -# currently posted (or empty string, if none). -# $tk_priv(inMenuButton)- if non-null, identifies menu button -# containing mouse pointer. -# $tk_priv(relief) - keeps track of original relief of posted -# menu button, so it can be restored later. -# $tk_priv(dragging) - if non-null, identifies menu button whose -# menu is currently being dragged in a tear-off -# operation. -# $tk_priv(focus) - records old focus window so focus can be -# returned there after keyboard traversal -# to menu. -# ---------------------------------------------------------------------- - -bind Menubutton { - set tk_priv(inMenuButton) %W - if {[lindex [%W config -state] 4] != "disabled"} { - if {!$tk_strictMotif} { - %W config -state active - } - } -} -bind Menubutton { - set tk_priv(inMenuButton) {} - if {[lindex [%W config -state] 4] == "active"} { - %W config -state normal - } -} -bind Menubutton <1> {tk_mbButtonDown %W} -bind Menubutton { - if {($tk_priv(posted) == "%W") && ($tk_priv(inMenuButton) == "%W")} { - [lindex [$tk_priv(posted) config -menu] 4] activate 0 - } else { - tk_mbUnpost - } -} - -# The binding below is trickier than it looks. It's important to check -# to see that another menu is posted in the "if" statement below. -# The check is needed because some window managers (e.g. mwm in -# click-to-focus mode) cause a button-press event to be preceded by -# a B1-Enter event; we don't want to process that B1-Enter event (if -# we do, the grab may get mis-set so that the menu is non-responsive). - -bind Menubutton { - set tk_priv(inMenuButton) %W - if {([lindex [%W config -state] 4] != "disabled") - && ($tk_priv(posted) != "")} { - if {!$tk_strictMotif} { - %W config -state active - } - tk_mbPost %W - } -} -bind Menubutton <2> { - if {($tk_priv(posted) == "") - && ([lindex [%W config -state] 4] != "disabled")} { - set tk_priv(dragging) %W - [lindex [$tk_priv(dragging) config -menu] 4] post %X %Y - } -} -bind Menubutton { - if {$tk_priv(dragging) != ""} { - [lindex [$tk_priv(dragging) config -menu] 4] post %X %Y - } -} -bind Menubutton {set tk_priv(dragging) ""} - -# ---------------------------------------------------------------------- -# Class bindings for menu widgets. $tk_priv(x) and $tk_priv(y) are used -# to keep track of the position of the mouse cursor in the menu window -# during dragging of tear-off menus. $tk_priv(window) keeps track of -# the menu containing the mouse, if any. -# ---------------------------------------------------------------------- - -bind Menu {set tk_priv(window) %W; %W activate @%y} -bind Menu {set tk_priv(window) {}; %W activate none} -bind Menu { - if {$tk_priv(window) == "%W"} { - %W activate @%y - } -} -bind Menu <1> { - if {$tk_priv(grab) != ""} { - grab $tk_priv(grab) - } -} -bind Menu {tk_invokeMenu %W} -bind Menu <2> {set tk_priv(x) %x; set tk_priv(y) %y} -bind Menu { - if {$tk_priv(posted) == ""} { - %W post [expr %X-$tk_priv(x)] [expr %Y-$tk_priv(y)] - } -} -bind Menu { } -bind Menu { } -bind Menu {tk_mbUnpost} -bind Menu {tk_traverseWithinMenu %W %A} -bind Menu {tk_nextMenu -1} -bind Menu {tk_nextMenu 1} -bind Menu {tk_nextMenuEntry -1} -bind Menu {tk_nextMenuEntry 1} -bind Menu {tk_invokeMenu %W} - -# ---------------------------------------------------------------------- -# Class bindings for text widgets. $tk_priv(selectMode) holds one of -# "char", "word", or "line" to indicate which selection mode is active. -# ---------------------------------------------------------------------- - -bind Text <1> { - set tk_priv(selectMode) char - %W mark set insert @%x,%y - %W mark set anchor insert - if {[lindex [%W config -state] 4] == "normal"} {focus %W} -} -bind Text { - set tk_priv(selectMode) word - %W mark set insert "@%x,%y wordstart" - tk_textSelectTo %W insert -} -bind Text { - set tk_priv(selectMode) line - %W mark set insert "@%x,%y linestart" - tk_textSelectTo %W insert -} -bind Text {tk_textSelectTo %W @%x,%y} -bind Text { - tk_textResetAnchor %W @%x,%y - tk_textSelectTo %W @%x,%y -} -bind Text {tk_textSelectTo %W @%x,%y} -bind Text <2> {%W scan mark %y} -bind Text {%W scan dragto %y} -bind Text { - if {"%A" != ""} { - %W insert insert %A - %W yview -pickplace insert - } -} -bind Text {%W insert insert \n; %W yview -pickplace insert} -bind Text {tk_textBackspace %W; %W yview -pickplace insert} -bind Text {tk_textBackspace %W; %W yview -pickplace insert} -bind Text {tk_textBackspace %W; %W yview -pickplace insert} -bind Text {%W delete sel.first sel.last} -bind Text { - %W insert insert [selection get] - %W yview -pickplace insert -} -tk_bindForTraversal Text - -# Initialize the elements of tk_priv that require initialization. - -set tk_priv(buttons) 0 -set tk_priv(buttonWindow) {} -set tk_priv(dragging) {} -set tk_priv(focus) {} -set tk_priv(grab) {} -set tk_priv(inMenuButton) {} -set tk_priv(posted) {} -set tk_priv(selectMode) char -set tk_priv(window) {} diff --git a/tk3.6/library/tkerror.tcl b/tk3.6/library/tkerror.tcl deleted file mode 100644 index 3b6df20..0000000 --- a/tk3.6/library/tkerror.tcl +++ /dev/null @@ -1,39 +0,0 @@ -# This file contains a default version of the tkError procedure. It -# posts a dialog box with the error message and gives the user a chance -# to see a more detailed stack trace. - -proc tkerror err { - global errorInfo - set info $errorInfo - if {[tk_dialog .tkerrorDialog "Error in Tcl Script" \ - "Error: $err" error 0 OK "See Stack Trace"] == 0} { - return - } - - set w .tkerrorTrace - catch {destroy $w} - toplevel $w -class ErrorTrace - wm minsize $w 1 1 - wm title $w "Stack Trace for Error" - wm iconname $w "Stack Trace" - button $w.ok -text OK -command "destroy $w" - text $w.text -relief raised -bd 2 -yscrollcommand "$w.scroll set" \ - -setgrid true -width 40 -height 10 - scrollbar $w.scroll -relief flat -command "$w.text yview" - pack $w.ok -side bottom -padx 3m -pady 3m -ipadx 2m -ipady 1m - pack $w.scroll -side right -fill y - pack $w.text -side left -expand yes -fill both - $w.text insert 0.0 $info - $w.text mark set insert 0.0 - - # Center the window on the screen. - - wm withdraw $w - update idletasks - set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \ - - [winfo vrootx [winfo parent $w]]] - set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \ - - [winfo vrooty [winfo parent $w]]] - wm geom $w +$x+$y - wm deiconify $w -} diff --git a/tk3.6/patchlevel.h b/tk3.6/patchlevel.h deleted file mode 100644 index f916d82..0000000 --- a/tk3.6/patchlevel.h +++ /dev/null @@ -1,13 +0,0 @@ -/* - * patchlevel.h -- - * - * This file does nothing except define a "patch level" for Tk. - * The patch level has the form "X.YpZ" where X.Y is the base - * release, and Z is a serial number that is used to sequence - * patches for a given release. Thus 3.6p1 is the first patch - * to release 3.6, 3.6p2 is the patch that follows 3.6p1, and - * so on. The patch level ensures that patches are applied in - * the correct order and only to appropriate sources. - */ - -#define TK_PATCH_LEVEL "3.6p1" diff --git a/tk3.6/tests/btree.test b/tk3.6/tests/btree.test deleted file mode 100644 index 7685b2b..0000000 --- a/tk3.6/tests/btree.test +++ /dev/null @@ -1,626 +0,0 @@ -# This file is a Tcl script to test out the B-tree facilities of -# Tk's text widget. The file "text.test" contains additional tests -# for the features of text widgets not directly involved in manipulating -# B-trees. This file is organized in the standard fashion for Tcl tests. -# -# 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/wish/tests/RCS/btree.test,v 1.7 93/10/11 17:12:01 ouster Exp $ (Berkeley) - -if {[string compare test [info procs test]] == 1} then \ - {source defs} - -catch {destroy .t} -text .t -.t debug on - -test btree-1.1 {basic insertions} { - .t delete 1.0 100000.0 - .t insert 1.0 "Line 1\nLine 2\nLine 3" - .t get 1.0 1000000.0 -} "Line 1\nLine 2\nLine 3\n" -test btree-1.2 {basic insertions} { - .t delete 1.0 100000.0 - .t insert 1.0 "Line 1\nLine 2\nLine 3" - .t insert 1.3 XXX - .t get 1.0 1000000.0 -} "LinXXXe 1\nLine 2\nLine 3\n" -test btree-1.3 {basic insertions} { - .t delete 1.0 100000.0 - .t insert 1.0 "Line 1\nLine 2\nLine 3" - .t insert 3.0 YYY - .t get 1.0 1000000.0 -} "Line 1\nLine 2\nYYYLine 3\n" -test btree-1.4 {basic insertions} { - .t delete 1.0 100000.0 - .t insert 1.0 "Line 1\nLine 2\nLine 3" - .t insert 2.1 X\nYY - .t get 1.0 1000000.0 -} "Line 1\nLX\nYYine 2\nLine 3\n" -test btree-1.5 {basic insertions} { - .t delete 1.0 100000.0 - .t insert 1.0 "Line 1\nLine 2\nLine 3" - .t insert 2.0 X\n\n\n - .t get 1.0 1000000.0 -} "Line 1\nX\n\n\nLine 2\nLine 3\n" -test btree-1.6 {basic insertions} { - .t delete 1.0 100000.0 - .t insert 1.0 "Line 1\nLine 2\nLine 3" - .t insert 2.6 X\n - .t get 1.0 1000000.0 -} "Line 1\nLine 2X\n\nLine 3\n" -test btree-1.7 {insertion before start of text} { - .t delete 1.0 100000.0 - .t insert 1.0 "Line 1\nLine 2\nLine 3" - .t insert 0.4 XXX - .t get 1.0 1000000.0 -} "XXXLine 1\nLine 2\nLine 3\n" -test btree-1.8 {insertion past end of text} { - .t delete 1.0 100000.0 - .t insert 1.0 "Line 1\nLine 2\nLine 3" - .t insert 100.0 ZZ - .t get 1.0 1000000.0 -} "Line 1\nLine 2\nLine 3ZZ\n" -test btree-1.9 {insertion before start of line} { - .t delete 1.0 100000.0 - .t insert 1.0 "Line 1\nLine 2\nLine 3" - .t insert 2.-3 Q - .t get 1.0 1000000.0 -} "Line 1\nQLine 2\nLine 3\n" -test btree-1.10 {insertion past end of line} { - .t delete 1.0 100000.0 - .t insert 1.0 "Line 1\nLine 2\nLine 3" - .t insert 2.40 XYZZY - .t get 1.0 1000000.0 -} "Line 1\nLine 2\nXYZZYLine 3\n" -test btree-1.11 {insertion past end of last line} { - .t delete 1.0 100000.0 - .t insert 1.0 "Line 1\nLine 2\nLine 3" - .t insert 3.40 ABC - .t get 1.0 1000000.0 -} "Line 1\nLine 2\nLine 3ABC\n" - -test btree-2.1 {basic deletions} { - .t delete 1.0 100000.0 - .t insert 1.0 "Line 1\nLine 2\nLine 3" - .t delete 1.0 1.3 - .t get 1.0 1000000.0 -} "e 1\nLine 2\nLine 3\n" -test btree-2.2 {basic deletions} { - .t delete 1.0 100000.0 - .t insert 1.0 "Line 1\nLine 2\nLine 3" - .t delete 2.2 - .t get 1.0 1000000.0 -} "Line 1\nLie 2\nLine 3\n" -test btree-2.3 {deleting whole lines} { - .t delete 1.0 100000.0 - .t insert 1.0 "Line 1\nLine 2\nLine 3" - .t delete 1.2 3.0 - .t get 1.0 1000000.0 -} "LiLine 3\n" -test btree-2.4 {deleting whole lines} { - .t delete 1.0 100000.0 - .t insert 1.0 "Line 1\nLine 2\n\n\nLine 5" - .t delete 1.0 5.2 - .t get 1.0 1000000.0 -} "ne 5\n" -test btree-2.5 {deleting before start of file} { - .t delete 1.0 100000.0 - .t insert 1.0 "Line 1\nLine 2\nLine 3" - .t delete 0.3 1.2 - .t get 1.0 1000000.0 -} "ne 1\nLine 2\nLine 3\n" -test btree-2.6 {deleting after end of file} { - .t delete 1.0 100000.0 - .t insert 1.0 "Line 1\nLine 2\nLine 3" - .t delete 10.3 - .t get 1.0 1000000.0 -} "Line 1\nLine 2\nLine 3\n" -test btree-2.7 {deleting before start of line} { - .t delete 1.0 100000.0 - .t insert 1.0 "Line 1\nLine 2\nLine 3" - .t delete 3.-1 3.3 - .t get 1.0 1000000.0 -} "Line 1\nLine 2\ne 3\n" -test btree-2.8 {deleting before start of line} { - .t delete 1.0 100000.0 - .t insert 1.0 "Line 1\nLine 2\nLine 3" - .t delete 1.-1 1.0 - .t get 1.0 1000000.0 -} "Line 1\nLine 2\nLine 3\n" -test btree-2.9 {deleting after end of line} { - .t delete 1.0 100000.0 - .t insert 1.0 "Line 1\nLine 2\nLine 3" - .t delete 1.8 2.1 - .t get 1.0 1000000.0 -} "Line 1\nine 2\nLine 3\n" -test btree-2.10 {deleting after end of last line} { - .t delete 1.0 100000.0 - .t insert 1.0 "Line 1\nLine 2\nLine 3" - .t delete 3.8 4.1 - .t get 1.0 1000000.0 -} "Line 1\nLine 2\nLine 3\n" -test btree-2.11 {deleting before start of file} { - .t delete 1.0 100000.0 - .t insert 1.0 "Line 1\nLine 2\nLine 3" - .t delete 1.8 0.0 - .t get 1.0 1000000.0 -} "Line 1\nLine 2\nLine 3\n" -test btree-2.12 {deleting past end of file} { - .t delete 1.0 100000.0 - .t insert 1.0 "Line 1\nLine 2\nLine 3" - .t delete 1.8 4.0 - .t get 1.0 1000000.0 -} "Line 1\n" -test btree-2.13 {deleting with end before start of line} { - .t delete 1.0 100000.0 - .t insert 1.0 "Line 1\nLine 2\nLine 3" - .t delete 1.3 2.-3 - .t get 1.0 1000000.0 -} "LinLine 2\nLine 3\n" -test btree-2.14 {deleting past end of line} { - .t delete 1.0 100000.0 - .t insert 1.0 "Line 1\nLine 2\nLine 3" - .t delete 1.3 1.9 - .t get 1.0 1000000.0 -} "LinLine 2\nLine 3\n" -test btree-2.15 {deleting past end of line} { - .t delete 1.0 100000.0 - .t insert 1.0 "Line 1\nLine 2\nLine 3" - .t delete 3.2 3.15 - .t get 1.0 1000000.0 -} "Line 1\nLine 2\nLi\n" -test btree-2.16 {deleting past end of line} { - .t delete 1.0 100000.0 - .t insert 1.0 "Line 1\nLine 2\nLine 3" - .t delete 3.0 3.15 - .t get 1.0 1000000.0 -} "Line 1\nLine 2\n" -test btree-2.17 {deleting past end of line} { - .t delete 1.0 100000.0 - .t insert 1.0 "Line 1\nLine 2\nLine 3" - .t delete 1.0 3.15 - .t get 1.0 1000000.0 -} "\n" -test btree-2.18 {deleting with negative range} { - .t delete 1.0 100000.0 - .t insert 1.0 "Line 1\nLine 2\nLine 3" - .t delete 3.2 2.4 - .t get 1.0 1000000.0 -} "Line 1\nLine 2\nLine 3\n" -test btree-2.19 {deleting with negative range} { - .t delete 1.0 100000.0 - .t insert 1.0 "Line 1\nLine 2\nLine 3" - .t delete 3.2 3.1 - .t get 1.0 1000000.0 -} "Line 1\nLine 2\nLine 3\n" -test btree-2.20 {deleting with negative range} { - .t delete 1.0 100000.0 - .t insert 1.0 "Line 1\nLine 2\nLine 3" - .t delete 3.2 3.2 - .t get 1.0 1000000.0 -} "Line 1\nLine 2\nLine 3\n" - -proc setup {} { - .t delete 1.0 100000.0 - .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" - .t tag add x 1.1 - .t tag add x 1.5 1.13 - .t tag add x 2.2 2.6 - .t tag add y 1.5 -} - -test btree-3.1 {inserting with tags} { - setup - .t insert 1.0 XXX - list [.t tag ranges x] [.t tag ranges y] -} {{1.4 1.5 1.8 1.16 2.2 2.6} {1.8 1.9}} -test btree-3.2 {inserting with tags} { - setup - .t insert 1.15 YYY - list [.t tag ranges x] [.t tag ranges y] -} {{1.1 1.2 1.5 1.13 2.2 2.6} {1.5 1.6}} -test btree-3.3 {inserting with tags} { - setup - .t insert 1.7 ZZZZ - list [.t tag ranges x] [.t tag ranges y] -} {{1.1 1.2 1.5 1.17 2.2 2.6} {1.5 1.6}} -test btree-3.4 {inserting with tags} { - setup - .t insert 1.7 \n\n - list [.t tag ranges x] [.t tag ranges y] -} {{1.1 1.2 1.5 3.6 4.2 4.6} {1.5 1.6}} -test btree-3.5 {inserting with tags} { - setup - .t insert 1.5 A\n - list [.t tag ranges x] [.t tag ranges y] -} {{1.1 1.2 2.0 2.8 3.2 3.6} {2.0 2.1}} - -test btree-4.1 {deleting with tags} { - setup - .t delete 1.6 1.9 - list [.t tag ranges x] [.t tag ranges y] -} {{1.1 1.2 1.5 1.10 2.2 2.6} {1.5 1.6}} -test btree-4.2 {deleting with tags} { - setup - .t delete 1.1 2.3 - list [.t tag ranges x] [.t tag ranges y] -} {{1.1 1.4} {}} -test btree-4.3 {deleting with tags} { - setup - .t delete 1.4 2.1 - list [.t tag ranges x] [.t tag ranges y] -} {{1.1 1.2 1.5 1.9} {}} -test btree-4.4 {deleting with tags} { - setup - .t delete 1.14 2.1 - list [.t tag ranges x] [.t tag ranges y] -} {{1.1 1.2 1.5 1.13 1.15 1.19} {1.5 1.6}} -test btree-4.5 {deleting with tags} { - setup - .t delete 1.0 2.10 - list [.t tag ranges x] [.t tag ranges y] -} {{} {}} -test btree-4.6 {deleting with tags} { - setup - .t delete 1.0 1.5 - list [.t tag ranges x] [.t tag ranges y] -} {{1.0 1.8 2.2 2.6} {1.0 1.1}} -test btree-4.7 {deleting with tags} { - setup - .t delete 1.6 1.9 - list [.t tag ranges x] [.t tag ranges y] -} {{1.1 1.2 1.5 1.10 2.2 2.6} {1.5 1.6}} -test btree-4.8 {deleting with tags} { - setup - .t delete 1.5 1.13 - list [.t tag ranges x] [.t tag ranges y] -} {{1.1 1.2 2.2 2.6} {}} - -set bigText1 {} -for {set i 0} {$i < 10} {incr i} { - append bigText1 "Line $i\n" -} -set bigText2 {} -for {set i 0} {$i < 200} {incr i} { - append bigText2 "Line $i\n" -} -test btree-5.1 {very large inserts, with tags} { - setup - .t insert 1.0 $bigText1 - list [.t tag ranges x] [.t tag ranges y] -} {{11.1 11.2 11.5 11.13 12.2 12.6} {11.5 11.6}} -test btree-5.2 {very large inserts, with tags} { - setup - .t insert 1.2 $bigText2 - list [.t tag ranges x] [.t tag ranges y] -} {{1.1 201.0 201.3 201.11 202.2 202.6} {201.3 201.4}} -test btree-5.3 {very large inserts, with tags} { - setup - for {set i 0} {$i < 200} {incr i} { - .t insert 1.8 "longer line $i\n" - } - list [.t tag ranges x] [.t tag ranges y] [.t get 1.0 1.100] [.t get 198.0 198.100] -} {{1.1 1.2 1.5 201.5 202.2 202.6} {1.5 1.6} {Text forlonger line 199 -} {longer line 2 -}} - -test btree-6.1 {very large deletes, with tags} { - setup - .t insert 1.1 $bigText2 - .t delete 1.2 201.2 - list [.t tag ranges x] [.t tag ranges y] -} {{1.4 1.12 2.2 2.6} {1.4 1.5}} -test btree-6.2 {very large deletes, with tags} { - setup - .t insert 1.1 $bigText2 - for {set i 0} {$i < 200} {incr i} { - .t delete 1.2 2.2 - } - list [.t tag ranges x] [.t tag ranges y] -} {{1.4 1.12 2.2 2.6} {1.4 1.5}} -test btree-6.3 {very large deletes, with tags} { - setup - .t insert 1.1 $bigText2 - .t delete 2.3 10000.0 - .t get 1.0 1000.0 -} {TLine 0 -Lin -} -test btree-6.4 {very large deletes, with tags} { - setup - .t insert 1.1 $bigText2 - for {set i 0} {$i < 100} {incr i} { - .t delete 30.0 31.0 - } - list [.t tag ranges x] [.t tag ranges y] -} {{101.0 101.1 101.4 101.12 102.2 102.6} {101.4 101.5}} -test btree-6.5 {very large deletes, with tags} { - setup - .t insert 1.1 $bigText2 - for {set i 0} {$i < 100} {incr i} { - set j [expr $i+2] - set k [expr 1+2*$i] - .t tag add x $j.1 $j.3 - .t tag add y $k.1 $k.6 - } - .t delete 2.0 200.0 - list [.t tag ranges x] [.t tag ranges y] -} {{3.0 3.1 3.4 3.12 4.2 4.6} {1.1 1.6 3.4 3.5}} -test btree-6.5 {very large deletes, with tags} { - setup - .t insert 1.1 $bigText2 - for {set i 0} {$i < 100} {incr i} { - set j [expr $i+2] - set k [expr 1+2*$i] - .t tag add x $j.1 $j.3 - .t tag add y $k.1 $k.6 - } - for {set i 199} {$i >= 2} {incr i -1} { - .t delete $i.0 $i.100 - } - list [.t tag ranges x] [.t tag ranges y] -} {{3.0 3.1 3.4 3.12 4.2 4.6} {1.1 1.6 3.4 3.5}} - -test btree-7.1 {tag addition and removal, weird ranges} { - .t delete 1.0 100000.0 - .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" - .t tag add x 0.0 1.3 - .t tag ranges x -} {1.0 1.3} -test btree-7.2 {tag addition and removal, weird ranges} { - .t delete 1.0 100000.0 - .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" - .t tag add x 1.40 2.4 - .t tag ranges x -} {2.0 2.4} -test btree-7.3 {tag addition and removal, weird ranges} { - .t delete 1.0 100000.0 - .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" - .t tag add x 4.40 4.41 - .t tag ranges x -} {} -test btree-7.4 {tag addition and removal, weird ranges} { - .t delete 1.0 100000.0 - .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" - .t tag add x 5.1 5.2 - .t tag ranges x -} {} -test btree-7.5 {tag addition and removal, weird ranges} { - .t delete 1.0 100000.0 - .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" - .t tag add x 1.1 9.0 - .t tag ranges x -} {1.1 4.17} -test btree-7.6 {tag addition and removal, weird ranges} { - .t delete 1.0 100000.0 - .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" - .t tag add x 1.1 1.90 - .t tag ranges x -} {1.1 2.0} -test btree-7.6 {tag addition and removal, weird ranges} { - .t delete 1.0 100000.0 - .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" - .t tag add x 1.1 4.90 - .t tag ranges x -} {1.1 4.17} -test btree-7.7 {tag addition and removal with other tags in range} { - .t delete 1.0 100000.0 - .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" - .t tag add x 1.3 1.5 - .t tag add x 1.10 1.12 - .t tag add x 1.7 1.9 - .t tag ranges x -} {1.3 1.5 1.7 1.9 1.10 1.12} -test btree-7.8 {tag addition and removal with other tags in range} { - .t delete 1.0 100000.0 - .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" - .t tag add x 1.3 1.5 - .t tag add x 1.10 1.12 - .t tag add x 1.5 1.9 - .t tag ranges x -} {1.3 1.9 1.10 1.12} -test btree-7.9 {tag addition and removal with other tags in range} { - .t delete 1.0 100000.0 - .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" - .t tag add x 1.3 1.5 - .t tag add x 1.10 1.12 - .t tag add x 1.4 1.9 - .t tag ranges x -} {1.3 1.9 1.10 1.12} -test btree-7.10 {tag addition and removal with other tags in range} { - .t delete 1.0 100000.0 - .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" - .t tag add x 1.3 1.5 - .t tag add x 1.10 1.12 - .t tag add x 1.2 1.9 - .t tag ranges x -} {1.2 1.9 1.10 1.12} -test btree-7.11 {tag addition and removal with other tags in range} { - .t delete 1.0 100000.0 - .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" - .t tag add x 1.3 1.5 - .t tag add x 1.10 1.12 - .t tag add x 1.7 1.10 - .t tag ranges x -} {1.3 1.5 1.7 1.12} -test btree-7.12 {tag addition and removal with other tags in range} { - .t delete 1.0 100000.0 - .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" - .t tag add x 1.3 1.5 - .t tag add x 1.10 1.12 - .t tag add x 1.7 1.11 - .t tag ranges x -} {1.3 1.5 1.7 1.12} -test btree-7.13 {tag addition and removal with other tags in range} { - .t delete 1.0 100000.0 - .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" - .t tag add x 1.3 1.5 - .t tag add x 1.10 1.12 - .t tag add x 1.7 1.12 - .t tag ranges x -} {1.3 1.5 1.7 1.12} -test btree-7.14 {tag addition and removal with other tags in range} { - .t delete 1.0 100000.0 - .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" - .t tag add x 1.3 1.5 - .t tag add x 1.10 1.12 - .t tag add x 1.7 1.14 - .t tag ranges x -} {1.3 1.5 1.7 1.14} -test btree-7.14 {tag addition and removal with other tags in range} { - .t delete 1.0 100000.0 - .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" - .t tag add x 1.3 1.5 - .t tag add x 1.10 1.12 - .t tag add x 1.1 2.3 - .t tag ranges x -} {1.1 2.3} - -test btree-8.1 {tag names} { - setup - .t tag names -} {sel x y} -test btree-8.2 {tag names} { - setup - .t tag add tag1 1.8 - .t tag add tag2 1.8 - .t tag add tag3 1.7 1.9 - .t tag names 1.8 -} {x tag1 tag2 tag3} -test btree-8.3 {lots of tag names} { - setup - .t insert 1.2 $bigText2 - foreach i {tag1 foo ThisOne {x space} q r s t} { - .t tag add $i 150.2 - } - foreach i {u tagA tagB tagC and more {$} \{} { - .t tag add $i 150.1 150.3 - } - .t tag names 150.2 -} {x tag1 foo ThisOne {x space} q r s t u tagA tagB tagC and more {$} \{} - -proc msetup {} { - .t delete 1.0 100000.0 - .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" - .t mark set m1 1.2 - .t mark set next 1.6 - .t mark set x 1.6 - .t mark set m2 2.0 - .t mark set m3 2.100 - .t tag add x 1.3 1.8 -} -test btree-9.1 {basic mark facilities} { - msetup - list [lsort [.t mark names]] [.t index m1] [.t index m2] [.t index m3] -} {{current insert m1 m2 m3 next x} 1.2 2.0 3.0} -test btree-9.2 {basic mark facilities} { - msetup - .t mark unset m2 - lsort [.t mark names] -} {current insert m1 m3 next x} -test btree-9.3 {basic mark facilities} { - msetup - .t mark set m2 1.8 - list [lsort [.t mark names]] [.t index m1] [.t index m2] [.t index m3] -} {{current insert m1 m2 m3 next x} 1.2 1.8 3.0} - -test btree-10.1 {marks and inserts} { - msetup - .t insert 1.1 abcde - list [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] -} {1.7 1.11 1.11 2.0 3.0} -test btree-10.2 {marks and inserts} { - msetup - .t insert 1.2 abcde - list [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] -} {1.7 1.11 1.11 2.0 3.0} -test btree-10.3 {marks and inserts} { - msetup - .t insert 1.3 abcde - list [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] -} {1.2 1.11 1.11 2.0 3.0} -test btree-10.4 {marks and inserts} { - msetup - .t insert 1.1 ab\n\ncde - list [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] -} {3.4 3.8 3.8 4.0 5.0} -test btree-10.5 {marks and inserts} { - msetup - .t insert 1.4 ab\n\ncde - list [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] -} {1.2 3.5 3.5 4.0 5.0} -test btree-10.6 {marks and inserts} { - msetup - .t insert 1.7 ab\n\ncde - list [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] -} {1.2 1.6 1.6 4.0 5.0} - -test btree-11.1 {marks and deletes} { - msetup - .t delete 1.3 1.5 - list [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] -} {1.2 1.4 1.4 2.0 3.0} -test btree-11.2 {marks and deletes} { - msetup - .t delete 1.3 1.8 - list [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] -} {1.2 1.3 1.3 2.0 3.0} -test btree-11.3 {marks and deletes} { - msetup - .t delete 1.2 1.8 - list [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] -} {1.2 1.2 1.2 2.0 3.0} -test btree-11.4 {marks and deletes} { - msetup - .t delete 1.1 1.8 - list [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] -} {1.1 1.1 1.1 2.0 3.0} -test btree-11.5 {marks and deletes} { - msetup - .t delete 1.5 3.1 - list [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] -} {1.2 1.5 1.5 1.5 1.5} -test btree-11.6 {marks and deletes} { - msetup - .t mark set m2 4.5 - .t delete 1.5 4.1 - list [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] -} {1.2 1.5 1.5 1.9 1.5} -test btree-11.7 {marks and deletes} { - msetup - .t mark set m2 4.5 - .t mark set m3 4.5 - .t mark set m1 4.7 - .t delete 1.5 4.1 - list [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] -} {1.11 1.5 1.5 1.9 1.9} - -test btree-12.1 {rebalance with empty node} { - catch {destroy .t} - text .t - .t delete 1.0 end - .t insert end "1\n2\n3\n4\n5\n6\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16\n17\n18\n19\n20\n21\n22\n23\n" - .t delete 6.0 12.0 - .t get 1.0 end -} "1\n2\n3\n4\n5\n12\n13\n14\n15\n16\n17\n18\n19\n20\n21\n22\n23\n" - -destroy .t diff --git a/tk3.6/tests/defs b/tk3.6/tests/defs deleted file mode 100644 index 3abfb66..0000000 --- a/tk3.6/tests/defs +++ /dev/null @@ -1,90 +0,0 @@ -# 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 {} - -# Some of the tests don't work on some system configurations due to -# configuration quirks, not due to Tk 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 -} - -# If the main window isn't already mapped (e.g. because the tests are -# being run automatically) , specify a precise size for it so that the -# user won't have to position it manually. - -if {![winfo ismapped .]} { - wm geometry . +0+0 - update -} diff --git a/tk3.6/tests/listbox.test b/tk3.6/tests/listbox.test deleted file mode 100644 index da64535..0000000 --- a/tk3.6/tests/listbox.test +++ /dev/null @@ -1,426 +0,0 @@ -# This file is a Tcl script to test out the "listbox" command -# of Tk. It is organized in the standard fashion for Tcl tests. -# -# 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/wish/tests/RCS/listbox.test,v 1.3 93/04/24 14:03:10 ouster Exp $ (Berkeley) - -if {[string compare test [info procs test]] == 1} then \ - {source defs} - -foreach i [winfo children .] { - destroy $i -} -wm geometry . {} -listbox .l -geometry 20x20 -bd 2 -relief raised -pack append . .l top -update - -proc listboxGet {} { - set last [.l size] - set result {} - for {set i 0} {$i < $last} {incr i} { - lappend result [.l get $i] - } - return $result -} - -test listbox-1.1 {insert widget command} { - listboxGet -} {} -.l insert end a b c {d e} -test listbox-1.2 {insert widget command} { - listboxGet -} {a b c {d e}} -.l i 1 x y -test listbox-1.3 {insert widget command} { - listboxGet -} {a x y b c {d e}} -.l insert end xx -test listbox-1.4 {insert widget command} { - listboxGet -} {a x y b c {d e} xx} -.l insert -2 early -test listbox-1.5 {insert widget command} { - listboxGet -} {early a x y b c {d e} xx} -.l insert 100 late -test listbox-1.6 {insert widget command} { - listboxGet -} {early a x y b c {d e} xx late} -test listbox-1.7 {insert widget command} { - list [catch {.l insert 1} msg] $msg [listboxGet] -} {0 {} {early a x y b c {d e} xx late}} -test listbox-1.8 {insert widget command} { - list [catch {.l insert} msg] $msg -} {1 {wrong # args: should be ".l insert index ?element element ...?"}} -test listbox-1.9 {insert widget command} { - list [catch {.l insert gorp} msg] $msg -} {1 {bad listbox index "gorp"}} - -test listbox-2.1 {delete widget command} { - .l delete 0 end - .l insert 0 a b c d e - .l delete 1 - listboxGet -} {a c d e} -test listbox-2.2 {delete widget command} { - .l delete 0 end - .l insert 0 a b c d e - .l d 1 3 - listboxGet -} {a e} -test listbox-2.3 {delete widget command} { - .l delete 0 end - .l insert 0 a b c d e - .l delete 3 end - listboxGet -} {a b c} -test listbox-2.4 {delete widget command} { - .l delete 0 end - .l insert 0 a b c d e - .l delete end - listboxGet -} {a b c d} -test listbox-2.5 {delete widget command} { - .l delete 0 end - .l insert 0 a b c d e - .l delete 0 - listboxGet -} {b c d e} -test listbox-2.6 {delete widget command} { - .l delete 0 end - .l insert 0 a b c d e - .l delete 3 2 - listboxGet -} {a b c d e} -test listbox-2.7 {delete widget command} { - .l delete 0 end - .l insert 0 a b c d e - .l delete -2 2 - listboxGet -} {d e} -test listbox-2.8 {delete widget command} { - .l delete 0 end - .l insert 0 a b c d e - .l delete 1 1000 - listboxGet -} {a} -test listbox-2.9 {delete widget command} { - .l delete 0 end - .l delete end - listboxGet -} {} -test listbox-2.10 {delete widget command} { - list [catch {.l delete} msg] $msg -} {1 {wrong # args: should be ".l delete firstIndex ?lastIndex?"}} -test listbox-2.11 {delete widget command} { - list [catch {.l delete 1 2 3} msg] $msg -} {1 {wrong # args: should be ".l delete firstIndex ?lastIndex?"}} -test listbox-2.12 {delete widget command} { - list [catch {.l delete eof} msg] $msg -} {1 {bad listbox index "eof"}} - -.l delete 0 end -.l insert 0 el0 el1 el2 el3 el4 -update -test listbox-3.1 {get widget command} { - .l get 0 -} el0 -test listbox-3.2 {get widget command} { - .l g 1 -} el1 -test listbox-3.3 {get widget command} { - .l get end -} el4 -test listbox-3.4 {get widget command} { - .l get -2 -} el0 -test listbox-3.5 {get widget command} { - .l get 100 -} el4 -test listbox-3.6 {get widget command} { - list [catch {.l get} msg] $msg -} {1 {wrong # args: should be ".l get index"}} -test listbox-3.7 {get widget command} { - list [catch {.l get 1 2} msg] $msg -} {1 {wrong # args: should be ".l get index"}} -test listbox-3.8 {get widget command} { - list [catch {.l get junk} msg] $msg -} {1 {bad listbox index "junk"}} - -.l delete 0 end -for {set i 0} {$i < 30} {incr i} { - .l insert end el$i -} -test listbox-4.1 {nearest widget command} { - .l n 0 -} 0 -test listbox-4.2 {nearest widget command} { - .l nearest [winfo height .l] -} 19 -.l yview 5 -test listbox-4.3 {nearest widget command} { - .l nearest 0 -} 5 -test listbox-4.4 {nearest widget command} { - .l nearest [winfo height .l] -} 24 -test listbox-4.5 {nearest widget command} { - list [catch {.l nearest} msg] $msg -} {1 {wrong # args: should be ".l nearest y"}} -test listbox-4.6 {nearest widget command} { - list [catch {.l nearest 1 2} msg] $msg -} {1 {wrong # args: should be ".l nearest y"}} -test listbox-4.7 {nearest widget command} { - list [catch {.l nearest gorp} msg] $msg -} {1 {expected integer but got "gorp"}} - -test listbox-5.1 {selections} { - .l curselection -} {} -test listbox-5.2 {selections} { - .l select clear - .l select from 1 - .l curselection -} {1} -test listbox-5.3 {selections} { - .l select clear - .l select from end - .l curselection -} {29} -test listbox-5.4 {selections} { - .l select clear - .l select to 2 - .l curselection -} {2} -test listbox-5.5 {selections} { - .l select clear - .l select from 23 - .l select to end - .l curselection -} {23 24 25 26 27 28 29} -test listbox-5.6 {selections} { - .l select clear - .l select from 23 - .l select to 20 - .l curselection -} {20 21 22 23} -test listbox-5.7 {selections} { - .l select clear - .l select from 23 - .l select to 28 - .l select to 20 - .l curselection -} {20 21 22 23} -test listbox-5.8 {selections} { - .l select clear - .l select from 5 - .l select to 10 - .l select adjust 12 - .l curselection -} {5 6 7 8 9 10 11 12} -test listbox-5.9 {selections} { - .l select clear - .l select from 5 - .l select to 10 - .l select adjust 9 - .l curselection -} {5 6 7 8 9} -test listbox-5.10 {selections} { - .l select c - .l select f 5 - .l select t 10 - .l select a 6 - .l curselection -} {6 7 8 9 10} -test listbox-5.11 {selections} { - .l select clear - .l select from 5 - .l select t 10 - .l select adjust 3 - .l curselection -} {3 4 5 6 7 8 9 10} -test listbox-5.12 {selections} { - .l select clear - .l select from 5 - .l select to 10 - .l select adjust 12 - .l select adjust 7 - .l curselection -} {7 8 9 10 11 12} -test listbox-5.13 {selections} { - .l select clear - .l select from 5 - .l select to 10 - .l select clear - .l curselection -} {} -test listbox-5.14 {selections} { - list [catch {.l select} msg] $msg -} {1 {too few args: should be ".l select option ?index?"}} -test listbox-5.15 {selections} { - list [catch {.l select adjust} msg] $msg -} {1 {wrong # args: should be ".l select option index"}} -test listbox-5.16 {selections} { - list [catch {.l select adjust 1 2} msg] $msg -} {1 {wrong # args: should be ".l select option index"}} -test listbox-5.17 {selections} { - list [catch {.l select adjust junk} msg] $msg -} {1 {bad listbox index "junk"}} -test listbox-5.18 {selections} { - list [catch {.l select clear 1} msg] $msg -} {1 {wrong # args: should be ".l select clear"}} -test listbox-5.19 {selections} { - list [catch {.l select from} msg] $msg -} {1 {wrong # args: should be ".l select option index"}} -test listbox-5.20 {selections} { - list [catch {.l select from 1 2} msg] $msg -} {1 {wrong # args: should be ".l select option index"}} -test listbox-5.21 {selections} { - list [catch {.l select from eof} msg] $msg -} {1 {bad listbox index "eof"}} -test listbox-5.22 {selections} { - list [catch {.l select to} msg] $msg -} {1 {wrong # args: should be ".l select option index"}} -test listbox-5.23 {selections} { - list [catch {.l select to 1 2} msg] $msg -} {1 {wrong # args: should be ".l select option index"}} -test listbox-5.24 {selections} { - list [catch {.l select to eof} msg] $msg -} {1 {bad listbox index "eof"}} - -proc lbSelUpdateTest {cmd} { - .l delete 0 end - .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 - .l select from 3 - .l select to 6 - uplevel $cmd - .l curselection -} -test listbox-6.1 {selections and inserts/deletes} { - lbSelUpdateTest {.l delete 1} -} {2 3 4 5} -test listbox-6.2 {selections and inserts/deletes} { - lbSelUpdateTest {.l delete 1 4} -} {1 2} -test listbox-6.3 {selections and inserts/deletes} { - lbSelUpdateTest {.l delete 4} -} {3 4 5} -test listbox-6.4 {selections and inserts/deletes} { - lbSelUpdateTest {.l delete 5 7} -} {3 4} -test listbox-6.5 {selections and inserts/deletes} { - lbSelUpdateTest {.l delete end} -} {3 4 5 6} -test listbox-6.6 {selections and inserts/deletes} { - lbSelUpdateTest {.l delete 1 7} -} {} -test listbox-6.7 {selections and inserts/deletes} { - lbSelUpdateTest {.l insert 1 x} -} {4 5 6 7} -test listbox-6.8 {selections and inserts/deletes} { - lbSelUpdateTest {.l insert 3 x y} -} {5 6 7 8} -test listbox-6.9 {selections and inserts/deletes} { - lbSelUpdateTest {.l insert 4 x} -} {3 4 5 6 7} -test listbox-6.10 {selections and inserts/deletes} { - lbSelUpdateTest {.l insert 7 x y} -} {3 4 5 6} - -catch {unset x} -set x {} -test listbox-7.1 {-exportselection option} { - selection clear . - .l select from 1 - lappend x [catch {selection get} msg] $msg [.l curselection] - .l config -exportselection 0 - lappend x [catch {selection get} msg] $msg [.l curselection] - .l select clear - lappend x [catch {selection get} msg] $msg [.l curselection] - .l select from 1 - .l select to 3 - lappend x [catch {selection get} msg] $msg [.l curselection] - .l config -exportselection 1 - lappend x [catch {selection get} msg] $msg [.l curselection] -} {0 el1 1 1 {selection doesn't exist or form "STRING" not defined} 1 1 {selection doesn't exist or form "STRING" not defined} {} 1 {selection doesn't exist or form "STRING" not defined} {1 2 3} 0 {el1 el2 el3} {1 2 3}} -test list-7.2 {-exportselection option} { - .l select from 1 - .l select to 3 - selection clear . - list [catch {selection get} msg] $msg [.l curselection] -} {1 {selection doesn't exist or form "STRING" not defined} {}} - -.l delete 0 end -for {set i 0} {$i < 30} {incr i} { - .l insert end el$i -} -test list-8.1 {yview widget command} { - .l yview 0 - .l nearest 0 -} 0 -test list-8.2 {yview widget command} { - .l yview end - .l nearest 0 -} 29 -test list-8.3 {yview widget command} { - .l yview 5 - .l nearest 0 -} 5 -test list-8.4 {yview widget command} { - .l yview 5 - .l delete 1 3 - .l nearest 0 -} 2 -test list-8.5 {yview widget command} { - .l yview 5 - .l delete 5 8 - .l nearest 0 -} 5 -test list-8.6 {yview widget command} { - .l yview 5 - .l delete 10 - .l nearest 0 -} 5 -test list-8.6 {yview widget command} { - list [catch {.l yview} msg] $msg -} {1 {wrong # args: should be ".l yview index"}} -test list-8.7 {yview widget command} { - list [catch {.l yview 1 2} msg] $msg -} {1 {wrong # args: should be ".l yview index"}} -test list-8.8 {yview widget command} { - list [catch {.l yview junk} msg] $msg -} {1 {bad listbox index "junk"}} - -test listbox-9.1 {miscellaneous} { - list [catch {.l} msg] $msg -} {1 {wrong # args: should be ".l option ?arg arg ...?"}} -test listbox-9.2 {miscellaneous} { - list [catch {.l junk} msg] $msg -} {1 {bad option "junk": must be configure, curselection, delete, get, insert, nearest, scan, select, size, xview, or yview}} -test listbox-9.3 {miscellaneous} { - list [catch {.l s} msg] $msg -} {1 {bad option "s": must be configure, curselection, delete, get, insert, nearest, scan, select, size, xview, or yview}} -destroy .l -test listbox-9.4 {miscellaneous} { - list [catch {.l} msg] $msg -} {1 {invalid command name ".l"}} diff --git a/tk3.6/tests/select.test b/tk3.6/tests/select.test deleted file mode 100644 index 2d1e29a..0000000 --- a/tk3.6/tests/select.test +++ /dev/null @@ -1,212 +0,0 @@ -# This file is a Tcl script to test out Tk's selection management code, -# especially the "selection" command. It is organized in the standard -# fashion for Tcl tests. -# -# 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/wish/tests/RCS/select.test,v 1.4 93/06/04 08:44:14 ouster Exp $ (Berkeley) - -if {[string compare test [info procs test]] == 1} { - source defs -} - -catch {destroy .f1} -catch {destroy .f2} -catch {destroy .f3} - -frame .f1 -frame .f2 -frame .f3 - -proc handler {type offset count} { - global selValue selInfo - - lappend selInfo $type $offset $count - set numBytes [expr {[string length $selValue] - $offset}] - if {$numBytes <= 0} { - return "" - } - string range $selValue $offset [expr $numBytes+$offset] -} - -proc errHandler args { - error "selection handler aborted" -} - -# Eliminate any existing selection on the screen. This is needed in case -# there is a selection in some other application, in order to prevent races -# from causing false errors in the tests below. - -selection clear . -after 1000 - -test select-1.1 {simple Tcl-based handler} { - selection own .f1 - lsort [selection get TARGETS] -} {APPLICATION MULTIPLE TARGETS TIMESTAMP WINDOW_NAME} -selection handle .f1 {handler TEST} TEST -test select-1.2 {simple Tcl-based handler} { - selection own .f1 - lsort [selection get TARGETS] -} {APPLICATION MULTIPLE TARGETS TEST TIMESTAMP WINDOW_NAME} -test select-1.3 {simple Tcl-based handler} { - selection own .f1 - set selValue "Test value" - set selInfo "" - list [selection get TEST] $selInfo -} {{Test value} {TEST 0 4000}} -selection handle .f1 {handler STRING} -test select-1.4 {simple Tcl-based handler} { - selection own .f1 - lsort [selection get TARGETS] -} {APPLICATION MULTIPLE STRING TARGETS TEST TIMESTAMP WINDOW_NAME} -test select-1.5 {simple Tcl-based handler} { - selection own .f1 - set selValue "" - set selInfo "" - list [selection get] $selInfo -} {{} {STRING 0 4000}} -test select-1.6 {simple Tcl-based handler} { - list [catch {selection get BADTARGET} msg] $msg -} {1 {selection doesn't exist or form "BADTARGET" not defined}} -test select-1.7 {simple Tcl-based handler} { - set lostSel {XXX} - selection own .f1 {set lostSel "selection gone"} - selection own .f2 - set lostSel -} {selection gone} -selection handle .f1 ERROR errHandler -test select-1.8 {simple Tcl-based handler} { - selection own .f1 - list [catch {selection get ERROR} msg] $msg -} {1 {selection doesn't exist or form "ERROR" not defined}} -if $atBerkeley { - test select-1.9 {simple Tcl-based handler} { - set lostSel {XXX} - set selValue "Test2" - set selInfo "" - selection own .f1 {set lostSel "selection gone"} - destroy .f1 - list [catch {selection get} msg] $msg $lostSel $selInfo - } {1 {selection doesn't exist or form "STRING" not defined} XXX {}} -} - -selection handle .f2 {handler STRING.f2} -set selValue "" -foreach i {a b c d e f g j h i j k l m o p q r s t u v w x y z} { - set j $i.1$i.2$i.3$i.4$i.5$i.6$i.7$i.8$i.9$i.10$i.11$i.12$i.13$i.14 - append selValue A$j B$j C$j D$j E$j F$j G$j H$j I$j K$j L$j M$j N$j -} -test select-2.1 {long retrievals} { - selection own .f2 - set selInfo "" - list [selection get] $selInfo -} "$selValue {STRING.f2 0 4000 STRING.f2 4000 4000 STRING.f2 8000 4000 STRING.f2 12000 4000 STRING.f2 16000 4000}" - -test select-3.1 {handlers provided by Tk} { - selection own .f2 - list [selection get APPLICATION] [selection get WINDOW_NAME] -} [list [winfo name .] .f2] -selection handle .f2 {handler TARGETS.f2} TARGETS -test select-3.2 {handlers provided by Tk} { - selection own .f2 - set selValue "Timestamp value" - set selInfo "" - list [selection get TARGETS] $selInfo -} {{Timestamp value} {TARGETS.f2 0 4000}} -selection handle .f2 {} TARGETS -test select-3.3 {handlers provided by Tk} { - selection get TARGETS -} {APPLICATION MULTIPLE TARGETS TIMESTAMP WINDOW_NAME STRING} - -catch {destroy .f1} -frame .f1 -selection handle .f1 {handler TEST1.f1} TEST1 -selection handle .f1 {handler TEST2.f1} TEST2 -selection handle .f1 {handler TEST3.f1} TEST3 -test select-4.1 {modifying and deleting handlers} { - selection handle .f1 {handler TEST1.new} TEST1 - selection own .f1 - set selValue "value" - set selInfo "" - list [selection get TEST1] $selInfo -} {value {TEST1.new 0 4000}} -selection handle .f1 {} TEST2 -test select-4.2 {modifying and deleting handlers} { - selection get TARGETS -} {APPLICATION MULTIPLE TARGETS TIMESTAMP WINDOW_NAME TEST3 TEST1} -selection handle .f1 {} TEST1 -test select-4.3 {modifying and deleting handlers} { - selection get TARGETS -} {APPLICATION MULTIPLE TARGETS TIMESTAMP WINDOW_NAME TEST3} -selection handle .f1 {} TEST3 -test select-4.4 {modifying and deleting handlers} { - selection get TARGETS -} {APPLICATION MULTIPLE TARGETS TIMESTAMP WINDOW_NAME} - -test select-5.1 {clearing the selection} { - selection own .f2 - set result [selection get WINDOW_NAME] - selection clear . - list $result [catch {selection get WINDOW_NAME} msg] $msg -} {.f2 1 {selection doesn't exist or form "WINDOW_NAME" not defined}} - -test select-6.1 {selection own option} { - selection own .f2 - selection own -} .f2 -test select-6.2 {selection own option} { - selection own .f3 - selection clear . - selection own -} {} - -test select-6.1 {errors in selection command} { - list [catch selection msg] $msg -} {1 {wrong # args: should be "selection option ?arg arg ...?"}} -test select-6.2 {errors in selection command} { - list [catch {selection junk} msg] $msg -} {1 {bad option "junk": must be clear, get, handle, or own}} -test select-6.3 {errors in selection command} { - list [catch {selection clear} msg] $msg -} {1 {wrong # args: should be "selection clear window"}} -test select-6.4 {errors in selection command} { - list [catch {selection clear foo} msg] $msg -} {1 {bad window path name "foo"}} -test select-6.5 {errors in selection command} { - list [catch {selection get a b} msg] $msg -} {1 {too may args: should be "selection get ?type?"}} -test select-6.6 {errors in selection command} { - list [catch {selection handle a} msg] $msg -} {1 {wrong # args: should be "selection handle window command ?type? ?format?"}} -test select-6.7 {errors in selection command} { - list [catch {selection handle a b c d e} msg] $msg -} {1 {wrong # args: should be "selection handle window command ?type? ?format?"}} -test select-6.8 {errors in selection command} { - list [catch {selection own a b c} msg] $msg -} {1 {wrong # args: should be "selection own ?window? ?command?"}} -test select-6.9 {errors in selection command} { - list [catch {selection own junk} msg] $msg -} {1 {bad window path name "junk"}} - -destroy .f1 -destroy .f2 -destroy .f3 diff --git a/tk3.6/tests/text.test b/tk3.6/tests/text.test deleted file mode 100644 index d13be5a..0000000 --- a/tk3.6/tests/text.test +++ /dev/null @@ -1,1149 +0,0 @@ -# This file is a Tcl script to test out Tk's text widget. The test -# file "btree.test" contains additional tests focussed on the B-tree -# facilities in particular. This file is organized in the standard -# fashion for Tcl tests. -# -# 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/wish/tests/RCS/text.test,v 1.13 93/11/01 14:52:02 ouster Exp $ (Berkeley) - -if {[string compare test [info procs test]] == 1} then \ - {source defs} - -catch {destroy .t} -if [catch {text .t \ - -font -adobe-courier-medium-r-normal--12-120-75-75-m-70-iso8859-1 \ - -width 80 -height 24}] { - puts "The font needed by the text tests isn't available, so I'm" - puts "going to skip these tests." - return -} -pack append . .t {top expand fill} -.t debug on -wm geometry . {} - -# The statements below reset the main window; it's needed if the window -# manager is mwm to make mwm forget about a previous minimum size setting. - -wm withdraw . -wm minsize . 1 1 -wm positionfrom . user -wm deiconify . - -proc setup {} { - .t delete 1.0 end - foreach i [.t tag names] { - if {$i != "sel"} { - .t tag delete $i - } - } - .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" - .t tag add x 1.1 - .t tag add x 1.5 1.13 - .t tag add x 2.2 2.6 - .t tag add y 1.5 -} - -setup -foreach i [.t mark names] { - if {($i != "insert") && ($i != "current")} { - .t mark unset $i - } -} -test text-1.1 {"compare" option} { - list [.t compare 1.1 < 1.2] [.t compare 1.1 < 1.1] [.t compare 1.1 < 1.0] -} {1 0 0} -test text-1.2 {"compare" option} { - list [.t compare 1.1 <= 1.2] [.t compare 1.1 <= 1.1] [.t compare 1.1 <= 1.0] -} {1 1 0} -test text-1.3 {"compare" option} { - list [.t compare 1.1 == 1.2] [.t compare 1.1 == 1.1] [.t compare 1.1 == 1.0] -} {0 1 0} -test text-1.4 {"compare" option} { - list [.t compare 1.1 >= 1.2] [.t compare 1.1 >= 1.1] [.t compare 1.1 >= 1.0] -} {0 1 1} -test text-1.5 {"compare" option} { - list [.t compare 1.1 > 1.2] [.t compare 1.1 > 1.1] [.t compare 1.1 > 1.0] -} {0 0 1} -test text-1.6 {"compare" option} { - list [.t compare 1.1 != 1.2] [.t compare 1.1 != 1.1] [.t compare 1.1 != 1.0] -} {1 0 1} -test text-1.7 {"compare" option} { - list [.t compare 1.3 < 2.3] [.t compare 1.3 == 2.3] [.t compare 1.1 > 2.3] -} {1 0 0} -test text-1.8 {"compare" option} { - list [.t compare 2.1 < 2.3] [.t compare 2.1 == 2.3] [.t compare 2.1 > 2.3] -} {1 0 0} -test text-1.9 {"compare" option} { - list [.t compare 2.3 < 2.3] [.t compare 2.3 == 2.3] [.t compare 2.3 > 2.3] -} {0 1 0} -test text-1.10 {"compare" option} { - list [.t compare 2.5 < 2.3] [.t compare 2.5 == 2.3] [.t compare 2.5 > 2.3] -} {0 0 1} -test text-1.11 {"compare" option} { - list [.t compare 3.0 < 2.3] [.t compare 3.0 == 2.3] [.t compare 3.0 > 2.3] -} {0 0 1} -test text-1.12 {"compare" option} { - list [catch {.t compare} msg] $msg -} {1 {wrong # args: should be ".t compare index1 op index2"}} -test text-1.13 {"compare" option} { - list [catch {.t compare 1 2} msg] $msg -} {1 {wrong # args: should be ".t compare index1 op index2"}} -test text-1.14 {"compare" option} { - list [catch {.t compare 1 2 3 4} msg] $msg -} {1 {wrong # args: should be ".t compare index1 op index2"}} -test text-1.15 {"compare" option} { - list [catch {.t compare foo < 1.2} msg] $msg -} {1 {bad text index "foo"}} -test text-1.16 {"compare" option} { - list [catch {.t compare 1.2 < foo} msg] $msg -} {1 {bad text index "foo"}} -test text-1.17 {"compare" option} { - list [catch {.t compare 1.0 a 1.2} msg] $msg -} {1 {bad comparison operator "a": must be <, <=, ==, >=, >, or !=}} -test text-1.18 {"compare" option} { - list [catch {.t compare 1.0 =, >, or !=}} -test text-1.19 {"compare" option} { - list [catch {.t compare 1.0 <=x 1.2} msg] $msg -} {1 {bad comparison operator "<=x": must be <, <=, ==, >=, >, or !=}} -test text-1.20 {"compare" option} { - list [catch {.t compare 1.0 >=x 1.2} msg] $msg -} {1 {bad comparison operator ">=x": must be <, <=, ==, >=, >, or !=}} -test text-1.21 {"compare" option} { - list [catch {.t compare 1.0 >a 1.2} msg] $msg -} {1 {bad comparison operator ">a": must be <, <=, ==, >=, >, or !=}} -test text-1.22 {"compare" option} { - list [catch {.t compare 1.0 !x 1.2} msg] $msg -} {1 {bad comparison operator "!x": must be <, <=, ==, >=, >, or !=}} -test text-1.23 {"compare" option} { - list [catch {.t compare 1.0 === 1.2} msg] $msg -} {1 {bad comparison operator "===": must be <, <=, ==, >=, >, or !=}} - -setup -.t mark set m1 1.2 -.t mark set m2 2.4 -update -test text-2.1 {"index" option, "@" notation} { - .t index @1,1 -} {1.0} -test text-2.2 {"index" option, "@" notation} { - .t index @133,8 -} {1.18} -test text-2.3 {"index" option, "@" notation} { - .t index @136,8 -} {1.19} -test text-2.4 {"index" option, "@" notation} { - .t index @5,19 -} {2.0} -test text-2.5 {"index" option, "@" notation} { - .t index @69,46 -} {4.9} -test text-2.6 {"index" option, "@" notation} { - .t index @10,100 -} {4.17} -test text-2.7 {"index" option, "@" notation} { - list [catch {.t index "@"} msg] $msg -} {1 {bad text index "@"}} -test text-2.8 {"index" option, "@" notation} { - list [catch {.t index "@a"} msg] $msg -} {1 {bad text index "@a"}} -test text-2.9 {"index" option, "@" notation} { - list [catch {.t index "@1x"} msg] $msg -} {1 {bad text index "@1x"}} -test text-2.10 {"index" option, "@" notation} { - list [catch {.t index "@1."} msg] $msg -} {1 {bad text index "@1."}} -test text-2.11 {"index" option, "@" notation} { - list [catch {.t index "@1.a"} msg] $msg -} {1 {bad text index "@1.a"}} - -test text-3.1 {"index" option, line.char notation} { - .t index 1.1 -} {1.1} -test text-3.2 {"index" option, line.char notation} { - .t index 2.end -} {2.11} -test text-3.3 {"index" option, line.char notation} { - .t index 3.end -} {3.0} -test text-3.4 {"index" option, line.char notation} { - .t index -1.-2 -} {-1.-2} -test text-3.5 {"index" option, line.char notation} { - list [catch {.t index -a} msg] $msg -} {1 {bad text index "-a"}} -test text-3.6 {"index" option, line.char notation} { - list [catch {.t index 1.} msg] $msg -} {1 {bad text index "1."}} -test text-3.7 {"index" option, line.char notation} { - list [catch {.t index 1.e} msg] $msg -} {1 {bad text index "1.e"}} -test text-3.8 {"index" option, line.char notation} { - list [catch {.t index 1.enda} msg] $msg -} {1 {bad text index "1.enda"}} -test text-3.9 {"index" option, line.char notation} { - list [catch {.t index 400.end} msg] $msg -} {1 {bad text index "400.end": no such line in text}} -test text-3.10 {"index" option, line.char notation} { - list [catch {.t index 1.x} msg] $msg -} {1 {bad text index "1.x"}} - -test text-4.1 {"index" option, miscellaneous bases} { - .t index end -} {4.17} -test text-4.2 {"index" option, miscellaneous bases} { - .t index m1 -} {1.2} -test text-4.3 {"index" option, miscellaneous bases} { - .t index m2 -} {2.4} -test text-4.4 {"index" option, miscellaneous bases} { - .t index x.first -} {1.1} -test text-4.5 {"index" option, miscellaneous bases} { - .t index x.last -} {2.6} -test text-4.6 {"index" option, miscellaneous bases} { - .t index y.first -} {1.5} -test text-4.7 {"index" option, miscellaneous bases} { - .t index y.last -} {1.6} -test text-4.8 {"index" option, miscellaneous bases} { - list [catch {.t index x.f} msg] $msg -} {1 {bad text index "x.f"}} -test text-4.9 {"index" option, miscellaneous bases} { - list [catch {.t index x.firstl} msg] $msg -} {1 {bad text index "x.firstl"}} -test text-4.10 {"index" option, miscellaneous bases} { - list [catch {.t index x.las} msg] $msg -} {1 {bad text index "x.las"}} -test text-4.11 {"index" option, miscellaneous bases} { - list [catch {.t index x.last1} msg] $msg -} {1 {bad text index "x.last1"}} -test text-4.12 {"index" option, miscellaneous bases} { - .t tag remove sel 0.0 end - list [catch {.t index sel.first} msg] $msg -} {1 {text doesn't contain any characters tagged with "sel"}} - -test text-5.1 {"index" option with +/- modifiers} { - .t index 1.1+1c -} 1.2 -test text-5.2 {"index" option with +/- modifiers} { - .t index @0,0+1c -} 1.1 -test text-5.3 {"index" option with +/- modifiers} { - .t index 1.end+1c -} 2.0 -test text-5.4 {"index" option with +/- modifiers} { - .t index m1+1c -} 1.3 -test text-5.5 {"index" option with +/- modifiers} { - .t index "m1 +1c" -} 1.3 -test text-5.6 {"index" option with +/- modifiers} { - .t index "m1-1c" -} 1.1 -test text-5.7 {"index" option with +/- modifiers} { - list [catch {.t index "m1 x"} msg] $msg -} {1 {bad text index "m1 x"}} -test text-5.8 {"index" option with +/- modifiers} { - .t index "m1 + 1 c" -} 1.3 -test text-5.9 {"index" option with +/- modifiers} { - list [catch {.t index "m1+x"} msg] $msg -} {1 {bad text index "m1+x"}} -test text-5.10 {"index" option with +/- modifiers} { - list [catch {.t index "m1+22gorps"} msg] $msg -} {1 {bad text index "m1+22gorps"}} -test text-5.11 {"index" option with +/- modifiers} { - .t index "1.2+1c" -} 1.3 -test text-5.12 {"index" option with +/- modifiers} { - .t index "1.2+3c" -} 1.5 -test text-5.13 {"index" option with +/- modifiers} { - .t index "1.2+17c" -} 1.19 -test text-5.14 {"index" option with +/- modifiers} { - .t index "1.2+18c" -} 2.0 -test text-5.15 {"index" option with +/- modifiers} { - .t index "1.2+20c" -} 2.2 -test text-5.16 {"index" option with +/- modifiers} { - .t index "1.2+100c" -} 4.17 -test text-5.17 {"index" option with +/- modifiers} { - .t index "2.4-1c" -} 2.3 -test text-5.18 {"index" option with +/- modifiers} { - .t index "2.4-4c" -} 2.0 -test text-5.19 {"index" option with +/- modifiers} { - .t index "2.4-5c" -} 1.19 -test text-5.20 {"index" option with +/- modifiers} { - .t index "2.4-10c" -} 1.14 -test text-5.21 {"index" option with +/- modifiers} { - .t index "2.4-100c" -} 1.0 -test text-5.22 {"index" option with +/- modifiers} { - .t index "2.4 - 100 chars" -} 1.0 -test text-5.23 {"index" option with +/- modifiers} { - list [catch {.t index "2.4 - 100 charsx"} msg] $msg -} {1 {bad text index "2.4 - 100 charsx"}} -test text-5.24 {"index" option with +/- modifiers} { - .t index "1.3+1l" -} 2.3 -test text-5.25 {"index" option with +/- modifiers} { - .t index "1.3+2l" -} 3.0 -test text-5.26 {"index" option with +/- modifiers} { - .t index "1.3+3li" -} 4.3 -test text-5.27 {"index" option with +/- modifiers} { - .t index "1.3+4lines" -} 4.3 -test text-5.28 {"index" option with +/- modifiers} { - .t index "3.2 - 1 lines" -} 2.2 -test text-5.29 {"index" option with +/- modifiers} { - .t index "3.2 - 2 lines" -} 1.2 -test text-5.30 {"index" option with +/- modifiers} { - .t index "3.2 - 3 lines" -} 1.2 -test text-5.31 {"index" option with +/- modifiers} { - .t index "3.-2 - 1 lines" -} 2.0 -test text-5.32 {"index" option with +/- modifiers} { - list [catch {.t index "3.-2 - 1 linesx"} msg] $msg -} {1 {bad text index "3.-2 - 1 linesx"}} - -setup -.t insert end "\n#\$foo.bar! first_l60t _ " -test text-6.1 {"index" option with start/end modifiers} { - .t index "2.3 lines" -} 2.0 -test text-6.2 {"index" option with start/end modifiers} { - .t index "2.0 linestart" -} 2.0 -test text-6.3 {"index" option with start/end modifiers} { - .t index "2.-4 linestart" -} 2.0 -test text-6.4 {"index" option with start/end modifiers} { - .t index "2.30 linestart" -} 3.0 -test text-6.5 {"index" option with start/end modifiers} { - .t index "10.0 linestart" -} 5.0 -test text-6.6 {"index" option with start/end modifiers} { - .t index "10.0 lineend" -} 5.24 -test text-6.7 {"index" option with start/end modifiers} { - .t index "3.5 linee" -} 4.17 -test text-6.8 {"index" option with start/end modifiers} { - .t index "2.4 lineend" -} 2.11 -test text-6.9 {"index" option with start/end modifiers} { - .t index "0.0 lineend" -} 1.19 -test text-6.10 {"index" option with start/end modifiers} { - list [catch {.t index "2.2 line"} msg] $msg -} {1 {bad text index "2.2 line"}} -test text-6.11 {"index" option with start/end modifiers} { - .t index "1.0 wordstart" -} 1.0 -test text-6.12 {"index" option with start/end modifiers} { - .t index "1.1 wordstart" -} 1.0 -test text-6.13 {"index" option with start/end modifiers} { - .t index "1.3 wordstart" -} 1.0 -test text-6.14 {"index" option with start/end modifiers} { - .t index "1.4 words" -} 1.4 -test text-6.15 {"index" option with start/end modifiers} { - .t index "1.5 wordstart" -} 1.5 -test text-6.16 {"index" option with start/end modifiers} { - .t index "1.19 wordstart" -} 1.19 -test text-6.17 {"index" option with start/end modifiers} { - .t index "5.3 wordstart" -} 5.2 -test text-6.18 {"index" option with start/end modifiers} { - .t index "5.20 wordstart" -} 5.11 -test text-6.19 {"index" option with start/end modifiers} { - .t index "5.0 wordend" -} 5.1 -test text-6.20 {"index" option with start/end modifiers} { - .t index "5.1 wordend" -} 5.2 -test text-6.21 {"index" option with start/end modifiers} { - .t index "5.2 wordend" -} 5.5 -test text-6.22 {"index" option with start/end modifiers} { - .t index "5.4 wordend" -} 5.5 -test text-6.23 {"index" option with start/end modifiers} { - .t index "5.5 wordend" -} 5.6 -test text-6.24 {"index" option with start/end modifiers} { - .t index "5.11 wordend" -} 5.21 -test text-6.25 {"index" option with start/end modifiers} { - .t index "5.100 wordend" -} 5.24 -test text-6.26 {"index" option with start/end modifiers} { - list [catch {.t index "2.2 word"} msg] $msg -} {1 {bad text index "2.2 word"}} -test text-6.27 {"index" option with start/end modifiers} { - .t index "1.2 wordend+1line wordend" -} 2.6 -test text-6.28 {"index" option with start/end modifiers} { - .t index "2.1 wordend-1 line wordend" -} 1.8 -test text-6.29 {"index" option with start/end modifiers} { - .t index "2.3 wordend + 1 char wordend" -} 2.11 - -setup -test text-7.1 {RoundIndex procedure} { - .t index -1.4+0c -} 1.0 -test text-7.2 {RoundIndex procedure} { - .t index 100.2+0c -} 4.17 -test text-7.3 {RoundIndex procedure} { - .t index 2.-3+0c -} 2.0 -test text-7.4 {RoundIndex procedure} { - .t index 2.100+0c -} 3.0 -test text-7.5 {RoundIndex procedure} { - .t index 4.100+0c -} 4.17 - -test text-8.1 {"tag" option} { - list [catch {.t tag} msg] $msg -} {1 {wrong # args: should be ".t tag option ?arg arg ...?"}} -test text-8.2 {"tag" option} { - list [catch {.t tag gorp} msg] $msg -} {1 {bad tag option "gorp": must be add, bind, configure, delete, lower, names, nextrange, raise, ranges, or remove}} -test text-8.3 {"tag" option} { - list [catch {.t tag n} msg] $msg -} {1 {bad tag option "n": must be add, bind, configure, delete, lower, names, nextrange, raise, ranges, or remove}} -test text-8.4 {"tag" option} { - list [catch {.t tag r} msg] $msg -} {1 {bad tag option "r": must be add, bind, configure, delete, lower, names, nextrange, raise, ranges, or remove}} -test text-8.5 {"tag" option} { - list [catch {.t tag ra} msg] $msg -} {1 {bad tag option "ra": must be add, bind, configure, delete, lower, names, nextrange, raise, ranges, or remove}} - -setup -test text-9.1 {"tag add" option} { - .t tag add x1 2.0 - .t tag ranges x1 -} {2.0 2.1} -test text-9.2 {"tag add" option} { - .t tag a x2 2.0 2.3 - .t tag ranges x2 -} {2.0 2.3} -test text-9.3 {"tag add" option} { - .t tag remove sel 0.0 end - .t tag add sel 2.0 2.3 - selection get -} {Sec} -test text-9.4 {"tag add" option} { - list [catch {.t tag add} msg] $msg -} {1 {wrong # args: should be ".t tag add tagName index1 ?index2?"}} -test text-9.5 {"tag add" option} { - list [catch {.t tag add a b c d} msg] $msg -} {1 {wrong # args: should be ".t tag add tagName index1 ?index2?"}} -test text-9.6 {"tag add" option} { - list [catch {.t tag add a #xgorp} msg] $msg -} {1 {bad text index "#xgorp"}} -test text-9.7 {"tag add" option} { - list [catch {.t tag add a 1.0 #xgorp} msg] $msg -} {1 {bad text index "#xgorp"}} - -setup -test text-10.1 {"tag configure" option} { - .t tag configure test -foreground white - lindex [.t tag c test -foreground] 4 -} {white} -test text-10.2 {"tag configure" option} { - llength [.t tag configure test] -} {8} -test text-10.3 {"tag configure" option} { - list [catch {.t tag configure test -gorp} msg] $msg -} {1 {unknown option "-gorp"}} -test text-10.4 {"tag configure" option} { - list [catch {.t tag configure test -gorp blue} msg] $msg -} {1 {unknown option "-gorp"}} -test text-10.5 {"tag configure" option} { - list [catch {.t tag configure} msg] $msg -} {1 {wrong # args: should be ".t tag configure tagName ?option? ?value? ?option value ...?"}} -test text-10.6 {"tag configure" option} { - .t tag configure sel -foreground white - lindex [.t configure -selectforeground] 4 -} {white} -test text-10.7 {"tag configure" option} { - .t tag configure sel -foreground black - lindex [.t configure -selectforeground] 4 -} {black} -test text-10.8 {"tag configure" option} { - .t tag configure sel -borderwidth 8 - lindex [.t configure -selectborderwidth] 4 -} {8} -test text-10.6 {"tag configure" option} { - .t tag configure sel -background white - lindex [.t configure -selectbackground] 4 -} {white} -test text-10.7 {"tag configure" option} { - .t tag configure sel -background black - lindex [.t configure -selectbackground] 4 -} {black} - -setup -test text-11.1 {"tag delete" option} { - .t tag add t1 2.0 2.3 - .t tag delete t1 - .t tag names -} {sel x y} -test text-11.2 {"tag delete" option} { - .t tag d x y - .t tag names -} {sel} -test text-11.3 {"tag delete" option} { - list [catch {.t tag delete sel} msg] $msg -} {1 {can't delete selection tag}} -test text-11.4 {"tag delete" option} { - list [catch {.t tag delete} msg] $msg -} {1 {wrong # args: should be ".t tag delete tagName tagName ..."}} -test text-11.5 {"tag delete" option} { - list [catch {.t tag delete #gorp} msg] $msg -} {0 {}} - -setup -.t tag add a 2.0 -.t tag add b 2.1 -.t tag lower b -test text-12.1 {"tag lower" option} { - .t tag names -} {b sel x y a} -.t tag l b a -test text-12.2 {"tag lower" option} { - .t tag names -} {sel x y b a} -.t tag lower b b -test text-12.3 {"tag lower" option} { - .t tag names -} {sel x y b a} -.t tag lower b y -test text-12.4 {"tag lower" option} { - .t tag names -} {sel x b y a} -test text-12.5 {"tag lower" option} { - list [catch {.t tag lower} msg] $msg -} {1 {wrong # args: should be ".t tag lower tagName ?belowThis?"}} -test text-12.6 {"tag lower" option} { - list [catch {.t tag lower a b c} msg] $msg -} {1 {wrong # args: should be ".t tag lower tagName ?belowThis?"}} -test text-12.7 {"tag lower" option} { - list [catch {.t tag lower #gorp} msg] $msg -} {1 {tag "#gorp" isn't defined in text widget}} -test text-12.8 {"tag lower" option} { - list [catch {.t tag lower a #gorp} msg] $msg -} {1 {tag "#gorp" isn't defined in text widget}} - -setup -.t tag add a 2.0 2.3 -.t tag add b 2.2 -.t tag lower b -test text-13.1 {"tag names" option} { - .t tag na -} {b sel x y a} -test text-13.2 {"tag names" option} { - .t tag names 2.2 -} {b x a} -test text-13.3 {"tag names" option} { - list [catch {.t tag names a b} msg] $msg -} {1 {wrong # args: should be ".t tag names ?index?"}} -test text-13.4 {"tag names" option} { - list [catch {.t tag names @gorp} msg] $msg -} {1 {bad text index "@gorp"}} -test text-13.5 {"tag names" option} { - list [catch {.t tag names 100000.0} msg] $msg -} {0 {}} -test text-13.6 {"tag names" option} { - list [catch {.t tag names 2.7} msg] $msg -} {0 {}} - -setup -test text-14.1 {"tag nextrange" option} { - .t tag ne x 1.0 -} {1.1 1.2} -test text-14.2 {"tag nextrange" option} { - .t tag nextrange x 1.1 -} {1.1 1.2} -test text-14.3 {"tag nextrange" option} { - .t tag nextrange x 1.2 -} {1.5 1.13} -test text-14.4 {"tag nextrange" option} { - .t tag nextrange x 1.6 -} {2.2 2.6} -test text-14.5 {"tag nextrange" option} { - .t tag nextrange x 1.3 1.14 -} {1.5 1.13} -test text-14.6 {"tag nextrange" option} { - .t tag nextrange x 1.3 1.13 -} {1.5 1.13} -test text-14.7 {"tag nextrange" option} { - .t tag nextrange x 1.3 1.10 -} {1.5 1.13} -test text-14.8 {"tag nextrange" option} { - .t tag nextrange x 1.3 1.6 -} {1.5 1.13} -test text-14.9 {"tag nextrange" option} { - .t tag nextrange x 1.3 1.5 -} {} -test text-14.10 {"tag nextrange" option} { - list [catch {.t tag nextrange} msg] $msg -} {1 {wrong # args: should be ".t tag nextrange tagName index1 ?index2?"}} -test text-14.11 {"tag nextrange" option} { - list [catch {.t tag nextrange a} msg] $msg -} {1 {wrong # args: should be ".t tag nextrange tagName index1 ?index2?"}} -test text-14.12 {"tag nextrange" option} { - list [catch {.t tag nextrange a b c d} msg] $msg -} {1 {wrong # args: should be ".t tag nextrange tagName index1 ?index2?"}} -test text-14.13 {"tag nextrange" option} { - list [catch {.t tag nextrange #gorp 1.0} msg] $msg -} {0 {}} -test text-14.14 {"tag nextrange" option} { - list [catch {.t tag nextrange x @bogus} msg] $msg -} {1 {bad text index "@bogus"}} -test text-14.15 {"tag nextrange" option} { - list [catch {.t tag nextrange x 1.0 @bogus} msg] $msg -} {1 {bad text index "@bogus"}} - -setup -.t tag add a 2.0 -.t tag add b 2.1 -.t tag rai x -test text-15.1 {"tag raise" option} { - .t tag names -} {sel y a b x} -.t tag raise x y -test text-15.2 {"tag raise" option} { - .t tag names -} {sel y x a b} -.t tag raise x x -test text-15.3 {"tag raise" option} { - .t tag names -} {sel y x a b} -.t tag raise x a -test text-15.4 {"tag raise" option} { - .t tag names -} {sel y a x b} -test text-15.5 {"tag raise" option} { - list [catch {.t tag raise} msg] $msg -} {1 {wrong # args: should be ".t tag raise tagName ?aboveThis?"}} -test text-15.6 {"tag raise" option} { - list [catch {.t tag raise a b c} msg] $msg -} {1 {wrong # args: should be ".t tag raise tagName ?aboveThis?"}} -test text-15.7 {"tag raise" option} { - list [catch {.t tag raise #gorp} msg] $msg -} {1 {tag "#gorp" isn't defined in text widget}} -test text-15.8 {"tag raise" option} { - list [catch {.t tag raise a #gorp} msg] $msg -} {1 {tag "#gorp" isn't defined in text widget}} - -setup -.t tag configure a -foreground black -test text-16.1 {"tag ranges" option} { - .t tag ran x -} {1.1 1.2 1.5 1.13 2.2 2.6} -test text-16.2 {"tag ranges" option} { - .t tag ranges y -} {1.5 1.6} -test text-16.3 {"tag ranges" option} { - .t tag ranges a -} {} -test text-16.4 {"tag ranges" option} { - .t tag ranges #gorp -} {} -test text-16.5 {"tag ranges" option} { - list [catch {.t tag ranges} msg] $msg -} {1 {wrong # args: should be ".t tag ranges tagName"}} -test text-16.6 {"tag ranges" option} { - list [catch {.t tag ranges a b} msg] $msg -} {1 {wrong # args: should be ".t tag ranges tagName"}} - -setup -test text-17.1 {"tag remove" option} { - .t tag re x 2.3 2.7 - .t tag ranges x -} {1.1 1.2 1.5 1.13 2.2 2.3} -test text-17.2 {"tag remove" option} { - list [catch {.t tag remove} msg] $msg -} {1 {wrong # args: should be ".t tag remove tagName index1 ?index2?"}} - -setup -test text-18.1 {"tag bind" option} { - .t tag delete x - .t tag bind x "going in" - .t tag bind x "going out" - list [lsort [.t tag bind x]] [.t tag bind x ] [.t tag bind x ] -} {{ } {going in} {going out}} -test text-18.2 {"tag bind" option} { - .t tag delete x - .t tag bind x "command #1" - .t tag bind x "+command #2" - .t tag bind x -} {command #1; command #2} -test text-18.3 {"tag bind" option} { - .t tag delete x - .t tag bind x "command #1" - .t tag bind x {} - list [catch {.t tag bind x } msg] $msg -} {1 {no binding exists for ""}} -test text-18.4 {"tag bind" option} { - list [catch {.t tag bind} msg] $msg -} {1 {wrong # args: should be ".t tag bind tagName ?sequence? ?command?"}} -test text-18.5 {"tag bind" option} { - list [catch {.t tag bind a b c d} msg] $msg -} {1 {wrong # args: should be ".t tag bind tagName ?sequence? ?command?"}} -test text-18.6 {"tag bind" option} { - list [catch {.t tag bind x abcd} msg] $msg -} {1 {bad event type or keysym "badEvent"}} -test text-18.7 {"tag bind" option} { - .t tag delete x - list [catch {.t tag bind x abcd} msg] $msg [.t tag bind x] -} {1 {requested illegal events; only key, button, motion, and enter/leave events may be used} {}} - -setup -test text-19.1 {"debug" option} { - .t debug on - .t debug -} on -test text-19.2 {"debug" option} { - .t debug off - .t debug -} off -test text-19.3 {"debug" option} { - list [catch {.t debug a b} msg] $msg -} {1 {wrong # args: should be ".t debug ?on|off?"}} -test text-19.4 {"debug" option} { - list [catch {.t debug gorp} msg] $msg -} {1 {expected boolean value but got "gorp"}} - -test text-20.1 {"delete" option} { - setup - .t delete 1.2 - .t get 1.0 1.end -} {Tet for first line} -test text-20.2 {"delete" option} { - setup - .t delete 1.2 1.6 - .t get 1.0 1.end -} {Teor first line} -test text-20.3 {"delete" option} { - list [catch {.t delete} msg] $msg -} {1 {wrong # args: should be ".t delete index1 ?index2?"}} -test text-20.4 {"delete" option} { - list [catch {.t delete a b c} msg] $msg -} {1 {wrong # args: should be ".t delete index1 ?index2?"}} -test text-20.5 {"delete" option} { - list [catch {.t delete @badIndex} msg] $msg -} {1 {bad text index "@badIndex"}} -test text-20.6 {"delete" option} { - list [catch {.t delete 1.2 @badIndex} msg] $msg -} {1 {bad text index "@badIndex"}} -test text-20.7 {"delete" option} { - setup - .t config -state disabled - list [catch {.t delete 1.2} msg] $msg - .t get 1.0 1.end -} {Text for first line} -.t config -state normal - -setup -test text-21.1 {"get" option} { - .t get 1.3 1.5 -} {t } -test text-21.2 {"get" option} { - .t get 1.8 2.4 -} " first line\nSeco" -test text-21.3 {"get" option} { - .t get 1.5 4.4 -} "for first line\nSecond line\n\nLast" -test text-21.4 {"get" option} { - .t get 2.0 -} S -test text-21.5 {"get" option} { - .t get 1.0 2.0 -} "Text for first line\n" -test text-21.6 {"get" option} { - list [catch {.t get} msg] $msg -} {1 {wrong # args: should be ".t get index1 ?index2?"}} -test text-21.7 {"get" option} { - list [catch {.t get a b c} msg] $msg -} {1 {wrong # args: should be ".t get index1 ?index2?"}} -test text-21.8 {"get" option} { - list [catch {.t get badMark} msg] $msg -} {1 {bad text index "badMark"}} -test text-21.8 {"get" option} { - list [catch {.t get 1.0 badMarkToo} msg] $msg -} {1 {bad text index "badMarkToo"}} - -test text-22.1 {errors in "index" option} { - list [catch {.t index} msg] $msg -} {1 {wrong # args: should be ".t index index"}} -test text-22.2 {errors in "index" option} { - list [catch {.t index a b} msg] $msg -} {1 {wrong # args: should be ".t index index"}} -test text-22.3 {errors in "index" option} { - list [catch {.t index badMarkToo} msg] $msg -} {1 {bad text index "badMarkToo"}} - -test text-23.1 {"insert" option} { - setup - .t insert 1.3 XYZ - .t get 1.0 1.end -} {TexXYZt for first line} -test text-23.2 {"insert" option} { - setup - .t insert 1.3 {} - .t get 1.0 1.end -} {Text for first line} -test text-23.3 {"insert" option} { - setup - .t configure -state disabled - .t insert 1.3 "Lots of text" - .t configure -state normal - .t get 1.0 1.end -} {Text for first line} -test text-23.4 {"insert" option} { - list [catch {.t insert a} msg] $msg -} {1 {wrong # args: should be ".t insert index chars ?chars ...?"}} -test text-23.5 {"insert" option} { - list [catch {.t insert a b c} msg] $msg -} {1 {wrong # args: should be ".t insert index chars ?chars ...?"}} -test text-23.6 {"insert" option} { - list [catch {.t insert @bogus foo} msg] $msg -} {1 {bad text index "@bogus"}} - -setup -.t mark set mark1 1.3 -.t mark set mark2 1.6 -test text-24.1 {"mark" options} { - list [catch {.t mark} msg] $msg -} {1 {wrong # args: should be ".t mark option ?arg arg ...?"}} -test text-24.2 {"mark" options} { - list [catch {.t mark badOption} msg] $msg -} {1 {bad mark option "badOption": must be names, set, or unset}} -test text-24.3 {"mark" options} { - lsort [.t mark names] -} {current insert m1 m2 mark1 mark2} -test text-24.4 {"mark" options} { - list [catch {.t mark names a} msg] $msg -} {1 {wrong # args: should be ".t mark names"}} -test text-24.5 {"mark" options} { - .t index mark1 -} 1.3 -test text-24.6 {"mark" options} { - list [catch {.t mark set} msg] $msg -} {1 {wrong # args: should be ".t mark set markName index"}} -test text-24.7 {"mark" options} { - list [catch {.t mark set a b c} msg] $msg -} {1 {wrong # args: should be ".t mark set markName index"}} -test text-24.8 {"mark" options} { - list [catch {.t mark set a @bogus} msg] $msg -} {1 {bad text index "@bogus"}} -.t mark unset mark1 mark2 -test text-24.9 {"mark" options} { - list [catch {.t index mark1} msg] $msg -} {1 {bad text index "mark1"}} -test text-24.10 {"mark" options} { - list [catch {.t index mark2} msg] $msg -} {1 {bad text index "mark2"}} -test text-24.11 {"mark" options} { - list [catch {.t mark unset bogus bogus m1} msg] $msg -} {0 {}} -test text-24.12 {"mark" options} { - list [catch {.t mark unset insert} msg] $msg -} {1 {can't delete "insert" mark}} -test text-24.13 {"mark" options} { - list [catch {.t mark unset current} msg] $msg -} {1 {can't delete "current" mark}} - -.t delete 1.0 end -.t insert insert "Line 1" -for {set i 2} {$i <= 200} {incr i} { - .t insert insert "\nLine $i" -} -update -test text-25.1 {"yview" option} { - .t y 2 - .t index @0,0 -} {3.0} -test text-25.2 {"yview" option} { - .t yview 50 - .t index @0,0 -} {51.0} -test text-25.3 {"yview" option} { - .t yview 1.0 - .t index @0,0 -} {1.0} -test text-25.4 {"yview" option} { - .t yview 1000000 - .t index @0,0 -} {200.0} -test text-25.5 {"yview" option} { - .t yview 1.0 - .t yview -pickplace 25.0 - .t index @0,0 -} {2.0} -test text-25.6 {"yview" option} { - .t yview 0.0 - .t yview -pickplace 29.0 - .t index @0,0 -} {6.0} -test text-25.7 {"yview" option} { - .t yview 0.0 - .t yview -pickplace 30.0 - .t index @0,0 -} {19.0} -test text-25.8 {"yview" option} { - .t yview 40.0 - .t yview -pickplace 39.0 - .t index @0,0 -} {39.0} -test text-25.9 {"yview" option} { - .t yview 40.0 - .t yview -pickplace 35.0 - .t index @0,0 -} {35.0} -test text-25.10 {"yview" option} { - .t yview 40.0 - .t yview -pickplace 34.0 - .t index @0,0 -} {23.0} -test text-25.11 {"yview" option} { - .t yview -100 - .t index @0,0 -} {1.0} -test text-25.12 {"yview" option} { - list [catch {.t yview} msg] $msg -} {1 {wrong # args: should be ".t yview ?-pickplace? lineNum|index"}} -test text-25.13 {"yview" option} { - list [catch {.t yview 1.0 1.0} msg] $msg -} {1 {wrong # args: should be ".t yview ?-pickplace? lineNum|index"}} -test text-25.14 {"yview" option} { - list [catch {.t yview -pickplace 1.0 1.0} msg] $msg -} {1 {wrong # args: should be ".t yview ?-pickplace? lineNum|index"}} -test text-25.15 {"yview" option} { - list [catch {.t yview -poop 1.0} msg] $msg -} {1 {wrong # args: should be ".t yview ?-pickplace? lineNum|index"}} -test text-25.16 {"yview" option} { - list [catch {.t yview @bogus} msg] $msg -} {1 {bad text index "@bogus"}} -proc bizarre_scroll args { - .t2.t delete 5.0 end -} -test text-25.17 {"yview" option with bizarre scroll command} { - catch {destroy .t2} - toplevel .t2 - text .t2.t -width 40 -height 4 - .t2.t insert end "1\n2\n3\n4\n5\n6\n7\n8\n" - pack .t2.t - wm geometry .t2 +0+0 - update - .t2.t configure -yscrollcommand bizarre_scroll - .t2.t yview 100 - set result [.t2.t index @0,0] - update - lappend result [.t2.t index @0,0] -} {9.0 5.0} -catch {destroy .t2} - -test text-26.1 {ambiguous options, other errors} { - list [catch {.t badOption} msg] $msg -} {1 {bad option "badOption": must be compare, configure, debug, delete, get, index, insert, mark, scan, tag, or yview}} -test text-26.2 {ambiguous options, other errors} { - list [catch {.t co} msg] $msg -} {1 {bad option "co": must be compare, configure, debug, delete, get, index, insert, mark, scan, tag, or yview}} -test text-26.3 {ambiguous options, other errors} { - list [catch {.t de} msg] $msg -} {1 {bad option "de": must be compare, configure, debug, delete, get, index, insert, mark, scan, tag, or yview}} -test text-26.4 {ambiguous options, other errors} { - list [catch {.t in} msg] $msg -} {1 {bad option "in": must be compare, configure, debug, delete, get, index, insert, mark, scan, tag, or yview}} -test text-26.4 {ambiguous options, other errors} { - list [catch {.t} msg] $msg -} {1 {wrong # args: should be ".t option ?arg arg ...?"}} - -setup -.t tag remove sel 1.0 end -.t tag add sel 1.0 1.10 -test text-27.1 {selection exporting} { - list [catch {selection get} msg] $msg -} {0 {Text for f}} -.t configure -exportselection off -test text-27.2 {selection exporting} { - list [catch {selection get} msg] $msg -} {1 {selection doesn't exist or form "STRING" not defined}} -.t tag add sel 2.0 2.end -test text-27.3 {selection exporting} { - list [catch {selection get} msg] $msg -} {1 {selection doesn't exist or form "STRING" not defined}} -.t configure -exportselection on -test text-27.4 {selection exporting} { - list [catch {selection get} msg] $msg -} {0 {Text for fSecond line}} -.t configure -exportselection off -.t tag remove sel 1.0 end -.t configure -exportselection on -test text-27.5 {selection exporting} { - list [catch {selection get} msg] $msg -} {1 {selection doesn't exist or form "STRING" not defined}} -.t tag add sel 1.0 1.10 -.t tag remove sel 1.0 1.10 -test text-27.6 {selection exporting} { - list [catch {selection get} msg] $msg -} {1 {selection doesn't exist or form "STRING" not defined}} -.t tag add sel 1.0 1.4 -.t tag add sel 1.9 1.14 -.t tag add sel 1.15 1.19 -.t tag add sel 2.3 2.6 -.t tag add sel 4.0 4.9 -test text-27.7 {selection exporting} { - list [catch {selection get} msg] $msg -} {0 {TextfirstlineondLast line}} -.t tag remove sel 1.0 end -.t tag add sel 1.15 2.6 -.t tag add sel 2.7 4.4 -test text-27.8 {selection exporting} { - list [catch {selection get} msg] $msg -} {0 {line -Secondline - -Last}} -entry .e -.e insert end "Some text" -.e select from 0 -.e select to 4 -test text-27.9 {losing the selection} { - .t tag ranges sel -} {} -destroy .e - -test text-28.1 {copying from configs to sel tag} { - .t configure -selectbackground white - lindex [.t tag configure sel -background] 4 -} {white} -test text-28.2 {copying from configs to sel tag} { - .t configure -selectbackground black - lindex [.t tag configure sel -background] 4 -} {black} -test text-28.3 {copying from configs to sel tag} { - .t configure -selectforeground black - lindex [.t tag configure sel -foreground] 4 -} {black} -test text-28.4 {copying from configs to sel tag} { - .t configure -selectforeground white - lindex [.t tag configure sel -foreground] 4 -} {white} -test text-28.5 {copying from configs to sel tag} { - .t configure -selectborderwidth 3 - lindex [.t tag configure sel -borderwidth] 4 -} {3} - -.t delete 1.0 end -.t config -width 20 -height 10 -.t insert 1.0 "abcd efgh ijklmno pqrst uvwxyz 1234 56 7890\nLine 2\nLine 3" -update -after 200 -wm geometry . [expr [winfo width .]+3]x[winfo height .] -update -after 200 -.t config -wrap none -test text-29.1 {-wrap option} { - list [.t index @500,8] [.t index @1,20] [.t index @500,20] \ - [.t index @1,35] [.t index @500,35] [.t index @1,48] -} {1.20 2.0 2.6 3.0 3.6 3.6} -.t config -wrap char -test text-29.2 {-wrap option} { - list [.t index @500,8] [.t index @1,20] [.t index @500,20] \ - [.t index @1,35] [.t index @500,35] [.t index @1,48] -} {1.19 1.20 1.39 1.40 1.43 2.0} -.t config -wrap word -test text-29.3 {-wrap option} { - list [.t index @500,8] [.t index @1,20] [.t index @500,20] \ - [.t index @1,35] [.t index @500,35] [.t index @1,48] -} {1.17 1.18 1.38 1.39 1.43 2.0} -.t tag add sel 1.16 -.t tag add sel 1.18 -.t tag add sel 1.38 -.t tag add sel 1.39 -.t config -wrap none -test text-29.4 {-wrap option} { - list [.t index @500,8] [.t index @1,20] [.t index @500,20] \ - [.t index @1,35] [.t index @500,35] [.t index @1,48] -} {1.20 2.0 2.6 3.0 3.6 3.6} -.t config -wrap char -test text-29.5 {-wrap option} { - list [.t index @500,8] [.t index @1,20] [.t index @500,20] \ - [.t index @1,35] [.t index @500,35] [.t index @1,48] -} {1.19 1.20 1.39 1.40 1.43 2.0} -.t config -wrap word -test text-29.6 {-wrap option} { - list [.t index @500,8] [.t index @1,20] [.t index @500,20] \ - [.t index @1,35] [.t index @500,35] [.t index @1,48] -} {1.17 1.18 1.38 1.39 1.43 2.0} -.t tag remove sel 1.0 end -.t tag add sel 1.17 -.t tag add sel 1.37 -.t config -wrap none -test text-29.7 {-wrap option} { - list [.t index @500,8] [.t index @1,20] [.t index @500,20] \ - [.t index @1,35] [.t index @500,35] [.t index @1,48] -} {1.20 2.0 2.6 3.0 3.6 3.6} -.t config -wrap char -test text-29.8 {-wrap option} { - list [.t index @500,8] [.t index @1,20] [.t index @500,20] \ - [.t index @1,35] [.t index @500,35] [.t index @1,48] -} {1.19 1.20 1.39 1.40 1.43 2.0} -.t config -wrap word -test text-29.9 {-wrap option} { - list [.t index @500,8] [.t index @1,20] [.t index @500,20] \ - [.t index @1,35] [.t index @500,35] [.t index @1,48] -} {1.17 1.18 1.38 1.39 1.43 2.0} - -#destroy .t diff --git a/tk3.6/tests/wm.test b/tk3.6/tests/wm.test deleted file mode 100644 index 3b52f27..0000000 --- a/tk3.6/tests/wm.test +++ /dev/null @@ -1,288 +0,0 @@ -# This file is a Tcl script to test out Tk's interactions with -# the window manager, including the "wm" command. It is organized -# in the standard fashion for Tcl tests. -# -# 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/wish/tests/RCS/wm.test,v 1.12 93/07/10 14:54:01 ouster Exp $ (Berkeley) - -if {[string compare test [info procs test]] == 1} { - source defs -} - -proc sleep ms { - global x - after $ms {set x 1} - tkwait variable x -} - -set i 1 -foreach geom {+20+80 +80+20 +0+0} { - catch {destroy .t} - test wm-1.$i {initial window position} { - toplevel .t -width 200 -height 150 - wm geom .t $geom - update - wm geom .t - } 200x150$geom - incr i -} - -# The tests below are tricky because window managers don't all move -# windows correctly. Try one motion and compute the window manager's -# error, then factor this error into the actual tests. In other words, -# this just makes sure that things are consistent between moves. - -set i 1 -catch {destroy .t} -toplevel .t -width 100 -height 150 -wm geom .t +200+200 -update -wm geom .t +150+150 -update -scan [wm geom .t] %dx%d+%d+%d width height x y -set xerr [expr 150-$x] -set yerr [expr 150-$y] -foreach geom {+20+80 +80+20 +0+0 -0-0 +0-0 -0+0 -10-5 -10+5 +10-5} { - test wm-2.$i {moving window while mapped} { - wm geom .t $geom - update - scan [wm geom .t] %dx%d%1s%d%1s%d width height xsign x ysign y - format "%s%d%s%d" $xsign [expr $x$xsign$xerr] $ysign \ - [expr $y$ysign$yerr] - } $geom - incr i -} - -set i 1 -foreach geom {+20+80 +80+20 +0+0 -0-0 +0-0 -0+0 -10-5 -10+5 +10-5} { - test wm-3.$i {moving window while iconified} { - wm iconify .t - sleep 200 - wm geom .t $geom - update - wm deiconify .t - scan [wm geom .t] %dx%d%1s%d%1s%d width height xsign x ysign y - format "%s%d%s%d" $xsign [expr $x$xsign$xerr] $ysign \ - [expr $y$ysign$yerr] - } $geom - incr i -} - -set i 1 -foreach geom {+20+80 +100+40 +0+0} { - test wm-4.$i {moving window while withdrawn} { - wm withdraw .t - sleep 200 - wm geom .t $geom - update - wm deiconify .t - wm geom .t - } 100x150$geom - incr i -} - -test wm-5.1 {compounded state changes} { - catch {destroy .t} - toplevel .t -width 200 -height 100 - wm geometry .t +100+100 - update - wm withdraw .t - wm deiconify .t - list [winfo ismapped .t] [wm state .t] -} {1 normal} -test wm-5.2 {compounded state changes} { - catch {destroy .t} - toplevel .t -width 200 -height 100 - wm geometry .t +100+100 - update - wm withdraw .t - wm deiconify .t - wm withdraw .t - list [winfo ismapped .t] [wm state .t] -} {0 withdrawn} -test wm-5.3 {compounded state changes} { - catch {destroy .t} - toplevel .t -width 200 -height 100 - wm geometry .t +100+100 - update - wm iconify .t - wm deiconify .t - wm iconify .t - wm deiconify .t - list [winfo ismapped .t] [wm state .t] -} {1 normal} -test wm-5.4 {compounded state changes} { - catch {destroy .t} - toplevel .t -width 200 -height 100 - wm geometry .t +100+100 - update - wm iconify .t - wm deiconify .t - wm iconify .t - list [winfo ismapped .t] [wm state .t] -} {0 iconic} -test wm-5.5 {compounded state changes} { - catch {destroy .t} - toplevel .t -width 200 -height 100 - wm geometry .t +100+100 - update - wm iconify .t - wm withdraw .t - list [winfo ismapped .t] [wm state .t] -} {0 withdrawn} -test wm-5.6 {compounded state changes} { - catch {destroy .t} - toplevel .t -width 200 -height 100 - wm geometry .t +100+100 - update - wm iconify .t - wm withdraw .t - wm deiconify .t - list [winfo ismapped .t] [wm state .t] -} {1 normal} -if $atBerkeley { - test wm-5.7 {compounded state changes} { - catch {destroy .t} - toplevel .t -width 200 -height 100 - wm geometry .t +100+100 - update - wm withdraw .t - wm iconify .t - list [winfo ismapped .t] [wm state .t] - } {0 iconic} -} - -catch {destroy .t} -toplevel .t -width 200 -height 100 -wm geom .t +10+10 -wm minsize .t 1 1 -update -test wm-6.1 {size changes} { - .t config -width 180 -height 150 - update - wm geom .t -} 180x150+10+10 -test wm-6.2 {size changes} { - wm geom .t 250x60 - .t config -width 170 -height 140 - update - wm geom .t -} 250x60+10+10 -test wm-6.3 {size changes} { - wm geom .t 250x60 - .t config -width 170 -height 140 - wm geom .t {} - update - wm geom .t -} 170x140+10+10 -if $atBerkeley { - test wm-6.4 {size changes} { - wm minsize .t 1 1 - update - puts stdout "Please resize window \"t\" with the mouse (but don't move it!)," - puts -nonewline stdout "then hit return: " - flush stdout - gets stdin - update - set width [winfo width .t] - set height [winfo height .t] - .t config -width 230 -height 110 - update - incr width -[winfo width .t] - incr height -[winfo height .t] - wm geom .t {} - update - set w2 [winfo width .t] - set h2 [winfo height .t] - .t config -width 114 -height 261 - update - list $width $height $w2 $h2 [wm geom .t] - } {0 0 230 110 114x261+10+10} -} - -test wm-7.1 {window initially withdrawn} { - catch {destroy .t} - toplevel .t -width 100 -height 30 - wm geometry .t +0+0 - wm withdraw .t - sleep 200 - set result [winfo ismapped .t] - wm deiconify .t - list $result [winfo ismapped .t] -} {0 1} -test wm-7.2 {window initially withdrawn} { - catch {destroy .t} - toplevel .t -width 100 -height 30 - wm geometry .t +0+0 - wm withdraw .t - wm deiconify .t - sleep 200 - winfo ismapped .t -} 1 - -test wm-8.1 {window initially iconic} { - catch {destroy .t} - toplevel .t -width 100 -height 30 - wm geometry .t +0+0 - wm title .t 1 - wm iconify .t - update idletasks - list [winfo ismapped .t] [wm state .t] -} {0 iconic} - -# I don't know why the wait below is needed, but without it the test -# fails under twm. -sleep 200 - -test wm-8.2 {window initially iconic} { - catch {destroy .t} - toplevel .t -width 100 -height 30 - wm geometry .t +0+0 - wm title .t 2 - wm iconify .t - update idletasks - wm withdraw .t - wm deiconify .t - list [winfo ismapped .t] [wm state .t] -} {1 normal} - -catch {destroy .m} -menu .m -foreach i {{Test label} Another {Yet another} {Last label}} { - .m add command -label $i -} -.m post 100 200 -test wm-9.1 {override_redirect and Tk_MoveTopLevelWindow} { - list [winfo ismapped .m] [wm state .m] [winfo x .m] [winfo y .m] -} {1 normal 100 200} -.m post 150 210 -test wm-9.2 {override_redirect and Tk_MoveTopLevelWindow} { - list [winfo ismapped .m] [wm state .m] [winfo x .m] [winfo y .m] -} {1 normal 150 210} -.m unpost -test wm-9.3 {override_redirect and Tk_MoveTopLevelWindow} { - list [winfo ismapped .m] -} 0 -destroy .m - -catch {destroy .t} -concat {} diff --git a/tk3.6/tk.h b/tk3.6/tk.h deleted file mode 100644 index 1e2033b..0000000 --- a/tk3.6/tk.h +++ /dev/null @@ -1,765 +0,0 @@ -/* - * tk.h -- - * - * Declarations for Tk-related things that are visible - * outside of the Tk module itself. - * - * 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 - * 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/wish/RCS/tk.h,v 1.119 93/11/21 14:55:48 ouster Exp $ SPRITE (Berkeley) - */ - -#ifndef _TK -#define _TK - -#define TK_VERSION "3.6" -#define TK_MAJOR_VERSION 3 -#define TK_MINOR_VERSION 6 - -#ifndef _TCL -#include -#endif -#ifndef _XLIB_H -#include -#endif -#ifdef __STDC__ -#include -#endif - -/* - * Dummy types that are used by clients: - */ - -typedef struct Tk_ErrorHandler_ *Tk_ErrorHandler; -typedef struct Tk_TimerToken_ *Tk_TimerToken; -typedef struct Tk_Window_ *Tk_Window; -typedef struct Tk_3DBorder_ *Tk_3DBorder; -typedef struct Tk_BindingTable_ *Tk_BindingTable; - -/* - * Additional types exported to clients. - */ - -typedef char *Tk_Uid; - -/* - * Structure used to specify how to handle argv options. - */ - -typedef struct { - char *key; /* The key string that flags the option in the - * argv array. */ - int type; /* Indicates option type; see below. */ - char *src; /* Value to be used in setting dst; usage - * depends on type. */ - char *dst; /* Address of value to be modified; usage - * depends on type. */ - char *help; /* Documentation message describing this option. */ -} Tk_ArgvInfo; - -/* - * Legal values for the type field of a Tk_ArgvInfo: see the user - * documentation for details. - */ - -#define TK_ARGV_CONSTANT 15 -#define TK_ARGV_INT 16 -#define TK_ARGV_STRING 17 -#define TK_ARGV_UID 18 -#define TK_ARGV_REST 19 -#define TK_ARGV_FLOAT 20 -#define TK_ARGV_FUNC 21 -#define TK_ARGV_GENFUNC 22 -#define TK_ARGV_HELP 23 -#define TK_ARGV_CONST_OPTION 24 -#define TK_ARGV_OPTION_VALUE 25 -#define TK_ARGV_OPTION_NAME_VALUE 26 -#define TK_ARGV_END 27 - -/* - * Flag bits for passing to Tk_ParseArgv: - */ - -#define TK_ARGV_NO_DEFAULTS 0x1 -#define TK_ARGV_NO_LEFTOVERS 0x2 -#define TK_ARGV_NO_ABBREV 0x4 -#define TK_ARGV_DONT_SKIP_FIRST_ARG 0x8 - -/* - * Structure used to describe application-specific configuration - * options: indicates procedures to call to parse an option and - * to return a text string describing an option. - */ - -typedef int (Tk_OptionParseProc) _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, Tk_Window tkwin, char *value, char *widgRec, - int offset)); -typedef char *(Tk_OptionPrintProc) _ANSI_ARGS_((ClientData clientData, - Tk_Window tkwin, char *widgRec, int offset, - Tcl_FreeProc **freeProcPtr)); - -typedef struct Tk_CustomOption { - Tk_OptionParseProc *parseProc; /* Procedure to call to parse an - * option and store it in converted - * form. */ - Tk_OptionPrintProc *printProc; /* Procedure to return a printable - * string describing an existing - * option. */ - ClientData clientData; /* Arbitrary one-word value used by - * option parser: passed to - * parseProc and printProc. */ -} Tk_CustomOption; - -/* - * Structure used to specify information for Tk_ConfigureWidget. Each - * structure gives complete information for one option, including - * how the option is specified on the command line, where it appears - * in the option database, etc. - */ - -typedef struct Tk_ConfigSpec { - int type; /* Type of option, such as TK_CONFIG_COLOR; - * see definitions below. Last option in - * table must have type TK_CONFIG_END. */ - char *argvName; /* Switch used to specify option in argv. - * NULL means this spec is part of a group. */ - char *dbName; /* Name for option in option database. */ - char *dbClass; /* Class for option in database. */ - char *defValue; /* Default value for option if not - * specified in command line or database. */ - int offset; /* Where in widget record to store value; - * use Tk_Offset macro to generate values - * for this. */ - int specFlags; /* Any combination of the values defined - * below; other bits are used internally - * by tkConfig.c. */ - Tk_CustomOption *customPtr; /* If type is TK_CONFIG_CUSTOM then this is - * a pointer to info about how to parse and - * print the option. Otherwise it is - * irrelevant. */ -} Tk_ConfigSpec; - -/* - * Type values for Tk_ConfigSpec structures. See the user - * documentation for details. - */ - -#define TK_CONFIG_BOOLEAN 1 -#define TK_CONFIG_INT 2 -#define TK_CONFIG_DOUBLE 3 -#define TK_CONFIG_STRING 4 -#define TK_CONFIG_UID 5 -#define TK_CONFIG_COLOR 6 -#define TK_CONFIG_FONT 7 -#define TK_CONFIG_BITMAP 8 -#define TK_CONFIG_BORDER 9 -#define TK_CONFIG_RELIEF 10 -#define TK_CONFIG_CURSOR 11 -#define TK_CONFIG_ACTIVE_CURSOR 12 -#define TK_CONFIG_JUSTIFY 13 -#define TK_CONFIG_ANCHOR 14 -#define TK_CONFIG_SYNONYM 15 -#define TK_CONFIG_CAP_STYLE 16 -#define TK_CONFIG_JOIN_STYLE 17 -#define TK_CONFIG_PIXELS 18 -#define TK_CONFIG_MM 19 -#define TK_CONFIG_WINDOW 20 -#define TK_CONFIG_CUSTOM 21 -#define TK_CONFIG_END 22 - -/* - * Macro to use to fill in "offset" fields of Tk_ConfigInfos. - * Computes number of bytes from beginning of structure to a - * given field. - */ - -#ifdef offsetof -#define Tk_Offset(type, field) ((int) offsetof(type, field)) -#else -#define Tk_Offset(type, field) ((int) ((char *) &((type *) 0)->field)) -#endif - -/* - * Possible values for flags argument to Tk_ConfigureWidget: - */ - -#define TK_CONFIG_ARGV_ONLY 1 - -/* - * Possible flag values for Tk_ConfigInfo structures. Any bits at - * or above TK_CONFIG_USER_BIT may be used by clients for selecting - * certain entries. Before changing any values here, coordinate with - * tkConfig.c (internal-use-only flags are defined there). - */ - -#define TK_CONFIG_COLOR_ONLY 1 -#define TK_CONFIG_MONO_ONLY 2 -#define TK_CONFIG_NULL_OK 4 -#define TK_CONFIG_DONT_SET_DEFAULT 8 -#define TK_CONFIG_OPTION_SPECIFIED 0x10 -#define TK_CONFIG_USER_BIT 0x100 - -/* - * Bits to pass to Tk_CreateFileHandler to indicate what sorts - * of events are of interest: - */ - -#define TK_READABLE 1 -#define TK_WRITABLE 2 -#define TK_EXCEPTION 4 - -/* - * Flag values to pass to Tk_DoOneEvent to disable searches - * for some kinds of events: - */ - -#define TK_DONT_WAIT 1 -#define TK_X_EVENTS 2 -#define TK_FILE_EVENTS 4 -#define TK_TIMER_EVENTS 8 -#define TK_IDLE_EVENTS 0x10 -#define TK_ALL_EVENTS 0x1e - -/* - * Priority levels to pass to Tk_AddOption: - */ - -#define TK_WIDGET_DEFAULT_PRIO 20 -#define TK_STARTUP_FILE_PRIO 40 -#define TK_USER_DEFAULT_PRIO 60 -#define TK_INTERACTIVE_PRIO 80 -#define TK_MAX_PRIO 100 - -/* - * Relief values returned by Tk_GetRelief: - */ - -#define TK_RELIEF_RAISED 1 -#define TK_RELIEF_FLAT 2 -#define TK_RELIEF_SUNKEN 4 -#define TK_RELIEF_GROOVE 8 -#define TK_RELIEF_RIDGE 16 - -/* - * Special EnterNotify/LeaveNotify "mode" for use in events - * generated by tkShare.c. Pick a high enough value that it's - * unlikely to conflict with existing values (like NotifyNormal) - * or any new values defined in the future. - */ - -#define TK_NOTIFY_SHARE 20 - -/* - * Enumerated type for describing a point by which to anchor something: - */ - -typedef enum { - TK_ANCHOR_N, TK_ANCHOR_NE, TK_ANCHOR_E, TK_ANCHOR_SE, - TK_ANCHOR_S, TK_ANCHOR_SW, TK_ANCHOR_W, TK_ANCHOR_NW, - TK_ANCHOR_CENTER -} Tk_Anchor; - -/* - * Enumerated type for describing a style of justification: - */ - -typedef enum { - TK_JUSTIFY_LEFT, TK_JUSTIFY_RIGHT, - TK_JUSTIFY_CENTER, TK_JUSTIFY_FILL -} Tk_Justify; - -/* - * Enumerated type for describing the color model that should be used - * for the application: - */ - -typedef enum {TK_MONO, TK_COLOR} Tk_ColorModel; - -/* - *-------------------------------------------------------------- - * - * Macros for querying Tk_Window structures. See the - * manual entries for documentation. - * - *-------------------------------------------------------------- - */ - -#define Tk_Display(tkwin) (((Tk_FakeWin *) (tkwin))->display) -#define Tk_ScreenNumber(tkwin) (((Tk_FakeWin *) (tkwin))->screenNum) -#define Tk_Screen(tkwin) (ScreenOfDisplay(Tk_Display(tkwin), \ - Tk_ScreenNumber(tkwin))) -#define Tk_Depth(tkwin) (((Tk_FakeWin *) (tkwin))->depth) -#define Tk_Visual(tkwin) (((Tk_FakeWin *) (tkwin))->visual) -#define Tk_WindowId(tkwin) (((Tk_FakeWin *) (tkwin))->window) -#define Tk_PathName(tkwin) (((Tk_FakeWin *) (tkwin))->pathName) -#define Tk_Name(tkwin) (((Tk_FakeWin *) (tkwin))->nameUid) -#define Tk_Class(tkwin) (((Tk_FakeWin *) (tkwin))->classUid) -#define Tk_X(tkwin) (((Tk_FakeWin *) (tkwin))->changes.x) -#define Tk_Y(tkwin) (((Tk_FakeWin *) (tkwin))->changes.y) -#define Tk_Width(tkwin) (((Tk_FakeWin *) (tkwin))->changes.width) -#define Tk_Height(tkwin) \ - (((Tk_FakeWin *) (tkwin))->changes.height) -#define Tk_Changes(tkwin) (&((Tk_FakeWin *) (tkwin))->changes) -#define Tk_Attributes(tkwin) (&((Tk_FakeWin *) (tkwin))->atts) -#define Tk_IsMapped(tkwin) \ - (((Tk_FakeWin *) (tkwin))->flags & TK_MAPPED) -#define Tk_IsTopLevel(tkwin) \ - (((Tk_FakeWin *) (tkwin))->flags & TK_TOP_LEVEL) -#define Tk_ReqWidth(tkwin) (((Tk_FakeWin *) (tkwin))->reqWidth) -#define Tk_ReqHeight(tkwin) (((Tk_FakeWin *) (tkwin))->reqHeight) -#define Tk_InternalBorderWidth(tkwin) \ - (((Tk_FakeWin *) (tkwin))->internalBorderWidth) -#define Tk_Parent(tkwin) (((Tk_FakeWin *) (tkwin))->parentPtr) -#define Tk_Colormap(tkwin) (((Tk_FakeWin *) (tkwin))->atts.colormap) - -/* - * The structure below is needed by the macros above so that they can - * access the fields of a Tk_Window. The fields not needed by the macros - * are declared as "dummyX". The structure has its own type in order to - * prevent applications from accessing Tk_Window fields except using - * official macros. WARNING!! The structure definition must be kept - * consistent with the TkWindow structure in tkInt.h. If you change one, - * then change the other. See the declaration in tkInt.h for - * documentation on what the fields are used for internally. - */ - -typedef struct Tk_FakeWin { - Display *display; - char *dummy1; - int screenNum; - Visual *visual; - int depth; - Window window; - char *dummy2; - char *dummy3; - Tk_Window parentPtr; - char *dummy4; - char *dummy5; - char *pathName; - Tk_Uid nameUid; - Tk_Uid classUid; - XWindowChanges changes; - unsigned int dummy6; - XSetWindowAttributes atts; - unsigned long dummy7; - unsigned int flags; - char *dummy8; - char *dummy9; - ClientData dummy10; - int dummy12; - char *dummy13; - char *dummy14; - ClientData dummy15; - char *dummy16; - ClientData dummy17; - int reqWidth, reqHeight; - int internalBorderWidth; - char *dummyX; -} Tk_FakeWin; - -/* - * Flag values for TkWindow (and Tk_FakeWin) structures are: - * - * TK_MAPPED: 1 means window is currently mapped, - * 0 means unmapped. - * TK_RECURSIVE_DESTROY: 1 means a recursive destroy is in - * progress, so some cleanup operations - * can be omitted. - * TK_TOP_LEVEL: 1 means this is a top-level window (it - * was or will be created as a child of - * a root window). - * TK_ALREADY_DEAD: 1 means the window is in the process of - * being destroyed already. - * TK_NEED_CONFIG_NOTIFY: 1 means that the window has been reconfigured - * before it was made to exist. At the time of - * making it exist a ConfigureNotify event needs - * to be generated. - * TK_GRAB_FLAG: Used to manage grabs. See tkGrab.c for - * details. - */ - -#define TK_MAPPED 1 -#define TK_RECURSIVE_DESTROY 2 -#define TK_TOP_LEVEL 4 -#define TK_ALREADY_DEAD 8 -#define TK_NEED_CONFIG_NOTIFY 0x10 -#define TK_GRAB_FLAG 0x20 - -/* - *-------------------------------------------------------------- - * - * Additional procedure types defined by Tk. - * - *-------------------------------------------------------------- - */ - -typedef int (Tk_ErrorProc) _ANSI_ARGS_((ClientData clientData, - XErrorEvent *errEventPtr)); -typedef void (Tk_EventProc) _ANSI_ARGS_((ClientData clientData, - XEvent *eventPtr)); -typedef void (Tk_FileProc) _ANSI_ARGS_((ClientData clientData, int mask)); -typedef void (Tk_FocusProc) _ANSI_ARGS_((ClientData clientData, int gotFocus)); -typedef void (Tk_FreeProc) _ANSI_ARGS_((ClientData clientData)); -typedef int (Tk_GenericProc) _ANSI_ARGS_((ClientData clientData, - XEvent *eventPtr)); -typedef void (Tk_GeometryProc) _ANSI_ARGS_((ClientData clientData, - Tk_Window tkwin)); -typedef int (Tk_GetSelProc) _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, char *portion)); -typedef void (Tk_IdleProc) _ANSI_ARGS_((ClientData clientData)); -typedef void (Tk_LostSelProc) _ANSI_ARGS_((ClientData clientData)); -typedef Bool (Tk_RestrictProc) _ANSI_ARGS_((Display *display, XEvent *eventPtr, - char *arg)); -typedef int (Tk_SelectionProc) _ANSI_ARGS_((ClientData clientData, - int offset, char *buffer, int maxBytes)); -typedef void (Tk_TimerProc) _ANSI_ARGS_((ClientData clientData)); - -/* - *-------------------------------------------------------------- - * - * Exported procedures and variables. - * - *-------------------------------------------------------------- - */ - -EXTERN XColor * Tk_3DBorderColor _ANSI_ARGS_((Tk_3DBorder border)); -EXTERN void Tk_AddOption _ANSI_ARGS_((Tk_Window tkwin, char *name, - char *value, int priority)); -EXTERN void Tk_BackgroundError _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN void Tk_BindEvent _ANSI_ARGS_((Tk_BindingTable bindingTable, - XEvent *eventPtr, Tk_Window tkwin, int numObjects, - ClientData *objectPtr)); -EXTERN void Tk_CancelIdleCall _ANSI_ARGS_((Tk_IdleProc *idleProc, - ClientData clientData)); -EXTERN void Tk_ChangeWindowAttributes _ANSI_ARGS_((Tk_Window tkwin, - unsigned long valueMask, - XSetWindowAttributes *attsPtr)); -EXTERN void Tk_ClearSelection _ANSI_ARGS_((Tk_Window tkwin)); -EXTERN void Tk_ConfigureFree _ANSI_ARGS_((Tk_ConfigSpec *specs, - char *widgRec, Display *display, int needFlags)); -EXTERN int Tk_ConfigureInfo _ANSI_ARGS_((Tcl_Interp *interp, - Tk_Window tkwin, Tk_ConfigSpec *specs, - char *widgRec, char *argvName, int flags)); -EXTERN int Tk_ConfigureWidget _ANSI_ARGS_((Tcl_Interp *interp, - Tk_Window tkwin, Tk_ConfigSpec *specs, - int argc, char **argv, char *widgRec, - int flags)); -EXTERN void Tk_ConfigureWindow _ANSI_ARGS_((Tk_Window tkwin, - unsigned int valueMask, XWindowChanges *valuePtr)); -EXTERN Tk_Window Tk_CoordsToWindow _ANSI_ARGS_((int rootX, int rootY, - Tk_Window tkwin)); -EXTERN unsigned long Tk_CreateBinding _ANSI_ARGS_((Tcl_Interp *interp, - Tk_BindingTable bindingTable, ClientData object, - char *eventString, char *command, int append)); -EXTERN Tk_BindingTable Tk_CreateBindingTable _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN Tk_ErrorHandler Tk_CreateErrorHandler _ANSI_ARGS_((Display *display, - int errNum, int request, int minorCode, - Tk_ErrorProc *errorProc, ClientData clientData)); -EXTERN void Tk_CreateEventHandler _ANSI_ARGS_((Tk_Window token, - unsigned long mask, Tk_EventProc *proc, - ClientData clientData)); -EXTERN void Tk_CreateFileHandler _ANSI_ARGS_((int fd, int mask, - Tk_FileProc *proc, ClientData clientData)); -EXTERN void Tk_CreateFocusHandler _ANSI_ARGS_((Tk_Window tkwin, - Tk_FocusProc *proc, ClientData clientData)); -EXTERN void Tk_CreateGenericHandler _ANSI_ARGS_(( - Tk_GenericProc *proc, ClientData clientData)); -EXTERN Tk_Window Tk_CreateMainWindow _ANSI_ARGS_((Tcl_Interp *interp, - char *screenName, char *baseName, - char *className)); -EXTERN void Tk_CreateSelHandler _ANSI_ARGS_((Tk_Window tkwin, - Atom target, Tk_SelectionProc *proc, - ClientData clientData, Atom format)); -EXTERN Tk_TimerToken Tk_CreateTimerHandler _ANSI_ARGS_((int milliseconds, - Tk_TimerProc *proc, ClientData clientData)); -EXTERN Tk_Window Tk_CreateWindow _ANSI_ARGS_((Tcl_Interp *interp, - Tk_Window parent, char *name, char *screenName)); -EXTERN Tk_Window Tk_CreateWindowFromPath _ANSI_ARGS_(( - Tcl_Interp *interp, Tk_Window tkwin, - char *pathName, char *screenName)); -EXTERN int Tk_DefineBitmap _ANSI_ARGS_((Tcl_Interp *interp, - Tk_Uid name, char *source, unsigned int width, - unsigned int height)); -EXTERN void Tk_DefineCursor _ANSI_ARGS_((Tk_Window window, - Cursor cursor)); -EXTERN void Tk_DeleteAllBindings _ANSI_ARGS_(( - Tk_BindingTable bindingTable, ClientData object)); -EXTERN int Tk_DeleteBinding _ANSI_ARGS_((Tcl_Interp *interp, - Tk_BindingTable bindingTable, ClientData object, - char *eventString)); -EXTERN void Tk_DeleteBindingTable _ANSI_ARGS_(( - Tk_BindingTable bindingTable)); -EXTERN void Tk_DeleteErrorHandler _ANSI_ARGS_(( - Tk_ErrorHandler handler)); -EXTERN void Tk_DeleteEventHandler _ANSI_ARGS_((Tk_Window token, - unsigned long mask, Tk_EventProc *proc, - ClientData clientData)); -EXTERN void Tk_DeleteFileHandler _ANSI_ARGS_((int fd)); -EXTERN void Tk_DeleteGenericHandler _ANSI_ARGS_(( - Tk_GenericProc *proc, ClientData clientData)); -EXTERN void Tk_DeleteSelHandler _ANSI_ARGS_((Tk_Window tkwin, - Atom target)); -EXTERN void Tk_DeleteTimerHandler _ANSI_ARGS_(( - Tk_TimerToken token)); -EXTERN void Tk_DestroyWindow _ANSI_ARGS_((Tk_Window tkwin)); -EXTERN char * Tk_DisplayName _ANSI_ARGS_((Tk_Window tkwin)); -EXTERN int Tk_DoOneEvent _ANSI_ARGS_((int flags)); -EXTERN void Tk_DoWhenIdle _ANSI_ARGS_((Tk_IdleProc *proc, - ClientData clientData)); -EXTERN void Tk_Draw3DPolygon _ANSI_ARGS_((Display *display, - Drawable drawable, Tk_3DBorder border, - XPoint *pointPtr, int numPoints, int borderWidth, - int leftRelief)); -EXTERN void Tk_Draw3DRectangle _ANSI_ARGS_((Display *display, - Drawable drawable, Tk_3DBorder border, int x, - int y, int width, int height, int borderWidth, - int relief)); -EXTERN void Tk_EventuallyFree _ANSI_ARGS_((ClientData clientData, - Tk_FreeProc *freeProc)); -EXTERN void Tk_Fill3DPolygon _ANSI_ARGS_((Display *display, - Drawable drawable, Tk_3DBorder border, - XPoint *pointPtr, int numPoints, int borderWidth, - int leftRelief)); -EXTERN void Tk_Fill3DRectangle _ANSI_ARGS_((Display *display, - Drawable drawable, Tk_3DBorder border, int x, - int y, int width, int height, int borderWidth, - int relief)); -EXTERN void Tk_Free3DBorder _ANSI_ARGS_((Tk_3DBorder border)); -EXTERN void Tk_FreeBitmap _ANSI_ARGS_((Display *display, - Pixmap bitmap)); -EXTERN void Tk_FreeColor _ANSI_ARGS_((XColor *colorPtr)); -EXTERN void Tk_FreeCursor _ANSI_ARGS_((Display *display, - Cursor cursor)); -EXTERN void Tk_FreeFontStruct _ANSI_ARGS_(( - XFontStruct *fontStructPtr)); -EXTERN void Tk_FreeGC _ANSI_ARGS_((Display *display, GC gc)); -EXTERN void Tk_FreeOptions _ANSI_ARGS_((Tk_ConfigSpec *specs, - char *widgRec, Display *display, int needFlags)); -EXTERN void Tk_GeometryRequest _ANSI_ARGS_((Tk_Window tkwin, - int reqWidth, int reqHeight)); -EXTERN Tk_3DBorder Tk_Get3DBorder _ANSI_ARGS_((Tcl_Interp *interp, - Tk_Window tkwin, Colormap colormap, - Tk_Uid colorName)); -EXTERN void Tk_GetAllBindings _ANSI_ARGS_((Tcl_Interp *interp, - Tk_BindingTable bindingTable, ClientData object)); -EXTERN int Tk_GetAnchor _ANSI_ARGS_((Tcl_Interp *interp, - char *string, Tk_Anchor *anchorPtr)); -EXTERN char * Tk_GetAtomName _ANSI_ARGS_((Tk_Window tkwin, - Atom atom)); -EXTERN char * Tk_GetBinding _ANSI_ARGS_((Tcl_Interp *interp, - Tk_BindingTable bindingTable, ClientData object, - char *eventString)); -EXTERN Pixmap Tk_GetBitmap _ANSI_ARGS_((Tcl_Interp *interp, - Tk_Window tkwin, Tk_Uid string)); -EXTERN Pixmap Tk_GetBitmapFromData _ANSI_ARGS_((Tcl_Interp *interp, - Tk_Window tkwin, char *source, - unsigned int width, unsigned int height)); -EXTERN int Tk_GetCapStyle _ANSI_ARGS_((Tcl_Interp *interp, - char *string, int *capPtr)); -EXTERN XColor * Tk_GetColor _ANSI_ARGS_((Tcl_Interp *interp, - Tk_Window tkwin, Colormap colormap, Tk_Uid name)); -EXTERN XColor * Tk_GetColorByValue _ANSI_ARGS_((Tcl_Interp *interp, - Tk_Window tkwin, Colormap colormap, - XColor *colorPtr)); -EXTERN Tk_ColorModel Tk_GetColorModel _ANSI_ARGS_((Tk_Window tkwin)); -EXTERN Cursor Tk_GetCursor _ANSI_ARGS_((Tcl_Interp *interp, - Tk_Window tkwin, Tk_Uid string)); -EXTERN Cursor Tk_GetCursorFromData _ANSI_ARGS_((Tcl_Interp *interp, - Tk_Window tkwin, char *source, char *mask, - unsigned int width, unsigned int height, - int xHot, int yHot, Tk_Uid fg, Tk_Uid bg)); -EXTERN XFontStruct * Tk_GetFontStruct _ANSI_ARGS_((Tcl_Interp *interp, - Tk_Window tkwin, Tk_Uid name)); -EXTERN GC Tk_GetGC _ANSI_ARGS_((Tk_Window tkwin, - unsigned long valueMask, XGCValues *valuePtr)); -EXTERN int Tk_GetJoinStyle _ANSI_ARGS_((Tcl_Interp *interp, - char *string, int *joinPtr)); -EXTERN int Tk_GetJustify _ANSI_ARGS_((Tcl_Interp *interp, - char *string, Tk_Justify *justifyPtr)); -EXTERN Tk_Uid Tk_GetOption _ANSI_ARGS_((Tk_Window tkwin, char *name, - char *className)); -EXTERN int Tk_GetPixels _ANSI_ARGS_((Tcl_Interp *interp, - Tk_Window tkwin, char *string, int *intPtr)); -EXTERN int Tk_GetRelief _ANSI_ARGS_((Tcl_Interp *interp, - char *name, int *reliefPtr)); -EXTERN void Tk_GetRootCoords _ANSI_ARGS_ ((Tk_Window tkwin, - int *xPtr, int *yPtr)); -EXTERN int Tk_GetScreenMM _ANSI_ARGS_((Tcl_Interp *interp, - Tk_Window tkwin, char *string, double *doublePtr)); -EXTERN int Tk_GetSelection _ANSI_ARGS_((Tcl_Interp *interp, - Tk_Window tkwin, Atom target, Tk_GetSelProc *proc, - ClientData clientData)); -EXTERN Tk_Uid Tk_GetUid _ANSI_ARGS_((char *string)); -EXTERN void Tk_GetVRootGeometry _ANSI_ARGS_((Tk_Window tkwin, - int *xPtr, int *yPtr, unsigned int *widthPtr, - unsigned int *heightPtr)); -EXTERN int Tk_Grab _ANSI_ARGS_((Tcl_Interp *interp, - Tk_Window tkwin, int grabGlobal)); -EXTERN void Tk_HandleEvent _ANSI_ARGS_((XEvent *eventPtr)); -EXTERN int Tk_Init _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN Atom Tk_InternAtom _ANSI_ARGS_((Tk_Window tkwin, - char *name)); -EXTERN void Tk_MainLoop _ANSI_ARGS_((void)); -EXTERN Tk_Window Tk_MainWindow _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN void Tk_MakeWindowExist _ANSI_ARGS_((Tk_Window tkwin)); -EXTERN void Tk_ManageGeometry _ANSI_ARGS_((Tk_Window tkwin, - Tk_GeometryProc *proc, ClientData clientData)); -EXTERN void Tk_MapWindow _ANSI_ARGS_((Tk_Window tkwin)); -EXTERN void Tk_MoveResizeWindow _ANSI_ARGS_((Tk_Window tkwin, - int x, int y, unsigned int width, - unsigned int height)); -EXTERN void Tk_MoveWindow _ANSI_ARGS_((Tk_Window tkwin, int x, - int y)); -EXTERN void Tk_MoveToplevelWindow _ANSI_ARGS_((Tk_Window tkwin, - int x, int y)); -EXTERN char * Tk_NameOf3DBorder _ANSI_ARGS_((Tk_3DBorder border)); -EXTERN char * Tk_NameOfAnchor _ANSI_ARGS_((Tk_Anchor anchor)); -EXTERN char * Tk_NameOfBitmap _ANSI_ARGS_((Display *display, - Pixmap bitmap)); -EXTERN char * Tk_NameOfCapStyle _ANSI_ARGS_((int cap)); -EXTERN char * Tk_NameOfColor _ANSI_ARGS_((XColor *colorPtr)); -EXTERN char * Tk_NameOfCursor _ANSI_ARGS_((Display *display, - Cursor cursor)); -EXTERN char * Tk_NameOfFontStruct _ANSI_ARGS_(( - XFontStruct *fontStructPtr)); -EXTERN char * Tk_NameOfJoinStyle _ANSI_ARGS_((int join)); -EXTERN char * Tk_NameOfJustify _ANSI_ARGS_((Tk_Justify justify)); -EXTERN char * Tk_NameOfRelief _ANSI_ARGS_((int relief)); -EXTERN Tk_Window Tk_NameToWindow _ANSI_ARGS_((Tcl_Interp *interp, - char *pathName, Tk_Window tkwin)); -EXTERN void Tk_OwnSelection _ANSI_ARGS_((Tk_Window tkwin, - Tk_LostSelProc *proc, ClientData clientData)); -EXTERN int Tk_ParseArgv _ANSI_ARGS_((Tcl_Interp *interp, - Tk_Window tkwin, int *argcPtr, char **argv, - Tk_ArgvInfo *argTable, int flags)); -EXTERN void Tk_Preserve _ANSI_ARGS_((ClientData clientData)); -EXTERN int Tk_RegisterInterp _ANSI_ARGS_((Tcl_Interp *interp, - char *name, Tk_Window tkwin)); -EXTERN void Tk_Release _ANSI_ARGS_((ClientData clientData)); -EXTERN void Tk_ResizeWindow _ANSI_ARGS_((Tk_Window tkwin, - unsigned int width, unsigned int height)); -EXTERN int Tk_RestackWindow _ANSI_ARGS_((Tk_Window tkwin, - int aboveBelow, Tk_Window other)); -EXTERN Tk_RestrictProc *Tk_RestrictEvents _ANSI_ARGS_((Tk_RestrictProc *proc, - char *arg, char **prevArgPtr)); -EXTERN void Tk_SetBackgroundFromBorder _ANSI_ARGS_(( - Tk_Window tkwin, Tk_3DBorder border)); -EXTERN void Tk_SetClass _ANSI_ARGS_((Tk_Window tkwin, - char *className)); -EXTERN void Tk_SetColorModel _ANSI_ARGS_((Tk_Window tkwin, - Tk_ColorModel model)); -EXTERN void Tk_SetGrid _ANSI_ARGS_((Tk_Window tkwin, - int reqWidth, int reqHeight, int gridWidth, - int gridHeight)); -EXTERN void Tk_SetInternalBorder _ANSI_ARGS_((Tk_Window tkwin, - int width)); -EXTERN void Tk_SetWindowBackground _ANSI_ARGS_((Tk_Window tkwin, - unsigned long pixel)); -EXTERN void Tk_SetWindowBackgroundPixmap _ANSI_ARGS_(( - Tk_Window tkwin, Pixmap pixmap)); -EXTERN void Tk_SetWindowBorder _ANSI_ARGS_((Tk_Window tkwin, - unsigned long pixel)); -EXTERN void Tk_SetWindowBorderWidth _ANSI_ARGS_((Tk_Window tkwin, - int width)); -EXTERN void Tk_SetWindowBorderPixmap _ANSI_ARGS_((Tk_Window tkwin, - Pixmap pixmap)); -EXTERN void Tk_SetWindowColormap _ANSI_ARGS_((Tk_Window tkwin, - Colormap colormap)); -EXTERN int Tk_SetWindowVisual _ANSI_ARGS_((Tk_Window tkwin, - Visual *visual, unsigned int depth, - Colormap colormap)); -EXTERN void Tk_SizeOfBitmap _ANSI_ARGS_((Display *display, - Pixmap bitmap, unsigned int *widthPtr, - unsigned int *heightPtr)); -EXTERN void Tk_Sleep _ANSI_ARGS_((int ms)); -EXTERN void Tk_UndefineCursor _ANSI_ARGS_((Tk_Window window)); -EXTERN void Tk_Ungrab _ANSI_ARGS_((Tk_Window tkwin)); -EXTERN void Tk_UnmapWindow _ANSI_ARGS_((Tk_Window tkwin)); - - -EXTERN int tk_NumMainWindows; - -/* - * Tcl commands exported by Tk: - */ - -EXTERN int Tk_AfterCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_ApplicationCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_BindCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_ButtonCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_CanvasCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_DestroyCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_EntryCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_ExitCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_FrameCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_FocusCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_GrabCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_ListboxCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_LowerCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_MenuCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_MenubuttonCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_MessageCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_OptionCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_PackCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_PlaceCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_RaiseCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_ScaleCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_ScrollbarCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_SelectionCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_SendCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_TextCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_TkCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_TkwaitCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_UpdateCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_WinfoCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_WmCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); - -#endif /* _TK */ diff --git a/tk3.6/tk3.6p1.patch b/tk3.6/tk3.6p1.patch deleted file mode 100644 index 69055df..0000000 --- a/tk3.6/tk3.6p1.patch +++ /dev/null @@ -1,110 +0,0 @@ -tk3.6p1.patch - - -This patch file updates from Tk 3.6 to Tk 3.6p1. It should be applied -by running the "patch" program in the top-level directory of a clean -Tk 3.6 release, using the command "patch -p < tk3.6p1.patch". - -The patches in this file fix two bugs: -1. Tk versions 3.4-3.6 have a bug that causes a core dump at line - 1467 of file tkTextDisp.c under some esoteric conditions where - a text widget gets redisplayed when it has a -yscrollcommand - but hasn't been mapped onto the screen. The "exmh" program seems - to be particularly adept at causing the problem. -2. The filled area of an oval tends to stick out past the outline in - some cases. - -Prereq: 206 -*** ../tk3.6/patchlevel.h Sun Nov 21 15:25:43 1993 ---- patchlevel.h Thu Dec 23 09:32:33 1993 -*************** -*** 2,11 **** - * patchlevel.h -- - * - * This file does nothing except define a "patch level" for Tk. -! * The patch level is an integer that increments with each new -! * release or patch release. It's used to make sure that Tk -! * patches are applied in the correct order and only to appropriate -! * sources. - */ - -! #define TK_PATCH_LEVEL 206 ---- 2,13 ---- - * patchlevel.h -- - * - * This file does nothing except define a "patch level" for Tk. -! * The patch level has the form "X.YpZ" where X.Y is the base -! * release, and Z is a serial number that is used to sequence -! * patches for a given release. Thus 3.6p1 is the first patch -! * to release 3.6, 3.6p2 is the patch that follows 3.6p1, and -! * so on. The patch level ensures that patches are applied in -! * the correct order and only to appropriate sources. - */ - -! #define TK_PATCH_LEVEL "3.6p1" -*** ../tk3.6/./tkWindow.c Fri Oct 8 11:37:05 1993 ---- ./tkWindow.c Thu Dec 23 09:30:37 1993 -*************** -*** 619,625 **** - register TkWindow *winPtr; - register TkCmd *cmdPtr; - char *libDir; -- char buffer[30]; - static char *argv[] = {"-width", "200", "-height", "200", (char *) NULL}; - - /* ---- 619,624 ---- -*************** -*** 701,708 **** - libDir = TK_LIBRARY; - } - Tcl_SetVar(interp, "tk_library", libDir, TCL_GLOBAL_ONLY); -! sprintf(buffer, "%d", TK_PATCH_LEVEL); -! Tcl_SetVar(interp, "tk_patchLevel", buffer, TCL_GLOBAL_ONLY); - Tcl_SetVar(interp, "tk_version", TK_VERSION, TCL_GLOBAL_ONLY); - Tcl_SetVar(interp, "tkVersion", TK_VERSION, TCL_GLOBAL_ONLY); - ---- 700,706 ---- - libDir = TK_LIBRARY; - } - Tcl_SetVar(interp, "tk_library", libDir, TCL_GLOBAL_ONLY); -! Tcl_SetVar(interp, "tk_patchLevel", TK_PATCH_LEVEL, TCL_GLOBAL_ONLY); - Tcl_SetVar(interp, "tk_version", TK_VERSION, TCL_GLOBAL_ONLY); - Tcl_SetVar(interp, "tkVersion", TK_VERSION, TCL_GLOBAL_ONLY); - -*** ../tk3.6/./tkRectOval.c Sat Oct 23 14:59:45 1993 ---- ./tkRectOval.c Thu Dec 23 08:56:28 1993 -*************** -*** 534,543 **** - if (rectOvalPtr->outlineGC != None) { - if (rectOvalPtr->header.typePtr == &TkRectangleType) { - XDrawRectangle(display, drawable, rectOvalPtr->outlineGC, -! x1, y1, (x2-x1-1), (y2-y1-1)); - } else { - XDrawArc(display, drawable, rectOvalPtr->outlineGC, -! x1, y1, (x2-x1-1), (y2-y1-1), 0, 360*64); - } - } - } ---- 534,543 ---- - if (rectOvalPtr->outlineGC != None) { - if (rectOvalPtr->header.typePtr == &TkRectangleType) { - XDrawRectangle(display, drawable, rectOvalPtr->outlineGC, -! x1, y1, (x2-x1), (y2-y1)); - } else { - XDrawArc(display, drawable, rectOvalPtr->outlineGC, -! x1, y1, (x2-x1), (y2-y1), 0, 360*64); - } - } - } -*** ../tk3.6/./tkTextDisp.c Mon Nov 1 15:06:04 1993 ---- ./tkTextDisp.c Thu Dec 23 08:56:04 1993 -*************** -*** 1217,1222 **** ---- 1217,1223 ---- - if ((textPtr->tkwin == NULL) || !Tk_IsMapped(textPtr->tkwin) - || (dInfoPtr->maxX <= dInfoPtr->x) - || (dInfoPtr->maxY <= dInfoPtr->y)) { -+ UpdateDisplayInfo(textPtr); - goto doScrollbars; - } - numRedisplays++; diff --git a/tk3.6/tkBind.c b/tk3.6/tkBind.c deleted file mode 100644 index 6a42d65..0000000 --- a/tk3.6/tkBind.c +++ /dev/null @@ -1,2393 +0,0 @@ -/* - * tkBind.c -- - * - * This file provides procedures that associate Tcl commands - * with X events or sequences of X events. - * - * 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 - * 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/wish/RCS/tkBind.c,v 1.67 93/09/30 08:37:31 ouster Exp $ SPRITE (Berkeley)"; -#endif /* not lint */ - -#include "tkConfig.h" -#include "tkInt.h" - -/* - * The structure below represents a binding table. A binding table - * represents a domain in which event bindings may occur. It includes - * a space of objects relative to which events occur (usually windows, - * but not always), a history of recent events in the domain, and - * a set of mappings that associate particular Tcl commands with sequences - * of events in the domain. Multiple binding tables may exist at once, - * either because there are multiple applications open, or because there - * are multiple domains within an application with separate event - * bindings for each (for example, each canvas widget has a separate - * binding table for associating events with the items in the canvas). - */ - -#define EVENT_BUFFER_SIZE 20 -typedef struct BindingTable { - XEvent eventRing[EVENT_BUFFER_SIZE];/* Circular queue of recent events - * (higher indices are for more recent - * events). */ - int detailRing[EVENT_BUFFER_SIZE]; /* "Detail" information (keySym or - * button or 0) for each entry in - * eventRing. */ - int curEvent; /* Index in eventRing of most recent - * event. Newer events have higher - * indices. */ - Tcl_HashTable patternTable; /* Used to map from an event to a list - * of patterns that may match that - * event. Keys are PatternTableKey - * structs, values are (PatSeq *). */ - Tcl_HashTable objectTable; /* Used to map from an object to a list - * of patterns associated with that - * object. Keys are ClientData, - * values are (PatSeq *). */ - Tcl_Interp *interp; /* Interpreter in which commands are - * executed. */ -} BindingTable; - -/* - * Structures of the following form are used as keys in the patternTable - * for a binding table: - */ - -typedef struct PatternTableKey { - ClientData object; /* Identifies object (or class of objects) - * relative to which event occurred. For - * example, in the widget binding table for - * an application this is the path name of - * a widget, or a widget class, or "all". */ - int type; /* Type of event (from X). */ - int detail; /* Additional information, such as - * keysym or button, or 0 if nothing - * additional.*/ -} PatternTableKey; - -/* - * The following structure defines a pattern, which is matched - * against X events as part of the process of converting X events - * into Tcl commands. - */ - -typedef struct Pattern { - int eventType; /* Type of X event, e.g. ButtonPress. */ - int needMods; /* Mask of modifiers that must be - * present (0 means no modifiers are - * required). */ - int hateMods; /* Mask of modifiers that must not be - * present (0 means any modifiers are - * OK). */ - int detail; /* Additional information that must - * match event. Normally this is 0, - * meaning no additional information - * must match. For KeyPress and - * KeyRelease events, a keySym may - * be specified to select a - * particular keystroke (0 means any - * keystrokes). For button events, - * specifies a particular button (0 - * means any buttons are OK). */ -} Pattern; - -/* - * The structure below defines a pattern sequence, which consists - * of one or more patterns. In order to trigger, a pattern - * sequence must match the most recent X events (first pattern - * to most recent event, next pattern to next event, and so on). - */ - -typedef struct PatSeq { - int numPats; /* Number of patterns in sequence - * (usually 1). */ - char *command; /* Command to invoke when this - * pattern sequence matches (malloc-ed). */ - int flags; /* Miscellaneous flag values; see - * below for definitions. */ - struct PatSeq *nextSeqPtr; - /* Next in list of all pattern - * sequences that have the same - * initial pattern. NULL means - * end of list. */ - Tcl_HashEntry *hPtr; /* Pointer to hash table entry for - * the initial pattern. This is the - * head of the list of which nextSeqPtr - * forms a part. */ - ClientData object; /* Identifies object with which event is - * associated (e.g. window). */ - struct PatSeq *nextObjPtr; - /* Next in list of all pattern - * sequences for the same object - * (NULL for end of list). Needed to - * implement Tk_DeleteAllBindings. */ - Pattern pats[1]; /* Array of "numPats" patterns. Only - * one element is declared here but - * in actuality enough space will be - * allocated for "numPats" patterns. - * To match, pats[0] must match event - * n, pats[1] must match event n-1, - * etc. */ -} PatSeq; - -/* - * Flag values for PatSeq structures: - * - * PAT_NEARBY 1 means that all of the events matching - * this sequence must occur with nearby X - * and Y mouse coordinates and close in time. - * This is typically used to restrict multiple - * button presses. - * PAT_PERCENTS 1 means that the command for this pattern - * requires percent substitution. 0 means there - * are no percents in the command. - */ - -#define PAT_NEARBY 1 -#define PAT_PERCENTS 2 - -/* - * Constants that define how close together two events must be - * in milliseconds or pixels to meet the PAT_NEARBY constraint: - */ - -#define NEARBY_PIXELS 5 -#define NEARBY_MS 500 - -/* - * The data structure and hash table below are used to map from - * textual keysym names to keysym numbers. This structure is - * present here because the corresponding X procedures are - * ridiculously slow. - */ - -typedef struct { - char *name; /* Name of keysym. */ - KeySym value; /* Numeric identifier for keysym. */ -} KeySymInfo; -KeySymInfo keyArray[] = { -#ifndef lint -#include "ks_names.h" -#endif - {(char *) NULL, 0} -}; -static Tcl_HashTable keySymTable; /* Hashed form of above structure. */ - -static int initialized = 0; - -/* - * A hash table is kept to map from the string names of event - * modifiers to information about those modifiers. The structure - * for storing this information, and the hash table built at - * initialization time, are defined below. - */ - -typedef struct { - char *name; /* Name of modifier. */ - int mask; /* Button/modifier mask value, * such as Button1Mask. */ - int flags; /* Various flags; see below for - * definitions. */ -} ModInfo; - -/* - * Flags for ModInfo structures: - * - * DOUBLE - Non-zero means duplicate this event, - * e.g. for double-clicks. - * TRIPLE - Non-zero means triplicate this event, - * e.g. for triple-clicks. - * ANY - Non-zero means that this event allows - * any unspecified modifiers. - */ - -#define DOUBLE 1 -#define TRIPLE 2 -#define ANY 4 - -static ModInfo modArray[] = { - {"Control", ControlMask, 0}, - {"Shift", ShiftMask, 0}, - {"Lock", LockMask, 0}, - {"B1", Button1Mask, 0}, - {"Button1", Button1Mask, 0}, - {"B2", Button2Mask, 0}, - {"Button2", Button2Mask, 0}, - {"B3", Button3Mask, 0}, - {"Button3", Button3Mask, 0}, - {"B4", Button4Mask, 0}, - {"Button4", Button4Mask, 0}, - {"B5", Button5Mask, 0}, - {"Button5", Button5Mask, 0}, - {"Mod1", Mod1Mask, 0}, - {"M1", Mod1Mask, 0}, - {"Meta", Mod1Mask, 0}, - {"M", Mod1Mask, 0}, - {"Mod2", Mod2Mask, 0}, - {"M2", Mod2Mask, 0}, - {"Alt", Mod2Mask, 0}, - {"Mod3", Mod3Mask, 0}, - {"M3", Mod3Mask, 0}, - {"Mod4", Mod4Mask, 0}, - {"M4", Mod4Mask, 0}, - {"Mod5", Mod5Mask, 0}, - {"M5", Mod5Mask, 0}, - {"Double", 0, DOUBLE}, - {"Triple", 0, TRIPLE}, - {"Any", 0, ANY}, - {NULL, 0, 0} -}; -static Tcl_HashTable modTable; - -/* - * This module also keeps a hash table mapping from event names - * to information about those events. The structure, an array - * to use to initialize the hash table, and the hash table are - * all defined below. - */ - -typedef struct { - char *name; /* Name of event. */ - int type; /* Event type for X, such as - * ButtonPress. */ - int eventMask; /* Mask bits (for XSelectInput) - * for this event type. */ -} EventInfo; - -/* - * Note: some of the masks below are an OR-ed combination of - * several masks. This is necessary because X doesn't report - * up events unless you also ask for down events. Also, X - * doesn't report button state in motion events unless you've - * asked about button events. - */ - -static EventInfo eventArray[] = { - {"Motion", MotionNotify, - ButtonPressMask|PointerMotionMask}, - {"Button", ButtonPress, ButtonPressMask}, - {"ButtonPress", ButtonPress, ButtonPressMask}, - {"ButtonRelease", ButtonRelease, - ButtonPressMask|ButtonReleaseMask}, - {"Colormap", ColormapNotify, ColormapChangeMask}, - {"Enter", EnterNotify, EnterWindowMask}, - {"Leave", LeaveNotify, LeaveWindowMask}, - {"Expose", Expose, ExposureMask}, - {"FocusIn", FocusIn, FocusChangeMask}, - {"FocusOut", FocusOut, FocusChangeMask}, - {"Keymap", KeymapNotify, KeymapStateMask}, - {"Key", KeyPress, KeyPressMask}, - {"KeyPress", KeyPress, KeyPressMask}, - {"KeyRelease", KeyRelease, - KeyPressMask|KeyReleaseMask}, - {"Property", PropertyNotify, PropertyChangeMask}, - {"ResizeRequest", ResizeRequest, ResizeRedirectMask}, - {"Circulate", CirculateNotify, StructureNotifyMask}, - {"Configure", ConfigureNotify, StructureNotifyMask}, - {"Destroy", DestroyNotify, StructureNotifyMask}, - {"Gravity", GravityNotify, StructureNotifyMask}, - {"Map", MapNotify, StructureNotifyMask}, - {"Reparent", ReparentNotify, StructureNotifyMask}, - {"Unmap", UnmapNotify, StructureNotifyMask}, - {"Visibility", VisibilityNotify, VisibilityChangeMask}, - {"CirculateRequest",CirculateRequest, SubstructureRedirectMask}, - {"ConfigureRequest",ConfigureRequest, SubstructureRedirectMask}, - {"MapRequest", MapRequest, SubstructureRedirectMask}, - {(char *) NULL, 0, 0} -}; -static Tcl_HashTable eventTable; - -/* - * The defines and table below are used to classify events into - * various groups. The reason for this is that logically identical - * fields (e.g. "state") appear at different places in different - * types of events. The classification masks can be used to figure - * out quickly where to extract information from events. - */ - -#define KEY_BUTTON_MOTION 0x1 -#define CROSSING 0x2 -#define FOCUS 0x4 -#define EXPOSE 0x8 -#define VISIBILITY 0x10 -#define CREATE 0x20 -#define MAP 0x40 -#define REPARENT 0x80 -#define CONFIG 0x100 -#define CONFIG_REQ 0x200 -#define RESIZE_REQ 0x400 -#define GRAVITY 0x800 -#define PROP 0x1000 -#define SEL_CLEAR 0x2000 -#define SEL_REQ 0x4000 -#define SEL_NOTIFY 0x8000 -#define COLORMAP 0x10000 -#define MAPPING 0x20000 - -static int flagArray[LASTEvent] = { - /* Not used */ 0, - /* Not used */ 0, - /* KeyPress */ KEY_BUTTON_MOTION, - /* KeyRelease */ KEY_BUTTON_MOTION, - /* ButtonPress */ KEY_BUTTON_MOTION, - /* ButtonRelease */ KEY_BUTTON_MOTION, - /* MotionNotify */ KEY_BUTTON_MOTION, - /* EnterNotify */ CROSSING, - /* LeaveNotify */ CROSSING, - /* FocusIn */ FOCUS, - /* FocusOut */ FOCUS, - /* KeymapNotify */ 0, - /* Expose */ EXPOSE, - /* GraphicsExpose */ EXPOSE, - /* NoExpose */ 0, - /* VisibilityNotify */ VISIBILITY, - /* CreateNotify */ CREATE, - /* DestroyNotify */ 0, - /* UnmapNotify */ 0, - /* MapNotify */ MAP, - /* MapRequest */ 0, - /* ReparentNotify */ REPARENT, - /* ConfigureNotify */ CONFIG, - /* ConfigureRequest */ CONFIG_REQ, - /* GravityNotify */ 0, - /* ResizeRequest */ RESIZE_REQ, - /* CirculateNotify */ 0, - /* CirculateRequest */ 0, - /* PropertyNotify */ PROP, - /* SelectionClear */ SEL_CLEAR, - /* SelectionRequest */ SEL_REQ, - /* SelectionNotify */ SEL_NOTIFY, - /* ColormapNotify */ COLORMAP, - /* ClientMessage */ 0, - /* MappingNotify */ MAPPING -}; - -/* - * Forward declarations for procedures defined later in this - * file: - */ - -static char * ExpandPercents _ANSI_ARGS_((char *before, - XEvent *eventPtr, KeySym keySym, char *after, - int afterSize)); -static PatSeq * FindSequence _ANSI_ARGS_((Tcl_Interp *interp, - BindingTable *bindPtr, ClientData object, - char *eventString, int create, - unsigned long *maskPtr)); -static char * GetField _ANSI_ARGS_((char *p, char *copy, int size)); -static KeySym GetKeySym _ANSI_ARGS_((TkDisplay *dispPtr, - XEvent *eventPtr)); -static void InitKeymapInfo _ANSI_ARGS_((TkDisplay *dispPtr)); -static PatSeq * MatchPatterns _ANSI_ARGS_((TkDisplay *dispPtr, - BindingTable *bindPtr, PatSeq *psPtr)); - -/* - *-------------------------------------------------------------- - * - * Tk_CreateBindingTable -- - * - * Set up a new domain in which event bindings may be created. - * - * Results: - * The return value is a token for the new table, which must - * be passed to procedures like Tk_CreatBinding. - * - * Side effects: - * Memory is allocated for the new table. - * - *-------------------------------------------------------------- - */ - -Tk_BindingTable -Tk_CreateBindingTable(interp) - Tcl_Interp *interp; /* Interpreter to associate with the binding - * table: commands are executed in this - * interpreter. */ -{ - register BindingTable *bindPtr; - int i; - - /* - * If this is the first time a binding table has been created, - * initialize the global data structures. - */ - - if (!initialized) { - register KeySymInfo *kPtr; - register Tcl_HashEntry *hPtr; - register ModInfo *modPtr; - register EventInfo *eiPtr; - int dummy; - - initialized = 1; - - Tcl_InitHashTable(&keySymTable, TCL_STRING_KEYS); - for (kPtr = keyArray; kPtr->name != NULL; kPtr++) { - hPtr = Tcl_CreateHashEntry(&keySymTable, kPtr->name, &dummy); - Tcl_SetHashValue(hPtr, kPtr->value); - } - - Tcl_InitHashTable(&modTable, TCL_STRING_KEYS); - for (modPtr = modArray; modPtr->name != NULL; modPtr++) { - hPtr = Tcl_CreateHashEntry(&modTable, modPtr->name, &dummy); - Tcl_SetHashValue(hPtr, modPtr); - } - - Tcl_InitHashTable(&eventTable, TCL_STRING_KEYS); - for (eiPtr = eventArray; eiPtr->name != NULL; eiPtr++) { - hPtr = Tcl_CreateHashEntry(&eventTable, eiPtr->name, &dummy); - Tcl_SetHashValue(hPtr, eiPtr); - } - } - - /* - * Create and initialize a new binding table. - */ - - bindPtr = (BindingTable *) ckalloc(sizeof(BindingTable)); - for (i = 0; i < EVENT_BUFFER_SIZE; i++) { - bindPtr->eventRing[i].type = -1; - } - bindPtr->curEvent = 0; - Tcl_InitHashTable(&bindPtr->patternTable, - sizeof(PatternTableKey)/sizeof(int)); - Tcl_InitHashTable(&bindPtr->objectTable, TCL_ONE_WORD_KEYS); - bindPtr->interp = interp; - return (Tk_BindingTable) bindPtr; -} - -/* - *-------------------------------------------------------------- - * - * Tk_DeleteBindingTable -- - * - * Destroy a binding table and free up all its memory. - * The caller should not use bindingTable again after - * this procedure returns. - * - * Results: - * None. - * - * Side effects: - * Memory is freed. - * - *-------------------------------------------------------------- - */ - -void -Tk_DeleteBindingTable(bindingTable) - Tk_BindingTable bindingTable; /* Token for the binding table to - * destroy. */ -{ - BindingTable *bindPtr = (BindingTable *) bindingTable; - PatSeq *psPtr, *nextPtr; - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; - - /* - * Find and delete all of the patterns associated with the binding - * table. - */ - - for (hPtr = Tcl_FirstHashEntry(&bindPtr->patternTable, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - for (psPtr = (PatSeq *) Tcl_GetHashValue(hPtr); - psPtr != NULL; psPtr = nextPtr) { - nextPtr = psPtr->nextSeqPtr; - ckfree((char *) psPtr->command); - ckfree((char *) psPtr); - } - } - - /* - * Clean up the rest of the information associated with the - * binding table. - */ - - Tcl_DeleteHashTable(&bindPtr->patternTable); - Tcl_DeleteHashTable(&bindPtr->objectTable); - ckfree((char *) bindPtr); -} - -/* - *-------------------------------------------------------------- - * - * Tk_CreateBinding -- - * - * Add a binding to a binding table, so that future calls to - * Tk_BindEvent may execute the command in the binding. - * - * Results: - * The return value is 0 if an error occurred while setting - * up the binding. In this case, an error message will be - * left in interp->result. If all went well then the return - * value is a mask of the event types that must be made - * available to Tk_BindEvent in order to properly detect when - * this binding triggers. This value can be used to determine - * what events to select for in a window, for example. - * - * Side effects: - * The new binding may cause future calls to Tk_BindEvent to - * behave differently than they did previously. - * - *-------------------------------------------------------------- - */ - -unsigned long -Tk_CreateBinding(interp, bindingTable, object, eventString, command, append) - Tcl_Interp *interp; /* Used for error reporting. */ - Tk_BindingTable bindingTable; /* Table in which to create binding. */ - ClientData object; /* Token for object with which binding - * is associated. */ - char *eventString; /* String describing event sequence - * that triggers binding. */ - char *command; /* Contains Tcl command to execute - * when binding triggers. */ - int append; /* 0 means replace any existing - * binding for eventString; 1 means - * append to that binding. */ -{ - BindingTable *bindPtr = (BindingTable *) bindingTable; - register PatSeq *psPtr; - unsigned long eventMask; - - psPtr = FindSequence(interp, bindPtr, object, eventString, 1, &eventMask); - if (psPtr == NULL) { - return 0; - } - if (append && (psPtr->command != NULL)) { - int length; - char *new; - - length = strlen(psPtr->command) + strlen(command) + 3; - new = (char *) ckalloc((unsigned) length); - sprintf(new, "%s; %s", psPtr->command, command); - ckfree((char *) psPtr->command); - psPtr->command = new; - } else { - if (psPtr->command != NULL) { - ckfree((char *) psPtr->command); - } - psPtr->command = (char *) ckalloc((unsigned) (strlen(command) + 1)); - strcpy(psPtr->command, command); - } - - /* - * See if the command contains percents and thereby requires - * percent substitution. - */ - - if (strchr(psPtr->command, '%') != NULL) { - psPtr->flags |= PAT_PERCENTS; - } - return eventMask; -} - -/* - *-------------------------------------------------------------- - * - * Tk_DeleteBinding -- - * - * Remove an event binding from a binding table. - * - * Results: - * The result is a standard Tcl return value. If an error - * occurs then interp->result will contain an error message. - * - * Side effects: - * The binding given by object and eventString is removed - * from bindingTable. - * - *-------------------------------------------------------------- - */ - -int -Tk_DeleteBinding(interp, bindingTable, object, eventString) - Tcl_Interp *interp; /* Used for error reporting. */ - Tk_BindingTable bindingTable; /* Table in which to delete binding. */ - ClientData object; /* Token for object with which binding - * is associated. */ - char *eventString; /* String describing event sequence - * that triggers binding. */ -{ - BindingTable *bindPtr = (BindingTable *) bindingTable; - register PatSeq *psPtr, *prevPtr; - unsigned long eventMask; - Tcl_HashEntry *hPtr; - - psPtr = FindSequence(interp, bindPtr, object, eventString, 0, &eventMask); - if (psPtr == NULL) { - Tcl_ResetResult(interp); - return TCL_OK; - } - - /* - * Unlink the binding from the list for its object, then from the - * list for its pattern. - */ - - hPtr = Tcl_FindHashEntry(&bindPtr->objectTable, (char *) object); - if (hPtr == NULL) { - panic("Tk_DeleteBinding couldn't find object table entry"); - } - prevPtr = (PatSeq *) Tcl_GetHashValue(hPtr); - if (prevPtr == psPtr) { - Tcl_SetHashValue(hPtr, psPtr->nextObjPtr); - } else { - for ( ; ; prevPtr = prevPtr->nextObjPtr) { - if (prevPtr == NULL) { - panic("Tk_DeleteBinding couldn't find on object list"); - } - if (prevPtr->nextObjPtr == psPtr) { - prevPtr->nextObjPtr = psPtr->nextObjPtr; - break; - } - } - } - prevPtr = (PatSeq *) Tcl_GetHashValue(psPtr->hPtr); - if (prevPtr == psPtr) { - if (psPtr->nextSeqPtr == NULL) { - Tcl_DeleteHashEntry(psPtr->hPtr); - } else { - Tcl_SetHashValue(psPtr->hPtr, psPtr->nextSeqPtr); - } - } else { - for ( ; ; prevPtr = prevPtr->nextSeqPtr) { - if (prevPtr == NULL) { - panic("Tk_DeleteBinding couldn't find on hash chain"); - } - if (prevPtr->nextSeqPtr == psPtr) { - prevPtr->nextSeqPtr = psPtr->nextSeqPtr; - break; - } - } - } - ckfree((char *) psPtr->command); - ckfree((char *) psPtr); - return TCL_OK; -} - -/* - *-------------------------------------------------------------- - * - * Tk_GetBinding -- - * - * Return the command associated with a given event string. - * - * Results: - * The return value is a pointer to the command string - * associated with eventString for object in the domain - * given by bindingTable. If there is no binding for - * eventString, or if eventString is improperly formed, - * then NULL is returned and an error message is left in - * interp->result. The return value is semi-static: it - * will persist until the binding is changed or deleted. - * - * Side effects: - * None. - * - *-------------------------------------------------------------- - */ - -char * -Tk_GetBinding(interp, bindingTable, object, eventString) - Tcl_Interp *interp; /* Interpreter for error reporting. */ - Tk_BindingTable bindingTable; /* Table in which to look for - * binding. */ - ClientData object; /* Token for object with which binding - * is associated. */ - char *eventString; /* String describing event sequence - * that triggers binding. */ -{ - BindingTable *bindPtr = (BindingTable *) bindingTable; - register PatSeq *psPtr; - unsigned long eventMask; - - psPtr = FindSequence(interp, bindPtr, object, eventString, 0, &eventMask); - if (psPtr == NULL) { - return NULL; - } - return psPtr->command; -} - -/* - *-------------------------------------------------------------- - * - * Tk_GetAllBindings -- - * - * Return a list of event strings for all the bindings - * associated with a given object. - * - * Results: - * There is no return value. Interp->result is modified to - * hold a Tcl list with one entry for each binding associated - * with object in bindingTable. Each entry in the list - * contains the event string associated with one binding. - * - * Side effects: - * None. - * - *-------------------------------------------------------------- - */ - -void -Tk_GetAllBindings(interp, bindingTable, object) - Tcl_Interp *interp; /* Interpreter for error reporting. */ - Tk_BindingTable bindingTable; /* Table in which to look for - * bindings. */ - ClientData object; /* Token for object. */ - -{ - BindingTable *bindPtr = (BindingTable *) bindingTable; - register PatSeq *psPtr; - register Pattern *patPtr; - Tcl_HashEntry *hPtr; - char string[200*EVENT_BUFFER_SIZE]; - register char *p; - int patsLeft, needMods; - register ModInfo *modPtr; - register EventInfo *eiPtr; - - hPtr = Tcl_FindHashEntry(&bindPtr->objectTable, (char *) object); - if (hPtr == NULL) { - return; - } - for (psPtr = (PatSeq *) Tcl_GetHashValue(hPtr); psPtr != NULL; - psPtr = psPtr->nextObjPtr) { - - p = string; - - /* - * For each binding, output information about each of the - * patterns in its sequence. The order of the patterns in - * the sequence is backwards from the order in which they - * must be output. - */ - - for (patsLeft = psPtr->numPats, - patPtr = &psPtr->pats[psPtr->numPats - 1]; - patsLeft > 0; patsLeft--, patPtr--) { - - /* - * Check for simple case of an ASCII character. - */ - - if ((patPtr->eventType == KeyPress) - && (patPtr->needMods == 0) - && (patPtr->hateMods == ~LockMask) - && (patPtr->detail < 128) - && isprint(UCHAR(patPtr->detail)) - && (patPtr->detail != '<') - && (patPtr->detail != ' ')) { - - *p = patPtr->detail; - p++; - continue; - } - - /* - * It's a more general event specification. First check - * for "Double" or "Triple", then "Any", then modifiers, - * the event type, then keysym or button detail. - */ - - *p = '<'; - p++; - if ((patsLeft > 1) && (memcmp((char *) patPtr, - (char *) (patPtr-1), sizeof(Pattern)) == 0)) { - patsLeft--; - patPtr--; - if ((patsLeft > 1) && (memcmp((char *) patPtr, - (char *) (patPtr-1), sizeof(Pattern)) == 0)) { - patsLeft--; - patPtr--; - strcpy(p, "Triple-"); - } else { - strcpy(p, "Double-"); - } - p += strlen(p); - } - - if (patPtr->hateMods == 0) { - strcpy(p, "Any-"); - p += strlen(p); - } - - for (needMods = patPtr->needMods, modPtr = modArray; - needMods != 0; modPtr++) { - if (modPtr->mask & needMods) { - needMods &= ~modPtr->mask; - strcpy(p, modPtr->name); - p += strlen(p); - *p = '-'; - p++; - } - } - - for (eiPtr = eventArray; eiPtr->name != NULL; eiPtr++) { - if (eiPtr->type == patPtr->eventType) { - strcpy(p, eiPtr->name); - p += strlen(p); - if (patPtr->detail != 0) { - *p = '-'; - p++; - } - break; - } - } - - if (patPtr->detail != 0) { - if ((patPtr->eventType == KeyPress) - || (patPtr->eventType == KeyRelease)) { - register KeySymInfo *kPtr; - - for (kPtr = keyArray; kPtr->name != NULL; kPtr++) { - if (patPtr->detail == (int) kPtr->value) { - sprintf(p, "%.100s", kPtr->name); - p += strlen(p); - break; - } - } - } else { - sprintf(p, "%d", patPtr->detail); - p += strlen(p); - } - } - *p = '>'; - p++; - } - *p = 0; - if ((p - string) >= sizeof(string)) { - panic("Tk_GetAllBindings overflowed buffer"); - } - Tcl_AppendElement(interp, string); - } -} - -/* - *-------------------------------------------------------------- - * - * Tk_DeleteAllBindings -- - * - * Remove all bindings associated with a given object in a - * given binding table. - * - * Results: - * All bindings associated with object are removed from - * bindingTable. - * - * Side effects: - * None. - * - *-------------------------------------------------------------- - */ - -void -Tk_DeleteAllBindings(bindingTable, object) - Tk_BindingTable bindingTable; /* Table in which to delete - * bindings. */ - ClientData object; /* Token for object. */ -{ - BindingTable *bindPtr = (BindingTable *) bindingTable; - register PatSeq *psPtr, *prevPtr; - PatSeq *nextPtr; - Tcl_HashEntry *hPtr; - - hPtr = Tcl_FindHashEntry(&bindPtr->objectTable, (char *) object); - if (hPtr == NULL) { - return; - } - for (psPtr = (PatSeq *) Tcl_GetHashValue(hPtr); psPtr != NULL; - psPtr = nextPtr) { - nextPtr = psPtr->nextObjPtr; - - /* - * Be sure to remove each binding from its hash chain in the - * pattern table. If this is the last pattern in the chain, - * then delete the hash entry too. - */ - - prevPtr = (PatSeq *) Tcl_GetHashValue(psPtr->hPtr); - if (prevPtr == psPtr) { - if (psPtr->nextSeqPtr == NULL) { - Tcl_DeleteHashEntry(psPtr->hPtr); - } else { - Tcl_SetHashValue(psPtr->hPtr, psPtr->nextSeqPtr); - } - } else { - for ( ; ; prevPtr = prevPtr->nextSeqPtr) { - if (prevPtr == NULL) { - panic("Tk_DeleteAllBindings couldn't find on hash chain"); - } - if (prevPtr->nextSeqPtr == psPtr) { - prevPtr->nextSeqPtr = psPtr->nextSeqPtr; - break; - } - } - } - ckfree((char *) psPtr->command); - ckfree((char *) psPtr); - } - Tcl_DeleteHashEntry(hPtr); -} - -/* - *-------------------------------------------------------------- - * - * Tk_BindEvent -- - * - * This procedure is invoked to process an X event. The - * event is added to those recorded for the binding table. - * Then each of the objects at *objectPtr is checked in - * order to see if it has a binding that matches the recent - * events. If so, that binding is invoked and the rest of - * objects are skipped. - * - * Results: - * None. - * - * Side effects: - * Depends on the command associated with the matching - * binding. - * - *-------------------------------------------------------------- - */ - -void -Tk_BindEvent(bindingTable, eventPtr, tkwin, numObjects, objectPtr) - Tk_BindingTable bindingTable; /* Table in which to look for - * bindings. */ - XEvent *eventPtr; /* What actually happened. */ - Tk_Window tkwin; /* Window on display where event - * occurred (needed in order to - * locate display information). */ - int numObjects; /* Number of objects at *objectPtr. */ - ClientData *objectPtr; /* Array of one or more objects - * to check for a matching binding. */ -{ - BindingTable *bindPtr = (BindingTable *) bindingTable; - TkDisplay *dispPtr = ((TkWindow *) tkwin)->dispPtr; - XEvent *ringPtr; - PatSeq *matchPtr; - PatternTableKey key; - Tcl_HashEntry *hPtr; - int detail; - - /* - * Add the new event to the ring of saved events for the - * binding table. Consecutive MotionNotify events get combined: - * if both the new event and the previous event are MotionNotify, - * then put the new event *on top* of the previous event. - */ - - if ((eventPtr->type != MotionNotify) - || (bindPtr->eventRing[bindPtr->curEvent].type != MotionNotify)) { - bindPtr->curEvent++; - if (bindPtr->curEvent >= EVENT_BUFFER_SIZE) { - bindPtr->curEvent = 0; - } - } - ringPtr = &bindPtr->eventRing[bindPtr->curEvent]; - memcpy((VOID *) ringPtr, (VOID *) eventPtr, sizeof(XEvent)); - detail = 0; - bindPtr->detailRing[bindPtr->curEvent] = 0; - if ((ringPtr->type == KeyPress) || (ringPtr->type == KeyRelease)) { - detail = (int) GetKeySym(dispPtr, ringPtr); - if (detail == NoSymbol) { - detail = 0; - } - } else if ((ringPtr->type == ButtonPress) - || (ringPtr->type == ButtonRelease)) { - detail = ringPtr->xbutton.button; - } - bindPtr->detailRing[bindPtr->curEvent] = detail; - - /* - * Loop over all the objects, matching the new event against - * each in turn. - */ - - for ( ; numObjects > 0; numObjects--, objectPtr++) { - - /* - * Match the new event against those recorded in the - * pattern table, saving the longest matching pattern. - * For events with details (button and key events) first - * look for a binding for the specific key or button. - * If none is found, then look for a binding for all - * keys or buttons (detail of 0). - */ - - matchPtr = NULL; - key.object = *objectPtr; - key.type = ringPtr->type; - key.detail = detail; - hPtr = Tcl_FindHashEntry(&bindPtr->patternTable, (char *) &key); - if (hPtr != NULL) { - matchPtr = MatchPatterns(dispPtr, bindPtr, - (PatSeq *) Tcl_GetHashValue(hPtr)); - } - if ((detail != 0) && (matchPtr == NULL)) { - key.detail = 0; - hPtr = Tcl_FindHashEntry(&bindPtr->patternTable, (char *) &key); - if (hPtr != NULL) { - matchPtr = MatchPatterns(dispPtr, bindPtr, - (PatSeq *) Tcl_GetHashValue(hPtr)); - } - } - - if (matchPtr != NULL) { - - /* - * %-substitution can increase the length of the command. - * This code handles three cases: (a) no substitution; - * (b) substitution results in short command (use space - * on stack); and (c) substitution results in long - * command (malloc it). - */ - -#define STATIC_SPACE 200 - char shortSpace[STATIC_SPACE]; - int result; - - if (matchPtr->flags & PAT_PERCENTS) { - char *p; - - p = ExpandPercents(matchPtr->command, eventPtr, - (KeySym) detail, shortSpace, STATIC_SPACE); - result = Tcl_GlobalEval(bindPtr->interp, p); - if (p != shortSpace) { - ckfree(p); - } - } else { - result = TkCopyAndGlobalEval(bindPtr->interp, - matchPtr->command); - } - if (result != TCL_OK) { - Tcl_AddErrorInfo(bindPtr->interp, - "\n (command bound to event)"); - Tk_BackgroundError(bindPtr->interp); - } - return; - } - } -} - -/* - *---------------------------------------------------------------------- - * - * FindSequence -- - * - * Find the entry in a binding table that corresponds to a - * particular pattern string, and return a pointer to that - * entry. - * - * Results: - * The return value is normally a pointer to the PatSeq - * in patternTable that corresponds to eventString. If an error - * was found while parsing eventString, or if "create" is 0 and - * no pattern sequence previously existed, then NULL is returned - * and interp->result contains a message describing the problem. - * If no pattern sequence previously existed for eventString, then - * a new one is created with a NULL command field. In a successful - * return, *maskPtr is filled in with a mask of the event types - * on which the pattern sequence depends. - * - * Side effects: - * A new pattern sequence may be created. - * - *---------------------------------------------------------------------- - */ - -static PatSeq * -FindSequence(interp, bindPtr, object, eventString, create, maskPtr) - Tcl_Interp *interp; /* Interpreter to use for error - * reporting. */ - BindingTable *bindPtr; /* Table to use for lookup. */ - ClientData object; /* Token for object(s) with which binding - * is associated. */ - char *eventString; /* String description of pattern to - * match on. See user documentation - * for details. */ - int create; /* 0 means don't create the entry if - * it doesn't already exist. Non-zero - * means create. */ - unsigned long *maskPtr; /* *maskPtr is filled in with the event - * types on which this pattern sequence - * depends. */ - -{ - Pattern pats[EVENT_BUFFER_SIZE]; - int numPats; - register char *p; - register Pattern *patPtr; - register PatSeq *psPtr; - register Tcl_HashEntry *hPtr; -#define FIELD_SIZE 20 - char field[FIELD_SIZE]; - int flags, any, count, new, sequenceSize; - unsigned long eventMask; - PatternTableKey key; - - /* - *------------------------------------------------------------- - * Step 1: parse the pattern string to produce an array - * of Patterns. The array is generated backwards, so - * that the lowest-indexed pattern corresponds to the last - * event that must occur. - *------------------------------------------------------------- - */ - - p = eventString; - flags = 0; - eventMask = 0; - for (numPats = 0, patPtr = &pats[EVENT_BUFFER_SIZE-1]; - numPats < EVENT_BUFFER_SIZE; - numPats++, patPtr--) { - patPtr->eventType = -1; - patPtr->needMods = 0; - - /* - * Note: the presence of Caps Lock should not prevent bindings - * from triggering (unless it is explicitly asked for and it - * isn't present); it should only affect the keysym that's - * generated for key events (and that is handled elsewhere. - */ - - patPtr->hateMods = ~LockMask; - patPtr->detail = 0; - while (isspace(UCHAR(*p))) { - p++; - } - if (*p == '\0') { - break; - } - - /* - * Handle simple ASCII characters. - */ - - if (*p != '<') { - char string[2]; - - patPtr->eventType = KeyPress; - eventMask |= KeyPressMask; - string[0] = *p; - string[1] = 0; - hPtr = Tcl_FindHashEntry(&keySymTable, string); - if (hPtr != NULL) { - patPtr->detail = (int) Tcl_GetHashValue(hPtr); - } else { - if (isprint(UCHAR(*p))) { - patPtr->detail = *p; - } else { - sprintf(interp->result, - "bad ASCII character 0x%x", *p); - return NULL; - } - } - p++; - continue; - } - - /* - * A fancier event description. Must consist of - * 1. open angle bracket. - * 2. any number of modifiers, each followed by spaces - * or dashes. - * 3. an optional event name. - * 4. an option button or keysym name. Either this or - * item 3 *must* be present; if both are present - * then they are separated by spaces or dashes. - * 5. a close angle bracket. - */ - - any = 0; - count = 1; - p++; - while (1) { - register ModInfo *modPtr; - p = GetField(p, field, FIELD_SIZE); - hPtr = Tcl_FindHashEntry(&modTable, field); - if (hPtr == NULL) { - break; - } - modPtr = (ModInfo *) Tcl_GetHashValue(hPtr); - patPtr->needMods |= modPtr->mask; - if (modPtr->flags & (DOUBLE|TRIPLE)) { - flags |= PAT_NEARBY; - if (modPtr->flags & DOUBLE) { - count = 2; - } else { - count = 3; - } - } - if (modPtr->flags & ANY) { - any = 1; - } - while ((*p == '-') || isspace(UCHAR(*p))) { - p++; - } - } - if (any) { - patPtr->hateMods = 0; - } else { - patPtr->hateMods = ~(patPtr->needMods | LockMask); - } - hPtr = Tcl_FindHashEntry(&eventTable, field); - if (hPtr != NULL) { - register EventInfo *eiPtr; - eiPtr = (EventInfo *) Tcl_GetHashValue(hPtr); - patPtr->eventType = eiPtr->type; - eventMask |= eiPtr->eventMask; - while ((*p == '-') || isspace(UCHAR(*p))) { - p++; - } - p = GetField(p, field, FIELD_SIZE); - } - if (*field != '\0') { - if ((*field >= '1') && (*field <= '5') && (field[1] == '\0')) { - static int masks[] = {~0, ~Button1Mask, ~Button2Mask, - ~Button3Mask, ~Button4Mask, ~Button5Mask}; - - if (patPtr->eventType == -1) { - patPtr->eventType = ButtonPress; - eventMask |= ButtonPressMask; - } else if ((patPtr->eventType == KeyPress) - || (patPtr->eventType == KeyRelease)) { - goto getKeysym; - } else if ((patPtr->eventType != ButtonPress) - && (patPtr->eventType != ButtonRelease)) { - Tcl_AppendResult(interp, "specified button \"", field, - "\" for non-button event", (char *) NULL); - return NULL; - } - patPtr->detail = (*field - '0'); - - /* - * Ignore this button as a modifier: its state is already - * fixed. - */ - - patPtr->needMods &= masks[patPtr->detail]; - patPtr->hateMods &= masks[patPtr->detail]; - } else { - getKeysym: - hPtr = Tcl_FindHashEntry(&keySymTable, (char *) field); - if (hPtr == NULL) { - Tcl_AppendResult(interp, "bad event type or keysym \"", - field, "\"", (char *) NULL); - return NULL; - } - if (patPtr->eventType == -1) { - patPtr->eventType = KeyPress; - eventMask |= KeyPressMask; - } else if ((patPtr->eventType != KeyPress) - && (patPtr->eventType != KeyRelease)) { - Tcl_AppendResult(interp, "specified keysym \"", field, - "\" for non-key event", (char *) NULL); - return NULL; - } - patPtr->detail = (int) Tcl_GetHashValue(hPtr); - } - } else if (patPtr->eventType == -1) { - interp->result = "no event type or button # or keysym"; - return NULL; - } - while ((*p == '-') || isspace(UCHAR(*p))) { - p++; - } - if (*p != '>') { - interp->result = "missing \">\" in binding"; - return NULL; - } - p++; - - /* - * Replicate events for DOUBLE and TRIPLE. - */ - - if ((count > 1) && (numPats < EVENT_BUFFER_SIZE-1)) { - patPtr[-1] = patPtr[0]; - patPtr--; - numPats++; - if ((count == 3) && (numPats < EVENT_BUFFER_SIZE-1)) { - patPtr[-1] = patPtr[0]; - patPtr--; - numPats++; - } - } - } - - /* - *------------------------------------------------------------- - * Step 2: find the sequence in the binding table if it exists, - * and add a new sequence to the table if it doesn't. - *------------------------------------------------------------- - */ - - if (numPats == 0) { - interp->result = "no events specified in binding"; - return NULL; - } - patPtr = &pats[EVENT_BUFFER_SIZE-numPats]; - key.object = object; - key.type = patPtr->eventType; - key.detail = patPtr->detail; - hPtr = Tcl_CreateHashEntry(&bindPtr->patternTable, (char *) &key, &new); - sequenceSize = numPats*sizeof(Pattern); - if (!new) { - for (psPtr = (PatSeq *) Tcl_GetHashValue(hPtr); psPtr != NULL; - psPtr = psPtr->nextSeqPtr) { - if ((numPats == psPtr->numPats) - && ((flags & PAT_NEARBY) == (psPtr->flags & PAT_NEARBY)) - && (memcmp((char *) patPtr, (char *) psPtr->pats, - sequenceSize) == 0)) { - goto done; - } - } - } - if (!create) { - if (new) { - Tcl_DeleteHashEntry(hPtr); - } - Tcl_AppendResult(interp, "no binding exists for \"", - eventString, "\"", (char *) NULL); - return NULL; - } - psPtr = (PatSeq *) ckalloc((unsigned) (sizeof(PatSeq) - + (numPats-1)*sizeof(Pattern))); - psPtr->numPats = numPats; - psPtr->command = NULL; - psPtr->flags = flags; - psPtr->nextSeqPtr = (PatSeq *) Tcl_GetHashValue(hPtr); - psPtr->hPtr = hPtr; - Tcl_SetHashValue(hPtr, psPtr); - - /* - * Link the pattern into the list associated with the object. - */ - - psPtr->object = object; - hPtr = Tcl_CreateHashEntry(&bindPtr->objectTable, (char *) object, &new); - if (new) { - psPtr->nextObjPtr = NULL; - } else { - psPtr->nextObjPtr = (PatSeq *) Tcl_GetHashValue(hPtr); - } - Tcl_SetHashValue(hPtr, psPtr); - - memcpy((VOID *) psPtr->pats, (VOID *) patPtr, sequenceSize); - - done: - *maskPtr = eventMask; - return psPtr; -} - -/* - *---------------------------------------------------------------------- - * - * GetField -- - * - * Used to parse pattern descriptions. Copies up to - * size characters from p to copy, stopping at end of - * string, space, "-", ">", or whenever size is - * exceeded. - * - * Results: - * The return value is a pointer to the character just - * after the last one copied (usually "-" or space or - * ">", but could be anything if size was exceeded). - * Also places NULL-terminated string (up to size - * character, including NULL), at copy. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static char * -GetField(p, copy, size) - register char *p; /* Pointer to part of pattern. */ - register char *copy; /* Place to copy field. */ - int size; /* Maximum number of characters to - * copy. */ -{ - while ((*p != '\0') && !isspace(UCHAR(*p)) && (*p != '>') - && (*p != '-') && (size > 1)) { - *copy = *p; - p++; - copy++; - size--; - } - *copy = '\0'; - return p; -} - -/* - *---------------------------------------------------------------------- - * - * GetKeySym -- - * - * Given an X KeyPress or KeyRelease event, map the - * keycode in the event into a KeySym. - * - * Results: - * The return value is the KeySym corresponding to - * eventPtr, or NoSymbol if no matching Keysym could be - * found. - * - * Side effects: - * In the first call for a given display, keycode-to- - * KeySym maps get loaded. - * - *---------------------------------------------------------------------- - */ - -static KeySym -GetKeySym(dispPtr, eventPtr) - register TkDisplay *dispPtr; /* Display in which to - * map keycode. */ - register XEvent *eventPtr; /* Description of X event. */ -{ - KeySym sym; - int index; - - /* - * Refresh the mapping information if it's stale - */ - - if (dispPtr->bindInfoStale) { - InitKeymapInfo(dispPtr); - } - - /* - * Figure out which of the four slots in the keymap vector to - * use for this key. Refer to Xlib documentation for more info - * on how this computation works. - */ - - index = 0; - if (eventPtr->xkey.state & dispPtr->modeModMask) { - index = 2; - } - if ((eventPtr->xkey.state & ShiftMask) - || ((dispPtr->lockUsage != IGNORE) - && (eventPtr->xkey.state & LockMask))) { - index += 1; - } - sym = XKeycodeToKeysym(dispPtr->display, eventPtr->xkey.keycode, index); - - /* - * Special handling: if the key was shifted because of Lock, but - * lock is only caps lock, not shift lock, and the shifted keysym - * isn't upper-case alphabetic, then switch back to the unshifted - * keysym. - */ - - if ((index & 1) && !(eventPtr->xkey.state & ShiftMask) - && (dispPtr->lockUsage == CAPS)) { - if (!(((sym >= XK_A) && (sym <= XK_Z)) - || ((sym >= XK_Agrave) && (sym <= XK_Odiaeresis)) - || ((sym >= XK_Ooblique) && (sym <= XK_Thorn)))) { - index &= ~1; - sym = XKeycodeToKeysym(dispPtr->display, eventPtr->xkey.keycode, - index); - } - } - - /* - * Another bit of special handling: if this is a shifted key and there - * is no keysym defined, then use the keysym for the unshifted key. - */ - - if ((index & 1) && (sym == NoSymbol)) { - sym = XKeycodeToKeysym(dispPtr->display, eventPtr->xkey.keycode, - index & ~1); - } - return sym; -} - -/* - *---------------------------------------------------------------------- - * - * MatchPatterns -- - * - * Given a list of pattern sequences and a list of - * recent events, return a pattern sequence that matches - * the event list. - * - * Results: - * The return value is NULL if no pattern matches the - * recent events from bindPtr. If one or more patterns - * matches, then the longest (or most specific) matching - * pattern is returned. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static PatSeq * -MatchPatterns(dispPtr, bindPtr, psPtr) - TkDisplay *dispPtr; /* Display from which the event came. */ - BindingTable *bindPtr; /* Information about binding table, such - * as ring of recent events. */ - register PatSeq *psPtr; /* List of pattern sequences. */ -{ - register PatSeq *bestPtr = NULL; - - /* - * Iterate over all the pattern sequences. - */ - - for ( ; psPtr != NULL; psPtr = psPtr->nextSeqPtr) { - register XEvent *eventPtr; - register Pattern *patPtr; - Window window; - int *detailPtr; - int patCount, ringCount, flags, state; - - /* - * Iterate over all the patterns in a sequence to be - * sure that they all match. - */ - - eventPtr = &bindPtr->eventRing[bindPtr->curEvent]; - detailPtr = &bindPtr->detailRing[bindPtr->curEvent]; - window = eventPtr->xany.window; - patPtr = psPtr->pats; - patCount = psPtr->numPats; - ringCount = EVENT_BUFFER_SIZE; - while (patCount > 0) { - if (ringCount <= 0) { - goto nextSequence; - } - if (eventPtr->xany.type != patPtr->eventType) { - /* - * Most of the event types are considered superfluous - * in that they are ignored if they occur in the middle - * of a pattern sequence and have mismatching types. The - * only ones that cannot be ignored are ButtonPress and - * ButtonRelease events (unless the next event in the pattern - * is a KeyPress or KeyRelease) and KeyPress and KeyRelease - * events (unless the next pattern event is a KeyPress or - * KeyRelease). Here are some tricky cases to consider: - * 1. Double-Button or Double-Key events. - * 2. Double-ButtonRelease or Double-KeyRelease events. - * 3. The arrival of various events like Enter and Leave - * and FocusIn and GraphicsExpose between two button - * presses or key presses. - */ - - if ((patPtr->eventType == KeyPress) - || (patPtr->eventType == KeyRelease)) { - if ((eventPtr->xany.type == ButtonPress) - || (eventPtr->xany.type == ButtonRelease)) { - goto nextSequence; - } - } else if ((patPtr->eventType == ButtonPress) - || (patPtr->eventType == ButtonRelease)) { - if ((eventPtr->xany.type == KeyPress) - || (eventPtr->xany.type == KeyRelease)) { - goto nextSequence; - } - } - goto nextEvent; - } - if (eventPtr->xany.window != window) { - goto nextSequence; - } - - flags = flagArray[eventPtr->type]; - if (flags & KEY_BUTTON_MOTION) { - state = eventPtr->xkey.state; - } else if (flags & CROSSING) { - state = eventPtr->xcrossing.state; - } else { - state = 0; - } - if ((state & patPtr->needMods) - != patPtr->needMods) { - goto nextSequence; - } - if ((state & patPtr->hateMods) != 0) { - /* - * There appear to be unwanted modifiers. However, if this - * is a KeyPress or KeyRelease event then ignore modifiers - * such as shift, lock, and mode_switch, since they are - * already included in the keysym spec. - */ - - if (((patPtr->eventType != KeyPress) - && (patPtr->eventType != KeyRelease)) - || ((state & patPtr->hateMods - & ~dispPtr->ignoreModMask) != 0)) { - goto nextSequence; - } - } - if ((patPtr->detail != 0) - && (patPtr->detail != *detailPtr)) { - /* - * The detail appears not to match. However, if the event - * is a KeyPress for a modifier key then just ignore the - * event. Otherwise event sequences like "aD" never match - * because the shift key goes down between the "a" and the - * "D". - */ - - if (eventPtr->xany.type == KeyPress) { - int i; - - for (i = 0; i < dispPtr->numModKeyCodes; i++) { - if (dispPtr->modKeyCodes[i] == eventPtr->xkey.keycode) { - goto nextEvent; - } - } - } - goto nextSequence; - } - if (psPtr->flags & PAT_NEARBY) { - register XEvent *firstPtr; - - firstPtr = &bindPtr->eventRing[bindPtr->curEvent]; - if ((firstPtr->xkey.x_root - < (eventPtr->xkey.x_root - NEARBY_PIXELS)) - || (firstPtr->xkey.x_root - > (eventPtr->xkey.x_root + NEARBY_PIXELS)) - || (firstPtr->xkey.y_root - < (eventPtr->xkey.y_root - NEARBY_PIXELS)) - || (firstPtr->xkey.y_root - > (eventPtr->xkey.y_root + NEARBY_PIXELS)) - || (firstPtr->xkey.time - > (eventPtr->xkey.time + NEARBY_MS))) { - goto nextSequence; - } - } - patPtr++; - patCount--; - nextEvent: - if (eventPtr == bindPtr->eventRing) { - eventPtr = &bindPtr->eventRing[EVENT_BUFFER_SIZE-1]; - detailPtr = &bindPtr->detailRing[EVENT_BUFFER_SIZE-1]; - } else { - eventPtr--; - detailPtr--; - } - ringCount--; - } - - /* - * This sequence matches. If we've already got another match, - * pick whichever is most specific. Detail is most important, - * then needMods, then hateMods. - */ - - if (bestPtr != NULL) { - register Pattern *patPtr2; - int i; - - if (psPtr->numPats != bestPtr->numPats) { - if (bestPtr->numPats > psPtr->numPats) { - goto nextSequence; - } else { - goto newBest; - } - } - for (i = 0, patPtr = psPtr->pats, patPtr2 = bestPtr->pats; - i < psPtr->numPats; i++,patPtr++, patPtr2++) { - if (patPtr->detail != patPtr2->detail) { - if (patPtr->detail == 0) { - goto nextSequence; - } else { - goto newBest; - } - } - if (patPtr->needMods != patPtr2->needMods) { - if ((patPtr->needMods & patPtr2->needMods) - == patPtr->needMods) { - goto nextSequence; - } else { - goto newBest; - } - } - if (patPtr->hateMods != patPtr2->hateMods) { - if ((patPtr->hateMods & patPtr2->hateMods) - == patPtr2->hateMods) { - goto newBest; - } else { - goto nextSequence; - } - } - } - goto nextSequence; /* Tie goes to newest pattern. */ - } - newBest: - bestPtr = psPtr; - - nextSequence: continue; - } - return bestPtr; -} - -/* - *-------------------------------------------------------------- - * - * ExpandPercents -- - * - * Given a command and an event, produce a new command - * by replacing % constructs in the original command - * with information from the X event. - * - * Results: - * The return result is a pointer to the new %-substituted - * command. If the command fits in the space at after, then - * the return value is after. If the command is too large - * to fit at after, then the return value is a pointer to - * a malloc-ed buffer holding the command; in this case it - * is the caller's responsibility to free up the buffer when - * finished with it. - * - * Side effects: - * None. - * - *-------------------------------------------------------------- - */ - -static char * -ExpandPercents(before, eventPtr, keySym, after, afterSize) - register char *before; /* Command containing percent - * expressions to be replaced. */ - register XEvent *eventPtr; /* X event containing information - * to be used in % replacements. */ - KeySym keySym; /* KeySym: only relevant for - * KeyPress and KeyRelease events). */ - char *after; /* Place to generate new expanded - * command. Must contain at least - * "afterSize" bytes of space. */ - int afterSize; /* Number of bytes of space available at - * after. */ -{ - register char *buffer; /* Pointer to buffer currently being used - * as destination. */ - register char *dst; /* Pointer to next place to store character - * in substituted string. */ - int spaceLeft; /* Indicates how many more non-null bytes - * may be stored at *dst before space - * runs out. */ - int spaceNeeded, cvtFlags; /* Used to substitute string as proper Tcl - * list element. */ - int number, flags; -#define NUM_SIZE 40 - register char *string; - char numStorage[NUM_SIZE+1]; - - if (eventPtr->type < LASTEvent) { - flags = flagArray[eventPtr->type]; - } else { - flags = 0; - } - dst = buffer = after; - spaceLeft = afterSize - 1; - while (*before != 0) { - if (*before != '%') { - - /* - * Expand the destination string if necessary. - */ - - if (spaceLeft <= 0) { - char *newSpace; - - newSpace = (char *) ckalloc((unsigned) (2*afterSize)); - memcpy((VOID *) newSpace, (VOID *) buffer, afterSize); - afterSize *= 2; - dst = newSpace + (dst - buffer); - if (buffer != after) { - ckfree(buffer); - } - buffer = newSpace; - spaceLeft = afterSize - (dst-buffer) - 1; - } - *dst = *before; - dst++; - before++; - spaceLeft--; - continue; - } - - number = 0; - string = "??"; - switch (before[1]) { - case '#': - number = eventPtr->xany.serial; - goto doNumber; - case 'a': - number = (int) eventPtr->xconfigure.above; - goto doNumber; - case 'b': - number = eventPtr->xbutton.button; - goto doNumber; - case 'c': - if (flags & EXPOSE) { - number = eventPtr->xexpose.count; - } else if (flags & MAPPING) { - number = eventPtr->xmapping.count; - } - goto doNumber; - case 'd': - if (flags & (CROSSING|FOCUS)) { - if (flags & FOCUS) { - number = eventPtr->xfocus.detail; - } else { - number = eventPtr->xcrossing.detail; - } - switch (number) { - case NotifyAncestor: - string = "NotifyAncestor"; - break; - case NotifyVirtual: - string = "NotifyVirtual"; - break; - case NotifyInferior: - string = "NotifyInferior"; - break; - case NotifyNonlinear: - string = "NotifyNonlinear"; - break; - case NotifyNonlinearVirtual: - string = "NotifyNonlinearVirtual"; - break; - case NotifyPointer: - string = "NotifyPointer"; - break; - case NotifyPointerRoot: - string = "NotifyPointerRoot"; - break; - case NotifyDetailNone: - string = "NotifyDetailNone"; - break; - } - } else if (flags & CONFIG_REQ) { - switch (eventPtr->xconfigurerequest.detail) { - case Above: - string = "Above"; - break; - case Below: - string = "Below"; - break; - case TopIf: - string = "TopIf"; - break; - case BottomIf: - string = "BottomIf"; - break; - case Opposite: - string = "Opposite"; - break; - } - } - goto doString; - case 'f': - number = eventPtr->xcrossing.focus; - goto doNumber; - case 'h': - if (flags & EXPOSE) { - number = eventPtr->xexpose.height; - } else if (flags & (CONFIG|CONFIG_REQ)) { - number = eventPtr->xconfigure.height; - } else if (flags & RESIZE_REQ) { - number = eventPtr->xresizerequest.height; - } - goto doNumber; - case 'k': - number = eventPtr->xkey.keycode; - goto doNumber; - case 'm': - if (flags & CROSSING) { - number = eventPtr->xcrossing.mode; - } else if (flags & FOCUS) { - number = eventPtr->xfocus.mode; - } - switch (number) { - case NotifyNormal: - string = "NotifyNormal"; - break; - case NotifyGrab: - string = "NotifyGrab"; - break; - case NotifyUngrab: - string = "NotifyUngrab"; - break; - case NotifyWhileGrabbed: - string = "NotifyWhileGrabbed"; - break; - } - goto doString; - case 'o': - if (flags & CREATE) { - number = eventPtr->xcreatewindow.override_redirect; - } else if (flags & MAP) { - number = eventPtr->xmap.override_redirect; - } else if (flags & REPARENT) { - number = eventPtr->xreparent.override_redirect; - } else if (flags & CONFIG) { - number = eventPtr->xconfigure.override_redirect; - } - goto doNumber; - case 'p': - switch (eventPtr->xcirculate.place) { - case PlaceOnTop: - string = "PlaceOnTop"; - break; - case PlaceOnBottom: - string = "PlaceOnBottom"; - break; - } - goto doString; - case 's': - if (flags & KEY_BUTTON_MOTION) { - number = eventPtr->xkey.state; - } else if (flags & CROSSING) { - number = eventPtr->xcrossing.state; - } else if (flags & VISIBILITY) { - switch (eventPtr->xvisibility.state) { - case VisibilityUnobscured: - string = "VisibilityUnobscured"; - break; - case VisibilityPartiallyObscured: - string = "VisibilityPartiallyObscured"; - break; - case VisibilityFullyObscured: - string = "VisibilityFullyObscured"; - break; - } - goto doString; - } - goto doNumber; - case 't': - if (flags & (KEY_BUTTON_MOTION|PROP|SEL_CLEAR)) { - number = (int) eventPtr->xkey.time; - } else if (flags & SEL_REQ) { - number = (int) eventPtr->xselectionrequest.time; - } else if (flags & SEL_NOTIFY) { - number = (int) eventPtr->xselection.time; - } - goto doNumber; - case 'v': - number = eventPtr->xconfigurerequest.value_mask; - goto doNumber; - case 'w': - if (flags & EXPOSE) { - number = eventPtr->xexpose.width; - } else if (flags & (CONFIG|CONFIG_REQ)) { - number = eventPtr->xconfigure.width; - } else if (flags & RESIZE_REQ) { - number = eventPtr->xresizerequest.width; - } - goto doNumber; - case 'x': - if (flags & KEY_BUTTON_MOTION) { - number = eventPtr->xkey.x; - } else if (flags & EXPOSE) { - number = eventPtr->xexpose.x; - } else if (flags & (CREATE|CONFIG|GRAVITY|CONFIG_REQ)) { - number = eventPtr->xcreatewindow.x; - } else if (flags & REPARENT) { - number = eventPtr->xreparent.x; - } else if (flags & CROSSING) { - number = eventPtr->xcrossing.x; - } - goto doNumber; - case 'y': - if (flags & KEY_BUTTON_MOTION) { - number = eventPtr->xkey.y; - } else if (flags & EXPOSE) { - number = eventPtr->xexpose.y; - } else if (flags & (CREATE|CONFIG|GRAVITY|CONFIG_REQ)) { - number = eventPtr->xcreatewindow.y; - } else if (flags & REPARENT) { - number = eventPtr->xreparent.y; - } else if (flags & CROSSING) { - number = eventPtr->xcrossing.y; - - } - goto doNumber; - case 'A': - if ((eventPtr->type == KeyPress) - || (eventPtr->type == KeyRelease)) { - int numChars; - - numChars = XLookupString(&eventPtr->xkey, numStorage, - NUM_SIZE, (KeySym *) NULL, - (XComposeStatus *) NULL); - numStorage[numChars] = '\0'; - string = numStorage; - } - goto doString; - case 'B': - number = eventPtr->xcreatewindow.border_width; - goto doNumber; - case 'D': - number = (int) eventPtr->xany.display; - goto doNumber; - case 'E': - number = (int) eventPtr->xany.send_event; - goto doNumber; - case 'K': - if ((eventPtr->type == KeyPress) - || (eventPtr->type == KeyRelease)) { - register KeySymInfo *kPtr; - - for (kPtr = keyArray; kPtr->name != NULL; kPtr++) { - if (kPtr->value == keySym) { - string = kPtr->name; - break; - } - } - } - goto doString; - case 'N': - number = (int) keySym; - goto doNumber; - case 'R': - number = (int) eventPtr->xkey.root; - goto doNumber; - case 'S': - number = (int) eventPtr->xkey.subwindow; - goto doNumber; - case 'T': - number = eventPtr->type; - goto doNumber; - case 'W': { - TkWindow *winPtr; - - if (XFindContext(eventPtr->xany.display, eventPtr->xany.window, - tkWindowContext, (caddr_t *) &winPtr) == 0) { - string = winPtr->pathName; - } else { - string = "??"; - } - goto doString; - } - case 'X': { - Tk_Window tkwin; - int x, y; - unsigned int width, height; - - number = eventPtr->xkey.x_root; - if (XFindContext(eventPtr->xany.display, eventPtr->xany.window, - tkWindowContext, (caddr_t *) &tkwin) == 0) { - Tk_GetVRootGeometry(tkwin, &x, &y, &width, &height); - number -= x; - } - goto doNumber; - } - case 'Y': { - Tk_Window tkwin; - int x, y; - unsigned int width, height; - - number = eventPtr->xkey.y_root; - if (XFindContext(eventPtr->xany.display, eventPtr->xany.window, - tkWindowContext, (caddr_t *) &tkwin) == 0) { - Tk_GetVRootGeometry(tkwin, &x, &y, &width, &height); - number -= y; - } - goto doNumber; - } - default: - numStorage[0] = before[1]; - numStorage[1] = '\0'; - string = numStorage; - goto doString; - } - - doNumber: - sprintf(numStorage, "%d", number); - string = numStorage; - - doString: - spaceNeeded = Tcl_ScanElement(string, &cvtFlags); - if (spaceNeeded >= spaceLeft) { - char *newSpace; - - newSpace = (char *) ckalloc((unsigned) - (afterSize + spaceNeeded + 50)); - memcpy((VOID *) newSpace, (VOID *) buffer, afterSize); - afterSize += spaceNeeded + 50; - dst = newSpace + (dst - buffer); - if (buffer != after) { - ckfree(buffer); - } - buffer = newSpace; - spaceLeft = afterSize - (dst-buffer) - 1; - } - spaceNeeded = Tcl_ConvertElement(string, dst, - cvtFlags | TCL_DONT_USE_BRACES); - dst += spaceNeeded; - spaceLeft -= spaceNeeded; - before += 2; - } - *dst = '\0'; - return buffer; -} - -/* - *---------------------------------------------------------------------- - * - * Tk_BackgroundError -- - * - * This procedure is invoked to handle errors that occur in Tcl - * commands that are invoked in "background" (e.g. from event or - * timer bindings). - * - * Results: - * None. - * - * Side effects: - * The command "tkerror" is invoked to process the error, passing - * it the error message. If that fails, then an error message - * is output on stderr. - * - *---------------------------------------------------------------------- - */ - -void -Tk_BackgroundError(interp) - Tcl_Interp *interp; /* Interpreter in which an error has - * occurred. */ -{ - char *argv[2]; - char *command; - char *error; - char *errorInfo, *tmp; - int result; - - /* - * The Tcl_AddErrorInfo call below (with an empty string) ensures that - * errorInfo gets properly set. It's needed in cases where the error - * came from a utility procedure like Tcl_GetVar instead of Tcl_Eval; - * in these cases errorInfo still won't have been set when this - * procedure is called. - */ - - Tcl_AddErrorInfo(interp, ""); - error = (char *) ckalloc((unsigned) (strlen(interp->result) + 1)); - strcpy(error, interp->result); - tmp = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); - if (tmp == NULL) { - errorInfo = error; - } else { - errorInfo = (char *) ckalloc((unsigned) (strlen(tmp) + 1)); - strcpy(errorInfo, tmp); - } - argv[0] = "tkerror"; - argv[1] = error; - command = Tcl_Merge(2, argv); - result = Tcl_GlobalEval(interp, command); - if (result != TCL_OK) { - if (strcmp(interp->result, "\"tkerror\" is an invalid command name or ambiguous abbreviation") == 0) { - fprintf(stderr, "%s\n", errorInfo); - } else { - fprintf(stderr, "tkerror failed to handle background error.\n"); - fprintf(stderr, " Original error: %s\n", error); - fprintf(stderr, " Error in tkerror: %s\n", interp->result); - } - } - Tcl_ResetResult(interp); - ckfree(command); - ckfree(error); - if (errorInfo != error) { - ckfree(errorInfo); - } -} - -/* - *---------------------------------------------------------------------- - * - * TkCopyAndGlobalEval -- - * - * This procedure makes a copy of a script then calls Tcl_GlobalEval - * to evaluate it. It's used in situations where the execution of - * a command may cause the original command string to be reallocated. - * - * Results: - * Returns the result of evaluating script, including both a standard - * Tcl completion code and a string in interp->result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TkCopyAndGlobalEval(interp, script) - Tcl_Interp *interp; /* Interpreter in which to evaluate - * script. */ - char *script; /* Script to evaluate. */ -{ - Tcl_DString buffer; - int code; - - Tcl_DStringInit(&buffer); - Tcl_DStringAppend(&buffer, script, -1); - code = Tcl_GlobalEval(interp, Tcl_DStringValue(&buffer)); - Tcl_DStringFree(&buffer); - return code; -} - -/* - *-------------------------------------------------------------- - * - * InitKeymapInfo -- - * - * This procedure is invoked to scan keymap information - * to recompute stuff that's important for binding, such - * as the modifier key (if any) that corresponds to "mode - * switch". - * - * Results: - * None. - * - * Side effects: - * Keymap-related information in dispPtr is updated. - * - *-------------------------------------------------------------- - */ - -static void -InitKeymapInfo(dispPtr) - TkDisplay *dispPtr; /* Display for which to recompute keymap - * information. */ -{ - XModifierKeymap *modMapPtr; - register KeyCode *codePtr; - KeySym keysym; - int count, i, j, max, arraySize; -#define KEYCODE_ARRAY_SIZE 20 - - dispPtr->bindInfoStale = 0; - modMapPtr = XGetModifierMapping(dispPtr->display); - - /* - * Check the keycodes associated with the Lock modifier. If - * any of them is associated with the XK_Shift_Lock modifier, - * then Lock has to be interpreted as Shift Lock, not Caps Lock. - */ - - dispPtr->lockUsage = IGNORE; - codePtr = modMapPtr->modifiermap + modMapPtr->max_keypermod*LockMapIndex; - for (count = modMapPtr->max_keypermod; count > 0; count--, codePtr++) { - if (*codePtr == 0) { - continue; - } - keysym = XKeycodeToKeysym(dispPtr->display, *codePtr, 0); - if (keysym == XK_Shift_Lock) { - dispPtr->lockUsage = SHIFT; - break; - } - if (keysym == XK_Caps_Lock) { - dispPtr->lockUsage = CAPS; - break; - } - } - - /* - * See if the "mode switch" keysym is associated with any keycode - * associated with any modifier. If so, store a mask for all such - * modifiers in dispPtr->modeModMask. At the same time, see if - * there is a Num_Lock key that generates a modifier, and if so - * save its modifier mask too. - */ - - dispPtr->modeModMask = 0; - dispPtr->ignoreModMask = 0; - codePtr = modMapPtr->modifiermap; - max = 8*modMapPtr->max_keypermod; - for (i = 0; i < max; i++, codePtr++) { - if (*codePtr == 0) { - continue; - } - if (XKeycodeToKeysym(dispPtr->display, *codePtr, 0) - == XK_Mode_switch) { - dispPtr->modeModMask |= ShiftMask << (i/modMapPtr->max_keypermod); - } - if (XKeycodeToKeysym(dispPtr->display, *codePtr, 0) - == XK_Num_Lock) { - dispPtr->ignoreModMask |= ShiftMask << (i/modMapPtr->max_keypermod); - } - } - dispPtr->ignoreModMask |= ShiftMask|LockMask|dispPtr->modeModMask; - - /* - * Create an array of the keycodes for all modifier keys. - */ - - if (dispPtr->modKeyCodes != NULL) { - ckfree((char *) dispPtr->modKeyCodes); - } - dispPtr->numModKeyCodes = 0; - arraySize = KEYCODE_ARRAY_SIZE; - dispPtr->modKeyCodes = (KeyCode *) ckalloc((unsigned) - (KEYCODE_ARRAY_SIZE * sizeof(KeyCode))); - for (i = 0, codePtr = modMapPtr->modifiermap; i < max; i++, codePtr++) { - if (*codePtr == 0) { - continue; - } - - /* - * Make sure that the keycode isn't already in the array. - */ - - for (j = 0; ; j++) { - if (dispPtr->modKeyCodes[j] == *codePtr) { - break; - } - if (j < dispPtr->numModKeyCodes) { - continue; - } - if (dispPtr->numModKeyCodes >= arraySize) { - KeyCode *new; - - /* - * Ran out of space in the array; grow it. - */ - - arraySize *= 2; - new = (KeyCode *) ckalloc((unsigned) - (arraySize * sizeof(KeyCode))); - memcpy((VOID *) new, (VOID *) dispPtr->modKeyCodes, - (dispPtr->numModKeyCodes * sizeof(KeyCode))); - ckfree((char *) dispPtr->modKeyCodes); - dispPtr->modKeyCodes = new; - } - dispPtr->modKeyCodes[dispPtr->numModKeyCodes] = *codePtr; - dispPtr->numModKeyCodes++; - break; - } - } - XFreeModifiermap(modMapPtr); -} diff --git a/tk3.6/tkCanvas.h b/tk3.6/tkCanvas.h deleted file mode 100644 index 224307b..0000000 --- a/tk3.6/tkCanvas.h +++ /dev/null @@ -1,429 +0,0 @@ -/* - * tkCanvas.h -- - * - * Declarations shared among all the files that implement - * canvas widgets. - * - * 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/wish/RCS/tkCanvas.h,v 1.21 93/06/16 17:15:32 ouster Exp $ SPRITE (Berkeley) - */ - -#ifndef _TKCANVAS -#define _TKCANVAS - -#ifndef _TK -#include "tk.h" -#endif - -/* - * For each item in a canvas widget there exists one record with - * the following structure. Each actual item is represented by - * a record with the following stuff at its beginning, plus additional - * type-specific stuff after that. - */ - -#define TK_TAG_SPACE 3 - -typedef struct Tk_Item { - int id; /* Unique identifier for this item - * (also serves as first tag for - * item). */ - struct Tk_Item *nextPtr; /* Next in display list of all - * items in this canvas. Later items - * in list are drawn on top of earlier - * ones. */ - Tk_Uid staticTagSpace[TK_TAG_SPACE];/* Built-in space for limited # of - * tags. */ - Tk_Uid *tagPtr; /* Pointer to array of tags. Usually - * points to staticTagSpace, but - * may point to malloc-ed space if - * there are lots of tags. */ - int tagSpace; /* Total amount of tag space available - * at tagPtr. */ - int numTags; /* Number of tag slots actually used - * at *tagPtr. */ - struct Tk_ItemType *typePtr; /* Table of procedures that implement - * this type of item. */ - int x1, y1, x2, y2; /* Bounding box for item, in integer - * canvas units. Set by item-specific - * code and guaranteed to contain every - * pixel drawn in item. Item area - * includes x1 and y1 but not x2 - * and y2. */ - - /* - *------------------------------------------------------------------ - * Starting here is additional type-specific stuff; see the - * declarations for individual types to see what is part of - * each type. The actual space below is determined by the - * "itemInfoSize" of the type's Tk_ItemType record. - *------------------------------------------------------------------ - */ -} Tk_Item; - -/* - * The record below describes a canvas widget. It is made available - * to the item procedures so they can access certain shared fields such - * as the overall displacement and scale factor for the canvas. - */ - -typedef struct { - Tk_Window tkwin; /* Window that embodies the canvas. NULL - * means that the window has been destroyed - * but the data structures haven't yet been - * cleaned up.*/ - Display *display; /* Display containing widget; needed, among - * other things, to release resources after - * tkwin has already gone away. */ - Tcl_Interp *interp; /* Interpreter associated with canvas. */ - Tk_Item *firstItemPtr; /* First in list of all items in canvas, - * or NULL if canvas empty. */ - Tk_Item *lastItemPtr; /* Last in list of all items in canvas, - * or NULL if canvas empty. */ - - /* - * Information used when displaying widget: - */ - - int borderWidth; /* Width of 3-D border around window. */ - Tk_3DBorder bgBorder; /* Used for canvas background. */ - int relief; /* Indicates whether window as a whole is - * raised, sunken, or flat. */ - GC pixmapGC; /* Used to copy bits from a pixmap to the - * screen and also to clear the pixmap. */ - int width, height; /* Dimensions to request for canvas window, - * specified in pixels. */ - int redrawX1, redrawY1; /* Upper left corner of area to redraw, - * in pixel coordinates. Border pixels - * are included. Only valid if - * REDRAW_PENDING flag is set. */ - int redrawX2, redrawY2; /* Lower right corner of area to redraw, - * in pixel coordinates. Border pixels - * will *not* be redrawn. */ - int confine; /* Non-zero means constrain view to keep - * as much of canvas visible as possible. */ - - /* - * Information used to manage and display selection: - */ - - Tk_3DBorder selBorder; /* Border and background for selected - * characters. */ - int selBorderWidth; /* Width of border around selection. */ - XColor *selFgColorPtr; /* Foreground color for selected text. */ - Tk_Item *selItemPtr; /* Pointer to selected item. NULL means - * selection isn't in this canvas. */ - int selectFirst; /* Index of first selected character. */ - int selectLast; /* Index of last selected character. */ - Tk_Item *anchorItemPtr; /* Item corresponding to "selectAnchor": - * not necessarily selItemPtr. */ - int selectAnchor; /* Fixed end of selection (i.e. "select to" - * operation will use this as one end of the - * selection). */ - - /* - * Information for display insertion cursor in text: - */ - - Tk_3DBorder insertBorder; /* Used to draw vertical bar for insertion - * cursor. */ - int insertWidth; /* Total width of insertion cursor. */ - int insertBorderWidth; /* Width of 3-D border around insert cursor. */ - int insertOnTime; /* Number of milliseconds cursor should spend - * in "on" state for each blink. */ - int insertOffTime; /* Number of milliseconds cursor should spend - * in "off" state for each blink. */ - Tk_TimerToken insertBlinkHandler; - /* Timer handler used to blink cursor on and - * off. */ - Tk_Item *focusItemPtr; /* Item that currently has the input focus, - * or NULL if no such item. */ - - /* - * Transformation applied to canvas as a whole: to compute screen - * coordinates (X,Y) from canvas coordinates (x,y), do the following: - * - * X = x - xOrigin; - * Y = y - yOrigin; - */ - - int xOrigin, yOrigin; /* Canvas coordinates corresponding to - * upper-left corner of window, given in - * canvas pixel units. */ - int drawableXOrigin, drawableYOrigin; - /* During redisplay, these fields give the - * canvas coordinates corresponding to - * the upper-left corner of the drawable - * where items are actually being drawn - * (typically a pixmap smaller than the - * whole window). */ - - /* - * Information used for event bindings associated with items. - */ - - Tk_BindingTable bindingTable; - /* Table of all bindings currently defined - * for this canvas. NULL means that no - * bindings exist, so the table hasn't been - * created. Each "object" used for this - * table is either a Tk_Uid for a tag or - * the address of an item named by id. */ - Tk_Item *currentItemPtr; /* The item currently containing the mouse - * pointer, or NULL if none. */ - double closeEnough; /* The mouse is assumed to be inside an - * item if it is this close to it. */ - XEvent pickEvent; /* The event upon which the current choice - * of currentItem is based. Must be saved - * so that if the currentItem is deleted, - * can pick another. */ - int state; /* Last known modifier state. Used to - * defer picking a new current object - * while buttons are down. */ - - /* - * Information used for managing scrollbars: - */ - - char *xScrollCmd; /* Command prefix for communicating with - * horizontal scrollbar. NULL means no - * horizontal scrollbar. Malloc'ed*/ - char *yScrollCmd; /* Command prefix for communicating with - * vertical scrollbar. NULL means no - * vertical scrollbar. Malloc'ed*/ - int scrollX1, scrollY1, scrollX2, scrollY2; - /* These four coordinates define the region - * that is the 100% area for scrolling (i.e. - * these numbers determine the size and - * location of the sliders on scrollbars). - * Units are pixels in canvas coords. */ - char *regionString; /* The option string from which scrollX1 - * etc. are derived. Malloc'ed. */ - int scrollIncrement; /* The number of canvas units that the - * picture shifts when a scrollbar up or - * down arrow is pressed. */ - - /* - * Information used for scanning: - */ - - int scanX; /* X-position at which scan started (e.g. - * button was pressed here). */ - int scanXOrigin; /* Value of xOrigin field when scan started. */ - int scanY; /* Y-position at which scan started (e.g. - * button was pressed here). */ - int scanYOrigin; /* Value of yOrigin field when scan started. */ - - /* - * Information used to speed up searches by remembering the last item - * created or found with an item id search. - */ - - Tk_Item *hotPtr; /* Pointer to "hot" item (one that's been - * recently used. NULL means there's no - * hot item. */ - Tk_Item *hotPrevPtr; /* Pointer to predecessor to hotPtr (NULL - * means item is first in list). This is - * only a hint and may not really be hotPtr's - * predecessor. */ - - /* - * Miscellaneous information: - */ - - Cursor cursor; /* Current cursor for window, or None. */ - double pixelsPerMM; /* Scale factor between MM and pixels; - * used when converting coordinates. */ - int flags; /* Various flags; see below for - * definitions. */ - int nextId; /* Number to use as id for next item - * created in widget. */ -} Tk_Canvas; - -/* - * Flag bits for canvases: - * - * REDRAW_PENDING - 1 means a DoWhenIdle handler has already - * been created to redraw some or all of the - * canvas. - * REPICK_NEEDED - 1 means DisplayCanvas should pick a new - * current item before redrawing the canvas. - * GOT_FOCUS - 1 means the focus is currently in this - * widget, so should draw the insertion cursor. - * CURSOR_ON - 1 means the insertion cursor is in the "on" - * phase of its blink cycle. 0 means either - * we don't have the focus or the cursor is in - * the "off" phase of its cycle. - * UPDATE_SCROLLBARS - 1 means the scrollbars should get updated - * as part of the next display operation. - */ - -#define REDRAW_PENDING 1 -#define REPICK_NEEDED 2 -#define GOT_FOCUS 4 -#define CURSOR_ON 8 -#define UPDATE_SCROLLBARS 0x10 - -/* - * Records of the following type are used to describe a type of - * item (e.g. lines, circles, etc.) that can form part of a - * canvas widget. - */ - -typedef int Tk_ItemCreateProc _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, int argc, char **argv)); -typedef int Tk_ItemConfigureProc _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, int argc, char **argv, int flags)); -typedef int Tk_ItemCoordProc _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, int argc, char **argv)); -typedef void Tk_ItemDeleteProc _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr)); -typedef void Tk_ItemDisplayProc _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, Drawable dst)); -typedef double Tk_ItemPointProc _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, double *pointPtr)); -typedef int Tk_ItemAreaProc _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, double *rectPtr)); -typedef int Tk_ItemPostscriptProc _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, Tk_PostscriptInfo *psInfoPtr)); -typedef void Tk_ItemScaleProc _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, double originX, double originY, - double scaleX, double scaleY)); -typedef void Tk_ItemTranslateProc _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, double deltaX, double deltaY)); -typedef int Tk_ItemIndexProc _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, char *indexString, - int *indexPtr)); -typedef void Tk_ItemCursorProc _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, int index)); -typedef int Tk_ItemSelectionProc _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, int offset, char *buffer, - int maxBytes)); -typedef int Tk_ItemInsertProc _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, int beforeThis, char *string)); -typedef int Tk_ItemDCharsProc _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, int first, int last)); - -typedef struct Tk_ItemType { - char *name; /* The name of this type of item, such - * as "line". */ - int itemSize; /* Total amount of space needed for - * item's record. */ - Tk_ItemCreateProc *createProc; /* Procedure to create a new item of - * this type. */ - Tk_ConfigSpec *configSpecs; /* Pointer to array of configuration - * specs for this type. Used for - * returning configuration info. */ - Tk_ItemConfigureProc *configProc; /* Procedure to call to change - * configuration options. */ - Tk_ItemCoordProc *coordProc; /* Procedure to call to get and set - * the item's coordinates. */ - Tk_ItemDeleteProc *deleteProc; /* Procedure to delete existing item of - * this type. */ - Tk_ItemDisplayProc *displayProc; /* Procedure to display items of - * this type. */ - int alwaysRedraw; /* Non-zero means displayProc should - * be called even when the item has - * been moved off-screen. */ - Tk_ItemPointProc *pointProc; /* Computes distance from item to - * a given point. */ - Tk_ItemAreaProc *areaProc; /* Computes whether item is inside, - * outside, or overlapping an area. */ - Tk_ItemPostscriptProc *postscriptProc; - /* Procedure to write a Postscript - * description for items of this - * type. */ - Tk_ItemScaleProc *scaleProc; /* Procedure to rescale items of - * this type. */ - Tk_ItemTranslateProc *translateProc;/* Procedure to translate items of - * this type. */ - Tk_ItemIndexProc *indexProc; /* Procedure to determine index of - * indicated character. NULL if - * item doesn't support indexing. */ - Tk_ItemCursorProc *icursorProc; /* Procedure to set insert cursor pos. - * to just before a given position. */ - Tk_ItemSelectionProc *selectionProc;/* Procedure to return selection (in - * STRING format) when it is in this - * item. */ - Tk_ItemInsertProc *insertProc; /* Procedure to insert something into - * an item. */ - Tk_ItemDCharsProc *dCharsProc; /* Procedure to delete characters - * from an item. */ - struct Tk_ItemType *nextPtr; /* Used to link types together into - * a list. */ -} Tk_ItemType; - -/* - * Macros to transform a point from double-precision canvas coordinates - * to integer pixel coordinates in the pixmap where redisplay is being - * done. - */ - -#define SCREEN_X(canvasPtr, x) \ - (((int) ((x) + (((x) > 0) ? 0.5 : -0.5))) - (canvasPtr)->drawableXOrigin) -#define SCREEN_Y(canvasPtr, y) \ - (((int) ((y) + (((y) > 0) ? 0.5 : -0.5))) - (canvasPtr)->drawableYOrigin) - -/* - * Canvas-related variables that are shared among Tk modules but not - * exported to the outside world: - */ - -extern Tk_CustomOption tkCanvasTagsOption; - -/* - * Canvas-related procedures that are shared among Tk modules but not - * exported to the outside world: - */ - -extern void TkBezierScreenPoints _ANSI_ARGS_((Tk_Canvas *canvasPtr, - double control[], int numSteps, - XPoint *xPointPtr)); -extern int TkCanvPostscriptCmd _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tcl_Interp *interp, int argc, char **argv)); -extern int TkCanvPsBitmap _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_PostscriptInfo *psInfoPtr, Pixmap bitmap)); -extern int TkCanvPsColor _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_PostscriptInfo *psInfoPtr, XColor *colorPtr)); -extern int TkCanvPsFont _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_PostscriptInfo *psInfoPtr, - XFontStruct *fontStructPtr)); -extern void TkCanvPsPath _ANSI_ARGS_((Tcl_Interp *interp, - double *coordPtr, int numPoints, - Tk_PostscriptInfo *psInfoPtr)); -extern int TkCanvPsStipple _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_PostscriptInfo *psInfoPtr, Pixmap bitmap, - int filled)); -extern double TkCanvPsY _ANSI_ARGS_((Tk_PostscriptInfo *psInfoPtr, - double y)); -extern void TkFillPolygon _ANSI_ARGS_((Tk_Canvas *canvasPtr, - double *coordPtr, int numPoints, Drawable drawable, - GC gc)); -extern int TkGetCanvasCoord _ANSI_ARGS_((Tk_Canvas *canvasPtr, - char *string, double *doublePtr)); -extern void TkIncludePoint _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, double *pointPtr)); -extern int TkMakeBezierCurve _ANSI_ARGS_((Tk_Canvas *canvasPtr, - double *pointPtr, int numPoints, int numSteps, - XPoint xPoints[], double dblPoints[])); - -#endif /* _TKCANVAS */ diff --git a/tk3.6/tkConfig.h b/tk3.6/tkConfig.h deleted file mode 100644 index a3b4de0..0000000 --- a/tk3.6/tkConfig.h +++ /dev/null @@ -1,165 +0,0 @@ -/* - * tkConfig.h -- - * - * This file is included by all of the Tk C files. It contains - * information that may be configuration-dependent, such as - * #includes for system include files and a few other things. - * - * 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/wish/RCS/tkConfig.h,v 1.33 93/08/27 08:17:58 ouster Exp $ SPRITE (Berkeley) - */ - -#ifndef _TKCONFIG -#define _TKCONFIG - -/* - * 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. This macro may be used in some of the include - * files below, which is why it is defined here. - */ - -#ifndef VOID -# ifdef __STDC__ -# define VOID void -# else -# define VOID char -# endif -#endif - -#include -#include -#include -#include -#include -#ifdef NO_STDLIB_H -# include "compat/stdlib.h" -#else -# include -#endif -#include -#include -#include -#ifdef HAVE_SYS_SELECT_H -# include -#endif -#include -#include -#ifndef _TCL -# include -#endif -#ifdef HAVE_UNISTD_H -# include -#else -# include "compat/unistd.h" -#endif -#include -#include -#include -#include -#include -#include -#include - -/* - * Not all systems declare the errno variable in errno.h. so this - * file does it explicitly. - */ - -extern int errno; - -/* - * Define OPEN_MAX if it isn't already defined for this system. - */ - -#ifndef OPEN_MAX -# define OPEN_MAX 256 -#endif - -/* - * The following macro defines the type of the mask arguments to - * select: - */ - -#ifndef NO_FD_SET -# define SELECT_MASK fd_set -#else -# ifndef _AIX - typedef long fd_mask; -# endif -# if defined(_IBMR2) -# define SELECT_MASK void -# else -# define SELECT_MASK int -# endif -#endif - -/* - * Define "NBBY" (number of bits per byte) if it's not already defined. - */ - -#ifndef NBBY -# define NBBY 8 -#endif - -/* - * The following macro defines the number of fd_masks in an fd_set: - */ - -#if !defined(howmany) -# define howmany(x, y) (((x)+((y)-1))/(y)) -#endif -#ifdef NFDBITS -# define MASK_SIZE howmany(FD_SETSIZE, NFDBITS) -#else -# define MASK_SIZE howmany(OPEN_MAX, NBBY*sizeof(fd_mask)) -#endif - -/* - * Substitute Tcl's own versions for several system calls. The - * Tcl versions retry automatically if interrupted by signals. - */ - -#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, mode_t mode)); -EXTERN int TclRead _ANSI_ARGS_((int fd, VOID *buf, - unsigned int numBytes)); -EXTERN int TclWaitpid _ANSI_ARGS_((pid_t pid, int *statPtr, int options)); -EXTERN int TclWrite _ANSI_ARGS_((int fd, VOID *buf, - unsigned int numBytes)); - -/* - * Declarations for various library procedures that may not be declared - * in any other header file. - */ - -extern void panic(); -#ifndef HAVE_SYS_SELECT_H -extern int select _ANSI_ARGS_((int nfds, SELECT_MASK *readfds, - SELECT_MASK *writefds, SELECT_MASK *exceptfds, - struct timeval *timeout)); -#endif - -#endif /* _TKCONFIG */ diff --git a/tk3.6/tkCursor.c b/tk3.6/tkCursor.c deleted file mode 100644 index 4d801fb..0000000 --- a/tk3.6/tkCursor.c +++ /dev/null @@ -1,669 +0,0 @@ -/* - * tkCursor.c -- - * - * This file maintains a database of read-only cursors for the Tk - * toolkit. This allows cursors to be shared between widgets and - * also avoids round-trips to the X server. - * - * 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/wish/RCS/tkCursor.c,v 1.16 93/06/16 17:16:20 ouster Exp $ SPRITE (Berkeley)"; -#endif /* not lint */ - -#include "tkConfig.h" -#include "tkInt.h" - -/* - * One of the following data structures exists for each cursor that is - * currently active. Each structure is indexed with two hash tables - * defined below. One of the tables is idTable, and the other is either - * nameTable or dataTable, also defined below. - * . - */ - -typedef struct { - Cursor cursor; /* X identifier for cursor. */ - Display *display; /* Display for which cursor is valid. */ - int refCount; /* Number of active uses of cursor. */ - Tcl_HashTable *otherTable; /* Second table (other than idTable) used - * to index this entry. */ - Tcl_HashEntry *hashPtr; /* Entry in otherTable for this structure - * (needed when deleting). */ -} TkCursor; - -/* - * Hash table to map from a textual description of a cursor to the - * TkCursor record for the cursor, and key structure used in that - * hash table: - */ - -static Tcl_HashTable nameTable; -typedef struct { - Tk_Uid name; /* Textual name for desired cursor. */ - Display *display; /* Display for which cursor will be used. */ -} NameKey; - -/* - * Hash table to map from a collection of in-core data about a - * cursor (bitmap contents, etc.) to a TkCursor structure: - */ - -static Tcl_HashTable dataTable; -typedef struct { - char *source; /* Cursor bits. */ - char *mask; /* Mask bits. */ - unsigned int width, height; /* Dimensions of cursor (and data - * and mask). */ - int xHot, yHot; /* Location of cursor hot-spot. */ - Tk_Uid fg, bg; /* Colors for cursor. */ - Display *display; /* Display on which cursor will be used. */ -} DataKey; - -/* - * Hash table that maps from to the TkCursor structure - * for the cursor. This table is used by Tk_FreeCursor. - */ - -static Tcl_HashTable idTable; -typedef struct { - Display *display; /* Display for which cursor was allocated. */ - Cursor cursor; /* Cursor identifier. */ -} IdKey; - -static int initialized = 0; /* 0 means static structures haven't been - * initialized yet. */ - -/* - * The table below is used to map from the name of a cursor to its - * index in the official cursor font: - */ - -static struct CursorName { - char *name; - unsigned int shape; -} cursorNames[] = { - {"X_cursor", XC_X_cursor}, - {"arrow", XC_arrow}, - {"based_arrow_down", XC_based_arrow_down}, - {"based_arrow_up", XC_based_arrow_up}, - {"boat", XC_boat}, - {"bogosity", XC_bogosity}, - {"bottom_left_corner", XC_bottom_left_corner}, - {"bottom_right_corner", XC_bottom_right_corner}, - {"bottom_side", XC_bottom_side}, - {"bottom_tee", XC_bottom_tee}, - {"box_spiral", XC_box_spiral}, - {"center_ptr", XC_center_ptr}, - {"circle", XC_circle}, - {"clock", XC_clock}, - {"coffee_mug", XC_coffee_mug}, - {"cross", XC_cross}, - {"cross_reverse", XC_cross_reverse}, - {"crosshair", XC_crosshair}, - {"diamond_cross", XC_diamond_cross}, - {"dot", XC_dot}, - {"dotbox", XC_dotbox}, - {"double_arrow", XC_double_arrow}, - {"draft_large", XC_draft_large}, - {"draft_small", XC_draft_small}, - {"draped_box", XC_draped_box}, - {"exchange", XC_exchange}, - {"fleur", XC_fleur}, - {"gobbler", XC_gobbler}, - {"gumby", XC_gumby}, - {"hand1", XC_hand1}, - {"hand2", XC_hand2}, - {"heart", XC_heart}, - {"icon", XC_icon}, - {"iron_cross", XC_iron_cross}, - {"left_ptr", XC_left_ptr}, - {"left_side", XC_left_side}, - {"left_tee", XC_left_tee}, - {"leftbutton", XC_leftbutton}, - {"ll_angle", XC_ll_angle}, - {"lr_angle", XC_lr_angle}, - {"man", XC_man}, - {"middlebutton", XC_middlebutton}, - {"mouse", XC_mouse}, - {"pencil", XC_pencil}, - {"pirate", XC_pirate}, - {"plus", XC_plus}, - {"question_arrow", XC_question_arrow}, - {"right_ptr", XC_right_ptr}, - {"right_side", XC_right_side}, - {"right_tee", XC_right_tee}, - {"rightbutton", XC_rightbutton}, - {"rtl_logo", XC_rtl_logo}, - {"sailboat", XC_sailboat}, - {"sb_down_arrow", XC_sb_down_arrow}, - {"sb_h_double_arrow", XC_sb_h_double_arrow}, - {"sb_left_arrow", XC_sb_left_arrow}, - {"sb_right_arrow", XC_sb_right_arrow}, - {"sb_up_arrow", XC_sb_up_arrow}, - {"sb_v_double_arrow", XC_sb_v_double_arrow}, - {"shuttle", XC_shuttle}, - {"sizing", XC_sizing}, - {"spider", XC_spider}, - {"spraycan", XC_spraycan}, - {"star", XC_star}, - {"target", XC_target}, - {"tcross", XC_tcross}, - {"top_left_arrow", XC_top_left_arrow}, - {"top_left_corner", XC_top_left_corner}, - {"top_right_corner", XC_top_right_corner}, - {"top_side", XC_top_side}, - {"top_tee", XC_top_tee}, - {"trek", XC_trek}, - {"ul_angle", XC_ul_angle}, - {"umbrella", XC_umbrella}, - {"ur_angle", XC_ur_angle}, - {"watch", XC_watch}, - {"xterm", XC_xterm}, - {NULL, 0} -}; - -/* - * Font to use for cursors: - */ - -#ifndef CURSORFONT -#define CURSORFONT "cursor" -#endif - -/* - * Forward declarations for procedures defined in this file: - */ - -static void CursorInit _ANSI_ARGS_((void)); - -/* - *---------------------------------------------------------------------- - * - * Tk_GetCursor -- - * - * Given a string describing a cursor, locate (or create if necessary) - * a cursor that fits the description. - * - * Results: - * The return value is the X identifer for the desired cursor, - * unless string couldn't be parsed correctly. In this case, - * None is returned and an error message is left in interp->result. - * The caller should never modify the cursor that is returned, and - * should eventually call Tk_FreeCursor when the cursor is no longer - * needed. - * - * Side effects: - * The cursor is added to an internal database with a reference count. - * For each call to this procedure, there should eventually be a call - * to Tk_FreeCursor, so that the database can be cleaned up when cursors - * aren't needed anymore. - * - *---------------------------------------------------------------------- - */ - -Cursor -Tk_GetCursor(interp, tkwin, string) - Tcl_Interp *interp; /* Interpreter to use for error reporting. */ - Tk_Window tkwin; /* Window in which cursor will be used. */ - Tk_Uid string; /* Description of cursor. See manual entry - * for details on legal syntax. */ -{ - NameKey nameKey; - IdKey idKey; - Tcl_HashEntry *nameHashPtr, *idHashPtr; - register TkCursor *cursorPtr; - int new; - Cursor cursor; - int argc; - char **argv = NULL; - Pixmap source = None; - Pixmap mask = None; - - if (!initialized) { - CursorInit(); - } - - nameKey.name = string; - nameKey.display = Tk_Display(tkwin); - nameHashPtr = Tcl_CreateHashEntry(&nameTable, (char *) &nameKey, &new); - if (!new) { - cursorPtr = (TkCursor *) Tcl_GetHashValue(nameHashPtr); - cursorPtr->refCount++; - return cursorPtr->cursor; - } - - /* - * No suitable cursor exists. Parse the cursor name into fields - * and create a cursor, either from the standard cursor font or - * from bitmap files. - */ - - if (Tcl_SplitList(interp, string, &argc, &argv) != TCL_OK) { - goto error; - } - if (argc == 0) { - badString: - Tcl_AppendResult(interp, "bad cursor spec \"", string, "\"", - (char *) NULL); - goto error; - } - if (argv[0][0] != '@') { - XColor fg, bg; - int maskIndex; - register struct CursorName *namePtr; - TkDisplay *dispPtr; - - /* - * The cursor is to come from the standard cursor font. If one - * arg, it is cursor name (use black and white for fg and bg). - * If two args, they are name and fg color (ignore mask). If - * three args, they are name, fg, bg. Some of the code below - * is stolen from the XCreateFontCursor Xlib procedure. - */ - - if (argc > 3) { - goto badString; - } - for (namePtr = cursorNames; ; namePtr++) { - if (namePtr->name == NULL) { - goto badString; - } - if ((namePtr->name[0] == argv[0][0]) - && (strcmp(namePtr->name, argv[0]) == 0)) { - break; - } - } - maskIndex = namePtr->shape + 1; - if (argc == 1) { - fg.red = fg.green = fg.blue = 0; - bg.red = bg.green = bg.blue = 65535; - } else { - if (XParseColor(nameKey.display, Tk_Colormap(tkwin), argv[1], - &fg) == 0) { - Tcl_AppendResult(interp, "invalid color name \"", argv[1], - "\"", (char *) NULL); - goto error; - } - if (argc == 2) { - bg.red = bg.green = bg.blue = 0; - maskIndex = namePtr->shape; - } else { - if (XParseColor(nameKey.display, Tk_Colormap(tkwin), argv[2], - &bg) == 0) { - Tcl_AppendResult(interp, "invalid color name \"", argv[2], - "\"", (char *) NULL); - goto error; - } - } - } - dispPtr = ((TkWindow *) tkwin)->dispPtr; - if (dispPtr->cursorFont == None) { - dispPtr->cursorFont = XLoadFont(nameKey.display, CURSORFONT); - if (dispPtr->cursorFont == None) { - interp->result = "couldn't load cursor font"; - goto error; - } - } - cursor = XCreateGlyphCursor(nameKey.display, dispPtr->cursorFont, - dispPtr->cursorFont, namePtr->shape, maskIndex, - &fg, &bg); - } else { - unsigned int width, height, maskWidth, maskHeight; - int xHot, yHot, dummy1, dummy2; - XColor fg, bg; - - /* - * The cursor is to be created by reading bitmap files. There - * should be either two elements in the list (source, color) or - * four (source mask fg bg). - */ - - if ((argc != 2) && (argc != 4)) { - goto badString; - } - if (XReadBitmapFile(nameKey.display, - RootWindowOfScreen(Tk_Screen(tkwin)), &argv[0][1], - &width, &height, &source, &xHot, &yHot) - != BitmapSuccess) { - Tcl_AppendResult(interp, "error reading bitmap file \"", - &argv[0][1], "\"", (char *) NULL); - goto error; - } - if ((xHot < 0) || (yHot < 0) || (xHot >= width) || (yHot >= height)) { - Tcl_AppendResult(interp, "bad hot spot in bitmap file \"", - &argv[0][1], "\"", (char *) NULL); - goto error; - } - if (argc == 2) { - if (XParseColor(nameKey.display, Tk_Colormap(tkwin), argv[1], - &fg) == 0) { - Tcl_AppendResult(interp, "invalid color name \"", - argv[1], "\"", (char *) NULL); - goto error; - } - cursor = XCreatePixmapCursor(nameKey.display, source, source, - &fg, &fg, xHot, yHot); - } else { - if (XReadBitmapFile(nameKey.display, - RootWindowOfScreen(Tk_Screen(tkwin)), argv[1], - &maskWidth, &maskHeight, &mask, &dummy1, - &dummy2) != BitmapSuccess) { - Tcl_AppendResult(interp, "error reading bitmap file \"", - argv[1], "\"", (char *) NULL); - goto error; - } - if ((maskWidth != width) && (maskHeight != height)) { - interp->result = - "source and mask bitmaps have different sizes"; - goto error; - } - if (XParseColor(nameKey.display, Tk_Colormap(tkwin), argv[2], - &fg) == 0) { - Tcl_AppendResult(interp, "invalid color name \"", argv[2], - "\"", (char *) NULL); - goto error; - } - if (XParseColor(nameKey.display, Tk_Colormap(tkwin), argv[3], - &bg) == 0) { - Tcl_AppendResult(interp, "invalid color name \"", argv[3], - "\"", (char *) NULL); - goto error; - } - cursor = XCreatePixmapCursor(nameKey.display, source, mask, - &fg, &bg, xHot, yHot); - } - } - ckfree((char *) argv); - - /* - * Add information about this cursor to our database. - */ - - cursorPtr = (TkCursor *) ckalloc(sizeof(TkCursor)); - cursorPtr->cursor = cursor; - cursorPtr->display = nameKey.display; - cursorPtr->refCount = 1; - cursorPtr->otherTable = &nameTable; - cursorPtr->hashPtr = nameHashPtr; - idKey.display = nameKey.display; - idKey.cursor = cursor; - idHashPtr = Tcl_CreateHashEntry(&idTable, (char *) &idKey, &new); - if (!new) { - panic("cursor already registered in Tk_GetCursor"); - } - Tcl_SetHashValue(nameHashPtr, cursorPtr); - Tcl_SetHashValue(idHashPtr, cursorPtr); - return cursorPtr->cursor; - - error: - Tcl_DeleteHashEntry(nameHashPtr); - if (argv != NULL) { - ckfree((char *) argv); - } - if (source != None) { - XFreePixmap(nameKey.display, source); - } - if (mask != None) { - XFreePixmap(nameKey.display, mask); - } - return None; -} - -/* - *---------------------------------------------------------------------- - * - * Tk_GetCursorFromData -- - * - * Given a description of the bits and colors for a cursor, - * make a cursor that has the given properties. - * - * Results: - * The return value is the X identifer for the desired cursor, - * unless it couldn't be created properly. In this case, None is - * returned and an error message is left in interp->result. The - * caller should never modify the cursor that is returned, and - * should eventually call Tk_FreeCursor when the cursor is no - * longer needed. - * - * Side effects: - * The cursor is added to an internal database with a reference count. - * For each call to this procedure, there should eventually be a call - * to Tk_FreeCursor, so that the database can be cleaned up when cursors - * aren't needed anymore. - * - *---------------------------------------------------------------------- - */ - -Cursor -Tk_GetCursorFromData(interp, tkwin, source, mask, width, height, - xHot, yHot, fg, bg) - Tcl_Interp *interp; /* Interpreter to use for error reporting. */ - Tk_Window tkwin; /* Window in which cursor will be used. */ - char *source; /* Bitmap data for cursor shape. */ - char *mask; /* Bitmap data for cursor mask. */ - unsigned int width, height; /* Dimensions of cursor. */ - int xHot, yHot; /* Location of hot-spot in cursor. */ - Tk_Uid fg; /* Foreground color for cursor. */ - Tk_Uid bg; /* Background color for cursor. */ -{ - DataKey dataKey; - IdKey idKey; - Tcl_HashEntry *dataHashPtr, *idHashPtr; - register TkCursor *cursorPtr; - int new; - XColor fgColor, bgColor; - Pixmap sourcePixmap, maskPixmap; - - if (!initialized) { - CursorInit(); - } - - dataKey.source = source; - dataKey.mask = mask; - dataKey.width = width; - dataKey.height = height; - dataKey.xHot = xHot; - dataKey.yHot = yHot; - dataKey.fg = fg; - dataKey.bg = bg; - dataKey.display = Tk_Display(tkwin); - dataHashPtr = Tcl_CreateHashEntry(&dataTable, (char *) &dataKey, &new); - if (!new) { - cursorPtr = (TkCursor *) Tcl_GetHashValue(dataHashPtr); - cursorPtr->refCount++; - return cursorPtr->cursor; - } - - /* - * No suitable cursor exists yet. Make one using the data - * available and add it to the database. - */ - - if (XParseColor(dataKey.display, Tk_Colormap(tkwin), fg, &fgColor) == 0) { - Tcl_AppendResult(interp, "invalid color name \"", fg, "\"", - (char *) NULL); - goto error; - } - if (XParseColor(dataKey.display, Tk_Colormap(tkwin), bg, &bgColor) == 0) { - Tcl_AppendResult(interp, "invalid color name \"", bg, "\"", - (char *) NULL); - goto error; - } - - cursorPtr = (TkCursor *) ckalloc(sizeof(TkCursor)); - sourcePixmap = XCreateBitmapFromData(dataKey.display, - RootWindowOfScreen(Tk_Screen(tkwin)), source, width, height); - maskPixmap = XCreateBitmapFromData(dataKey.display, - RootWindowOfScreen(Tk_Screen(tkwin)), mask, width, height); - cursorPtr->cursor = XCreatePixmapCursor(dataKey.display, sourcePixmap, - maskPixmap, &fgColor, &bgColor, xHot, yHot); - XFreePixmap(dataKey.display, sourcePixmap); - XFreePixmap(dataKey.display, maskPixmap); - cursorPtr->display = dataKey.display; - cursorPtr->refCount = 1; - cursorPtr->otherTable = &dataTable; - cursorPtr->hashPtr = dataHashPtr; - idKey.display = dataKey.display; - idKey.cursor = cursorPtr->cursor; - idHashPtr = Tcl_CreateHashEntry(&idTable, (char *) &idKey, &new); - if (!new) { - panic("cursor already registered in Tk_GetCursorFromData"); - } - Tcl_SetHashValue(dataHashPtr, cursorPtr); - Tcl_SetHashValue(idHashPtr, cursorPtr); - return cursorPtr->cursor; - - error: - Tcl_DeleteHashEntry(dataHashPtr); - return None; -} - -/* - *-------------------------------------------------------------- - * - * Tk_NameOfCursor -- - * - * Given a cursor, return a textual string identifying it. - * - * Results: - * If cursor was created by Tk_GetCursor, then the return - * value is the "string" that was used to create it. - * Otherwise the return value is a string giving the X - * identifier for the cursor. The storage for the returned - * string is only guaranteed to persist up until the next - * call to this procedure. - * - * Side effects: - * None. - * - *-------------------------------------------------------------- - */ - -char * -Tk_NameOfCursor(display, cursor) - Display *display; /* Display for which cursor was allocated. */ - Cursor cursor; /* Identifier for cursor whose name is - * wanted. */ -{ - IdKey idKey; - Tcl_HashEntry *idHashPtr; - TkCursor *cursorPtr; - static char string[20]; - - if (!initialized) { - printid: - sprintf(string, "cursor id 0x%x", cursor); - return string; - } - idKey.display = display; - idKey.cursor = cursor; - idHashPtr = Tcl_FindHashEntry(&idTable, (char *) &idKey); - if (idHashPtr == NULL) { - goto printid; - } - cursorPtr = (TkCursor *) Tcl_GetHashValue(idHashPtr); - if (cursorPtr->otherTable != &nameTable) { - goto printid; - } - return ((NameKey *) cursorPtr->hashPtr->key.words)->name; -} - -/* - *---------------------------------------------------------------------- - * - * Tk_FreeCursor -- - * - * This procedure is called to release a cursor allocated by - * Tk_GetCursor or TkGetCursorFromData. - * - * Results: - * None. - * - * Side effects: - * The reference count associated with cursor is decremented, and - * it is officially deallocated if no-one is using it anymore. - * - *---------------------------------------------------------------------- - */ - -void -Tk_FreeCursor(display, cursor) - Display *display; /* Display for which cursor was allocated. */ - Cursor cursor; /* Identifier for cursor to be released. */ -{ - IdKey idKey; - Tcl_HashEntry *idHashPtr; - register TkCursor *cursorPtr; - - if (!initialized) { - panic("Tk_FreeCursor called before Tk_GetCursor"); - } - - idKey.display = display; - idKey.cursor = cursor; - idHashPtr = Tcl_FindHashEntry(&idTable, (char *) &idKey); - if (idHashPtr == NULL) { - panic("Tk_FreeCursor received unknown cursor argument"); - } - cursorPtr = (TkCursor *) Tcl_GetHashValue(idHashPtr); - cursorPtr->refCount--; - if (cursorPtr->refCount == 0) { - XFreeCursor(cursorPtr->display, cursorPtr->cursor); - Tcl_DeleteHashEntry(cursorPtr->hashPtr); - Tcl_DeleteHashEntry(idHashPtr); - ckfree((char *) cursorPtr); - } -} - -/* - *---------------------------------------------------------------------- - * - * CursorInit -- - * - * Initialize the structures used for cursor management. - * - * Results: - * None. - * - * Side effects: - * Read the code. - * - *---------------------------------------------------------------------- - */ - -static void -CursorInit() -{ - initialized = 1; - Tcl_InitHashTable(&nameTable, sizeof(NameKey)/sizeof(int)); - Tcl_InitHashTable(&dataTable, sizeof(DataKey)/sizeof(int)); - - /* - * The call below is tricky: can't use sizeof(IdKey) because it - * gets padded with extra unpredictable bytes on some 64-bit - * machines. - */ - - Tcl_InitHashTable(&idTable, (sizeof(Display *) + sizeof(Cursor)) - /sizeof(int)); -} diff --git a/tk3.6/tkEvent.c b/tk3.6/tkEvent.c deleted file mode 100644 index f3eefab..0000000 --- a/tk3.6/tkEvent.c +++ /dev/null @@ -1,1701 +0,0 @@ -/* - * tkEvent.c -- - * - * This file provides basic event-managing facilities, - * whereby procedure callbacks may be attached to - * certain events. - * - * 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/wish/RCS/tkEvent.c,v 1.77 93/10/07 09:59:04 ouster Exp $ SPRITE (Berkeley)"; -#endif - -#include "tkConfig.h" -#include "tkInt.h" -#include -#include - -/* - * For each timer callback that's pending, there is one record - * of the following type, chained together in a list sorted by - * time (earliest event first). - */ - -typedef struct TimerEvent { - struct timeval time; /* When timer is to fire. */ - void (*proc) _ANSI_ARGS_((ClientData clientData)); - /* Procedure to call. */ - ClientData clientData; /* Argument to pass to proc. */ - Tk_TimerToken token; /* Identifies event so it can be - * deleted. */ - struct TimerEvent *nextPtr; /* Next event in queue, or NULL for - * end of queue. */ -} TimerEvent; - -static TimerEvent *timerQueue; /* First event in queue. */ - -/* - * The information below is used to provide read, write, and - * exception masks to select during calls to Tk_DoOneEvent. - */ - -static int readCount; /* Number of files for which we */ -static int writeCount; /* care about each event type. */ -static int exceptCount; -static fd_mask masks[3*MASK_SIZE]; - /* Integer array containing official - * copies of the three sets of - * masks. */ -static fd_mask ready[3*MASK_SIZE]; - /* Temporary copy of masks, passed - * to select and modified by kernel - * to indicate which files are - * actually ready. */ -static fd_mask *readPtr; /* Pointers to the portions of */ -static fd_mask *writePtr; /* *readyPtr for reading, writing, */ -static fd_mask *exceptPtr; /* and excepting. Will be NULL if - * corresponding count (e.g. readCount - * is zero. */ -static int numFds = 0; /* Number of valid bits in mask - * arrays (this value is passed - * to select). */ - -/* - * For each file registered in a call to Tk_CreateFileHandler, - * and for each display that's currently active, there is one - * record of the following type. All of these records are - * chained together into a single list. - */ - -typedef struct FileEvent { - int fd; /* Descriptor number for this file. */ - int isDisplay; /* Non-zero means that this file descriptor - * corresponds to a display and should be - * treated specially. */ - fd_mask *readPtr; /* Pointer to word in ready array - * for this file's read mask bit. */ - fd_mask *writePtr; /* Same for write mask bit. */ - fd_mask *exceptPtr; /* Same for except mask bit. */ - fd_mask mask; /* Value to AND with mask word to - * select just this file's bit. */ - void (*proc) _ANSI_ARGS_((ClientData clientData, int mask)); - /* Procedure to call. NULL means - * this is a display. */ - ClientData clientData; /* Argument to pass to proc. For - * displays, this is a (Display *). */ - struct FileEvent *nextPtr; /* Next in list of all files we - * care about (NULL for end of - * list). */ -} FileEvent; - -static FileEvent *fileList; /* List of all file events. */ - -/* - * There is one of the following structures for each of the - * handlers declared in a call to Tk_DoWhenIdle. All of the - * currently-active handlers are linked together into a list. - */ - -typedef struct IdleHandler { - void (*proc) _ANSI_ARGS_((ClientData clientData)); - /* Procedure to call. */ - ClientData clientData; /* Value to pass to proc. */ - int generation; /* Used to distinguish older handlers from - * recently-created ones. */ - struct IdleHandler *nextPtr;/* Next in list of active handlers. */ -} IdleHandler; - -static IdleHandler *idleList = NULL; - /* First in list of all idle handlers. */ -static IdleHandler *lastIdlePtr = NULL; - /* Last in list (or NULL for empty list). */ -static int idleGeneration = 0; /* Used to fill in the "generation" fields - * of IdleHandler structures. Increments - * each time Tk_DoOneEvent starts calling - * idle handlers, so that all old handlers - * can be called without calling any of the - * new ones created by old ones. */ - -/* - * There's a potential problem if a handler is deleted while it's - * current (i.e. its procedure is executing), since Tk_HandleEvent - * will need to read the handler's "nextPtr" field when the procedure - * returns. To handle this problem, structures of the type below - * indicate the next handler to be processed for any (recursively - * nested) dispatches in progress. The nextHandler fields get - * updated if the handlers pointed to are deleted. Tk_HandleEvent - * also needs to know if the entire window gets deleted; the winPtr - * field is set to zero if that particular window gets deleted. - */ - -typedef struct InProgress { - XEvent *eventPtr; /* Event currently being handled. */ - TkWindow *winPtr; /* Window for event. Gets set to None if - * window is deleted while event is being - * handled. */ - TkEventHandler *nextHandler; /* Next handler in search. */ - struct InProgress *nextPtr; /* Next higher nested search. */ -} InProgress; - -static InProgress *pendingPtr = NULL; - /* Topmost search in progress, or - * NULL if none. */ - -/* - * For each call to Tk_CreateGenericHandler, an instance of the following - * structure will be created. All of the active handlers are linked into a - * list. - */ - -typedef struct GenericHandler { - Tk_GenericProc *proc; /* Procedure to dispatch on all X events. */ - ClientData clientData; /* Client data to pass to procedure. */ - int deleteFlag; /* Flag to set when this handler is deleted. */ - struct GenericHandler *nextPtr; - /* Next handler in list of all generic - * handlers, or NULL for end of list. */ -} GenericHandler; - -static GenericHandler *genericList = NULL; - /* First handler in the list, or NULL. */ -static GenericHandler *lastGenericPtr = NULL; - /* Last handler in list. */ - -/* - * There's a potential problem if Tk_HandleEvent is entered recursively. - * A handler cannot be deleted physically until we have returned from - * calling it. Otherwise, we're looking at unallocated memory in advancing to - * its `next' entry. We deal with the problem by using the `delete flag' and - * deleting handlers only when it's known that there's no handler active. - * - * The following variable has a non-zero value when a handler is active. - */ - -static int genericHandlersActive = 0; - -/* - * Array of event masks corresponding to each X event: - */ - -static unsigned long eventMasks[] = { - 0, - 0, - KeyPressMask, /* KeyPress */ - KeyReleaseMask, /* KeyRelease */ - ButtonPressMask, /* ButtonPress */ - ButtonReleaseMask, /* ButtonRelease */ - PointerMotionMask|PointerMotionHintMask|ButtonMotionMask - |Button1MotionMask|Button2MotionMask|Button3MotionMask - |Button4MotionMask|Button5MotionMask, - /* MotionNotify */ - EnterWindowMask, /* EnterNotify */ - LeaveWindowMask, /* LeaveNotify */ - FocusChangeMask, /* FocusIn */ - FocusChangeMask, /* FocusOut */ - KeymapStateMask, /* KeymapNotify */ - ExposureMask, /* Expose */ - ExposureMask, /* GraphicsExpose */ - ExposureMask, /* NoExpose */ - VisibilityChangeMask, /* VisibilityNotify */ - SubstructureNotifyMask, /* CreateNotify */ - StructureNotifyMask, /* DestroyNotify */ - StructureNotifyMask, /* UnmapNotify */ - StructureNotifyMask, /* MapNotify */ - SubstructureRedirectMask, /* MapRequest */ - StructureNotifyMask, /* ReparentNotify */ - StructureNotifyMask, /* ConfigureNotify */ - SubstructureRedirectMask, /* ConfigureRequest */ - StructureNotifyMask, /* GravityNotify */ - ResizeRedirectMask, /* ResizeRequest */ - StructureNotifyMask, /* CirculateNotify */ - SubstructureRedirectMask, /* CirculateRequest */ - PropertyChangeMask, /* PropertyNotify */ - 0, /* SelectionClear */ - 0, /* SelectionRequest */ - 0, /* SelectionNotify */ - ColormapChangeMask, /* ColormapNotify */ - 0, /* ClientMessage */ - 0, /* Mapping Notify */ -}; - -/* - * If someone has called Tk_RestrictEvents, the information below - * keeps track of it. - */ - -static Bool (*restrictProc) _ANSI_ARGS_((Display *display, XEvent *eventPtr, - char *arg)); /* Procedure to call. NULL means no - * restrictProc is currently in effect. */ -static char *restrictArg; /* Argument to pass to restrictProc. */ - -/* - * The following array keeps track of the last TK_NEVENTS X events, for - * memory dump analysis. The tracing is only done if tkEventDebug is set - * to 1. - */ - -#define TK_NEVENTS 32 -static XEvent eventTrace[TK_NEVENTS]; -static int traceIndex = 0; -int tkEventDebug = 0; - -/* - *-------------------------------------------------------------- - * - * Tk_CreateEventHandler -- - * - * Arrange for a given procedure to be invoked whenever - * events from a given class occur in a given window. - * - * Results: - * None. - * - * Side effects: - * From now on, whenever an event of the type given by - * mask occurs for token and is processed by Tk_HandleEvent, - * proc will be called. See the manual entry for details - * of the calling sequence and return value for proc. - * - *-------------------------------------------------------------- - */ - -void -Tk_CreateEventHandler(token, mask, proc, clientData) - Tk_Window token; /* Token for window in which to - * create handler. */ - unsigned long mask; /* Events for which proc should - * be called. */ - Tk_EventProc *proc; /* Procedure to call for each - * selected event */ - ClientData clientData; /* Arbitrary data to pass to proc. */ -{ - register TkEventHandler *handlerPtr; - register TkWindow *winPtr = (TkWindow *) token; - int found; - - /* - * Skim through the list of existing handlers to (a) compute the - * overall event mask for the window (so we can pass this new - * value to the X system) and (b) see if there's already a handler - * declared with the same callback and clientData (if so, just - * change the mask). If no existing handler matches, then create - * a new handler. - */ - - found = 0; - if (winPtr->handlerList == NULL) { - handlerPtr = (TkEventHandler *) ckalloc( - (unsigned) sizeof(TkEventHandler)); - winPtr->handlerList = handlerPtr; - goto initHandler; - } else { - for (handlerPtr = winPtr->handlerList; ; - handlerPtr = handlerPtr->nextPtr) { - if ((handlerPtr->proc == proc) - && (handlerPtr->clientData == clientData)) { - handlerPtr->mask = mask; - found = 1; - } - if (handlerPtr->nextPtr == NULL) { - break; - } - } - } - - /* - * Create a new handler if no matching old handler was found. - */ - - if (!found) { - handlerPtr->nextPtr = (TkEventHandler *) - ckalloc(sizeof(TkEventHandler)); - handlerPtr = handlerPtr->nextPtr; - initHandler: - handlerPtr->mask = mask; - handlerPtr->proc = proc; - handlerPtr->clientData = clientData; - handlerPtr->nextPtr = NULL; - } - - /* - * No need to call XSelectInput: Tk always selects on all events - * for all windows (needed to support bindings on classes and "all"). - */ -} - -/* - *-------------------------------------------------------------- - * - * Tk_DeleteEventHandler -- - * - * Delete a previously-created handler. - * - * Results: - * None. - * - * Side effects: - * If there existed a handler as described by the - * parameters, the handler is deleted so that proc - * will not be invoked again. - * - *-------------------------------------------------------------- - */ - -void -Tk_DeleteEventHandler(token, mask, proc, clientData) - Tk_Window token; /* Same as corresponding arguments passed */ - unsigned long mask; /* previously to Tk_CreateEventHandler. */ - Tk_EventProc *proc; - ClientData clientData; -{ - register TkEventHandler *handlerPtr; - register InProgress *ipPtr; - TkEventHandler *prevPtr; - register TkWindow *winPtr = (TkWindow *) token; - - /* - * Find the event handler to be deleted, or return - * immediately if it doesn't exist. - */ - - for (handlerPtr = winPtr->handlerList, prevPtr = NULL; ; - prevPtr = handlerPtr, handlerPtr = handlerPtr->nextPtr) { - if (handlerPtr == NULL) { - return; - } - if ((handlerPtr->mask == mask) && (handlerPtr->proc == proc) - && (handlerPtr->clientData == clientData)) { - break; - } - } - - /* - * If Tk_HandleEvent is about to process this handler, tell it to - * process the next one instead. - */ - - for (ipPtr = pendingPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { - if (ipPtr->nextHandler == handlerPtr) { - ipPtr->nextHandler = handlerPtr->nextPtr; - } - } - - /* - * Free resources associated with the handler. - */ - - if (prevPtr == NULL) { - winPtr->handlerList = handlerPtr->nextPtr; - } else { - prevPtr->nextPtr = handlerPtr->nextPtr; - } - ckfree((char *) handlerPtr); - - - /* - * No need to call XSelectInput: Tk always selects on all events - * for all windows (needed to support bindings on classes and "all"). - */ -} - -/*-------------------------------------------------------------- - * - * Tk_CreateGenericHandler -- - * - * Register a procedure to be called on each X event, regardless - * of display or window. Generic handlers are useful for capturing - * events that aren't associated with windows, or events for windows - * not managed by Tk. - * - * Results: - * None. - * - * Side Effects: - * From now on, whenever an X event is given to Tk_HandleEvent, - * invoke proc, giving it clientData and the event as arguments. - * - *-------------------------------------------------------------- - */ - -void -Tk_CreateGenericHandler(proc, clientData) - Tk_GenericProc *proc; /* Procedure to call on every event. */ - ClientData clientData; /* One-word value to pass to proc. */ -{ - GenericHandler *handlerPtr; - - handlerPtr = (GenericHandler *) ckalloc (sizeof (GenericHandler)); - - handlerPtr->proc = proc; - handlerPtr->clientData = clientData; - handlerPtr->deleteFlag = 0; - handlerPtr->nextPtr = NULL; - if (genericList == NULL) { - genericList = handlerPtr; - } else { - lastGenericPtr->nextPtr = handlerPtr; - } - lastGenericPtr = handlerPtr; -} - -/* - *-------------------------------------------------------------- - * - * Tk_DeleteGenericHandler -- - * - * Delete a previously-created generic handler. - * - * Results: - * None. - * - * Side Effects: - * If there existed a handler as described by the parameters, - * that handler is logically deleted so that proc will not be - * invoked again. The physical deletion happens in the event - * loop in Tk_HandleEvent. - * - *-------------------------------------------------------------- - */ - -void -Tk_DeleteGenericHandler(proc, clientData) - Tk_GenericProc *proc; - ClientData clientData; -{ - GenericHandler * handler; - - for (handler = genericList; handler; handler = handler->nextPtr) { - if ((handler->proc == proc) && (handler->clientData == clientData)) { - handler->deleteFlag = 1; - } - } -} - -/* - *-------------------------------------------------------------- - * - * Tk_HandleEvent -- - * - * Given an event, invoke all the handlers that have - * been registered for the event. - * - * Results: - * None. - * - * Side effects: - * Depends on the handlers. - * - *-------------------------------------------------------------- - */ - -void -Tk_HandleEvent(eventPtr) - XEvent *eventPtr; /* Event to dispatch. */ -{ - register TkEventHandler *handlerPtr; - register GenericHandler *genericPtr; - register GenericHandler *genPrevPtr; - TkWindow *winPtr; - register unsigned long mask; - InProgress ip; - Window handlerWindow; - - /* - * First off, look for a special trigger event left around by the - * grab module. If it's found, call the grab module and discard - * the event. - */ - - if ((eventPtr->xany.type == -1) && (eventPtr->xany.window == None)) { - TkGrabTriggerProc(eventPtr); - return; - } - - /* - * Next, invoke all the generic event handlers (those that are - * invoked for all events). If a generic event handler reports that - * an event is fully processed, go no further. - */ - - for (genPrevPtr = NULL, genericPtr = genericList; genericPtr != NULL; ) { - if (genericPtr->deleteFlag) { - if (!genericHandlersActive) { - GenericHandler *tmpPtr; - - /* - * This handler needs to be deleted and there are no - * calls pending through the handler, so now is a safe - * time to delete it. - */ - - tmpPtr = genericPtr->nextPtr; - if (genPrevPtr == NULL) { - genericList = tmpPtr; - } else { - genPrevPtr->nextPtr = tmpPtr; - } - if (tmpPtr == NULL) { - lastGenericPtr = genPrevPtr; - } - (void) ckfree((char *) genericPtr); - genericPtr = tmpPtr; - continue; - } - } else { - int done; - - genericHandlersActive++; - done = (*genericPtr->proc)(genericPtr->clientData, eventPtr); - genericHandlersActive--; - if (done) { - return; - } - } - genPrevPtr = genericPtr; - genericPtr = genPrevPtr->nextPtr; - } - - /* - * If the event is a MappingNotify event, find its display and - * refresh the keyboard mapping information for the display. - * After that there's nothing else to do with the event, so just - * quit. - */ - - if (eventPtr->type == MappingNotify) { - TkDisplay *dispPtr; - - for (dispPtr = tkDisplayList; dispPtr != NULL; - dispPtr = dispPtr->nextPtr) { - if (dispPtr->display != eventPtr->xmapping.display) { - continue; - } - XRefreshKeyboardMapping(&eventPtr->xmapping); - dispPtr->bindInfoStale = 1; - break; - } - return; - } - - /* - * Events selected by StructureNotify look the same as those - * selected by SubstructureNotify; the only difference is - * whether the "event" and "window" fields are the same. - * Check it out and convert StructureNotify to - * SubstructureNotify if necessary. - */ - - handlerWindow = eventPtr->xany.window; - mask = eventMasks[eventPtr->xany.type]; - if (mask == StructureNotifyMask) { - if (eventPtr->xmap.event != eventPtr->xmap.window) { - mask = SubstructureNotifyMask; - handlerWindow = eventPtr->xmap.event; - } - } - if (XFindContext(eventPtr->xany.display, handlerWindow, - tkWindowContext, (caddr_t *) &winPtr) != 0) { - - /* - * There isn't a TkWindow structure for this window. - * However, if the event is a PropertyNotify event then call - * the selection manager (it deals beneath-the-table with - * certain properties). - */ - - if (eventPtr->type == PropertyNotify) { - TkSelPropProc(eventPtr); - } - return; - } - - /* - * Call focus-related code to look at FocusIn, FocusOut, Enter, - * and Leave events; depending on its return value, ignore the - * event. - */ - - if ((mask & (FocusChangeMask|EnterWindowMask|LeaveWindowMask)) - && !TkFocusFilterEvent(winPtr, eventPtr)) { - return; - } - - /* - * Redirect KeyPress and KeyRelease events to the focus window, - * or ignore them entirely if there is no focus window. Map the - * x and y coordinates to make sense in the context of the focus - * window, if possible (make both -1 if the map-from and map-to - * windows don't share the same screen). - */ - - if (mask & (KeyPressMask|KeyReleaseMask)) { - TkWindow *focusPtr; - int winX, winY, focusX, focusY; - - winPtr->dispPtr->lastEventTime = eventPtr->xkey.time; - if (winPtr->mainPtr->focusPtr == NULL) { - return; - } - focusPtr = winPtr->mainPtr->focusPtr; - if ((focusPtr->display != winPtr->display) - || (focusPtr->screenNum != winPtr->screenNum)) { - eventPtr->xkey.x = -1; - eventPtr->xkey.y = -1; - } else { - Tk_GetRootCoords((Tk_Window) winPtr, &winX, &winY); - Tk_GetRootCoords((Tk_Window) focusPtr, &focusX, &focusY); - eventPtr->xkey.x -= focusX - winX; - eventPtr->xkey.y -= focusY - winY; - } - eventPtr->xkey.window = focusPtr->window; - winPtr = focusPtr; - } - - /* - * Call a grab-related procedure to do special processing on - * pointer events. - */ - - if (mask & (ButtonPressMask|ButtonReleaseMask|PointerMotionMask - |EnterWindowMask|LeaveWindowMask)) { - if (mask & (ButtonPressMask|ButtonReleaseMask)) { - winPtr->dispPtr->lastEventTime = eventPtr->xbutton.time; - } else if (mask & PointerMotionMask) { - winPtr->dispPtr->lastEventTime = eventPtr->xmotion.time; - } else { - winPtr->dispPtr->lastEventTime = eventPtr->xcrossing.time; - } - if (TkPointerEvent(eventPtr, winPtr) == 0) { - return; - } - } - - /* - * For events where it hasn't already been done, update the current - * time in the display. - */ - - if (eventPtr->type == PropertyNotify) { - winPtr->dispPtr->lastEventTime = eventPtr->xproperty.time; - } - - /* - * There's a potential interaction here with Tk_DeleteEventHandler. - * Read the documentation for pendingPtr. - */ - - ip.eventPtr = eventPtr; - ip.winPtr = winPtr; - ip.nextHandler = NULL; - ip.nextPtr = pendingPtr; - pendingPtr = &ip; - if (mask == 0) { - if ((eventPtr->type == SelectionClear) - || (eventPtr->type == SelectionRequest) - || (eventPtr->type == SelectionNotify)) { - TkSelEventProc((Tk_Window) winPtr, eventPtr); - } else if ((eventPtr->type == ClientMessage) - && (eventPtr->xclient.message_type == - Tk_InternAtom((Tk_Window) winPtr, "WM_PROTOCOLS"))) { - TkWmProtocolEventProc(winPtr, eventPtr); - } - } else { - for (handlerPtr = winPtr->handlerList; handlerPtr != NULL; ) { - if ((handlerPtr->mask & mask) != 0) { - ip.nextHandler = handlerPtr->nextPtr; - (*(handlerPtr->proc))(handlerPtr->clientData, eventPtr); - handlerPtr = ip.nextHandler; - } else { - handlerPtr = handlerPtr->nextPtr; - } - } - - /* - * Pass the event to the "bind" command mechanism. But, don't - * do this for SubstructureNotify events. The "bind" command - * doesn't support them anyway, and it's easier to filter out - * these events here than in the lower-level procedures. - */ - - if ((ip.winPtr != None) && (mask != SubstructureNotifyMask)) { - TkBindEventProc(winPtr, eventPtr); - } - } - pendingPtr = ip.nextPtr; -} - -/* - *-------------------------------------------------------------- - * - * Tk_CreateFileHandler -- - * - * Arrange for a given procedure to be invoked whenever - * a given file becomes readable or writable. - * - * Results: - * None. - * - * Side effects: - * From now on, whenever the I/O channel given by fd becomes - * ready in the way indicated by mask, proc will be invoked. - * See the manual entry for details on the calling sequence - * to proc. If fd is already registered then the old mask - * and proc and clientData values will be replaced with - * new ones. - * - *-------------------------------------------------------------- - */ - -void -Tk_CreateFileHandler(fd, mask, proc, clientData) - int fd; /* Integer identifier for stream. */ - int mask; /* OR'ed combination of TK_READABLE, - * TK_WRITABLE, and TK_EXCEPTION: - * indicates conditions under which - * proc should be called. TK_IS_DISPLAY - * indicates that this is a display and that - * clientData is the (Display *) for it, - * and that events should be handled - * automatically.*/ - Tk_FileProc *proc; /* Procedure to call for each - * selected event. */ - ClientData clientData; /* Arbitrary data to pass to proc. */ -{ - register FileEvent *filePtr; - int index; - - if (fd >= OPEN_MAX) { - panic("Tk_CreatefileHandler can't handle file id %d", fd); - } - - /* - * Make sure the file isn't already registered. Create a - * new record in the normal case where there's no existing - * record. - */ - - for (filePtr = fileList; filePtr != NULL; - filePtr = filePtr->nextPtr) { - if (filePtr->fd == fd) { - break; - } - } - index = fd/(NBBY*sizeof(fd_mask)); - if (filePtr == NULL) { - filePtr = (FileEvent *) ckalloc(sizeof(FileEvent)); - filePtr->fd = fd; - filePtr->isDisplay = 0; - filePtr->readPtr = &ready[index]; - filePtr->writePtr = &ready[index+MASK_SIZE]; - filePtr->exceptPtr = &ready[index+2*MASK_SIZE]; - filePtr->mask = 1 << (fd%(NBBY*sizeof(fd_mask))); - filePtr->nextPtr = fileList; - fileList = filePtr; - } else { - if (masks[index] & filePtr->mask) { - readCount--; - *filePtr->readPtr &= ~filePtr->mask; - masks[index] &= ~filePtr->mask; - } - if (masks[index+MASK_SIZE] & filePtr->mask) { - writeCount--; - *filePtr->writePtr &= ~filePtr->mask; - masks[index+MASK_SIZE] &= ~filePtr->mask; - } - if (masks[index+2*MASK_SIZE] & filePtr->mask) { - exceptCount--; - *filePtr->exceptPtr &= ~filePtr->mask; - masks[index+2*MASK_SIZE] &= ~filePtr->mask; - } - } - - /* - * The remainder of the initialization below is done - * regardless of whether or not this is a new record - * or a modification of an old one. - */ - - if (mask & TK_READABLE) { - masks[index] |= filePtr->mask; - readCount++; - } - readPtr = (readCount == 0) ? (fd_mask *) NULL : &ready[0]; - - if (mask & TK_WRITABLE) { - masks[index+MASK_SIZE] |= filePtr->mask; - writeCount++; - } - writePtr = (writeCount == 0) ? (fd_mask *) NULL : &ready[MASK_SIZE]; - - if (mask & TK_EXCEPTION) { - masks[index+2*MASK_SIZE] |= filePtr->mask; - exceptCount++; - } - exceptPtr = (exceptCount == 0) ? (fd_mask *) NULL : &ready[2*MASK_SIZE]; - - if (mask & TK_IS_DISPLAY) { - filePtr->isDisplay = 1; - } else { - filePtr->isDisplay = 0; - } - - filePtr->proc = proc; - filePtr->clientData = clientData; - - if (numFds <= fd) { - numFds = fd+1; - } -} - -/* - *-------------------------------------------------------------- - * - * Tk_DeleteFileHandler -- - * - * Cancel a previously-arranged callback arrangement for - * a file. - * - * Results: - * None. - * - * Side effects: - * If a callback was previously registered on fd, remove it. - * - *-------------------------------------------------------------- - */ - -void -Tk_DeleteFileHandler(fd) - int fd; /* Stream id for which to remove - * callback procedure. */ -{ - register FileEvent *filePtr; - FileEvent *prevPtr; - int index; - - /* - * Find the entry for the given file (and return if there - * isn't one). - */ - - for (prevPtr = NULL, filePtr = fileList; ; - prevPtr = filePtr, filePtr = filePtr->nextPtr) { - if (filePtr == NULL) { - return; - } - if (filePtr->fd == fd) { - break; - } - } - - /* - * Clean up information in the callback record. - */ - - index = filePtr->fd/(NBBY*sizeof(fd_mask)); - if (masks[index] & filePtr->mask) { - readCount--; - *filePtr->readPtr &= ~filePtr->mask; - masks[index] &= ~filePtr->mask; - } - if (masks[index+MASK_SIZE] & filePtr->mask) { - writeCount--; - *filePtr->writePtr &= ~filePtr->mask; - masks[index+MASK_SIZE] &= ~filePtr->mask; - } - if (masks[index+2*MASK_SIZE] & filePtr->mask) { - exceptCount--; - *filePtr->exceptPtr &= ~filePtr->mask; - masks[index+2*MASK_SIZE] &= ~filePtr->mask; - } - if (prevPtr == NULL) { - fileList = filePtr->nextPtr; - } else { - prevPtr->nextPtr = filePtr->nextPtr; - } - ckfree((char *) filePtr); - - /* - * Recompute numFds. - */ - - numFds = 0; - for (filePtr = fileList; filePtr != NULL; - filePtr = filePtr->nextPtr) { - if (numFds <= filePtr->fd) { - numFds = filePtr->fd+1; - } - } -} - -/* - *-------------------------------------------------------------- - * - * Tk_CreateTimerHandler -- - * - * Arrange for a given procedure to be invoked at a particular - * time in the future. - * - * Results: - * The return value is a token for the timer event, which - * may be used to delete the event before it fires. - * - * Side effects: - * When milliseconds have elapsed, proc will be invoked - * exactly once. - * - *-------------------------------------------------------------- - */ - -Tk_TimerToken -Tk_CreateTimerHandler(milliseconds, proc, clientData) - int milliseconds; /* How many milliseconds to wait - * before invoking proc. */ - Tk_TimerProc *proc; /* Procedure to invoke. */ - ClientData clientData; /* Arbitrary data to pass to proc. */ -{ - register TimerEvent *timerPtr, *tPtr2, *prevPtr; - static int id = 0; - - timerPtr = (TimerEvent *) ckalloc(sizeof(TimerEvent)); - - /* - * Compute when the event should fire. - */ - - (void) gettimeofday(&timerPtr->time, (struct timezone *) NULL); - timerPtr->time.tv_sec += milliseconds/1000; - timerPtr->time.tv_usec += (milliseconds%1000)*1000; - if (timerPtr->time.tv_usec > 1000000) { - timerPtr->time.tv_usec -= 1000000; - timerPtr->time.tv_sec += 1; - } - - /* - * Fill in other fields for the event. - */ - - timerPtr->proc = proc; - timerPtr->clientData = clientData; - id++; - timerPtr->token = (Tk_TimerToken) id; - - /* - * Add the event to the queue in the correct position - * (ordered by event firing time). - */ - - for (tPtr2 = timerQueue, prevPtr = NULL; tPtr2 != NULL; - prevPtr = tPtr2, tPtr2 = tPtr2->nextPtr) { - if ((tPtr2->time.tv_sec > timerPtr->time.tv_sec) - || ((tPtr2->time.tv_sec == timerPtr->time.tv_sec) - && (tPtr2->time.tv_usec > timerPtr->time.tv_usec))) { - break; - } - } - if (prevPtr == NULL) { - timerPtr->nextPtr = timerQueue; - timerQueue = timerPtr; - } else { - timerPtr->nextPtr = prevPtr->nextPtr; - prevPtr->nextPtr = timerPtr; - } - return timerPtr->token; -} - -/* - *-------------------------------------------------------------- - * - * Tk_DeleteTimerHandler -- - * - * Delete a previously-registered timer handler. - * - * Results: - * None. - * - * Side effects: - * Destroy the timer callback identified by TimerToken, - * so that its associated procedure will not be called. - * If the callback has already fired, or if the given - * token doesn't exist, then nothing happens. - * - *-------------------------------------------------------------- - */ - -void -Tk_DeleteTimerHandler(token) - Tk_TimerToken token; /* Result previously returned by - * Tk_DeleteTimerHandler. */ -{ - register TimerEvent *timerPtr, *prevPtr; - - for (timerPtr = timerQueue, prevPtr = NULL; timerPtr != NULL; - prevPtr = timerPtr, timerPtr = timerPtr->nextPtr) { - if (timerPtr->token != token) { - continue; - } - if (prevPtr == NULL) { - timerQueue = timerPtr->nextPtr; - } else { - prevPtr->nextPtr = timerPtr->nextPtr; - } - ckfree((char *) timerPtr); - return; - } -} - -/* - *-------------------------------------------------------------- - * - * Tk_DoWhenIdle -- - * - * Arrange for proc to be invoked the next time the - * system is idle (i.e., just before the next time - * that Tk_DoOneEvent would have to wait for something - * to happen). - * - * Results: - * None. - * - * Side effects: - * Proc will eventually be called, with clientData - * as argument. See the manual entry for details. - * - *-------------------------------------------------------------- - */ - -void -Tk_DoWhenIdle(proc, clientData) - Tk_IdleProc *proc; /* Procedure to invoke. */ - ClientData clientData; /* Arbitrary value to pass to proc. */ -{ - register IdleHandler *idlePtr; - - idlePtr = (IdleHandler *) ckalloc(sizeof(IdleHandler)); - idlePtr->proc = proc; - idlePtr->clientData = clientData; - idlePtr->generation = idleGeneration; - idlePtr->nextPtr = NULL; - if (lastIdlePtr == NULL) { - idleList = idlePtr; - } else { - lastIdlePtr->nextPtr = idlePtr; - } - lastIdlePtr = idlePtr; -} - -/* - *---------------------------------------------------------------------- - * - * Tk_CancelIdleCall -- - * - * If there are any when-idle calls requested to a given procedure - * with given clientData, cancel all of them. - * - * Results: - * None. - * - * Side effects: - * If the proc/clientData combination were on the when-idle list, - * they are removed so that they will never be called. - * - *---------------------------------------------------------------------- - */ - -void -Tk_CancelIdleCall(proc, clientData) - Tk_IdleProc *proc; /* Procedure that was previously registered. */ - ClientData clientData; /* Arbitrary value to pass to proc. */ -{ - register IdleHandler *idlePtr, *prevPtr; - IdleHandler *nextPtr; - - for (prevPtr = NULL, idlePtr = idleList; idlePtr != NULL; - prevPtr = idlePtr, idlePtr = idlePtr->nextPtr) { - while ((idlePtr->proc == proc) - && (idlePtr->clientData == clientData)) { - nextPtr = idlePtr->nextPtr; - ckfree((char *) idlePtr); - idlePtr = nextPtr; - if (prevPtr == NULL) { - idleList = idlePtr; - } else { - prevPtr->nextPtr = idlePtr; - } - if (idlePtr == NULL) { - lastIdlePtr = prevPtr; - return; - } - } - } -} - -/* - *-------------------------------------------------------------- - * - * Tk_DoOneEvent -- - * - * Process a single event of some sort. If there's no - * work to do, wait for an event to occur, then process - * it. - * - * Results: - * The return value is 1 if the procedure actually found - * an event to process. If no event was found then 0 is - * returned. - * - * Side effects: - * May delay execution of process while waiting for an - * X event, X error, file-ready event, or timer event. - * The handling of the event could cause additional - * side effects. Collapses sequences of mouse-motion - * events for the same window into a single event by - * delaying motion event processing. - * - *-------------------------------------------------------------- - */ - -int -Tk_DoOneEvent(flags) - int flags; /* Miscellaneous flag values: may be any - * combination of TK_DONT_WAIT, TK_X_EVENTS, - * TK_FILE_EVENTS, TK_TIMER_EVENTS, and - * TK_IDLE_EVENTS. */ -{ - register FileEvent *filePtr; - struct timeval curTime, timeout, *timeoutPtr; - int numFound; - static XEvent delayedMotionEvent; /* Used to hold motion events that - * are being saved until later. */ - static int eventDelayed = 0; /* Non-zero means there is an event - * in delayedMotionEvent. */ - - if ((flags & TK_ALL_EVENTS) == 0) { - flags |= TK_ALL_EVENTS; - } - - /* - * Phase One: see if there's already something ready - * (either a file or a display) that was left over - * from before (i.e don't do a select, just check the - * bits from the last select). - */ - - checkFiles: - if (tcl_AsyncReady) { - (void) Tcl_AsyncInvoke((Tcl_Interp *) NULL, 0); - return 1; - } - for (filePtr = fileList; filePtr != NULL; - filePtr = filePtr->nextPtr) { - int mask; - - /* - * Displays: flush output, check for queued events, - * and read events from the server if display is ready. - * If there are any events, process one and then - * return. - */ - - if (filePtr->isDisplay) { - Display *display = (Display *) filePtr->clientData; - XEvent event; - - if (!(flags & TK_X_EVENTS)) { - continue; - } - XFlush(display); - if ((*filePtr->readPtr) & filePtr->mask) { - *filePtr->readPtr &= ~filePtr->mask; - if (XEventsQueued(display, QueuedAfterReading) == 0) { - - /* - * Things are very tricky if there aren't any events - * readable at this point (after all, there was - * supposedly data available on the connection). - * A couple of things could have occurred: - * - * One possibility is that there were only error events - * in the input from the server. If this happens, - * we should return (we don't want to go to sleep - * in XNextEvent below, since this would block out - * other sources of input to the process). - * - * Another possibility is that our connection to the - * server has been closed. This will not necessarily - * be detected in XEventsQueued (!!), so if we just - * return then there will be an infinite loop. To - * detect such an error, generate a NoOp protocol - * request to exercise the connection to the server, - * then return. However, must disable SIGPIPE while - * sending the event, or else the process will die - * from the signal and won't invoke the X error - * function to print a nice message. - */ - - void (*oldHandler)(); - - oldHandler = (void (*)()) signal(SIGPIPE, SIG_IGN); - XNoOp(display); - XFlush(display); - (void) signal(SIGPIPE, oldHandler); - return 1; - } - if (restrictProc != NULL) { - if (!XCheckIfEvent(display, &event, restrictProc, - restrictArg)) { - return 1; - } - } else { - XNextEvent(display, &event); - } - } else { - if (QLength(display) == 0) { - continue; - } - if (restrictProc != NULL) { - if (!XCheckIfEvent(display, &event, restrictProc, - restrictArg)) { - continue; - } - } else { - XNextEvent(display, &event); - } - } - - /* - * Got an event. Deal with mouse-motion-collapsing and - * event-delaying here. If there's already an event delayed, - * then process that event if it's incompatible with the new - * event (new event not mouse motion, or window changed, or - * state changed). If the new event is mouse motion, then - * don't process it now; delay it until later in the hopes - * that it can be merged with other mouse motion events - * immediately following. - */ - - if (tkEventDebug) { - eventTrace[traceIndex] = event; - traceIndex = (traceIndex+1) % TK_NEVENTS; - } - - if (eventDelayed) { - if (((event.type != MotionNotify) - && (event.type != GraphicsExpose) - && (event.type != NoExpose) - && (event.type != Expose)) - || (event.xmotion.display - != delayedMotionEvent.xmotion.display) - || (event.xmotion.window - != delayedMotionEvent.xmotion.window)) { - XEvent copy; - - /* - * Must copy the event out of delayedMotionEvent before - * processing it, in order to allow recursive calls to - * Tk_DoOneEvent as part of the handler. - */ - - copy = delayedMotionEvent; - eventDelayed = 0; - Tk_HandleEvent(©); - } - } - if (event.type == MotionNotify) { - delayedMotionEvent = event; - eventDelayed = 1; - } else { - Tk_HandleEvent(&event); - } - return 1; - } - - /* - * Not a display: if the file is ready, call the - * appropriate handler. - */ - - if (((*filePtr->readPtr | *filePtr->writePtr - | *filePtr->exceptPtr) & filePtr->mask) == 0) { - continue; - } - if (!(flags & TK_FILE_EVENTS)) { - continue; - } - mask = 0; - if (*filePtr->readPtr & filePtr->mask) { - mask |= TK_READABLE; - *filePtr->readPtr &= ~filePtr->mask; - } - if (*filePtr->writePtr & filePtr->mask) { - mask |= TK_WRITABLE; - *filePtr->writePtr &= ~filePtr->mask; - } - if (*filePtr->exceptPtr & filePtr->mask) { - mask |= TK_EXCEPTION; - *filePtr->exceptPtr &= ~filePtr->mask; - } - (*filePtr->proc)(filePtr->clientData, mask); - return 1; - } - - /* - * Phase Two: get the current time and see if any timer - * events are ready to fire. If so, fire one and return. - */ - - checkTime: - if ((timerQueue != NULL) && (flags & TK_TIMER_EVENTS)) { - register TimerEvent *timerPtr = timerQueue; - - (void) gettimeofday(&curTime, (struct timezone *) NULL); - if ((timerPtr->time.tv_sec < curTime.tv_sec) - || ((timerPtr->time.tv_sec == curTime.tv_sec) - && (timerPtr->time.tv_usec < curTime.tv_usec))) { - timerQueue = timerPtr->nextPtr; - (*timerPtr->proc)(timerPtr->clientData); - ckfree((char *) timerPtr); - return 1; - } - } - - - /* - * Phase Three: if there is a delayed motion event, process it - * now, before any DoWhenIdle handlers. Better to process before - * idle handlers than after, because the goal of idle handlers is - * to delay until after all pending events have been processed. - * Must free up delayedMotionEvent *before* calling Tk_HandleEvent, - * so that the event handler can call Tk_DoOneEvent recursively - * without infinite looping. - */ - - if ((eventDelayed) && (flags & TK_X_EVENTS)) { - XEvent copy; - - copy = delayedMotionEvent; - eventDelayed = 0; - Tk_HandleEvent(©); - return 1; - } - - /* - * Phase Four: if there are DoWhenIdle requests pending (or - * if we're not allowed to block), then do a select with an - * instantaneous timeout. If a ready file is found, then go - * back to process it. - */ - - if (((idleList != NULL) && (flags & TK_IDLE_EVENTS)) - || (flags & TK_DONT_WAIT)) { - if (flags & (TK_X_EVENTS|TK_FILE_EVENTS)) { - memcpy((VOID *) ready, (VOID *) masks, - 3*MASK_SIZE*sizeof(fd_mask)); - timeout.tv_sec = timeout.tv_usec = 0; - numFound = select(numFds, (SELECT_MASK *) readPtr, - (SELECT_MASK *) writePtr, (SELECT_MASK *) exceptPtr, - &timeout); - if (numFound == -1) { - /* - * Some systems don't clear the masks after an error, so - * we have to do it here. - */ - - memset((VOID *) ready, 0, 3*MASK_SIZE*sizeof(fd_mask)); - } - if ((numFound > 0) || ((numFound == -1) && (errno == EINTR))) { - goto checkFiles; - } - } - } - - /* - * Phase Five: process all pending DoWhenIdle requests. - */ - - if ((idleList != NULL) && (flags & TK_IDLE_EVENTS)) { - register IdleHandler *idlePtr; - int oldGeneration; - - oldGeneration = idleList->generation; - idleGeneration++; - - /* - * The code below is trickier than it may look, for the following - * reasons: - * - * 1. New handlers can get added to the list while the current - * one is being processed. If new ones get added, we don't - * want to process them during this pass through the list (want - * to check for other work to do first). This is implemented - * using the generation number in the handler: new handlers - * will have a different generation than any of the ones currently - * on the list. - * 2. The handler can call Tk_DoOneEvent, so we have to remove - * the hander from the list before calling it. Otherwise an - * infinite loop could result. - * 3. Tk_CancelIdleCall can be called to remove an element from - * the list while a handler is executing, so the list could - * change structure during the call. - */ - - for (idlePtr = idleList; - ((idlePtr != NULL) && (idlePtr->generation == oldGeneration)); - idlePtr = idleList) { - idleList = idlePtr->nextPtr; - if (idleList == NULL) { - lastIdlePtr = NULL; - } - (*idlePtr->proc)(idlePtr->clientData); - ckfree((char *) idlePtr); - } - return 1; - } - - /* - * Phase Six: do a select to wait for either one of the - * files to become ready or for the first timer event to - * fire. Then go back to process the event. - */ - - if ((flags & TK_DONT_WAIT) - || !(flags & (TK_TIMER_EVENTS|TK_FILE_EVENTS|TK_X_EVENTS))) { - return 0; - } - if ((timerQueue == NULL) || !(flags & TK_TIMER_EVENTS)) { - timeoutPtr = NULL; - } else { - timeoutPtr = &timeout; - timeout.tv_sec = timerQueue->time.tv_sec - curTime.tv_sec; - timeout.tv_usec = timerQueue->time.tv_usec - curTime.tv_usec; - if (timeout.tv_usec < 0) { - timeout.tv_sec -= 1; - timeout.tv_usec += 1000000; - } - } - memcpy((VOID *) ready, (VOID *) masks, 3*MASK_SIZE*sizeof(fd_mask)); - numFound = select(numFds, (SELECT_MASK *) readPtr, - (SELECT_MASK *) writePtr, (SELECT_MASK *) exceptPtr, - timeoutPtr); - if (numFound == -1) { - /* - * Some systems don't clear the masks after an error, so - * we have to do it here. - */ - - memset((VOID *) ready, 0, 3*MASK_SIZE*sizeof(fd_mask)); - } - if (numFound == 0) { - goto checkTime; - } - goto checkFiles; -} - -/* - *-------------------------------------------------------------- - * - * Tk_MainLoop -- - * - * Call Tk_DoOneEvent over and over again in an infinite - * loop as long as there exist any main windows. - * - * Results: - * None. - * - * Side effects: - * Arbitrary; depends on handlers for events. - * - *-------------------------------------------------------------- - */ - -void -Tk_MainLoop() -{ - while (tk_NumMainWindows > 0) { - Tk_DoOneEvent(0); - } -} - -/* - *---------------------------------------------------------------------- - * - * Tk_Sleep -- - * - * Delay execution for the specified number of milliseconds. - * - * Results: - * None. - * - * Side effects: - * Time passes. - * - *---------------------------------------------------------------------- - */ - -void -Tk_Sleep(ms) - int ms; /* Number of milliseconds to sleep. */ -{ - static struct timeval delay; - - delay.tv_sec = ms/1000; - delay.tv_usec = (ms%1000)*1000; - (void) select(0, (SELECT_MASK *) 0, (SELECT_MASK *) 0, - (SELECT_MASK *) 0, &delay); -} - -/* - *---------------------------------------------------------------------- - * - * Tk_RestrictEvents -- - * - * This procedure is used to globally restrict the set of events - * that will be dispatched. The restriction is done by filtering - * all incoming X events through a procedure that determines - * whether they are to be processed immediately or deferred. - * - * Results: - * The return value is the previous restriction procedure in effect, - * if there was one, or NULL if there wasn't. - * - * Side effects: - * From now on, proc will be called to determine whether to process - * or defer each incoming X event. - * - *---------------------------------------------------------------------- - */ - -Tk_RestrictProc * -Tk_RestrictEvents(proc, arg, prevArgPtr) - Tk_RestrictProc *proc; /* X "if" procedure to call for each - * incoming event. See "XIfEvent" doc. - * for details. */ - char *arg; /* Arbitrary argument to pass to proc. */ - char **prevArgPtr; /* Place to store information about previous - * argument. */ -{ - Bool (*prev) _ANSI_ARGS_((Display *display, XEvent *eventPtr, char *arg)); - - prev = restrictProc; - *prevArgPtr = restrictArg; - restrictProc = proc; - restrictArg = arg; - return prev; -} - -/* - *-------------------------------------------------------------- - * - * TkEventDeadWindow -- - * - * This procedure is invoked when it is determined that - * a window is dead. It cleans up event-related information - * about the window. - * - * Results: - * None. - * - * Side effects: - * Various things get cleaned up and recycled. - * - *-------------------------------------------------------------- - */ - -void -TkEventDeadWindow(winPtr) - TkWindow *winPtr; /* Information about the window - * that is being deleted. */ -{ - register TkEventHandler *handlerPtr; - register InProgress *ipPtr; - - /* - * While deleting all the handlers, be careful to check for - * Tk_HandleEvent being about to process one of the deleted - * handlers. If it is, tell it to quit (all of the handlers - * are being deleted). - */ - - while (winPtr->handlerList != NULL) { - handlerPtr = winPtr->handlerList; - winPtr->handlerList = handlerPtr->nextPtr; - for (ipPtr = pendingPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { - if (ipPtr->nextHandler == handlerPtr) { - ipPtr->nextHandler = NULL; - } - if (ipPtr->winPtr == winPtr) { - ipPtr->winPtr = None; - } - } - ckfree((char *) handlerPtr); - } -} - -/* - *---------------------------------------------------------------------- - * - * TkCurrentTime -- - * - * Try to deduce the current time. "Current time" means the time - * of the event that led to the current code being executed, which - * means the time in the most recently-nested invocation of - * Tk_HandleEvent. - * - * Results: - * The return value is the time from the current event, or - * CurrentTime if there is no current event or if the current - * event contains no time. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -Time -TkCurrentTime(dispPtr) - TkDisplay *dispPtr; /* Display for which the time is desired. */ -{ - register XEvent *eventPtr; - - if (pendingPtr == NULL) { - return dispPtr->lastEventTime; - } - eventPtr = pendingPtr->eventPtr; - switch (eventPtr->type) { - case ButtonPress: - case ButtonRelease: - return eventPtr->xbutton.time; - case KeyPress: - case KeyRelease: - return eventPtr->xkey.time; - case MotionNotify: - return eventPtr->xmotion.time; - case EnterNotify: - case LeaveNotify: - return eventPtr->xcrossing.time; - case PropertyNotify: - return eventPtr->xproperty.time; - } - return dispPtr->lastEventTime; -} diff --git a/tk3.6/tkFocus.c b/tk3.6/tkFocus.c deleted file mode 100644 index 4f67ba1..0000000 --- a/tk3.6/tkFocus.c +++ /dev/null @@ -1,501 +0,0 @@ -/* - * tkFocus.c -- - * - * This file contains procedures that manage the input - * focus for Tk. - * - * 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/wish/RCS/tkFocus.c,v 1.7 93/06/16 17:16:47 ouster Exp $ SPRITE (Berkeley)"; -#endif - -#include "tkInt.h" -#include "tkConfig.h" - -/* - * Magic value stored in "send_event" field to mark a FocusIn or FocusOut - * event generated by this file. It indicates to TkFilterFocusEvent that - * it shouldn't process this event. - */ - -#define GENERATED_EVENT 0x123abcde - -/* - * Forward declarations for procedures defined in this file: - */ - -static void ChangeFocusTopLevelPtr _ANSI_ARGS_((TkDisplay *dispPtr, - TkWindow *winPtr, int mode)); -static void QueueFocusEvent _ANSI_ARGS_((TkWindow *winPtr, - int type, int mode, int detail)); -static void SetFocus _ANSI_ARGS_((TkWindow *winPtr, - TkWindow *focusPtr)); - -/* - *-------------------------------------------------------------- - * - * Tk_CreateFocusHandler -- - * - * Arrange for a procedure to be called whenever the focus - * enters or leaves a given window. - * - * Results: - * None. - * - * Side effects: - * After this procedure has been invoked, whenever tkwin gets - * or loses the input focus, proc will be called. It should have - * the following structure: - * - * void - * proc(clientData, gotFocus) - * ClientData clientData; - * int gotFocus; - * { - * } - * - * The clientData argument to "proc" will be the same as the - * clientData argument to this procedure. GotFocus will be - * 1 if tkwin is getting the focus, and 0 if it's losing the - * focus. - * - *-------------------------------------------------------------- - */ - -void -Tk_CreateFocusHandler(tkwin, proc, clientData) - Tk_Window tkwin; /* Token for window. */ - Tk_FocusProc *proc; /* Procedure to call when tkwin gets - * or loses the input focus. */ - ClientData clientData; /* Arbitrary value to pass to proc. */ -{ - register TkWindow *winPtr = (TkWindow *) tkwin; - - winPtr->focusProc = proc; - winPtr->focusData = clientData; -} - -/* - *-------------------------------------------------------------- - * - * Tk_FocusCmd -- - * - * This procedure is invoked to process the "focus" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *-------------------------------------------------------------- - */ - -int -Tk_FocusCmd(clientData, interp, argc, argv) - ClientData clientData; /* Main window associated with - * interpreter. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - Tk_Window tkwin = (Tk_Window) clientData; - register TkWindow *winPtr = (TkWindow *) clientData; - register TkWindow *newPtr; - char c; - int length; - - /* - * If invoked with no arguments, just return the current focus window. - */ - - if (argc == 1) { - if (winPtr->mainPtr->focusPtr == NULL) { - interp->result = "none"; - } else { - interp->result = winPtr->mainPtr->focusPtr->pathName; - } - return TCL_OK; - } - - /* - * If invoked with a single argument beginning with "." then focus - * on that window. - */ - - if ((argc == 2) && (argv[1][0] == '.')) { - newPtr = (TkWindow *) Tk_NameToWindow(interp, argv[1], tkwin); - if (newPtr == NULL) { - return TCL_ERROR; - } - SetFocus(winPtr, newPtr); - return TCL_OK; - } - - length = strlen(argv[1]); - c = argv[1][0]; - if ((c == 'd') && (strncmp(argv[1], "default", length) == 0)) { - if (argc > 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " default ?window?\"", (char *) NULL); - return TCL_ERROR; - } - if (argc == 2) { - if (winPtr->mainPtr->focusDefaultPtr == NULL) { - interp->result = "none"; - } else { - interp->result = winPtr->mainPtr->focusDefaultPtr->pathName; - } - return TCL_OK; - } - if ((argv[2][0] == 'n') - && (strncmp(argv[2], "none", strlen(argv[2])) == 0)) { - newPtr = NULL; - } else { - newPtr = (TkWindow *) Tk_NameToWindow(interp, argv[2], tkwin); - if (newPtr == NULL) { - return TCL_ERROR; - } - } - winPtr->mainPtr->focusDefaultPtr = newPtr; - } else if ((c == 'n') && (strncmp(argv[1], "none", length) == 0)) { - if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " none\"", (char *) NULL); - return TCL_ERROR; - } - SetFocus(winPtr, (TkWindow *) NULL); - } else { - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be default or none", (char *) NULL); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *-------------------------------------------------------------- - * - * TkFocusFilterEvent -- - * - * This procedure is invoked by Tk_HandleEvent when it encounters - * a FocusIn, FocusOut, Enter, or Leave event. - * - * Results: - * A return value of 1 means that Tk_HandleEvent should process - * the event normally (i.e. event handlers should be invoked). - * A return value of 0 means that this event should be ignored. - * - * Side effects: - * An additional event may be generated and processed. - * - *-------------------------------------------------------------- - */ - -int -TkFocusFilterEvent(winPtr, eventPtr) - register TkWindow *winPtr; /* Window that focus event is directed to. */ - XEvent *eventPtr; /* FocusIn or FocusOut event. */ -{ - if ((eventPtr->type == FocusIn) || (eventPtr->type == FocusOut)) { - /* - * If this event was generated by us then just process it - * normally. - */ - - if (eventPtr->xfocus.send_event == GENERATED_EVENT) { - eventPtr->xfocus.send_event = 1; - return 1; - } - - /* - * Ignore the focus event if any of the following things is - * true: - * - * 1. The event isn't for a top-level window. - * 2. The event has detail NotifyInferior (which means the - * focus moved around within the top-level window; it - * didn't move between the top-level window and the - * outside world. - * 3. The event has detail NotifyPointer (I don't really understand - * what these events are for, but they don't seem to serve - * any useful purpose). - */ - - if (!(winPtr->flags & TK_TOP_LEVEL) - || (eventPtr->xfocus.detail == NotifyInferior) - || (eventPtr->xfocus.detail == NotifyPointer)) { - return 0; - } - - /* - * This is a useful event. Notify both the top-level window - * and the window that has been assigned the focus by the Tk - * "focus" command. - */ - - if (eventPtr->type == FocusOut) { - ChangeFocusTopLevelPtr(winPtr->dispPtr, (TkWindow *) NULL, - eventPtr->xfocus.mode); - } else { - ChangeFocusTopLevelPtr(winPtr->dispPtr, winPtr, - eventPtr->xfocus.mode); - } - - /* - * This particular event should now be ignored, since we just - * generated events to notify all of the relevant windows. - */ - - return 0; - } else { - /* - * This is an Enter or Leave event. If there's no window manager, - * or if the window manager is not moving the focus around (e.g. - * if the disgusting "NoTitleFocus" option has been selected in - * twm), then we won't get FocusIn or FocusOut events. Instead, - * watch enter and leave events. If an Enter event arrives for a - * top-level window with its focus field set, but we don't have a - * record of a FocusIn event, then simulate one. If a Leave event - * arrives and focus was set for the window via an Enter event, - * then simulate a FocusOut event. - */ - - if ((eventPtr->type == EnterNotify) && (winPtr->flags & TK_TOP_LEVEL) - && eventPtr->xcrossing.focus - && (eventPtr->xcrossing.detail != NotifyInferior) - && (winPtr->dispPtr->focusTopLevelPtr != winPtr)) { - ChangeFocusTopLevelPtr(winPtr->dispPtr, winPtr, - eventPtr->xcrossing.mode); - winPtr->dispPtr->focussedOnEnter = 1; - } else if ((eventPtr->type == LeaveNotify) - && (winPtr->dispPtr->focussedOnEnter) - && (eventPtr->xcrossing.detail != NotifyInferior) - && (winPtr->dispPtr->focusTopLevelPtr == winPtr)) { - ChangeFocusTopLevelPtr(winPtr->dispPtr, (TkWindow *) NULL, - eventPtr->xcrossing.mode); - } - return 1; - } -} - -/* - *---------------------------------------------------------------------- - * - * ChangeFocusTopLevelPtr -- - * - * This procedure is invoked to change the focusTopLevelPtr field - * of a display. It notifies the old focus window, if any, and - * the new one. - * - * Results: - * None. - * - * Side effects: - * Windows get notified, and they can do just about anything - * as part of the notification. - * - *---------------------------------------------------------------------- - */ - -static void -ChangeFocusTopLevelPtr(dispPtr, winPtr, mode) - TkDisplay *dispPtr; /* Display whose focus top-level - * changed. */ - TkWindow *winPtr; /* Top-level window that is to be the - * new focus top-level for display. - * If NULL, clears the old focus - * window without setting a new one. */ - int mode; /* Mode to use for generated events: - * NotifyNormal, NotifyGrab, or - * NotifyUngrab. */ -{ - TkWindow *focusPtr; - - if (dispPtr->focusTopLevelPtr == winPtr) { - /* - * The focus is already where it's supposed to be, so there's - * nothing else to do. - */ - return; - } - - if (dispPtr->focusTopLevelPtr != NULL) { - focusPtr = dispPtr->focusTopLevelPtr->mainPtr->focusPtr; - if (focusPtr != NULL) { - QueueFocusEvent(focusPtr, FocusOut, mode, NotifyAncestor); - } - QueueFocusEvent(dispPtr->focusTopLevelPtr, FocusOut, mode, - NotifyVirtual); - } - if (winPtr != NULL) { - focusPtr = winPtr->mainPtr->focusPtr; - QueueFocusEvent(winPtr, FocusIn, mode, NotifyVirtual); - if (focusPtr != NULL) { - QueueFocusEvent(focusPtr, FocusIn, mode, NotifyAncestor); - } - } - dispPtr->focusTopLevelPtr = winPtr; - dispPtr->focussedOnEnter = 0; -} - -/* - *---------------------------------------------------------------------- - * - * SetFocus -- - * - * This procedure is invoked to change the focus window for - * an application. - * - * Results: - * None. - * - * Side effects: - * Event handlers may be invoked to process the change of - * focus. - * - *---------------------------------------------------------------------- - */ - -static void -SetFocus(winPtr, focusPtr) - TkWindow *winPtr; /* Window that identifies the application - * whose focus is to change. */ - TkWindow *focusPtr; /* Window that is to be the new focus for - * the application. May be NULL. */ -{ - if (winPtr->mainPtr->focusPtr == focusPtr) { - return; - } - if ((winPtr->dispPtr->focusTopLevelPtr != NULL) && - (winPtr->mainPtr == winPtr->dispPtr->focusTopLevelPtr->mainPtr)) { - if (winPtr->mainPtr->focusPtr != NULL) { - QueueFocusEvent(winPtr->mainPtr->focusPtr, FocusOut, - NotifyNormal, NotifyAncestor); - } - if (focusPtr != NULL) { - QueueFocusEvent(focusPtr, FocusIn, NotifyNormal, NotifyAncestor); - } - } - winPtr->mainPtr->focusPtr = focusPtr; -} - -/* - *---------------------------------------------------------------------- - * - * QueueFocusEvent -- - * - * This procedure implements the mechanics of notifying a window - * that has just gotten or lost the focus. It generates an - * appropriate X event, queues it to be process before any other - * events from the server (but after any other queued events), - * and also uses the (now obsolete) mechanism of calling a focus - * procedure. - * - * Results: - * None. - * - * Side effects: - * Depends on the actions associated with the focus event and - * procedure callback. - * - *---------------------------------------------------------------------- - */ - -static void -QueueFocusEvent(winPtr, type, mode, detail) - TkWindow *winPtr; /* Window that's getting or losing focus. */ - int type; /* FocusIn or FocusOut: tells whether - * winPtr is getting or losing the focus. */ - int mode; /* Mode to use for event: NotifyNormal, - * NotifyGrab, or NotifyUngrab. */ - int detail; /* Detail to use for event: NotifyAncestor - * for the ultimate destination of the focus, - * and NotifyVirtual for the top-level window - * that actually got the X focus. */ -{ - XEvent event; - - if (winPtr->flags & TK_ALREADY_DEAD) { - /* - * Window is in the process of being destroyed so quit (otherwise - * the code below may recreate the window!). - */ - return; - } - Tk_MakeWindowExist((Tk_Window) winPtr); - - /* - * Generate an event for the focus change and process the event. - */ - - event.type = type; - event.xfocus.serial = LastKnownRequestProcessed(winPtr->display); - event.xfocus.send_event = GENERATED_EVENT; - event.xfocus.display = winPtr->display; - event.xfocus.window = winPtr->window; - event.xfocus.mode = mode; - event.xfocus.detail = detail; - TkQueueEvent(winPtr->dispPtr, &event); - - if ((detail == NotifyAncestor) && (winPtr->focusProc != NULL)) { - (*winPtr->focusProc)(winPtr->focusData, (type == FocusIn)); - } -} - -/* - *---------------------------------------------------------------------- - * - * TkFocusDeadWindow -- - * - * This procedure is invoked when it is determined that - * a window is dead. It cleans up focus-related information - * about the window. - * - * Results: - * None. - * - * Side effects: - * Various things get cleaned up and recycled. - * - *---------------------------------------------------------------------- - */ - -void -TkFocusDeadWindow(winPtr) - register TkWindow *winPtr; /* Information about the window - * that is being deleted. */ -{ - if (winPtr->mainPtr != NULL) { - if (winPtr->mainPtr->focusDefaultPtr == winPtr) { - winPtr->mainPtr->focusDefaultPtr = NULL; - } - if (winPtr->mainPtr->focusPtr == winPtr) { - SetFocus(winPtr, winPtr->mainPtr->focusDefaultPtr); - } - } - if (winPtr->dispPtr->focusTopLevelPtr == winPtr) { - winPtr->dispPtr->focusTopLevelPtr = NULL; - } -} diff --git a/tk3.6/tkFrame.c b/tk3.6/tkFrame.c deleted file mode 100644 index 8b9126e..0000000 --- a/tk3.6/tkFrame.c +++ /dev/null @@ -1,552 +0,0 @@ -/* - * tkFrame.c -- - * - * This module implements "frame" widgets for the Tk - * toolkit. Frames are windows with a background color - * and possibly a 3-D effect, but no other attributes. - * - * 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/wish/RCS/tkFrame.c,v 1.36 93/09/24 15:19:38 ouster Exp $ SPRITE (Berkeley)"; -#endif - -#include "default.h" -#include "tkConfig.h" -#include "tkInt.h" - -/* - * A data structure of the following type is kept for each - * frame that currently exists for this process: - */ - -typedef struct { - Tk_Window tkwin; /* Window that embodies the frame. NULL - * means that the window has been destroyed - * but the data structures haven't yet been - * cleaned up.*/ - Display *display; /* Display containing widget. Used, among - * other things, so that resources can be - * freed even after tkwin has gone away. */ - Tcl_Interp *interp; /* Interpreter associated with - * widget. Used to delete widget - * command. */ - Tk_3DBorder border; /* Structure used to draw 3-D border and - * background. */ - int borderWidth; /* Width of 3-D border (if any). */ - int relief; /* 3-d effect: TK_RELIEF_RAISED etc. */ - int width; /* Width to request for window. <= 0 means - * don't request any size. */ - int height; /* Height to request for window. <= 0 means - * don't request any size. */ - char *geometry; /* Geometry that user requested. NULL - * means use width and height instead. - * Malloc'ed. */ - Cursor cursor; /* Current cursor for window, or None. */ - int flags; /* Various flags; see below for - * definitions. */ -} Frame; - -/* - * Flag bits for frames: - * - * REDRAW_PENDING: Non-zero means a DoWhenIdle handler - * has already been queued to redraw - * this window. - * CLEAR_NEEDED; Need to clear the window when redrawing. - */ - -#define REDRAW_PENDING 1 -#define CLEAR_NEEDED 2 - -static Tk_ConfigSpec configSpecs[] = { - {TK_CONFIG_BORDER, "-background", "background", "Background", - DEF_FRAME_BG_COLOR, Tk_Offset(Frame, border), TK_CONFIG_COLOR_ONLY}, - {TK_CONFIG_BORDER, "-background", "background", "Background", - DEF_FRAME_BG_MONO, Tk_Offset(Frame, border), TK_CONFIG_MONO_ONLY}, - {TK_CONFIG_SYNONYM, "-bd", "borderWidth", (char *) NULL, - (char *) NULL, 0, 0}, - {TK_CONFIG_SYNONYM, "-bg", "background", (char *) NULL, - (char *) NULL, 0, 0}, - {TK_CONFIG_PIXELS, "-borderwidth", "borderWidth", "BorderWidth", - DEF_FRAME_BORDER_WIDTH, Tk_Offset(Frame, borderWidth), 0}, - {TK_CONFIG_ACTIVE_CURSOR, "-cursor", "cursor", "Cursor", - DEF_FRAME_CURSOR, Tk_Offset(Frame, cursor), TK_CONFIG_NULL_OK}, - {TK_CONFIG_STRING, "-geometry", "geometry", "Geometry", - DEF_FRAME_GEOMETRY, Tk_Offset(Frame, geometry), TK_CONFIG_NULL_OK}, - {TK_CONFIG_PIXELS, "-height", "height", "Height", - DEF_FRAME_HEIGHT, Tk_Offset(Frame, height), 0}, - {TK_CONFIG_RELIEF, "-relief", "relief", "Relief", - DEF_FRAME_RELIEF, Tk_Offset(Frame, relief), 0}, - {TK_CONFIG_PIXELS, "-width", "width", "Width", - DEF_FRAME_WIDTH, Tk_Offset(Frame, width), 0}, - {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, - (char *) NULL, 0, 0} -}; - -/* - * Forward declarations for procedures defined later in this file: - */ - -static int ConfigureFrame _ANSI_ARGS_((Tcl_Interp *interp, - Frame *framePtr, int argc, char **argv, int flags)); -static void DestroyFrame _ANSI_ARGS_((ClientData clientData)); -static void DisplayFrame _ANSI_ARGS_((ClientData clientData)); -static void FrameEventProc _ANSI_ARGS_((ClientData clientData, - XEvent *eventPtr)); -static int FrameWidgetCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -static void MapFrame _ANSI_ARGS_((ClientData clientData)); - -/* - *-------------------------------------------------------------- - * - * Tk_FrameCmd -- - * - * This procedure is invoked to process the "frame" and - * "toplevel" Tcl commands. See the user documentation for - * details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *-------------------------------------------------------------- - */ - -int -Tk_FrameCmd(clientData, interp, argc, argv) - ClientData clientData; /* Main window associated with - * interpreter. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - Tk_Window tkwin = (Tk_Window) clientData; - Tk_Window new; - Tk_Uid screenUid; - char *className, *screen; - int src, dst; - - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " pathName ?options?\"", (char *) NULL); - return TCL_ERROR; - } - - /* - * The code below is a special hack that extracts a few key - * options from the argument list now, rather than letting - * ConfigureFrame do it. This is necessary because we have - * to know the window's screen (if it's top-level) and its - * class before creating the window. - */ - - screen = NULL; - className = (argv[0][0] == 't') ? "Toplevel" : "Frame"; - for (src = 2, dst = 2; src < argc; src += 2) { - char c; - - c = argv[src][1]; - if ((c == 'c') - && (strncmp(argv[src], "-class", strlen(argv[src])) == 0)) { - className = argv[src+1]; - } else if ((argv[0][0] == 't') && (c == 's') - && (strncmp(argv[src], "-screen", strlen(argv[src])) == 0)) { - screen = argv[src+1]; - } else { - argv[dst] = argv[src]; - argv[dst+1] = argv[src+1]; - dst += 2; - } - } - argc -= src-dst; - - /* - * Provide a default screen for top-level windows (same as screen - * of parent window). - */ - - if ((argv[0][0] == 't') && (screen == NULL)) { - screen = ""; - } - if (screen != NULL) { - screenUid = Tk_GetUid(screen); - } else { - screenUid = NULL; - } - - /* - * Create the window and initialize our structures and event handlers. - */ - - new = Tk_CreateWindowFromPath(interp, tkwin, argv[1], screenUid); - if (new == NULL) { - return TCL_ERROR; - } - Tk_SetClass(new, className); - return TkInitFrame(interp, new, (screenUid != NULL), argc-2, argv+2); -} - -/* - *---------------------------------------------------------------------- - * - * TkInitFrame -- - * - * This procedure initializes a frame or toplevel widget. It's - * separate from Tk_FrameCmd so that it can be used for the - * main window, which has already been created elsewhere. - * - * Results: - * A standard Tcl completion code. - * - * Side effects: - * A widget record gets allocated, handlers get set up, etc.. - * - *---------------------------------------------------------------------- - */ - -int -TkInitFrame(interp, tkwin, toplevel, argc, argv) - Tcl_Interp *interp; /* Interpreter associated with the - * application. */ - Tk_Window tkwin; /* Window to use for frame or - * top-level. Caller must already - * have set window's class. */ - int toplevel; /* Non-zero means that this is a - * top-level window, 0 means it's a - * frame. */ - int argc; /* Number of configuration arguments - * (not including class command and - * window name). */ - char *argv[]; /* Configuration arguments. */ -{ - register Frame *framePtr; - - framePtr = (Frame *) ckalloc(sizeof(Frame)); - framePtr->tkwin = tkwin; - framePtr->display = Tk_Display(tkwin); - framePtr->interp = interp; - framePtr->border = NULL; - framePtr->borderWidth = 0; - framePtr->relief = TK_RELIEF_FLAT; - framePtr->width = 0; - framePtr->height = 0; - framePtr->geometry = NULL; - framePtr->cursor = None; - framePtr->flags = 0; - Tk_CreateEventHandler(framePtr->tkwin, ExposureMask|StructureNotifyMask, - FrameEventProc, (ClientData) framePtr); - Tcl_CreateCommand(interp, Tk_PathName(framePtr->tkwin), - FrameWidgetCmd, (ClientData) framePtr, (void (*)()) NULL); - - if (ConfigureFrame(interp, framePtr, argc, argv, 0) != TCL_OK) { - Tk_DestroyWindow(framePtr->tkwin); - return TCL_ERROR; - } - if (toplevel) { - Tk_DoWhenIdle(MapFrame, (ClientData) framePtr); - } - interp->result = Tk_PathName(framePtr->tkwin); - return TCL_OK; -} - -/* - *-------------------------------------------------------------- - * - * FrameWidgetCmd -- - * - * This procedure is invoked to process the Tcl command - * that corresponds to a frame widget. See the user - * documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *-------------------------------------------------------------- - */ - -static int -FrameWidgetCmd(clientData, interp, argc, argv) - ClientData clientData; /* Information about frame widget. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - register Frame *framePtr = (Frame *) clientData; - int result = TCL_OK; - int length; - char c; - - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " option ?arg arg ...?\"", (char *) NULL); - return TCL_ERROR; - } - Tk_Preserve((ClientData) framePtr); - c = argv[1][0]; - length = strlen(argv[1]); - if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0)) { - if (argc == 2) { - result = Tk_ConfigureInfo(interp, framePtr->tkwin, configSpecs, - (char *) framePtr, (char *) NULL, 0); - } else if (argc == 3) { - result = Tk_ConfigureInfo(interp, framePtr->tkwin, configSpecs, - (char *) framePtr, argv[2], 0); - } else { - result = ConfigureFrame(interp, framePtr, argc-2, argv+2, - TK_CONFIG_ARGV_ONLY); - } - } else { - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be configure", (char *) NULL); - result = TCL_ERROR; - } - Tk_Release((ClientData) framePtr); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * DestroyFrame -- - * - * This procedure is invoked by Tk_EventuallyFree or Tk_Release - * to clean up the internal structure of a frame at a safe time - * (when no-one is using it anymore). - * - * Results: - * None. - * - * Side effects: - * Everything associated with the frame is freed up. - * - *---------------------------------------------------------------------- - */ - -static void -DestroyFrame(clientData) - ClientData clientData; /* Info about frame widget. */ -{ - register Frame *framePtr = (Frame *) clientData; - - Tk_FreeOptions(configSpecs, (char *) framePtr, framePtr->display, 0); - ckfree((char *) framePtr); -} - -/* - *---------------------------------------------------------------------- - * - * ConfigureFrame -- - * - * This procedure is called to process an argv/argc list, plus - * the Tk option database, in order to configure (or - * reconfigure) a frame widget. - * - * Results: - * The return value is a standard Tcl result. If TCL_ERROR is - * returned, then interp->result contains an error message. - * - * Side effects: - * Configuration information, such as text string, colors, font, - * etc. get set for framePtr; old resources get freed, if there - * were any. - * - *---------------------------------------------------------------------- - */ - -static int -ConfigureFrame(interp, framePtr, argc, argv, flags) - Tcl_Interp *interp; /* Used for error reporting. */ - register Frame *framePtr; /* Information about widget; may or may - * not already have values for some fields. */ - int argc; /* Number of valid entries in argv. */ - char **argv; /* Arguments. */ - int flags; /* Flags to pass to Tk_ConfigureWidget. */ -{ - if (Tk_ConfigureWidget(interp, framePtr->tkwin, configSpecs, - argc, argv, (char *) framePtr, flags) != TCL_OK) { - return TCL_ERROR; - } - - Tk_SetBackgroundFromBorder(framePtr->tkwin, framePtr->border); - Tk_SetInternalBorder(framePtr->tkwin, framePtr->borderWidth); - if (framePtr->geometry != NULL) { - int height, width; - - if (sscanf(framePtr->geometry, "%dx%d", &width, &height) != 2) { - Tcl_AppendResult(interp, "bad geometry \"", framePtr->geometry, - "\": expected widthxheight", (char *) NULL); - return TCL_ERROR; - } - Tk_GeometryRequest(framePtr->tkwin, width, height); - } else if ((framePtr->width > 0) || (framePtr->height > 0)) { - Tk_GeometryRequest(framePtr->tkwin, framePtr->width, - framePtr->height); - } - - if (Tk_IsMapped(framePtr->tkwin) - && !(framePtr->flags & REDRAW_PENDING)) { - Tk_DoWhenIdle(DisplayFrame, (ClientData) framePtr); - framePtr->flags |= REDRAW_PENDING|CLEAR_NEEDED; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * DisplayFrame -- - * - * This procedure is invoked to display a frame widget. - * - * Results: - * None. - * - * Side effects: - * Commands are output to X to display the frame in its - * current mode. - * - *---------------------------------------------------------------------- - */ - -static void -DisplayFrame(clientData) - ClientData clientData; /* Information about widget. */ -{ - register Frame *framePtr = (Frame *) clientData; - register Tk_Window tkwin = framePtr->tkwin; - - framePtr->flags &= ~REDRAW_PENDING; - if ((framePtr->tkwin == NULL) || !Tk_IsMapped(tkwin)) { - return; - } - - if (framePtr->flags & CLEAR_NEEDED) { - XClearWindow(framePtr->display, Tk_WindowId(tkwin)); - framePtr->flags &= ~CLEAR_NEEDED; - } - if ((framePtr->border != NULL) - && (framePtr->relief != TK_RELIEF_FLAT)) { - Tk_Draw3DRectangle(framePtr->display, Tk_WindowId(tkwin), - framePtr->border, 0, 0, Tk_Width(tkwin), Tk_Height(tkwin), - framePtr->borderWidth, framePtr->relief); - } -} - -/* - *-------------------------------------------------------------- - * - * FrameEventProc -- - * - * This procedure is invoked by the Tk dispatcher on - * structure changes to a frame. For frames with 3D - * borders, this procedure is also invoked for exposures. - * - * Results: - * None. - * - * Side effects: - * When the window gets deleted, internal structures get - * cleaned up. When it gets exposed, it is redisplayed. - * - *-------------------------------------------------------------- - */ - -static void -FrameEventProc(clientData, eventPtr) - ClientData clientData; /* Information about window. */ - register XEvent *eventPtr; /* Information about event. */ -{ - register Frame *framePtr = (Frame *) clientData; - - if ((eventPtr->type == Expose) && (eventPtr->xexpose.count == 0)) { - if ((framePtr->relief != TK_RELIEF_FLAT) && (framePtr->tkwin != NULL) - && !(framePtr->flags & REDRAW_PENDING)) { - Tk_DoWhenIdle(DisplayFrame, (ClientData) framePtr); - framePtr->flags |= REDRAW_PENDING; - } - } else if (eventPtr->type == DestroyNotify) { - Tcl_DeleteCommand(framePtr->interp, Tk_PathName(framePtr->tkwin)); - framePtr->tkwin = NULL; - if (framePtr->flags & REDRAW_PENDING) { - Tk_CancelIdleCall(DisplayFrame, (ClientData) framePtr); - } - Tk_CancelIdleCall(MapFrame, (ClientData) framePtr); - Tk_EventuallyFree((ClientData) framePtr, DestroyFrame); - } -} - -/* - *---------------------------------------------------------------------- - * - * MapFrame -- - * - * This procedure is invoked as a when-idle handler to map a - * newly-created top-level frame. - * - * Results: - * None. - * - * Side effects: - * The frame given by the clientData argument is mapped. - * - *---------------------------------------------------------------------- - */ - -static void -MapFrame(clientData) - ClientData clientData; /* Pointer to frame structure. */ -{ - Frame *framePtr = (Frame *) clientData; - - /* - * Wait for all other background events to be processed before - * mapping window. This ensures that the window's correct geometry - * will have been determined before it is first mapped, so that the - * window manager doesn't get a false idea of its desired geometry. - */ - - Tk_Preserve((ClientData) framePtr); - while (1) { - if (Tk_DoOneEvent(TK_IDLE_EVENTS) == 0) { - break; - } - - /* - * After each event, make sure that the window still exists - * and quit if the window has been destroyed. - */ - - if (framePtr->tkwin == NULL) { - Tk_Release((ClientData) framePtr); - return; - } - } - Tk_MapWindow(framePtr->tkwin); - Tk_Release((ClientData) framePtr); -} diff --git a/tk3.6/tkGeometry.c b/tk3.6/tkGeometry.c deleted file mode 100644 index 0b0e665..0000000 --- a/tk3.6/tkGeometry.c +++ /dev/null @@ -1,170 +0,0 @@ -/* - * tkGeometry.c -- - * - * This file contains code generic Tk code for geometry - * management, plus code to manage the geometry of top-level - * windows (by reflecting information up to the window - * manager). - * - * 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/wish/RCS/tkGeometry.c,v 1.19 93/06/16 17:15:00 ouster Exp $ SPRITE (Berkeley)"; -#endif - -#include "tkConfig.h" -#include "tkInt.h" - -/* - *-------------------------------------------------------------- - * - * Tk_ManageGeometry -- - * - * Arrange for a particular procedure to handle geometry - * requests for a given window. - * - * Results: - * None. - * - * Side effects: - * Proc becomes the new geometry manager for tkwin, replacing - * any previous geometry manager. In the future, whenever - * Tk_GeometryRequest is called for tkwin, proc will be - * invoked to handle the request. Proc should have the - * following structure: - * - * void - * proc(clientData, tkwin) - * { - * } - * - * The clientData argument will be the same as the clientData - * argument to this procedure, and the tkwin arguments will - * be the same as the corresponding argument to - * Tk_GeometryRequest. Information about the desired - * geometry for tkwin is avilable to proc using macros such - * as Tk_ReqWidth. Proc should do the best it can to meet - * the request within the constraints of its geometry-management - * algorithm, but it is not obligated to meet the request. - * - *-------------------------------------------------------------- - */ - -void -Tk_ManageGeometry(tkwin, proc, clientData) - Tk_Window tkwin; /* Window whose geometry is to - * be managed by proc. */ - Tk_GeometryProc *proc; /* Procedure to manage geometry. - * NULL means make tkwin unmanaged. */ - ClientData clientData; /* Arbitrary one-word argument to - * pass to proc. */ -{ - register TkWindow *winPtr = (TkWindow *) tkwin; - - winPtr->geomProc = proc; - winPtr->geomData = clientData; -} - -/* - *-------------------------------------------------------------- - * - * Tk_GeometryRequest -- - * - * This procedure is invoked by widget code to indicate - * its preferences about the size of a window it manages. - * In general, widget code should call this procedure - * rather than Tk_ResizeWindow. - * - * Results: - * None. - * - * Side effects: - * The geometry manager for tkwin (if any) is invoked to - * handle the request. If possible, it will reconfigure - * tkwin and/or other windows to satisfy the request. The - * caller gets no indication of success or failure, but it - * will get X events if the window size was actually - * changed. - * - *-------------------------------------------------------------- - */ - -void -Tk_GeometryRequest(tkwin, reqWidth, reqHeight) - Tk_Window tkwin; /* Window that geometry information - * pertains to. */ - int reqWidth, reqHeight; /* Minimum desired dimensions for - * window, in pixels. */ -{ - register TkWindow *winPtr = (TkWindow *) tkwin; - - if ((reqWidth == winPtr->reqWidth) && (reqHeight == winPtr->reqHeight)) { - return; - } - winPtr->reqWidth = reqWidth; - winPtr->reqHeight = reqHeight; - if (winPtr->geomProc != NULL) { - (*winPtr->geomProc)(winPtr->geomData, tkwin); - } -} - -/* - *---------------------------------------------------------------------- - * - * Tk_SetInternalBorder -- - * - * Notify relevant geometry managers that a window has an internal - * border of a given width and that child windows should not be - * placed on that border. - * - * Results: - * None. - * - * Side effects: - * The border width is recorded for the window, and all geometry - * managers of all children are notified so that can re-layout, if - * necessary. - * - *---------------------------------------------------------------------- - */ - -void -Tk_SetInternalBorder(tkwin, width) - Tk_Window tkwin; /* Window that will have internal border. */ - int width; /* Width of internal border, in pixels. */ -{ - register TkWindow *winPtr = (TkWindow *) tkwin; - - if (width == winPtr->internalBorderWidth) { - return; - } - if (width < 0) { - width = 0; - } - winPtr->internalBorderWidth = width; - for (winPtr = winPtr->childList; winPtr != NULL; - winPtr = winPtr->nextPtr) { - if (winPtr->geomProc != NULL) { - (*winPtr->geomProc)(winPtr->geomData, (Tk_Window) winPtr); - } - } -} diff --git a/tk3.6/tkInt.h b/tk3.6/tkInt.h deleted file mode 100644 index e80803f..0000000 --- a/tk3.6/tkInt.h +++ /dev/null @@ -1,626 +0,0 @@ -/* - * tkInt.h -- - * - * Declarations for things used internally by the Tk - * procedures but not exported outside the module. - * - * 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. - * - * $Header: /user6/ouster/wish/RCS/tkInt.h,v 1.98 93/10/07 09:59:17 ouster Exp $ SPRITE (Berkeley) - */ - -#ifndef _TKINT -#define _TKINT - -#ifndef _XLIB_H_ -#include -#endif -#ifndef _XUTIL_H -#include -#endif -#ifndef _TK -#include "tk.h" -#endif -#ifndef _TCL -#include "tcl.h" -#endif - -/* - * Opaque type declarations: - */ - -typedef struct Tk_PostscriptInfo Tk_PostscriptInfo; -typedef struct TkGrabEvent TkGrabEvent; - -/* - * One of the following structures is maintained for each display - * containing a window managed by Tk: - */ - -typedef struct TkDisplay { - Display *display; /* Xlib's info about display. */ - struct TkDisplay *nextPtr; /* Next in list of all displays. */ - char *name; /* Name of display (with any screen - * identifier removed). Malloc-ed. */ - Time lastEventTime; /* Time of last event received for this - * display. */ - - /* - * Information used by tkFocus.c and tkEvent.c: - */ - - struct TkWindow *focusTopLevelPtr; - /* Pointer to the top-level window that - * currently contains the focus for this - * display. NULL means none of the - * top-levels managed by this application - * contains the focus. */ - int focussedOnEnter; /* Non-zero means the focus was set - * implicitly from an Enter event rather - * than from a FocusIn event. */ - - /* - * Information used primarily by tkBind.c: - */ - - int bindInfoStale; /* Non-zero means the variables in this - * part of the structure are potentially - * incorrect and should be recomputed. */ - unsigned int modeModMask; /* Has one bit set to indicate the modifier - * corresponding to "mode shift". If no - * such modifier, than this is zero. */ - unsigned int ignoreModMask; /* If any of the following modifiers are - * present in an event but not in the - * corresponding pattern, they don't prevent - * the pattern from matching the event. */ - enum {IGNORE, CAPS, SHIFT} lockUsage; - /* Indicates how to interpret lock modifier. */ - int numModKeyCodes; /* Number of entries in modKeyCodes array - * below. */ - KeyCode *modKeyCodes; /* Pointer to an array giving keycodes for - * all of the keys that have modifiers - * associated with them. Malloc'ed, but - * may be NULL. */ - - /* - * Information used by tkError.c only: - */ - - struct TkErrorHandler *errorPtr; - /* First in list of error handlers - * for this display. NULL means - * no handlers exist at present. */ - int deleteCount; /* Counts # of handlers deleted since - * last time inactive handlers were - * garbage-collected. When this number - * gets big, handlers get cleaned up. */ - int (*defaultHandler) _ANSI_ARGS_((Display *display, - XErrorEvent *eventPtr)); - /* X's default event handler: invoked - * if an error occurs that we can't handle - * ourselves. */ - - /* - * Information used by tkSend.c only: - */ - - Tk_Window commWindow; /* Window used for communication - * between interpreters during "send" - * commands. NULL means send info hasn't - * been initialized yet. */ - Atom commProperty; /* X's name for comm property. */ - Atom registryProperty; /* X's name for property containing - * registry of interpreter names. */ - int serverSecure; /* Non-zero means the server appears to - * be reasonably secure; zero means we - * should reject incoming sends because - * they can't be trusted. */ - - /* - * Information used by tkSelect.c only: - */ - - Tk_Window selectionOwner; /* Current owner of selection, or - * NULL if selection isn't owned by - * a window in this process. */ - int selectionSerial; /* Serial number of last XSelectionSetOwner - * request we made to server (used to - * filter out redundant SelectionClear - * events. */ - Time selectionTime; /* Timestamp used to acquire selection. */ - Atom multipleAtom; /* Atom for MULTIPLE. None means - * selection stuff isn't initialized. */ - Atom incrAtom; /* Atom for INCR. */ - Atom targetsAtom; /* Atom for TARGETS. */ - Atom timestampAtom; /* Atom for TIMESTAMP. */ - Atom textAtom; /* Atom for TEXT. */ - Atom compoundTextAtom; /* Atom for COMPOUND_TEXT. */ - Atom applicationAtom; /* Atom for APPLICATION. */ - Atom windowNameAtom; /* Atom for WINDOW_NAME. */ - - /* - * Information used by tkAtom.c only: - */ - - int atomInit; /* 0 means stuff below hasn't been - * initialized yet. */ - Tcl_HashTable nameTable; /* Maps from names to Atom's. */ - Tcl_HashTable atomTable; /* Maps from Atom's back to names. */ - - /* - * Information used by tkCursor.c only: - */ - - Font cursorFont; /* Font to use for standard cursors. - * None means font not loaded yet. */ - - /* - * Information used by tkGrab.c only: - */ - - struct TkWindow *grabWinPtr; - /* Window in which the pointer is currently - * grabbed, or NULL if none. */ - struct TkWindow *eventualGrabWinPtr; - /* Value that grabWinPtr will have once the - * grab event queue (below) has been - * completely emptied. */ - struct TkWindow *buttonWinPtr; - /* Window in which first mouse button was - * pressed while grab was in effect, or NULL - * if no such press in effect. */ - struct TkWindow *serverWinPtr; - /* If no application contains the pointer then - * this is NULL. Otherwise it contains the - * last window for which we've gotten an - * Enter or Leave event from the server (i.e. - * the last window known to have contained - * the pointer). Doesn't reflect events - * that were synthesized in tkGrab.c. */ - TkGrabEvent *firstGrabEventPtr; - /* First in list of enter/leave events - * synthesized by grab code. These events - * must be processed in order before any other - * events are processed. NULL means no such - * events. */ - TkGrabEvent *lastGrabEventPtr; - /* Last in list of synthesized events, or NULL - * if list is empty. */ - int grabFlags; /* Miscellaneous flag values. See definitions - * in tkGrab.c. */ - - /* - * Miscellaneous information: - */ - - Tk_ColorModel *colorModels; /* Array of color models, one per screen; - * indicates whether windows should attempt - * to use full color for display, just mono, - * etc. Malloc'ed. */ -} TkDisplay; - -/* - * One of the following structures exists for each error handler - * created by a call to Tk_CreateErrorHandler. The structure - * is managed by tkError.c. - */ - -typedef struct TkErrorHandler { - TkDisplay *dispPtr; /* Display to which handler applies. */ - unsigned long firstRequest; /* Only errors with serial numbers - * >= to this are considered. */ - unsigned long lastRequest; /* Only errors with serial numbers - * <= to this are considered. This - * field is filled in when XUnhandle - * is called. -1 means XUnhandle - * hasn't been called yet. */ - int error; /* Consider only errors with this - * error_code (-1 means consider - * all errors). */ - int request; /* Consider only errors with this - * major request code (-1 means - * consider all major codes). */ - int minorCode; /* Consider only errors with this - * minor request code (-1 means - * consider all minor codes). */ - Tk_ErrorProc *errorProc; /* Procedure to invoke when a matching - * error occurs. NULL means just ignore - * errors. */ - ClientData clientData; /* Arbitrary value to pass to - * errorProc. */ - struct TkErrorHandler *nextPtr; - /* Pointer to next older handler for - * this display, or NULL for end of - * list. */ -} TkErrorHandler; - -/* - * One of the following structures exists for each event handler - * created by calling Tk_CreateEventHandler. This information - * is used by tkEvent.c only. - */ - -typedef struct TkEventHandler { - unsigned long mask; /* Events for which to invoke - * proc. */ - Tk_EventProc *proc; /* Procedure to invoke when an event - * in mask occurs. */ - ClientData clientData; /* Argument to pass to proc. */ - struct TkEventHandler *nextPtr; - /* Next in list of handlers - * associated with window (NULL means - * end of list). */ -} TkEventHandler; - -/* - * One of the following structures exists for each selection - * handler created by calling Tk_CreateSelHandler. This - * information is used by tkSelect.c only. - */ - -typedef struct TkSelHandler { - Atom target; /* Target type for selection - * conversion, such as TARGETS or - * STRING. */ - Atom format; /* Format in which selection - * info will be returned, such - * as STRING or ATOM. */ - Tk_SelectionProc *proc; /* Procedure to generate selection - * in this format. */ - ClientData clientData; /* Argument to pass to proc. */ - int size; /* Size of units returned by proc - * (8 for STRING, 32 for almost - * anything else). */ - struct TkSelHandler *nextPtr; - /* Next selection handler associated - * with same window (NULL for end of - * list). */ -} TkSelHandler; - -/* - * Tk keeps one of the following data structures for each main - * window (created by a call to Tk_CreateMainWindow). It stores - * information that is shared by all of the windows associated - * with a particular main window. - */ - -typedef struct TkMainInfo { - struct TkWindow *winPtr; /* Pointer to main window. */ - Tcl_Interp *interp; /* Interpreter associated with application. */ - Tcl_HashTable nameTable; /* Hash table mapping path names to TkWindow - * structs for all windows related to this - * main window. Managed by tkWindow.c. */ - Tk_BindingTable bindingTable; - /* Used in conjunction with "bind" command - * to bind events to Tcl commands. */ - struct TkWindow *focusPtr; /* Identifies window that currently has the - * focus (or that will get the focus the next - * time the pointer enters any of the top-level - * windows associated with this main window). - * NULL means nobody has the focus. - * Managed by tkFocus.c. */ - struct TkWindow *focusDefaultPtr; - /* Window that is to receive the focus by - * default when the focusPtr window is - * deleted. */ - struct ElArray *optionRootPtr; - /* Top level of option hierarchy for this - * main window. NULL means uninitialized. - * Managed by tkOption.c. */ - struct TkMainInfo *nextPtr; /* Next in list of all main windows managed by - * this process. */ -} TkMainInfo; - -/* - * Tk keeps one of the following structures for each window. - * Some of the information (like size and location) is a shadow - * of information managed by the X server, and some is special - * information used here, such as event and geometry management - * information. This information is (mostly) managed by tkWindow.c. - * WARNING: the declaration below must be kept consistent with the - * Tk_ClientWindow structure in tk.h. If you change one, be sure to - * change the other!! - */ - -typedef struct TkWindow { - - /* - * Structural information: - */ - - Display *display; /* Display containing window. */ - TkDisplay *dispPtr; /* Tk's information about display - * for window. */ - int screenNum; /* Index of screen for window, among all - * those for dispPtr. */ - Visual *visual; /* Visual to use for window. If not default, - * MUST be set before X window is created. */ - int depth; /* Number of bits/pixel. */ - Window window; /* X's id for window. NULL means window - * hasn't actually been created yet, or it's - * been deleted. */ - struct TkWindow *childList; /* First in list of child windows, - * or NULL if no children. */ - struct TkWindow *lastChildPtr; - /* Last in list of child windows, or NULL - * if no children. */ - struct TkWindow *parentPtr; /* Pointer to parent window (logical - * parent, not necessarily X parent), or - * NULL if this is a main window. */ - struct TkWindow *nextPtr; /* Next in list of children with - * same parent (NULL if end of - * list). */ - TkMainInfo *mainPtr; /* Information shared by all windows - * associated with a particular main - * window. NULL means this window is - * a rogue that isn't associated with - * any application (at present, there - * should never be any rogues). */ - - /* - * Name and type information for the window: - */ - - char *pathName; /* Path name of window (concatenation - * of all names between this window and - * its top-level ancestor). This is a - * pointer into an entry in - * mainPtr->nameTable or NULL if mainPtr - * is NULL. */ - Tk_Uid nameUid; /* Name of the window within its parent - * (unique within the parent). */ - Tk_Uid classUid; /* Class of the window. NULL means window - * hasn't been given a class yet. */ - - /* - * Geometry and other attributes of window. This information - * may not be updated on the server immediately; stuff that - * hasn't been reflected in the server yet is called "dirty". - * At present, information can be dirty only if the window - * hasn't yet been created. - */ - - XWindowChanges changes; /* Geometry and other info about - * window. */ - unsigned int dirtyChanges; /* Bits indicate fields of "changes" - * that are dirty. */ - XSetWindowAttributes atts; /* Current attributes of window. */ - unsigned long dirtyAtts; /* Bits indicate fields of "atts" - * that are dirty. */ - - unsigned int flags; /* Various flag values: these are all - * defined in tk.h (confusing, but they're - * needed there for some query macros). */ - - /* - * Information kept by the event manager (tkEvent.c): - */ - - TkEventHandler *handlerList;/* First in list of event handlers - * declared for this window, or - * NULL if none. */ - /* - * Information related to input focussing (tkFocus.c): - */ - - Tk_FocusProc *focusProc; /* Procedure to invoke when this window - * gets or loses the input focus. NULL - * means this window is not prepared to - * receive the focus. */ - ClientData focusData; /* Arbitrary value to pass to focusProc. */ - - /* - * Information used by tkOption.c to manage options for the - * window. - */ - - int optionLevel; /* -1 means no option information is - * currently cached for this window. - * Otherwise this gives the level in - * the option stack at which info is - * cached. */ - /* - * Information used by tkSelect.c to manage the selection. - */ - - TkSelHandler *selHandlerList; - /* First in list of handlers for - * returning the selection in various - * forms. */ - Tk_LostSelProc *selClearProc; - ClientData selClearData; /* Info to pass to selClearProc. */ - - /* - * Information used by tkGeometry.c for geometry management. - */ - - Tk_GeometryProc *geomProc; /* Procedure to handle geometry - * requests (NULL means no window is - * unmanaged). */ - ClientData geomData; /* Argument for geomProc. */ - int reqWidth, reqHeight; /* Arguments from last call to - * Tk_GeometryRequest, or 0's if - * Tk_GeometryRequest hasn't been - * called. */ - int internalBorderWidth; /* Width of internal border of window - * (0 means no internal border). Geom. - * mgr. should not place children on top - * of the border. */ - - /* - * Information maintained by tkWm.c for window manager communication. - */ - - struct TkWmInfo *wmInfoPtr; /* For top-level windows, points to - * structure with wm-related info (see - * tkWm.c). For other windows, this - * is NULL. */ -} TkWindow; - -/* - * The context below is used to map from an X window id to - * the TkWindow structure associated with the window. - */ - -extern XContext tkWindowContext; - -/* - * Pointer to first entry in list of all displays currently known. - */ - -extern TkDisplay *tkDisplayList; - -/* - * Flags passed to TkMeasureChars: - */ - -#define TK_WHOLE_WORDS 1 -#define TK_AT_LEAST_ONE 2 -#define TK_PARTIAL_OK 4 -#define TK_NEWLINES_NOT_SPECIAL 8 - -/* - * Location of library directory containing Tk scripts. This value - * is put in the $tkLibrary variable for each application. - */ - -#ifndef TK_LIBRARY -#define TK_LIBRARY "/usr/local/lib/tk" -#endif - -/* - * Special flag to pass to Tk_CreateFileHandler to indicate that - * the file descriptor is actually for a display, not a file, and - * should be treated specially. Make sure that this value doesn't - * conflict with TK_READABLE, TK_WRITABLE, or TK_EXCEPTION from tk.h. - */ - -#define TK_IS_DISPLAY 32 - -/* - * 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)) - -/* - * SPECIAL HACK!!! I've started changing Tk over to use - * Tcl_PrintDouble instead of sprintf(... %g ...), but the change - * is not backwards-compatible. So, until the next incompatible - * release of Tk, the following macro replaces the Tcl_PrintDouble - * calls with sprintf again. - */ - -#define Tcl_PrintDouble(interp, value, dst) \ - sprintf(dst, "%g", value) - -/* - * Miscellaneous variables shared among Tk modules but not exported - * to the outside world: - */ - -extern Tk_Uid tkActiveUid; -extern Tk_Uid tkDisabledUid; -extern TkMainInfo *tkMainWindowList; -extern Tk_Uid tkNormalUid; - -/* - * Internal procedures shared among Tk modules but not exported - * to the outside world: - */ - -extern int TkAreaToPolygon _ANSI_ARGS_((double *polyPtr, - int numPoints, double *rectPtr)); -extern void TkBezierPoints _ANSI_ARGS_((double control[], - int numSteps, double *coordPtr)); -extern void TkBindEventProc _ANSI_ARGS_((TkWindow *winPtr, - XEvent *eventPtr)); -extern int TkCopyAndGlobalEval _ANSI_ARGS_((Tcl_Interp *interp, - char *script)); -extern Time TkCurrentTime _ANSI_ARGS_((TkDisplay *dispPtr)); -extern int TkDeadAppCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -extern void TkDisplayChars _ANSI_ARGS_((Display *display, - Drawable drawable, GC gc, - XFontStruct *fontStructPtr, char *string, - int numChars, int x, int y, int flags)); -extern void TkEventDeadWindow _ANSI_ARGS_((TkWindow *winPtr)); -extern void TkFocusDeadWindow _ANSI_ARGS_((TkWindow *winPtr)); -extern int TkFocusFilterEvent _ANSI_ARGS_((TkWindow *winPtr, - XEvent *eventPtr)); -extern void TkGetButtPoints _ANSI_ARGS_((double p1[], double p2[], - double width, int project, double m1[], - double m2[])); -extern int TkGetInterpNames _ANSI_ARGS_((Tcl_Interp *interp, - Tk_Window tkwin)); -extern int TkGetMiterPoints _ANSI_ARGS_((double p1[], double p2[], - double p3[], double width, double m1[], - double m2[])); -extern void TkGrabDeadWindow _ANSI_ARGS_((TkWindow *winPtr)); -extern void TkGrabTriggerProc _ANSI_ARGS_((XEvent *eventPtr)); -extern int TkInitFrame _ANSI_ARGS_((Tcl_Interp *interp, - Tk_Window tkwin, int toplevel, int argc, - char *argv[])); -extern int TkLineToArea _ANSI_ARGS_((double end1Ptr[2], - double end2Ptr[2], double rectPtr[4])); -extern double TkLineToPoint _ANSI_ARGS_((double end1Ptr[2], - double end2Ptr[2], double pointPtr[2])); -extern void TkMakeBezierPostscript _ANSI_ARGS_((Tcl_Interp *interp, - double *pointPtr, int numPoints, - Tk_PostscriptInfo *psInfoPtr)); -extern int TkMeasureChars _ANSI_ARGS_((XFontStruct *fontStructPtr, - char *source, int maxChars, int startX, int maxX, - int flags, int *nextXPtr)); -extern void TkOptionDeadWindow _ANSI_ARGS_((TkWindow *winPtr)); -extern int TkOvalToArea _ANSI_ARGS_((double *ovalPtr, - double *rectPtr)); -extern double TkOvalToPoint _ANSI_ARGS_((double ovalPtr[4], - double width, int filled, double pointPtr[2])); -extern int TkPointerEvent _ANSI_ARGS_((XEvent *eventPtr, - TkWindow *winPtr)); -extern int TkPolygonToArea _ANSI_ARGS_((double *polyPtr, - int numPoints, double *rectPtr)); -extern double TkPolygonToPoint _ANSI_ARGS_((double *polyPtr, - int numPoints, double *pointPtr)); -extern void TkQueueEvent _ANSI_ARGS_((TkDisplay *dispPtr, - XEvent *eventPtr)); -extern void TkSelDeadWindow _ANSI_ARGS_((TkWindow *winPtr)); -extern void TkSelEventProc _ANSI_ARGS_((Tk_Window tkwin, - XEvent *eventPtr)); -extern void TkSelPropProc _ANSI_ARGS_((XEvent *eventPtr)); -extern void TkUnderlineChars _ANSI_ARGS_((Display *display, - Drawable drawable, GC gc, - XFontStruct *fontStructPtr, char *string, - int x, int y, int flags, int firstChar, - int lastChar)); -extern void TkWmDeadWindow _ANSI_ARGS_((TkWindow *winPtr)); -extern void TkWmMapWindow _ANSI_ARGS_((TkWindow *winPtr)); -extern void TkWmNewWindow _ANSI_ARGS_((TkWindow *winPtr)); -extern void TkWmProtocolEventProc _ANSI_ARGS_((TkWindow *winPtr, - XEvent *evenvPtr)); -extern void TkWmRestackToplevel _ANSI_ARGS_((TkWindow *winPtr, - int aboveBelow, TkWindow *otherPtr)); -extern void TkWmSetClass _ANSI_ARGS_((TkWindow *winPtr)); -extern void TkWmUnmapWindow _ANSI_ARGS_((TkWindow *winPtr)); - -#endif /* _TKINT */ diff --git a/tk3.6/tkMain.c b/tk3.6/tkMain.c deleted file mode 100644 index 800b79f..0000000 --- a/tk3.6/tkMain.c +++ /dev/null @@ -1,449 +0,0 @@ -/* - * main.c -- - * - * This file contains the main program for "wish", a windowing - * shell based on Tk and Tcl. It also provides a template that - * can be used as the basis for main programs for other Tk - * applications. - * - * 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/wish/RCS/tkMain.c,v 1.99 93/11/11 09:35:24 ouster Exp $ SPRITE (Berkeley)"; -#endif - -#include -#include -#include - -/* - * Declarations for various library procedures and variables (don't want - * to include tkInt.h or tkConfig.h here, because people might copy this - * file out of the Tk source directory to make their own modified versions). - */ - -extern void exit _ANSI_ARGS_((int status)); -extern int isatty _ANSI_ARGS_((int fd)); -extern int read _ANSI_ARGS_((int fd, char *buf, size_t size)); -extern char * strrchr _ANSI_ARGS_((CONST char *string, int c)); - -/* - * Global variables used by the main program: - */ - -static Tk_Window mainWindow; /* The main window for the application. If - * NULL then the application no longer - * exists. */ -static Tcl_Interp *interp; /* Interpreter for this application. */ -char *tcl_RcFileName = NULL; /* Name of a user-specific startup script - * to source if the application is being run - * interactively (e.g. "~/.wishrc"). Set - * by Tcl_AppInit. NULL means don't source - * anything ever. */ -static Tcl_DString command; /* Used to assemble lines of terminal input - * into Tcl commands. */ -static int tty; /* Non-zero means standard input is a - * terminal-like device. Zero means it's - * a file. */ -static char errorExitCmd[] = "exit 1"; - -/* - * Command-line options: - */ - -static int synchronize = 0; -static char *fileName = NULL; -static char *name = NULL; -static char *display = NULL; -static char *geometry = NULL; - -static Tk_ArgvInfo argTable[] = { - {"-file", TK_ARGV_STRING, (char *) NULL, (char *) &fileName, - "File from which to read commands"}, - {"-geometry", TK_ARGV_STRING, (char *) NULL, (char *) &geometry, - "Initial geometry for window"}, - {"-display", TK_ARGV_STRING, (char *) NULL, (char *) &display, - "Display to use"}, - {"-name", TK_ARGV_STRING, (char *) NULL, (char *) &name, - "Name to use for application"}, - {"-sync", TK_ARGV_CONSTANT, (char *) 1, (char *) &synchronize, - "Use synchronous mode for display server"}, - {(char *) NULL, TK_ARGV_END, (char *) NULL, (char *) NULL, - (char *) NULL} -}; - -/* - * Declaration for Tcl command procedure to create demo widget. This - * procedure is only invoked if SQUARE_DEMO is defined. - */ - -extern int SquareCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char *argv[])); - -/* - * Forward declarations for procedures defined later in this file: - */ - -static void Prompt _ANSI_ARGS_((Tcl_Interp *interp, int partial)); -static void StdinProc _ANSI_ARGS_((ClientData clientData, - int mask)); - -/* - *---------------------------------------------------------------------- - * - * main -- - * - * Main program for Wish. - * - * Results: - * None. This procedure never returns (it exits the process when - * it's done - * - * Side effects: - * This procedure initializes the wish world and then starts - * interpreting commands; almost anything could happen, depending - * on the script being interpreted. - * - *---------------------------------------------------------------------- - */ - -int -main(argc, argv) - int argc; /* Number of arguments. */ - char **argv; /* Array of argument strings. */ -{ - char *args, *p, *msg; - char buf[20]; - int code; - - interp = Tcl_CreateInterp(); -#ifdef TCL_MEM_DEBUG - Tcl_InitMemory(interp); -#endif - - /* - * Parse command-line arguments. - */ - - if (Tk_ParseArgv(interp, (Tk_Window) NULL, &argc, argv, argTable, 0) - != TCL_OK) { - fprintf(stderr, "%s\n", interp->result); - exit(1); - } - if (name == NULL) { - if (fileName != NULL) { - p = fileName; - } else { - p = argv[0]; - } - name = strrchr(p, '/'); - if (name != NULL) { - name++; - } else { - name = p; - } - } - - /* - * If a display was specified, put it into the DISPLAY - * environment variable so that it will be available for - * any sub-processes created by us. - */ - - if (display != NULL) { - Tcl_SetVar2(interp, "env", "DISPLAY", display, TCL_GLOBAL_ONLY); - } - - /* - * Initialize the Tk application. - */ - - mainWindow = Tk_CreateMainWindow(interp, display, name, "Tk"); - if (mainWindow == NULL) { - fprintf(stderr, "%s\n", interp->result); - exit(1); - } - if (synchronize) { - XSynchronize(Tk_Display(mainWindow), True); - } - Tk_GeometryRequest(mainWindow, 200, 200); - - /* - * Make command-line arguments available in the Tcl variables "argc" - * and "argv". Also set the "geometry" variable from the geometry - * specified on the command line. - */ - - args = Tcl_Merge(argc-1, argv+1); - Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY); - ckfree(args); - sprintf(buf, "%d", argc-1); - Tcl_SetVar(interp, "argc", buf, TCL_GLOBAL_ONLY); - Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0], - TCL_GLOBAL_ONLY); - if (geometry != NULL) { - Tcl_SetVar(interp, "geometry", geometry, TCL_GLOBAL_ONLY); - } - - /* - * Set the "tcl_interactive" variable. - */ - - tty = isatty(0); - Tcl_SetVar(interp, "tcl_interactive", - ((fileName == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY); - - /* - * Add a few application-specific commands to the application's - * interpreter. - */ - -#ifdef SQUARE_DEMO - Tcl_CreateCommand(interp, "square", SquareCmd, (ClientData) mainWindow, - (void (*)()) NULL); -#endif - - /* - * Invoke application-specific initialization. - */ - - if (Tcl_AppInit(interp) != TCL_OK) { - fprintf(stderr, "Tcl_AppInit failed: %s\n", interp->result); - } - - /* - * Set the geometry of the main window, if requested. - */ - - if (geometry != NULL) { - code = Tcl_VarEval(interp, "wm geometry . ", geometry, (char *) NULL); - if (code != TCL_OK) { - fprintf(stderr, "%s\n", interp->result); - } - } - - /* - * Invoke the script specified on the command line, if any. - */ - - if (fileName != NULL) { - code = Tcl_VarEval(interp, "source ", fileName, (char *) NULL); - if (code != TCL_OK) { - goto error; - } - tty = 0; - } else { - /* - * Commands will come from standard input, so set up an event - * handler for standard input. If the input device is aEvaluate the - * .rc file, if one has been specified, set up an event handler - * for standard input, and print a prompt if the input - * device is a terminal. - */ - - 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); - } - Tk_CreateFileHandler(0, TK_READABLE, StdinProc, (ClientData) 0); - if (tty) { - Prompt(interp, 0); - } - } - fflush(stdout); - Tcl_DStringInit(&command); - - /* - * Loop infinitely, waiting for commands to execute. When there - * are no windows left, Tk_MainLoop returns and we exit. - */ - - Tk_MainLoop(); - - /* - * Don't exit directly, but rather invoke the Tcl "exit" command. - * This gives the application the opportunity to redefine "exit" - * to do additional cleanup. - */ - - Tcl_Eval(interp, "exit"); - exit(1); - -error: - msg = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); - if (msg == NULL) { - msg = interp->result; - } - fprintf(stderr, "%s\n", msg); - Tcl_Eval(interp, errorExitCmd); - return 1; /* Needed only to prevent compiler warnings. */ -} - -/* - *---------------------------------------------------------------------- - * - * StdinProc -- - * - * This procedure is invoked by the event dispatcher whenever - * standard input becomes readable. It grabs the next line of - * input characters, adds them to a command being assembled, and - * executes the command if it's complete. - * - * Results: - * None. - * - * Side effects: - * Could be almost arbitrary, depending on the command that's - * typed. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static void -StdinProc(clientData, mask) - ClientData clientData; /* Not used. */ - int mask; /* Not used. */ -{ -#define BUFFER_SIZE 4000 - char input[BUFFER_SIZE+1]; - static int gotPartial = 0; - char *cmd; - int code, count; - - count = read(fileno(stdin), input, BUFFER_SIZE); - if (count <= 0) { - if (!gotPartial) { - if (tty) { - Tcl_Eval(interp, "exit"); - exit(1); - } else { - Tk_DeleteFileHandler(0); - } - return; - } else { - count = 0; - } - } - cmd = Tcl_DStringAppend(&command, input, count); - if (count != 0) { - if ((input[count-1] != '\n') && (input[count-1] != ';')) { - gotPartial = 1; - goto prompt; - } - if (!Tcl_CommandComplete(cmd)) { - gotPartial = 1; - goto prompt; - } - } - gotPartial = 0; - - /* - * Disable the stdin file handler while evaluating the command; - * otherwise if the command re-enters the event loop we might - * process commands from stdin before the current command is - * finished. Among other things, this will trash the text of the - * command being evaluated. - */ - - Tk_CreateFileHandler(0, 0, StdinProc, (ClientData) 0); - code = Tcl_RecordAndEval(interp, cmd, 0); - Tk_CreateFileHandler(0, TK_READABLE, StdinProc, (ClientData) 0); - Tcl_DStringFree(&command); - if (*interp->result != 0) { - if ((code != TCL_OK) || (tty)) { - printf("%s\n", interp->result); - } - } - - /* - * Output a prompt. - */ - - prompt: - if (tty) { - Prompt(interp, gotPartial); - } -} - -/* - *---------------------------------------------------------------------- - * - * Prompt -- - * - * Issue a prompt on standard output, or invoke a script - * to issue the prompt. - * - * Results: - * None. - * - * Side effects: - * A prompt gets output, and a Tcl script may be evaluated - * in interp. - * - *---------------------------------------------------------------------- - */ - -static void -Prompt(interp, partial) - Tcl_Interp *interp; /* Interpreter to use for prompting. */ - int partial; /* Non-zero means there already - * exists a partial command, so use - * the secondary prompt. */ -{ - char *promptCmd; - int code; - - promptCmd = Tcl_GetVar(interp, - partial ? "tcl_prompt2" : "tcl_prompt1", TCL_GLOBAL_ONLY); - if (promptCmd == NULL) { - defaultPrompt: - if (!partial) { - fputs("% ", stdout); - } - } else { - code = Tcl_Eval(interp, promptCmd); - if (code != TCL_OK) { - Tcl_AddErrorInfo(interp, - "\n (script that generates prompt)"); - fprintf(stderr, "%s\n", interp->result); - goto defaultPrompt; - } - } - fflush(stdout); -} diff --git a/tk3.6/tkScale.c b/tk3.6/tkScale.c deleted file mode 100644 index 67c9091..0000000 --- a/tk3.6/tkScale.c +++ /dev/null @@ -1,1481 +0,0 @@ -/* - * tkScale.c -- - * - * This module implements a scale widgets for the Tk toolkit. - * A scale displays a slider that can be adjusted to change a - * value; it also displays numeric labels and a textual label, - * if desired. - * - * 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/wish/RCS/tkScale.c,v 1.40 93/08/16 15:47:37 ouster Exp $ SPRITE (Berkeley)"; -#endif - -#include "tkConfig.h" -#include "default.h" -#include "tkInt.h" - -/* - * A data structure of the following type is kept for each scale - * widget managed by this file: - */ - -typedef struct { - Tk_Window tkwin; /* Window that embodies the scale. NULL - * means that the window has been destroyed - * but the data structures haven't yet been - * cleaned up.*/ - Display *display; /* Display containing widget. Used, among - * other things, so that resources can be - * freed even after tkwin has gone away. */ - Tcl_Interp *interp; /* Interpreter associated with scale. */ - Tk_Uid orientUid; /* Orientation for window ("vertical" or - * "horizontal"). */ - int vertical; /* Non-zero means vertical orientation, - * zero means horizontal. */ - int value; /* Current value of scale. */ - int fromValue; /* Value corresponding to left or top of - * scale. */ - int toValue; /* Value corresponding to right or bottom - * of scale. */ - int tickInterval; /* Distance between tick marks; 0 means - * don't display any tick marks. */ - char *command; /* Command prefix to use when invoking Tcl - * commands because the scale value changed. - * NULL means don't invoke commands. - * Malloc'ed. */ - int commandLength; /* Number of non-NULL bytes in command. */ - char *label; /* Label to display above or to right of - * scale; NULL means don't display a - * label. Malloc'ed. */ - int labelLength; /* Number of non-NULL chars. in label. */ - Tk_Uid state; /* Normal or disabled. Value cannot be - * changed when scale is disabled. */ - - /* - * Information used when displaying widget: - */ - - int borderWidth; /* Width of 3-D border around window. */ - Tk_3DBorder bgBorder; /* Used for drawing background. */ - Tk_3DBorder sliderBorder; /* Used for drawing slider in normal mode. */ - Tk_3DBorder activeBorder; /* Used for drawing slider when active (i.e. - * when mouse is in window). */ - XFontStruct *fontPtr; /* Information about text font, or NULL. */ - XColor *textColorPtr; /* Color for drawing text. */ - GC textGC; /* GC for drawing text in normal mode. */ - int width; /* Desired narrow dimension of scale, - * in pixels. */ - int length; /* Desired long dimension of scale, - * in pixels. */ - int relief; /* Indicates whether window as a whole is - * raised, sunken, or flat. */ - int offset; /* Zero if relief is TK_RELIEF_FLAT, - * borderWidth otherwise. Indicates how - * much interior stuff must be offset from - * outside edges to leave room for border. */ - int sliderLength; /* Length of slider, measured in pixels along - * long dimension of scale. */ - int showValue; /* Non-zero means to display the scale value - * below or to the left of the slider; zero - * means don't display the value. */ - int tickPixels; /* Number of pixels required for widest tick - * mark. 0 means don't display ticks.*/ - int valuePixels; /* Number of pixels required for value text. */ - int labelPixels; /* Number of pixels required for label. 0 - * means don't display label. */ - - /* - * Miscellaneous information: - */ - - Cursor cursor; /* Current cursor for window, or None. */ - int flags; /* Various flags; see below for - * definitions. */ -} Scale; - -/* - * Flag bits for scales: - * - * REDRAW_SLIDER - 1 means slider (and numerical readout) need - * to be redrawn. - * REDRAW_OTHER - 1 means other stuff besides slider and value - * need to be redrawn. - * REDRAW_ALL - 1 means the entire widget needs to be redrawn. - * ACTIVE - 1 means the widget is active (the mouse is - * in its window). - * BUTTON_PRESSED - 1 means a button press is in progress, so - * slider should appear depressed and should be - * draggable. - * INVOKE_COMMAND - 1 means the scale's command needs to be - * invoked during the next redisplay (the - * value of the scale has changed since the - * last time the command was invoked). - */ - -#define REDRAW_SLIDER 1 -#define REDRAW_OTHER 2 -#define REDRAW_ALL 3 -#define ACTIVE 4 -#define BUTTON_PRESSED 8 -#define INVOKE_COMMAND 16 - -/* - * Space to leave between scale area and text. - */ - -#define SPACING 2 - -/* - * Information used for argv parsing. - */ - - -static Tk_ConfigSpec configSpecs[] = { - {TK_CONFIG_BORDER, "-activeforeground", "activeForeground", "Background", - DEF_SCALE_ACTIVE_FG_COLOR, Tk_Offset(Scale, activeBorder), - TK_CONFIG_COLOR_ONLY}, - {TK_CONFIG_BORDER, "-activeforeground", "activeForeground", "Background", - DEF_SCALE_ACTIVE_FG_MONO, Tk_Offset(Scale, activeBorder), - TK_CONFIG_MONO_ONLY}, - {TK_CONFIG_BORDER, "-background", "background", "Background", - DEF_SCALE_BG_COLOR, Tk_Offset(Scale, bgBorder), - TK_CONFIG_COLOR_ONLY}, - {TK_CONFIG_BORDER, "-background", "background", "Background", - DEF_SCALE_BG_MONO, Tk_Offset(Scale, bgBorder), - TK_CONFIG_MONO_ONLY}, - {TK_CONFIG_SYNONYM, "-bd", "borderWidth", (char *) NULL, - (char *) NULL, 0, 0}, - {TK_CONFIG_SYNONYM, "-bg", "background", (char *) NULL, - (char *) NULL, 0, 0}, - {TK_CONFIG_PIXELS, "-borderwidth", "borderWidth", "BorderWidth", - DEF_SCALE_BORDER_WIDTH, Tk_Offset(Scale, borderWidth), 0}, - {TK_CONFIG_STRING, "-command", "command", "Command", - DEF_SCALE_COMMAND, Tk_Offset(Scale, command), TK_CONFIG_NULL_OK}, - {TK_CONFIG_ACTIVE_CURSOR, "-cursor", "cursor", "Cursor", - DEF_SCALE_CURSOR, Tk_Offset(Scale, cursor), TK_CONFIG_NULL_OK}, - {TK_CONFIG_SYNONYM, "-fg", "foreground", (char *) NULL, - (char *) NULL, 0, 0}, - {TK_CONFIG_FONT, "-font", "font", "Font", - DEF_SCALE_FONT, Tk_Offset(Scale, fontPtr), - 0}, - {TK_CONFIG_COLOR, "-foreground", "foreground", "Foreground", - DEF_SCALE_FG_COLOR, Tk_Offset(Scale, textColorPtr), - TK_CONFIG_COLOR_ONLY}, - {TK_CONFIG_COLOR, "-foreground", "foreground", "Foreground", - DEF_SCALE_FG_MONO, Tk_Offset(Scale, textColorPtr), - TK_CONFIG_MONO_ONLY}, - {TK_CONFIG_INT, "-from", "from", "From", - DEF_SCALE_FROM, Tk_Offset(Scale, fromValue), 0}, - {TK_CONFIG_STRING, "-label", "label", "Label", - DEF_SCALE_LABEL, Tk_Offset(Scale, label), TK_CONFIG_NULL_OK}, - {TK_CONFIG_PIXELS, "-length", "length", "Length", - DEF_SCALE_LENGTH, Tk_Offset(Scale, length), 0}, - {TK_CONFIG_UID, "-orient", "orient", "Orient", - DEF_SCALE_ORIENT, Tk_Offset(Scale, orientUid), 0}, - {TK_CONFIG_RELIEF, "-relief", "relief", "Relief", - DEF_SCALE_RELIEF, Tk_Offset(Scale, relief), 0}, - {TK_CONFIG_BOOLEAN, "-showvalue", "showValue", "ShowValue", - DEF_SCALE_SHOW_VALUE, Tk_Offset(Scale, showValue), 0}, - {TK_CONFIG_BORDER, "-sliderforeground", "sliderForeground", "Background", - DEF_SCALE_SLIDER_FG_COLOR, Tk_Offset(Scale, sliderBorder), - TK_CONFIG_COLOR_ONLY}, - {TK_CONFIG_BORDER, "-sliderforeground", "sliderForeground", "Background", - DEF_SCALE_SLIDER_FG_MONO, Tk_Offset(Scale, sliderBorder), - TK_CONFIG_MONO_ONLY}, - {TK_CONFIG_PIXELS, "-sliderlength", "sliderLength", "SliderLength", - DEF_SCALE_SLIDER_LENGTH, Tk_Offset(Scale, sliderLength), 0}, - {TK_CONFIG_UID, "-state", "state", "State", - DEF_SCALE_STATE, Tk_Offset(Scale, state), 0}, - {TK_CONFIG_INT, "-tickinterval", "tickInterval", "TickInterval", - DEF_SCALE_TICK_INTERVAL, Tk_Offset(Scale, tickInterval), 0}, - {TK_CONFIG_INT, "-to", "to", "To", - DEF_SCALE_TO, Tk_Offset(Scale, toValue), 0}, - {TK_CONFIG_PIXELS, "-width", "width", "Width", - DEF_SCALE_WIDTH, Tk_Offset(Scale, width), 0}, - {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, - (char *) NULL, 0, 0} -}; - -/* - * Forward declarations for procedures defined later in this file: - */ - -static void ComputeScaleGeometry _ANSI_ARGS_((Scale *scalePtr)); -static int ConfigureScale _ANSI_ARGS_((Tcl_Interp *interp, - Scale *scalePtr, int argc, char **argv, - int flags)); -static void DestroyScale _ANSI_ARGS_((ClientData clientData)); -static void DisplayHorizontalScale _ANSI_ARGS_(( - ClientData clientData)); -static void DisplayHorizontalValue _ANSI_ARGS_((Scale *scalePtr, - int value, int bottom)); -static void DisplayVerticalScale _ANSI_ARGS_(( - ClientData clientData)); -static void DisplayVerticalValue _ANSI_ARGS_((Scale *scalePtr, - int value, int rightEdge)); -static void EventuallyRedrawScale _ANSI_ARGS_((Scale *scalePtr, - int what)); -static int PixelToValue _ANSI_ARGS_((Scale *scalePtr, int x, - int y)); -static void ScaleEventProc _ANSI_ARGS_((ClientData clientData, - XEvent *eventPtr)); -static void ScaleMouseProc _ANSI_ARGS_((ClientData clientData, - XEvent *eventPtr)); -static int ScaleWidgetCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -static void SetScaleValue _ANSI_ARGS_((Scale *scalePtr, - int value)); -static int ValueToPixel _ANSI_ARGS_((Scale *scalePtr, int value)); - -/* - *-------------------------------------------------------------- - * - * Tk_ScaleCmd -- - * - * This procedure is invoked to process the "scale" Tcl - * command. See the user documentation for details on what - * it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *-------------------------------------------------------------- - */ - -int -Tk_ScaleCmd(clientData, interp, argc, argv) - ClientData clientData; /* Main window associated with - * interpreter. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - Tk_Window tkwin = (Tk_Window) clientData; - register Scale *scalePtr; - Tk_Window new; - - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " pathName ?options?\"", (char *) NULL); - return TCL_ERROR; - } - - new = Tk_CreateWindowFromPath(interp, tkwin, argv[1], (char *) NULL); - if (new == NULL) { - return TCL_ERROR; - } - - /* - * Initialize fields that won't be initialized by ConfigureScale, - * or which ConfigureScale expects to have reasonable values - * (e.g. resource pointers). - */ - - scalePtr = (Scale *) ckalloc(sizeof(Scale)); - scalePtr->tkwin = new; - scalePtr->display = Tk_Display(new); - scalePtr->interp = interp; - scalePtr->orientUid = NULL; - scalePtr->vertical = 0; - scalePtr->value = 0; - scalePtr->fromValue = 0; - scalePtr->toValue = 0; - scalePtr->tickInterval = 0; - scalePtr->command = NULL; - scalePtr->commandLength = 0; - scalePtr->label = NULL; - scalePtr->labelLength = 0; - scalePtr->state = tkNormalUid; - scalePtr->borderWidth = 0; - scalePtr->bgBorder = NULL; - scalePtr->sliderBorder = NULL; - scalePtr->activeBorder = NULL; - scalePtr->fontPtr = NULL; - scalePtr->textColorPtr = NULL; - scalePtr->textGC = None; - scalePtr->width = 0; - scalePtr->length = 0; - scalePtr->relief = TK_RELIEF_FLAT; - scalePtr->offset = 0; - scalePtr->sliderLength = 0; - scalePtr->showValue = 0; - scalePtr->tickPixels = 0; - scalePtr->valuePixels = 0; - scalePtr->labelPixels = 0; - scalePtr->cursor = None; - scalePtr->flags = 0; - - Tk_SetClass(scalePtr->tkwin, "Scale"); - Tk_CreateEventHandler(scalePtr->tkwin, ExposureMask|StructureNotifyMask, - ScaleEventProc, (ClientData) scalePtr); - Tk_CreateEventHandler(scalePtr->tkwin, EnterWindowMask|LeaveWindowMask - |PointerMotionMask|ButtonPressMask|ButtonReleaseMask, - ScaleMouseProc, (ClientData) scalePtr); - Tcl_CreateCommand(interp, Tk_PathName(scalePtr->tkwin), ScaleWidgetCmd, - (ClientData) scalePtr, (void (*)()) NULL); - if (ConfigureScale(interp, scalePtr, argc-2, argv+2, 0) != TCL_OK) { - goto error; - } - - interp->result = Tk_PathName(scalePtr->tkwin); - return TCL_OK; - - error: - Tk_DestroyWindow(scalePtr->tkwin); - return TCL_ERROR; -} - -/* - *-------------------------------------------------------------- - * - * ScaleWidgetCmd -- - * - * This procedure is invoked to process the Tcl command - * that corresponds to a widget managed by this module. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *-------------------------------------------------------------- - */ - -static int -ScaleWidgetCmd(clientData, interp, argc, argv) - ClientData clientData; /* Information about scale - * widget. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - register Scale *scalePtr = (Scale *) clientData; - int result = TCL_OK; - int length; - char c; - - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " option ?arg arg ...?\"", (char *) NULL); - return TCL_ERROR; - } - Tk_Preserve((ClientData) scalePtr); - c = argv[1][0]; - length = strlen(argv[1]); - if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0)) { - if (argc == 2) { - result = Tk_ConfigureInfo(interp, scalePtr->tkwin, configSpecs, - (char *) scalePtr, (char *) NULL, 0); - } else if (argc == 3) { - result = Tk_ConfigureInfo(interp, scalePtr->tkwin, configSpecs, - (char *) scalePtr, argv[2], 0); - } else { - result = ConfigureScale(interp, scalePtr, argc-2, argv+2, - TK_CONFIG_ARGV_ONLY); - } - } else if ((c == 'g') && (strncmp(argv[1], "get", length) == 0)) { - if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " get\"", (char *) NULL); - goto error; - } - sprintf(interp->result, "%d", scalePtr->value); - } else if ((c == 's') && (strncmp(argv[1], "set", length) == 0)) { - int value; - - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " set value\"", (char *) NULL); - goto error; - } - if (Tcl_GetInt(interp, argv[2], &value) != TCL_OK) { - goto error; - } - if (scalePtr->state == tkNormalUid) { - if ((value < scalePtr->fromValue) - ^ (scalePtr->toValue < scalePtr->fromValue)) { - value = scalePtr->fromValue; - } - if ((value > scalePtr->toValue) - ^ (scalePtr->toValue < scalePtr->fromValue)) { - value = scalePtr->toValue; - } - SetScaleValue(scalePtr, value); - } - } else { - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be configure, get, or set", (char *) NULL); - goto error; - } - Tk_Release((ClientData) scalePtr); - return result; - - error: - Tk_Release((ClientData) scalePtr); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * DestroyScale -- - * - * This procedure is invoked by Tk_EventuallyFree or Tk_Release - * to clean up the internal structure of a button at a safe time - * (when no-one is using it anymore). - * - * Results: - * None. - * - * Side effects: - * Everything associated with the scale is freed up. - * - *---------------------------------------------------------------------- - */ - -static void -DestroyScale(clientData) - ClientData clientData; /* Info about scale widget. */ -{ - register Scale *scalePtr = (Scale *) clientData; - - /* - * Free up all the stuff that requires special handling, then - * let Tk_FreeOptions handle all the standard option-related - * stuff. - */ - - if (scalePtr->textGC != None) { - Tk_FreeGC(scalePtr->display, scalePtr->textGC); - } - Tk_FreeOptions(configSpecs, (char *) scalePtr, scalePtr->display, 0); - ckfree((char *) scalePtr); -} - -/* - *---------------------------------------------------------------------- - * - * ConfigureScale -- - * - * This procedure is called to process an argv/argc list, plus - * the Tk option database, in order to configure (or - * reconfigure) a scale widget. - * - * Results: - * The return value is a standard Tcl result. If TCL_ERROR is - * returned, then interp->result contains an error message. - * - * Side effects: - * Configuration information, such as colors, border width, - * etc. get set for scalePtr; old resources get freed, - * if there were any. - * - *---------------------------------------------------------------------- - */ - -static int -ConfigureScale(interp, scalePtr, argc, argv, flags) - Tcl_Interp *interp; /* Used for error reporting. */ - register Scale *scalePtr; /* Information about widget; may or may - * not already have values for some fields. */ - int argc; /* Number of valid entries in argv. */ - char **argv; /* Arguments. */ - int flags; /* Flags to pass to Tk_ConfigureWidget. */ -{ - XGCValues gcValues; - GC newGC; - int length; - - if (Tk_ConfigureWidget(interp, scalePtr->tkwin, configSpecs, - argc, argv, (char *) scalePtr, flags) != TCL_OK) { - return TCL_ERROR; - } - - /* - * A few options need special processing, such as parsing the - * orientation or setting the background from a 3-D border. - */ - - length = strlen(scalePtr->orientUid); - if (strncmp(scalePtr->orientUid, "vertical", length) == 0) { - scalePtr->vertical = 1; - } else if (strncmp(scalePtr->orientUid, "horizontal", length) == 0) { - scalePtr->vertical = 0; - } else { - Tcl_AppendResult(interp, "bad orientation \"", scalePtr->orientUid, - "\": must be vertical or horizontal", (char *) NULL); - return TCL_ERROR; - } - - if ((scalePtr->state != tkNormalUid) - && (scalePtr->state != tkDisabledUid)) { - Tcl_AppendResult(interp, "bad state value \"", scalePtr->state, - "\": must be normal or disabled", (char *) NULL); - scalePtr->state = tkNormalUid; - return TCL_ERROR; - } - - /* - * Make sure that the tick interval has the right sign so that - * addition moves from fromValue to toValue. - */ - - if ((scalePtr->tickInterval < 0) - ^ ((scalePtr->toValue - scalePtr->fromValue) < 0)) { - scalePtr->tickInterval = -scalePtr->tickInterval; - } - - /* - * Set the scale value to itself; all this does is to make sure - * that the scale's value is within the new acceptable range for - * the scale. - */ - - SetScaleValue(scalePtr, scalePtr->value); - - if (scalePtr->command != NULL) { - scalePtr->commandLength = strlen(scalePtr->command); - } else { - scalePtr->commandLength = 0; - } - - if (scalePtr->label != NULL) { - scalePtr->labelLength = strlen(scalePtr->label); - } else { - scalePtr->labelLength = 0; - } - - Tk_SetBackgroundFromBorder(scalePtr->tkwin, scalePtr->bgBorder); - - gcValues.font = scalePtr->fontPtr->fid; - gcValues.foreground = scalePtr->textColorPtr->pixel; - newGC = Tk_GetGC(scalePtr->tkwin, GCForeground|GCFont, &gcValues); - if (scalePtr->textGC != None) { - Tk_FreeGC(scalePtr->display, scalePtr->textGC); - } - scalePtr->textGC = newGC; - - if (scalePtr->relief != TK_RELIEF_FLAT) { - scalePtr->offset = scalePtr->borderWidth; - } else { - scalePtr->offset = 0; - } - - /* - * Recompute display-related information, and let the geometry - * manager know how much space is needed now. - */ - - ComputeScaleGeometry(scalePtr); - - EventuallyRedrawScale(scalePtr, REDRAW_ALL); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * ComputeScaleGeometry -- - * - * This procedure is called to compute various geometrical - * information for a scale, such as where various things get - * displayed. It's called when the window is reconfigured. - * - * Results: - * None. - * - * Side effects: - * Display-related numbers get changed in *scrollPtr. The - * geometry manager gets told about the window's preferred size. - * - *---------------------------------------------------------------------- - */ - -static void -ComputeScaleGeometry(scalePtr) - register Scale *scalePtr; /* Information about widget. */ -{ - XCharStruct bbox; - char valueString[30]; - int dummy, lineHeight; - - /* - * Horizontal scales are simpler than vertical ones because - * all sizes are the same (the height of a line of text); - * handle them first and then quit. - */ - - if (!scalePtr->vertical) { - lineHeight = scalePtr->fontPtr->ascent + scalePtr->fontPtr->descent; - if (scalePtr->tickInterval != 0) { - scalePtr->tickPixels = lineHeight; - } else { - scalePtr->tickPixels = 0; - } - if (scalePtr->showValue) { - scalePtr->valuePixels = lineHeight + SPACING; - } else { - scalePtr->valuePixels = 0; - } - if (scalePtr->labelLength != 0) { - scalePtr->labelPixels = lineHeight; - } else { - scalePtr->labelPixels = 0; - } - - Tk_GeometryRequest(scalePtr->tkwin, - scalePtr->length + 2*scalePtr->offset, - scalePtr->tickPixels + scalePtr->valuePixels - + scalePtr->width + 2*scalePtr->borderWidth - + scalePtr->labelPixels + 2*scalePtr->offset); - Tk_SetInternalBorder(scalePtr->tkwin, scalePtr->borderWidth); - return; - } - - /* - * Vertical scale: compute the amount of space needed for tick marks - * and current value by formatting strings for the two end points; - * use whichever length is longer. - */ - - sprintf(valueString, "%d", scalePtr->fromValue); - XTextExtents(scalePtr->fontPtr, valueString, strlen(valueString), - &dummy, &dummy, &dummy, &bbox); - scalePtr->tickPixels = bbox.rbearing - bbox.lbearing; - sprintf(valueString, "%d", scalePtr->toValue); - XTextExtents(scalePtr->fontPtr, valueString, strlen(valueString), - &dummy, &dummy, &dummy, &bbox); - if (scalePtr->tickPixels < bbox.rbearing - bbox.lbearing) { - scalePtr->tickPixels = bbox.rbearing - bbox.lbearing; - } - - /* - * Pad the value with a bit of extra space for prettier printing. - */ - - scalePtr->tickPixels += scalePtr->fontPtr->ascent/2; - scalePtr->valuePixels = scalePtr->tickPixels; - if (scalePtr->tickInterval == 0) { - scalePtr->tickPixels = 0; - } - if (!scalePtr->showValue) { - scalePtr->valuePixels = 0; - } - - if (scalePtr->labelLength == 0) { - scalePtr->labelPixels = 0; - } else { - XTextExtents(scalePtr->fontPtr, scalePtr->label, - scalePtr->labelLength, &dummy, &dummy, &dummy, &bbox); - scalePtr->labelPixels = bbox.rbearing - bbox.lbearing - + scalePtr->fontPtr->ascent; - } - Tk_GeometryRequest(scalePtr->tkwin, 4*scalePtr->borderWidth - + scalePtr->tickPixels + scalePtr->valuePixels + SPACING - + scalePtr->width + scalePtr->labelPixels, - scalePtr->length); - Tk_SetInternalBorder(scalePtr->tkwin, scalePtr->borderWidth); -} - -/* - *-------------------------------------------------------------- - * - * DisplayVerticalScale -- - * - * This procedure redraws the contents of a vertical scale - * window. It is invoked as a do-when-idle handler, so it only - * runs when there's nothing else for the application to do. - * - * Results: - * None. - * - * Side effects: - * Information appears on the screen. - * - *-------------------------------------------------------------- - */ - -static void -DisplayVerticalScale(clientData) - ClientData clientData; /* Information about widget. */ -{ - register Scale *scalePtr = (Scale *) clientData; - register Tk_Window tkwin = scalePtr->tkwin; - int tickRightEdge, valueRightEdge, labelLeftEdge, scaleLeftEdge; - int totalPixels, x, y, width, height, shadowWidth, tickValue; - int relief, result; - Tk_3DBorder sliderBorder; - char string[20]; - - if ((scalePtr->tkwin == NULL) || !Tk_IsMapped(tkwin)) { - goto done; - } - - /* - * Invoke the scale's command if needed. - */ - - if ((scalePtr->flags & INVOKE_COMMAND) && (scalePtr->command != NULL)) { - sprintf(string, " %d", scalePtr->value); - result = Tcl_VarEval(scalePtr->interp, scalePtr->command, string, - (char *) NULL); - if (result != TCL_OK) { - Tcl_AddErrorInfo(scalePtr->interp, - "\n (command executed by scale)"); - Tk_BackgroundError(scalePtr->interp); - } - } - scalePtr->flags &= ~INVOKE_COMMAND; - - /* - * Scanning from left to right across the window, the window - * will contain four columns: ticks, value, scale, and label. - * Compute the x-coordinate for each of the columns. - */ - - totalPixels = scalePtr->tickPixels + scalePtr->valuePixels - + 2*scalePtr->borderWidth + scalePtr->width - + 2*SPACING + scalePtr->labelPixels; - tickRightEdge = (Tk_Width(tkwin) - totalPixels)/2 + scalePtr->tickPixels; - valueRightEdge = tickRightEdge + scalePtr->valuePixels; - scaleLeftEdge = valueRightEdge + SPACING; - labelLeftEdge = scaleLeftEdge + 2*scalePtr->borderWidth - + scalePtr->width + scalePtr->fontPtr->ascent/2; - - /* - * Display the information from left to right across the window. - */ - - if (scalePtr->flags & REDRAW_OTHER) { - XClearWindow(scalePtr->display, Tk_WindowId(tkwin)); - - /* - * Display the tick marks. - */ - - if (scalePtr->tickPixels != 0) { - for (tickValue = scalePtr->fromValue; ; - tickValue += scalePtr->tickInterval) { - if (scalePtr->toValue > scalePtr->fromValue) { - if (tickValue > scalePtr->toValue) { - break; - } - } else { - if (tickValue < scalePtr->toValue) { - break; - } - } - DisplayVerticalValue(scalePtr, tickValue, tickRightEdge); - } - } - } - - /* - * Display the value, if it is desired. If not redisplaying the - * entire window, clear the area of the value to get rid of the - * old value displayed there. - */ - - if (scalePtr->showValue) { - if (!(scalePtr->flags & REDRAW_OTHER)) { - XClearArea(scalePtr->display, Tk_WindowId(tkwin), - valueRightEdge-scalePtr->valuePixels, scalePtr->offset, - scalePtr->valuePixels, - Tk_Height(tkwin) - 2*scalePtr->offset, False); - } - DisplayVerticalValue(scalePtr, scalePtr->value, valueRightEdge); - } - - /* - * Display the scale and the slider. If not redisplaying the - * entire window, must clear the trench area to erase the old - * slider, but don't need to redraw the border. - */ - - if (scalePtr->flags & REDRAW_OTHER) { - Tk_Draw3DRectangle(scalePtr->display, Tk_WindowId(tkwin), - scalePtr->bgBorder, scaleLeftEdge, scalePtr->offset, - scalePtr->width + 2*scalePtr->borderWidth, - Tk_Height(tkwin) - 2*scalePtr->offset, scalePtr->borderWidth, - TK_RELIEF_SUNKEN); - } else { - XClearArea(scalePtr->display, Tk_WindowId(tkwin), - scaleLeftEdge + scalePtr->borderWidth, - scalePtr->offset + scalePtr->borderWidth, - scalePtr->width, - Tk_Height(tkwin) - 2*scalePtr->offset - - 2*scalePtr->borderWidth, False); - } - if (scalePtr->flags & ACTIVE) { - sliderBorder = scalePtr->activeBorder; - } else { - sliderBorder = scalePtr->sliderBorder; - } - width = scalePtr->width; - height = scalePtr->sliderLength/2; - x = scaleLeftEdge + scalePtr->borderWidth; - y = ValueToPixel(scalePtr, scalePtr->value) - height; - shadowWidth = scalePtr->borderWidth/2; - if (shadowWidth == 0) { - shadowWidth = 1; - } - relief = (scalePtr->flags & BUTTON_PRESSED) ? TK_RELIEF_SUNKEN - : TK_RELIEF_RAISED; - Tk_Draw3DRectangle(scalePtr->display, Tk_WindowId(tkwin), sliderBorder, - x, y, width, 2*height, shadowWidth, relief); - x += shadowWidth; - y += shadowWidth; - width -= 2*shadowWidth; - height -= shadowWidth; - Tk_Fill3DRectangle(scalePtr->display, Tk_WindowId(tkwin), sliderBorder, - x, y, width, height, shadowWidth, relief); - Tk_Fill3DRectangle(scalePtr->display, Tk_WindowId(tkwin), sliderBorder, - x, y+height, width, height, shadowWidth, relief); - - /* - * Draw the label to the right of the scale. - */ - - if ((scalePtr->flags & REDRAW_OTHER) && (scalePtr->labelPixels != 0)) { - XDrawString(scalePtr->display, Tk_WindowId(scalePtr->tkwin), - scalePtr->textGC, labelLeftEdge, - scalePtr->offset + (3*scalePtr->fontPtr->ascent)/2, - scalePtr->label, scalePtr->labelLength); - } - - /* - * Draw the window border. - */ - - if ((scalePtr->flags & REDRAW_OTHER) - && (scalePtr->relief != TK_RELIEF_FLAT)) { - Tk_Draw3DRectangle(scalePtr->display, Tk_WindowId(tkwin), - scalePtr->bgBorder, 0, 0, Tk_Width(tkwin), Tk_Height(tkwin), - scalePtr->borderWidth, scalePtr->relief); - } - - done: - scalePtr->flags &= ~REDRAW_ALL; -} - -/* - *---------------------------------------------------------------------- - * - * DisplayVerticalValue -- - * - * This procedure is called to display values (scale readings) - * for vertically-oriented scales. - * - * Results: - * None. - * - * Side effects: - * The numerical value corresponding to value is displayed with - * its right edge at "rightEdge", and at a vertical position in - * the scale that corresponds to "value". - * - *---------------------------------------------------------------------- - */ - -static void -DisplayVerticalValue(scalePtr, value, rightEdge) - register Scale *scalePtr; /* Information about widget in which to - * display value. */ - int value; /* Y-coordinate of number to display, - * specified in application coords, not - * in pixels (we'll compute pixels). */ - int rightEdge; /* X-coordinate of right edge of text, - * specified in pixels. */ -{ - register Tk_Window tkwin = scalePtr->tkwin; - int y, dummy, length; - char valueString[30]; - XCharStruct bbox; - - y = ValueToPixel(scalePtr, value) + scalePtr->fontPtr->ascent/2; - sprintf(valueString, "%d", value); - length = strlen(valueString); - XTextExtents(scalePtr->fontPtr, valueString, length, - &dummy, &dummy, &dummy, &bbox); - - /* - * Adjust the y-coordinate if necessary to keep the text entirely - * inside the window. - */ - - if ((y - bbox.ascent) < scalePtr->offset) { - y = scalePtr->offset + bbox.ascent; - } - if ((y + bbox.descent) > (Tk_Height(tkwin) - scalePtr->offset)) { - y = Tk_Height(tkwin) - scalePtr->offset - bbox.descent; - } - XDrawString(scalePtr->display, Tk_WindowId(tkwin), - scalePtr->textGC, rightEdge - bbox.rbearing, - y, valueString, length); -} - -/* - *-------------------------------------------------------------- - * - * DisplayHorizontalScale -- - * - * This procedure redraws the contents of a horizontal scale - * window. It is invoked as a do-when-idle handler, so it only - * runs when there's nothing else for the application to do. - * - * Results: - * None. - * - * Side effects: - * Information appears on the screen. - * - *-------------------------------------------------------------- - */ - -static void -DisplayHorizontalScale(clientData) - ClientData clientData; /* Information about widget. */ -{ - register Scale *scalePtr = (Scale *) clientData; - register Tk_Window tkwin = scalePtr->tkwin; - int tickBottom, valueBottom, labelBottom, scaleBottom; - int totalPixels, x, y, width, height, shadowWidth, tickValue; - int relief, result; - Tk_3DBorder sliderBorder; - char string[20]; - - if ((scalePtr->tkwin == NULL) || !Tk_IsMapped(tkwin)) { - goto done; - } - - /* - * Invoke the scale's command if needed. - */ - - if ((scalePtr->flags & INVOKE_COMMAND) && (scalePtr->command != NULL)) { - sprintf(string, " %d", scalePtr->value); - result = Tcl_VarEval(scalePtr->interp, scalePtr->command, string, - (char *) NULL); - if (result != TCL_OK) { - Tcl_AddErrorInfo(scalePtr->interp, - "\n (command executed by scale)"); - Tk_BackgroundError(scalePtr->interp); - } - } - scalePtr->flags &= ~INVOKE_COMMAND; - - /* - * Scanning from bottom to top across the window, the window - * will contain four rows: ticks, value, scale, and label. - * Compute the y-coordinate for each of the rows. - */ - - totalPixels = scalePtr->tickPixels + scalePtr->valuePixels - + 2*scalePtr->borderWidth + scalePtr->width - + scalePtr->labelPixels; - tickBottom = (Tk_Height(tkwin) + totalPixels)/2 - 1; - valueBottom = tickBottom - scalePtr->tickPixels; - scaleBottom = valueBottom - scalePtr->valuePixels; - labelBottom = scaleBottom - 2*scalePtr->borderWidth - scalePtr->width; - - /* - * Display the information from bottom to top across the window. - */ - - if (scalePtr->flags & REDRAW_OTHER) { - XClearWindow(scalePtr->display, Tk_WindowId(tkwin)); - - /* - * Display the tick marks. - */ - - if (scalePtr->tickPixels != 0) { - for (tickValue = scalePtr->fromValue; ; - tickValue += scalePtr->tickInterval) { - if (scalePtr->toValue > scalePtr->fromValue) { - if (tickValue > scalePtr->toValue) { - break; - } - } else { - if (tickValue < scalePtr->toValue) { - break; - } - } - DisplayHorizontalValue(scalePtr, tickValue, tickBottom); - } - } - } - - /* - * Display the value, if it is desired. If not redisplaying the - * entire window, clear the area of the value to get rid of the - * old value displayed there. - */ - - if (scalePtr->showValue) { - if (!(scalePtr->flags & REDRAW_OTHER)) { - XClearArea(scalePtr->display, Tk_WindowId(tkwin), - scalePtr->offset, scaleBottom + 1, - Tk_Width(tkwin) - 2*scalePtr->offset, - valueBottom - scaleBottom, False); - } - DisplayHorizontalValue(scalePtr, scalePtr->value, valueBottom); - } - - /* - * Display the scale and the slider. If not redisplaying the - * entire window, must clear the trench area to erase the old - * slider, but don't need to redraw the border. - */ - - y = scaleBottom - 2*scalePtr->borderWidth - scalePtr->width + 1; - if (scalePtr->flags & REDRAW_OTHER) { - Tk_Draw3DRectangle(scalePtr->display, Tk_WindowId(tkwin), - scalePtr->bgBorder, scalePtr->offset, y, - Tk_Width(tkwin) - 2*scalePtr->offset, - scalePtr->width + 2*scalePtr->borderWidth, - scalePtr->borderWidth, TK_RELIEF_SUNKEN); - } else { - XClearArea(scalePtr->display, Tk_WindowId(tkwin), - scalePtr->offset + scalePtr->borderWidth, - y + scalePtr->borderWidth, - Tk_Width(tkwin) - 2*scalePtr->offset - 2*scalePtr->borderWidth, - scalePtr->width, False); - } - if (scalePtr->flags & ACTIVE) { - sliderBorder = scalePtr->activeBorder; - } else { - sliderBorder = scalePtr->sliderBorder; - } - width = scalePtr->sliderLength/2; - height = scalePtr->width; - x = ValueToPixel(scalePtr, scalePtr->value) - width; - y += scalePtr->borderWidth; - shadowWidth = scalePtr->borderWidth/2; - if (shadowWidth == 0) { - shadowWidth = 1; - } - relief = (scalePtr->flags & BUTTON_PRESSED) ? TK_RELIEF_SUNKEN - : TK_RELIEF_RAISED; - Tk_Draw3DRectangle(scalePtr->display, Tk_WindowId(tkwin), sliderBorder, - x, y, 2*width, height, shadowWidth, relief); - x += shadowWidth; - y += shadowWidth; - width -= shadowWidth; - height -= 2*shadowWidth; - Tk_Fill3DRectangle(scalePtr->display, Tk_WindowId(tkwin), sliderBorder, - x, y, width, height, shadowWidth, relief); - Tk_Fill3DRectangle(scalePtr->display, Tk_WindowId(tkwin), sliderBorder, - x+width, y, width, height, shadowWidth, relief); - - /* - * Draw the label to the top of the scale. - */ - - if ((scalePtr->flags & REDRAW_OTHER) && (scalePtr->labelPixels != 0)) { - XDrawString(scalePtr->display, Tk_WindowId(scalePtr->tkwin), - scalePtr->textGC, scalePtr->offset + scalePtr->fontPtr->ascent/2, - labelBottom - scalePtr->fontPtr->descent, - scalePtr->label, scalePtr->labelLength); - } - - /* - * Draw the window border. - */ - - if ((scalePtr->flags & REDRAW_OTHER) - && (scalePtr->relief != TK_RELIEF_FLAT)) { - Tk_Draw3DRectangle(scalePtr->display, Tk_WindowId(tkwin), - scalePtr->bgBorder, 0, 0, Tk_Width(tkwin), Tk_Height(tkwin), - scalePtr->borderWidth, scalePtr->relief); - } - - done: - scalePtr->flags &= ~REDRAW_ALL; -} - -/* - *---------------------------------------------------------------------- - * - * DisplayHorizontalValue -- - * - * This procedure is called to display values (scale readings) - * for horizontally-oriented scales. - * - * Results: - * None. - * - * Side effects: - * The numerical value corresponding to value is displayed with - * its bottom edge at "bottom", and at a horizontal position in - * the scale that corresponds to "value". - * - *---------------------------------------------------------------------- - */ - -static void -DisplayHorizontalValue(scalePtr, value, bottom) - register Scale *scalePtr; /* Information about widget in which to - * display value. */ - int value; /* Y-coordinate of number to display, - * specified in application coords, not - * in pixels (we'll compute pixels). */ - int bottom; /* Y-coordinate of bottom edge of text, - * specified in pixels. */ -{ - register Tk_Window tkwin = scalePtr->tkwin; - int x, y, dummy, length; - char valueString[30]; - XCharStruct bbox; - - x = ValueToPixel(scalePtr, value); - y = bottom - scalePtr->fontPtr->descent; - sprintf(valueString, "%d", value); - length = strlen(valueString); - XTextExtents(scalePtr->fontPtr, valueString, length, - &dummy, &dummy, &dummy, &bbox); - - /* - * Adjust the x-coordinate if necessary to keep the text entirely - * inside the window. - */ - - x -= (bbox.lbearing + bbox.rbearing)/2; - if ((x - bbox.lbearing) < scalePtr->offset) { - x = scalePtr->offset + bbox.lbearing; - } - if ((y + bbox.rbearing) > (Tk_Width(tkwin) - scalePtr->offset)) { - x = Tk_Width(tkwin) - scalePtr->offset - bbox.rbearing; - } - XDrawString(scalePtr->display, Tk_WindowId(tkwin), - scalePtr->textGC, x, y, valueString, length); -} - -/* - *---------------------------------------------------------------------- - * - * PixelToValue -- - * - * Given a pixel within a scale window, return the scale - * reading corresponding to that pixel. - * - * Results: - * An integer scale reading. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -PixelToValue(scalePtr, x, y) - register Scale *scalePtr; /* Information about widget. */ - int x, y; /* Coordinates of point within - * window. */ -{ - int value, pixelRange; - double dtmp; - - if (scalePtr->vertical) { - pixelRange = Tk_Height(scalePtr->tkwin) - scalePtr->sliderLength - - 2*scalePtr->offset - 2*scalePtr->borderWidth; - value = y; - } else { - pixelRange = Tk_Width(scalePtr->tkwin) - scalePtr->sliderLength - - 2*scalePtr->offset - 2*scalePtr->borderWidth; - value = x; - } - - if (pixelRange <= 0) { - /* - * Not enough room for the slider to actually slide: just return - * the scale's current value. - */ - - return scalePtr->value; - } - value -= scalePtr->sliderLength/2 + scalePtr->offset - + scalePtr->borderWidth; - if (value < 0) { - value = 0; - } - if (value > pixelRange) { - value = pixelRange; - } - - /* - * The mathematics below is a bit tricky. To avoid integer overflow - * during the multiplication and division steps, do the arithmetic - * using doubles. - */ - - dtmp = value * ((double) (scalePtr->toValue - scalePtr->fromValue)); - dtmp = scalePtr->fromValue + dtmp/pixelRange; - if (dtmp < 0) { - value = dtmp - 0.5; - } else { - value = dtmp + 0.5; - } - return value; -} - -/* - *---------------------------------------------------------------------- - * - * ValueToPixel -- - * - * Given a reading of the scale, return the x-coordinate or - * y-coordinate corresponding to that reading, depending on - * whether the scale is vertical or horizontal, respectively. - * - * Results: - * An integer value giving the pixel location corresponding - * to reading. The value is restricted to lie within the - * defined range for the scale. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -ValueToPixel(scalePtr, value) - register Scale *scalePtr; /* Information about widget. */ - int value; /* Reading of the widget. */ -{ - int y, pixelRange, valueRange; - double dtmp; - - valueRange = scalePtr->toValue - scalePtr->fromValue; - pixelRange = (scalePtr->vertical ? Tk_Height(scalePtr->tkwin) - : Tk_Width(scalePtr->tkwin)) - scalePtr->sliderLength - - 2*scalePtr->offset - 2*scalePtr->borderWidth; - if (valueRange == 0) { - y = 0; - } else { - /* - * Do arithmetic with doubles to avoid integer overflow if the - * scale has a large range. - */ - - dtmp = (value - scalePtr->fromValue); - dtmp = (dtmp * pixelRange)/valueRange; - y = dtmp + 0.5; - if (y < 0) { - y = 0; - } else if (y > pixelRange) { - y = pixelRange; - } - } - y += scalePtr->sliderLength/2 + scalePtr->offset + scalePtr->borderWidth; - return y; -} - -/* - *-------------------------------------------------------------- - * - * ScaleEventProc -- - * - * This procedure is invoked by the Tk dispatcher for various - * events on scales. - * - * Results: - * None. - * - * Side effects: - * When the window gets deleted, internal structures get - * cleaned up. When it gets exposed, it is redisplayed. - * - *-------------------------------------------------------------- - */ - -static void -ScaleEventProc(clientData, eventPtr) - ClientData clientData; /* Information about window. */ - XEvent *eventPtr; /* Information about event. */ -{ - Scale *scalePtr = (Scale *) clientData; - - if ((eventPtr->type == Expose) && (eventPtr->xexpose.count == 0)) { - EventuallyRedrawScale(scalePtr, REDRAW_ALL); - } else if (eventPtr->type == DestroyNotify) { - Tcl_DeleteCommand(scalePtr->interp, Tk_PathName(scalePtr->tkwin)); - scalePtr->tkwin = NULL; - if (scalePtr->flags & REDRAW_ALL) { - if (scalePtr->vertical) { - Tk_CancelIdleCall(DisplayVerticalScale, (ClientData) scalePtr); - } else { - Tk_CancelIdleCall(DisplayHorizontalScale, - (ClientData) scalePtr); - } - } - Tk_EventuallyFree((ClientData) scalePtr, DestroyScale); - } else if (eventPtr->type == ConfigureNotify) { - ComputeScaleGeometry(scalePtr); - } -} - -/* - *-------------------------------------------------------------- - * - * ScaleMouseProc -- - * - * This procedure is called back by Tk in response to - * mouse events such as window entry, window exit, mouse - * motion, and button presses. - * - * Results: - * None. - * - * Side effects: - * This procedure implements the "feel" of the scale by - * issuing commands in response to button presses and mouse - * motion. - * - *-------------------------------------------------------------- - */ - -static void -ScaleMouseProc(clientData, eventPtr) - ClientData clientData; /* Information about window. */ - register XEvent *eventPtr; /* Information about event. */ -{ - register Scale *scalePtr = (Scale *) clientData; - - if (scalePtr->state != tkNormalUid) { - return; - } - - Tk_Preserve((ClientData) scalePtr); - if (eventPtr->type == EnterNotify) { - scalePtr->flags |= ACTIVE; - EventuallyRedrawScale(scalePtr, REDRAW_SLIDER); - } else if (eventPtr->type == LeaveNotify) { - scalePtr->flags &= ~ACTIVE; - EventuallyRedrawScale(scalePtr, REDRAW_SLIDER); - } else if ((eventPtr->type == MotionNotify) - && (scalePtr->flags & BUTTON_PRESSED)) { - SetScaleValue(scalePtr, PixelToValue(scalePtr, - eventPtr->xmotion.x, eventPtr->xmotion.y)); - } else if ((eventPtr->type == ButtonPress) - && (eventPtr->xbutton.button == Button1) - && (eventPtr->xbutton.state == 0)) { - scalePtr->flags |= BUTTON_PRESSED; - SetScaleValue(scalePtr, PixelToValue(scalePtr, - eventPtr->xbutton.x, eventPtr->xbutton.y)); - EventuallyRedrawScale(scalePtr, REDRAW_SLIDER); - } else if ((eventPtr->type == ButtonRelease) - && (eventPtr->xbutton.button == Button1) - && (scalePtr->flags & BUTTON_PRESSED)) { - scalePtr->flags &= ~BUTTON_PRESSED; - EventuallyRedrawScale(scalePtr, REDRAW_SLIDER); - } - Tk_Release((ClientData) scalePtr); -} - -/* - *-------------------------------------------------------------- - * - * SetScaleValue -- - * - * This procedure changes the value of a scale and invokes - * a Tcl command to reflect the current position of a scale - * - * Results: - * None. - * - * Side effects: - * A Tcl command is invoked, and an additional error-processing - * command may also be invoked. The scale's slider is redrawn. - * - *-------------------------------------------------------------- - */ - -static void -SetScaleValue(scalePtr, value) - register Scale *scalePtr; /* Info about widget. */ - int value; /* New value for scale. Gets - * adjusted if it's off the scale. */ -{ - if ((value < scalePtr->fromValue) - ^ (scalePtr->toValue < scalePtr->fromValue)) { - value = scalePtr->fromValue; - } - if ((value > scalePtr->toValue) - ^ (scalePtr->toValue < scalePtr->fromValue)) { - value = scalePtr->toValue; - } - if (value == scalePtr->value) { - return; - } - scalePtr->value = value; - scalePtr->flags |= INVOKE_COMMAND; - EventuallyRedrawScale(scalePtr, REDRAW_SLIDER); -} - -/* - *-------------------------------------------------------------- - * - * EventuallyRedrawScale -- - * - * Arrange for part or all of a scale widget to redrawn at - * the next convenient time in the future. - * - * Results: - * None. - * - * Side effects: - * If "what" is REDRAW_SLIDER then just the slider and the - * value readout will be redrawn; if "what" is REDRAW_ALL - * then the entire widget will be redrawn. - * - *-------------------------------------------------------------- - */ - -static void -EventuallyRedrawScale(scalePtr, what) - register Scale *scalePtr; /* Information about widget. */ - int what; /* What to redraw: REDRAW_SLIDER - * or REDRAW_ALL. */ -{ - if ((what == 0) || (scalePtr->tkwin == NULL) - || !Tk_IsMapped(scalePtr->tkwin)) { - return; - } - if ((scalePtr->flags & REDRAW_ALL) == 0) { - if (scalePtr->vertical) { - Tk_DoWhenIdle(DisplayVerticalScale, (ClientData) scalePtr); - } else { - Tk_DoWhenIdle(DisplayHorizontalScale, (ClientData) scalePtr); - } - } - scalePtr->flags |= what; -} diff --git a/tk3.6/tkSelect.c b/tk3.6/tkSelect.c deleted file mode 100644 index fcd93cf..0000000 --- a/tk3.6/tkSelect.c +++ /dev/null @@ -1,2117 +0,0 @@ -/* - * tkSelect.c -- - * - * This file manages the selection for the Tk toolkit, - * translating between the standard X ICCCM conventions - * and Tcl commands. - * - * 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/wish/RCS/tkSelect.c,v 1.34 93/08/18 16:24:57 ouster Exp $ SPRITE (Berkeley)"; -#endif - -#include "tkConfig.h" -#include "tkInt.h" - -/* - * When the selection is being retrieved, one of the following - * structures is present on a list of pending selection retrievals. - * The structure is used to communicate between the background - * procedure that requests the selection and the foreground - * event handler that processes the events in which the selection - * is returned. There is a list of such structures so that there - * can be multiple simultaneous selection retrievals (e.g. on - * different displays). - */ - -typedef struct RetrievalInfo { - Tcl_Interp *interp; /* Interpreter for error reporting. */ - TkWindow *winPtr; /* Window used as requestor for - * selection. */ - Atom property; /* Property where selection will appear. */ - Atom target; /* Desired form for selection. */ - int (*proc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, - char *portion)); /* Procedure to call to handle pieces - * of selection. */ - ClientData clientData; /* Argument for proc. */ - int result; /* Initially -1. Set to a Tcl - * return value once the selection - * has been retrieved. */ - Tk_TimerToken timeout; /* Token for current timeout procedure. */ - int idleTime; /* Number of seconds that have gone by - * without hearing anything from the - * selection owner. */ - struct RetrievalInfo *nextPtr; - /* Next in list of all pending - * selection retrievals. NULL means - * end of list. */ -} RetrievalInfo; - -static RetrievalInfo *pendingRetrievals = NULL; - /* List of all retrievals currently - * being waited for. */ - -/* - * When "selection get" is being used to retrieve the selection, - * the following data structure is used for communication between - * Tk_SelectionCmd and SelGetProc. Its purpose is to keep track - * of the selection contents, which are gradually assembled in a - * string. - */ - -typedef struct { - char *string; /* Contents of selection are - * here. This space is malloc-ed. */ - int bytesAvl; /* Total number of bytes available - * at string. */ - int bytesUsed; /* Bytes currently in use in string, - * not including the terminating - * NULL. */ -} GetInfo; - -/* - * When handling INCR-style selection retrievals, the selection owner - * uses the following data structure to communicate between the - * ConvertSelection procedure and TkSelPropProc. - */ - -typedef struct IncrInfo { - TkWindow *winPtr; /* Window that owns selection. */ - Atom *multAtoms; /* Information about conversions to - * perform: one or more pairs of - * (target, property). This either - * points to a retrieved property (for - * MULTIPLE retrievals) or to a static - * array. */ - unsigned long numConversions; - /* Number of entries in offsets (same as - * # of pairs in multAtoms). */ - int *offsets; /* One entry for each pair in - * multAtoms; -1 means all data has - * been transferred for this - * conversion. -2 means only the - * final zero-length transfer still - * has to be done. Otherwise it is the - * offset of the next chunk of data - * to transfer. This array is malloc-ed. */ - int numIncrs; /* Number of entries in offsets that - * aren't -1 (i.e. # of INCR-mode transfers - * not yet completed). */ - Tk_TimerToken timeout; /* Token for timer procedure. */ - int idleTime; /* Number of seconds since we heard - * anything from the selection - * requestor. */ - Window reqWindow; /* Requestor's window id. */ - Time time; /* Timestamp corresponding to - * selection at beginning of request; - * used to abort transfer if selection - * changes. */ - struct IncrInfo *nextPtr; /* Next in list of all INCR-style - * retrievals currently pending. */ -} IncrInfo; - -static IncrInfo *pendingIncrs = NULL; - /* List of all IncrInfo structures - * currently active. */ - -/* - * When a selection handler is set up by invoking "selection handle", - * one of the following data structures is set up to hold information - * about the command to invoke and its interpreter. - */ - -typedef struct { - Tcl_Interp *interp; /* Interpreter in which to invoke command. */ - int cmdLength; /* # of non-NULL bytes in command. */ - char command[4]; /* Command to invoke. Actual space is - * allocated as large as necessary. This - * must be the last entry in the structure. */ -} CommandInfo; - -/* - * When selection ownership is claimed with the "selection own" Tcl command, - * one of the following structures is created to record the Tcl command - * to be executed when the selection is lost again. - */ - -typedef struct LostCommand { - Tcl_Interp *interp; /* Interpreter in which to invoke command. */ - char command[4]; /* Command to invoke. Actual space is - * allocated as large as necessary. This - * must be the last entry in the structure. */ -} LostCommand; - -/* - * Chunk size for retrieving selection. It's defined both in - * words and in bytes; the word size is used to allocate - * buffer space that's guaranteed to be word-aligned and that - * has an extra character for the terminating NULL. - */ - -#define TK_SEL_BYTES_AT_ONCE 4000 -#define TK_SEL_WORDS_AT_ONCE 1001 - -/* - * Largest property that we'll accept when sending or receiving the - * selection: - */ - -#define MAX_PROP_WORDS 100000 - -/* - * Forward declarations for procedures defined in this file: - */ - -static void ConvertSelection _ANSI_ARGS_((TkWindow *winPtr, - XSelectionRequestEvent *eventPtr)); -static int DefaultSelection _ANSI_ARGS_((TkWindow *winPtr, - Atom target, char *buffer, int maxBytes, - Atom *typePtr)); -static int HandleTclCommand _ANSI_ARGS_((ClientData clientData, - int offset, char *buffer, int maxBytes)); -static void IncrTimeoutProc _ANSI_ARGS_((ClientData clientData)); -static void LostSelection _ANSI_ARGS_((ClientData clientData)); -static char * SelCvtFromX _ANSI_ARGS_((long *propPtr, int numValues, - Atom type, Tk_Window tkwin)); -static long * SelCvtToX _ANSI_ARGS_((char *string, Atom type, - Tk_Window tkwin, int *numLongsPtr)); -static int SelGetProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, char *portion)); -static void SelInit _ANSI_ARGS_((Tk_Window tkwin)); -static void SelRcvIncrProc _ANSI_ARGS_((ClientData clientData, - XEvent *eventPtr)); -static void SelTimeoutProc _ANSI_ARGS_((ClientData clientData)); - -/* - *-------------------------------------------------------------- - * - * Tk_CreateSelHandler -- - * - * This procedure is called to register a procedure - * as the handler for selection requests of a particular - * target type on a particular window. - * - * Results: - * None. - * - * Side effects: - * In the future, whenever the selection is in tkwin's - * window and someone requests the selection in the - * form given by target, proc will be invoked to provide - * part or all of the selection in the given form. If - * there was already a handler declared for the given - * window and target type, then it is replaced. Proc - * should have the following form: - * - * int - * proc(clientData, offset, buffer, maxBytes) - * ClientData clientData; - * int offset; - * char *buffer; - * int maxBytes; - * { - * } - * - * The clientData argument to proc will be the same as - * the clientData argument to this procedure. The offset - * argument indicates which portion of the selection to - * return: skip the first offset bytes. Buffer is a - * pointer to an area in which to place the converted - * selection, and maxBytes gives the number of bytes - * available at buffer. Proc should place the selection - * in buffer as a string, and return a count of the number - * of bytes of selection actually placed in buffer (not - * including the terminating NULL character). If the - * return value equals maxBytes, this is a sign that there - * is probably still more selection information available. - * - *-------------------------------------------------------------- - */ - -void -Tk_CreateSelHandler(tkwin, target, proc, clientData, format) - Tk_Window tkwin; /* Token for window. */ - Atom target; /* The kind of selection conversions - * that can be handled by proc, - * e.g. TARGETS or XA_STRING. */ - Tk_SelectionProc *proc; /* Procedure to invoke to convert - * selection to type "target". */ - ClientData clientData; /* Value to pass to proc. */ - Atom format; /* Format in which the selection - * information should be returned to - * the requestor. XA_STRING is best by - * far, but anything listed in the ICCCM - * will be tolerated (blech). */ -{ - register TkSelHandler *selPtr; - TkWindow *winPtr = (TkWindow *) tkwin; - - if (winPtr->dispPtr->multipleAtom == None) { - SelInit(tkwin); - } - - /* - * See if there's already a handler for this target on - * this window. If so, re-use it. If not, create a new one. - */ - - for (selPtr = winPtr->selHandlerList; ; selPtr = selPtr->nextPtr) { - if (selPtr == NULL) { - selPtr = (TkSelHandler *) ckalloc(sizeof(TkSelHandler)); - selPtr->nextPtr = winPtr->selHandlerList; - winPtr->selHandlerList = selPtr; - break; - } - if (selPtr->target == target) { - - /* - * Special case: when replacing handler created by - * "selection handle" free up memory. Should there be a - * callback to allow other clients to do this too? - */ - - if (selPtr->proc == HandleTclCommand) { - ckfree((char *) selPtr->clientData); - } - break; - } - } - selPtr->target = target; - selPtr->format = format; - selPtr->proc = proc; - selPtr->clientData = clientData; - if (format == XA_STRING) { - selPtr->size = 8; - } else { - selPtr->size = 32; - } -} - -/* - *---------------------------------------------------------------------- - * - * Tk_DeleteSelHandler -- - * - * Remove the selection handler for a given window and target, - * if it exists. - * - * Results: - * None. - * - * Side effects: - * The selection handler for tkwin and target is removed. If there - * is no such handler then nothing happens. - * - *---------------------------------------------------------------------- - */ - -void -Tk_DeleteSelHandler(tkwin, target) - Tk_Window tkwin; /* Token for window. */ - Atom target; /* The target whose selection - * handler is to be removed. */ -{ - TkWindow *winPtr = (TkWindow *) tkwin; - register TkSelHandler *selPtr, *prevPtr; - - for (selPtr = winPtr->selHandlerList, prevPtr = NULL; - selPtr != NULL; prevPtr = selPtr, selPtr = selPtr->nextPtr) { - if (selPtr->target == target) { - if (prevPtr == NULL) { - winPtr->selHandlerList = selPtr->nextPtr; - } else { - prevPtr->nextPtr = selPtr->nextPtr; - } - if (selPtr->proc == HandleTclCommand) { - ckfree((char *) selPtr->clientData); - } - ckfree((char *) selPtr); - return; - } - } -} - -/* - *-------------------------------------------------------------- - * - * Tk_OwnSelection -- - * - * Arrange for tkwin to become the selection owner. - * - * Results: - * None. - * - * Side effects: - * From now on, requests for the selection will be - * directed to procedures associated with tkwin (they - * must have been declared with calls to Tk_CreateSelHandler). - * When the selection is lost by this window, proc will - * be invoked (see the manual entry for details). - * - *-------------------------------------------------------------- - */ - -void -Tk_OwnSelection(tkwin, proc, clientData) - Tk_Window tkwin; /* Window to become new selection - * owner. */ - Tk_LostSelProc *proc; /* Procedure to call when selection - * is taken away from tkwin. */ - ClientData clientData; /* Arbitrary one-word argument to - * pass to proc. */ -{ - register TkWindow *winPtr = (TkWindow *) tkwin; - TkDisplay *dispPtr = winPtr->dispPtr; - - if (dispPtr->multipleAtom == None) { - SelInit(tkwin); - } - - Tk_MakeWindowExist(tkwin); - winPtr->selClearProc = proc; - winPtr->selClearData = clientData; - if (dispPtr->selectionOwner != tkwin) { - TkWindow *ownerPtr = (TkWindow *) dispPtr->selectionOwner; - - if ((ownerPtr != NULL) - && (ownerPtr->selClearProc != NULL)) { - (*ownerPtr->selClearProc)(ownerPtr->selClearData); - ownerPtr->selClearProc = NULL; - } - } - dispPtr->selectionOwner = tkwin; - dispPtr->selectionSerial = NextRequest(winPtr->display); - dispPtr->selectionTime = TkCurrentTime(dispPtr); - XSetSelectionOwner(winPtr->display, XA_PRIMARY, winPtr->window, - dispPtr->selectionTime); -} - -/* - *---------------------------------------------------------------------- - * - * Tk_ClearSelection -- - * - * Eliminate the selection on tkwin's display, if there is one. - * - * Results: - * None. - * - * Side effects: - * The selection is cleared, so that future requests to retrieve - * it will fail until some application owns it again.. - * - *---------------------------------------------------------------------- - */ - -void -Tk_ClearSelection(tkwin) - Tk_Window tkwin; /* Window that selects a display. */ -{ - register TkWindow *winPtr = (TkWindow *) tkwin; - TkDisplay *dispPtr = winPtr->dispPtr; - - if (dispPtr->multipleAtom == None) { - SelInit(tkwin); - } - - if (dispPtr->selectionOwner != NULL) { - TkWindow *ownerPtr = (TkWindow *) dispPtr->selectionOwner; - - if ((ownerPtr != NULL) - && (ownerPtr->selClearProc != NULL)) { - (*ownerPtr->selClearProc)(ownerPtr->selClearData); - ownerPtr->selClearProc = NULL; - } - } - dispPtr->selectionOwner = NULL; - XSetSelectionOwner(winPtr->display, XA_PRIMARY, None, CurrentTime); -} - -/* - *-------------------------------------------------------------- - * - * Tk_GetSelection -- - * - * Retrieve the selection and pass it off (in pieces, - * possibly) to a given procedure. - * - * Results: - * The return value is a standard Tcl return value. - * If an error occurs (such as no selection exists) - * then an error message is left in interp->result. - * - * Side effects: - * The standard X11 protocols are used to retrieve the - * selection. When it arrives, it is passed to proc. If - * the selection is very large, it will be passed to proc - * in several pieces. Proc should have the following - * structure: - * - * int - * proc(clientData, interp, portion) - * ClientData clientData; - * Tcl_Interp *interp; - * char *portion; - * { - * } - * - * The interp and clientData arguments to proc will be the - * same as the corresponding arguments to Tk_GetSelection. - * The portion argument points to a character string - * containing part of the selection, and numBytes indicates - * the length of the portion, not including the terminating - * NULL character. If the selection arrives in several pieces, - * the "portion" arguments in separate calls will contain - * successive parts of the selection. Proc should normally - * return TCL_OK. If it detects an error then it should return - * TCL_ERROR and leave an error message in interp->result; the - * remainder of the selection retrieval will be aborted. - * - *-------------------------------------------------------------- - */ - -int -Tk_GetSelection(interp, tkwin, target, proc, clientData) - Tcl_Interp *interp; /* Interpreter to use for reporting - * errors. */ - Tk_Window tkwin; /* Window on whose behalf to retrieve - * the selection (determines display - * from which to retrieve). */ - Atom target; /* Desired form in which selection - * is to be returned. */ - Tk_GetSelProc *proc; /* Procedure to call to process the - * selection, once it has been retrieved. */ - ClientData clientData; /* Arbitrary value to pass to proc. */ -{ - RetrievalInfo retr; - TkWindow *winPtr = (TkWindow *) tkwin; - TkDisplay *dispPtr = winPtr->dispPtr; - - if (dispPtr->multipleAtom == None) { - SelInit(tkwin); - } - Tk_MakeWindowExist(tkwin); - - /* - * If the selection is owned by a window managed by this - * process, then call the retrieval procedure directly, - * rather than going through the X server (it's dangerous - * to go through the X server in this case because it could - * result in deadlock if an INCR-style selection results). - */ - - if (dispPtr->selectionOwner != NULL) { - register TkSelHandler *selPtr; - int offset, result, count; - char buffer[TK_SEL_BYTES_AT_ONCE+1]; - Time time; - - /* - * Make sure that the selection predates the request - * time. - */ - - time = TkCurrentTime(dispPtr); - if ((time < dispPtr->selectionTime) - && (time != CurrentTime) - && (dispPtr->selectionTime != CurrentTime)) { - interp->result = "selection changed before it could be retrieved"; - return TCL_ERROR; - } - - for (selPtr = ((TkWindow *) dispPtr->selectionOwner)->selHandlerList; - ; selPtr = selPtr->nextPtr) { - if (selPtr == NULL) { - Atom type; - - count = DefaultSelection((TkWindow *) dispPtr->selectionOwner, - target, buffer, TK_SEL_BYTES_AT_ONCE, &type); - if (count > TK_SEL_BYTES_AT_ONCE) { - panic("selection handler returned too many bytes"); - } - if (count < 0) { - cantget: - Tcl_AppendResult(interp, "selection doesn't exist", - " or form \"", Tk_GetAtomName(tkwin, target), - "\" not defined", (char *) NULL); - return TCL_ERROR; - } - buffer[count] = 0; - return (*proc)(clientData, interp, buffer); - } - if (selPtr->target == target) { - break; - } - } - offset = 0; - while (1) { - count = (*selPtr->proc)(selPtr->clientData, offset, - buffer, TK_SEL_BYTES_AT_ONCE); - if (count < 0) { - goto cantget; - } - if (count > TK_SEL_BYTES_AT_ONCE) { - panic("selection handler returned too many bytes"); - } - buffer[count] = '\0'; - result = (*proc)(clientData, interp, buffer); - if (result != TCL_OK) { - return result; - } - if (count < TK_SEL_BYTES_AT_ONCE) { - return TCL_OK; - } - offset += count; - } - } - - /* - * The selection is owned by some other process. To - * retrieve it, first record information about the retrieval - * in progress. Also, try to use a non-top-level window - * as the requestor (property changes on this window may - * be monitored by a window manager, which will waste time). - */ - - retr.interp = interp; - if ((winPtr->flags & TK_TOP_LEVEL) - && (winPtr->childList != NULL)) { - winPtr = winPtr->childList; - } - retr.winPtr = winPtr; - retr.property = XA_PRIMARY; - retr.target = target; - retr.proc = proc; - retr.clientData = clientData; - retr.result = -1; - retr.idleTime = 0; - retr.nextPtr = pendingRetrievals; - pendingRetrievals = &retr; - - /* - * Initiate the request for the selection. - */ - - Tk_MakeWindowExist((Tk_Window) winPtr); - XConvertSelection(winPtr->display, XA_PRIMARY, target, - retr.property, winPtr->window, TkCurrentTime(dispPtr)); - - /* - * Enter a loop processing X events until the selection - * has been retrieved and processed. If no response is - * received within a few seconds, then timeout. - */ - - retr.timeout = Tk_CreateTimerHandler(1000, SelTimeoutProc, - (ClientData) &retr); - while (retr.result == -1) { - Tk_DoOneEvent(0); - } - Tk_DeleteTimerHandler(retr.timeout); - - /* - * Unregister the information about the selection retrieval - * in progress. - */ - - if (pendingRetrievals == &retr) { - pendingRetrievals = retr.nextPtr; - } else { - RetrievalInfo *retrPtr; - - for (retrPtr = pendingRetrievals; retrPtr != NULL; - retrPtr = retrPtr->nextPtr) { - if (retrPtr->nextPtr == &retr) { - retrPtr->nextPtr = retr.nextPtr; - break; - } - } - } - return retr.result; -} - -/* - *-------------------------------------------------------------- - * - * Tk_SelectionCmd -- - * - * This procedure is invoked to process the "selection" Tcl - * command. See the user documentation for details on what - * it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *-------------------------------------------------------------- - */ - -int -Tk_SelectionCmd(clientData, interp, argc, argv) - ClientData clientData; /* Main window associated with - * interpreter. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - Tk_Window tkwin = (Tk_Window) clientData; - int length; - char c; - - if (argc < 2) { - sprintf(interp->result, - "wrong # args: should be \"%.50s option ?arg arg ...?\"", - argv[0]); - return TCL_ERROR; - } - c = argv[1][0]; - length = strlen(argv[1]); - if ((c == 'c') && (strncmp(argv[1], "clear", length) == 0)) { - Tk_Window window; - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " clear window\"", (char *) NULL); - return TCL_ERROR; - } - window = Tk_NameToWindow(interp, argv[2], tkwin); - if (window == NULL) { - return TCL_ERROR; - } - Tk_ClearSelection(window); - return TCL_OK; - } else if ((c == 'g') && (strncmp(argv[1], "get", length) == 0)) { - Atom target; - GetInfo getInfo; - int result; - - if (argc > 3) { - sprintf(interp->result, - "too may args: should be \"%.50s get ?type?\"", - argv[0]); - return TCL_ERROR; - } - if (argc == 3) { - target = Tk_InternAtom(tkwin, argv[2]); - } else { - target = XA_STRING; - } - getInfo.string = (char *) ckalloc(100); - getInfo.bytesAvl = 100; - getInfo.bytesUsed = 0; - result = Tk_GetSelection(interp, tkwin, target, SelGetProc, - (ClientData) &getInfo); - if (result == TCL_OK) { - Tcl_SetResult(interp, getInfo.string, TCL_DYNAMIC); - } else { - ckfree(getInfo.string); - } - return result; - } else if ((c == 'h') && (strncmp(argv[1], "handle", length) == 0)) { - Tk_Window window; - Atom target, format; - register CommandInfo *cmdInfoPtr; - int cmdLength; - - if ((argc < 4) || (argc > 6)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " handle window command ?type? ?format?\"", (char *) NULL); - return TCL_ERROR; - } - window = Tk_NameToWindow(interp, argv[2], tkwin); - if (window == NULL) { - return TCL_ERROR; - } - if (argc > 4) { - target = Tk_InternAtom(window, argv[4]); - } else { - target = XA_STRING; - } - if (argc > 5) { - format = Tk_InternAtom(window, argv[5]); - } else { - format = XA_STRING; - } - cmdLength = strlen(argv[3]); - if (cmdLength == 0) { - Tk_DeleteSelHandler(window, target); - } else { - cmdInfoPtr = (CommandInfo *) ckalloc((unsigned) ( - sizeof(CommandInfo) - 3 + cmdLength)); - cmdInfoPtr->interp = interp; - cmdInfoPtr->cmdLength = cmdLength; - strcpy(cmdInfoPtr->command, argv[3]); - Tk_CreateSelHandler(window, target, HandleTclCommand, - (ClientData) cmdInfoPtr, format); - } - return TCL_OK; - } else if ((c == 'o') && (strncmp(argv[1], "own", length) == 0)) { - Tk_Window window; - register LostCommand *lostPtr; - int cmdLength; - - if (argc > 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " own ?window? ?command?\"", (char *) NULL); - return TCL_ERROR; - } - if (argc == 2) { - window = ((TkWindow *) tkwin)->dispPtr->selectionOwner; - if (window != NULL) { - interp->result = Tk_PathName(window); - } - return TCL_OK; - } - window = Tk_NameToWindow(interp, argv[2], tkwin); - if (window == NULL) { - return TCL_ERROR; - } - if (argc == 3) { - Tk_OwnSelection(window, (Tk_LostSelProc *) NULL, - (ClientData) NULL); - return TCL_OK; - } - cmdLength = strlen(argv[3]); - lostPtr = (LostCommand *) ckalloc((unsigned) (sizeof(LostCommand) - -3 + cmdLength)); - lostPtr->interp = interp; - strcpy(lostPtr->command, argv[3]); - Tk_OwnSelection(window, LostSelection, (ClientData) lostPtr); - return TCL_OK; - } else { - sprintf(interp->result, - "bad option \"%.50s\": must be clear, get, handle, or own", - argv[1]); - return TCL_ERROR; - } -} - -/* - *---------------------------------------------------------------------- - * - * TkSelDeadWindow -- - * - * This procedure is invoked just before a TkWindow is deleted. - * It performs selection-related cleanup. - * - * Results: - * None. - * - * Side effects: - * Frees up memory associated with the selection. - * - *---------------------------------------------------------------------- - */ - -void -TkSelDeadWindow(winPtr) - register TkWindow *winPtr; /* Window that's being deleted. */ -{ - register TkSelHandler *selPtr; - - while (1) { - selPtr = winPtr->selHandlerList; - if (selPtr == NULL) { - break; - } - winPtr->selHandlerList = selPtr->nextPtr; - if (selPtr->proc == HandleTclCommand) { - ckfree((char *) selPtr->clientData); - } - ckfree((char *) selPtr); - } - if (winPtr->selClearProc == LostSelection) { - ckfree((char *) winPtr->selClearData); - } - winPtr->selClearProc = NULL; - - if (winPtr->dispPtr->selectionOwner == (Tk_Window) winPtr) { - winPtr->dispPtr->selectionOwner = NULL; - } -} - -/* - *---------------------------------------------------------------------- - * - * SelInit -- - * - * Initialize selection-related information for a display. - * - * Results: - * None. - * - * Side effects: - * Selection-related information is initialized. - * - *---------------------------------------------------------------------- - */ - -static void -SelInit(tkwin) - Tk_Window tkwin; /* Window token (used to find - * display to initialize). */ -{ - register TkDisplay *dispPtr = ((TkWindow *) tkwin)->dispPtr; - - /* - * Fetch commonly-used atoms. - */ - - dispPtr->multipleAtom = Tk_InternAtom(tkwin, "MULTIPLE"); - dispPtr->incrAtom = Tk_InternAtom(tkwin, "INCR"); - dispPtr->targetsAtom = Tk_InternAtom(tkwin, "TARGETS"); - dispPtr->timestampAtom = Tk_InternAtom(tkwin, "TIMESTAMP"); - dispPtr->textAtom = Tk_InternAtom(tkwin, "TEXT"); - dispPtr->compoundTextAtom = Tk_InternAtom(tkwin, "COMPOUND_TEXT"); - dispPtr->applicationAtom = Tk_InternAtom(tkwin, "APPLICATION"); - dispPtr->windowNameAtom = Tk_InternAtom(tkwin, "WINDOW_NAME"); -} - -/* - *-------------------------------------------------------------- - * - * TkSelEventProc -- - * - * This procedure is invoked whenever a selection-related - * event occurs. It does the lion's share of the work - * in implementing the selection protocol. - * - * Results: - * None. - * - * Side effects: - * Lots: depends on the type of event. - * - *-------------------------------------------------------------- - */ - -void -TkSelEventProc(tkwin, eventPtr) - Tk_Window tkwin; /* Window for which event was - * targeted. */ - register XEvent *eventPtr; /* X event: either SelectionClear, - * SelectionRequest, or - * SelectionNotify. */ -{ - register TkWindow *winPtr = (TkWindow *) tkwin; - - /* - * Case #1: SelectionClear events. Invoke clear procedure - * for window that just lost the selection. This code is a - * bit tricky, because any callbacks to due selection changes - * between windows managed by the process have already been - * made. Thus, ignore the event unless it refers to the - * window that's currently the selection owner and the event - * was generated after the server saw the SetSelectionOwner - * request. - */ - - if (eventPtr->type == SelectionClear) { - if ((eventPtr->xselectionclear.selection == XA_PRIMARY) - && (winPtr->dispPtr->selectionOwner == tkwin) - && (eventPtr->xselectionclear.serial - >= winPtr->dispPtr->selectionSerial) - && (winPtr->selClearProc != NULL)) { - (*winPtr->selClearProc)(winPtr->selClearData); - winPtr->selClearProc = NULL; - winPtr->dispPtr->selectionOwner = NULL; - } - return; - } - - /* - * Case #2: SelectionNotify events. Call the relevant procedure - * to handle the incoming selection. - */ - - if (eventPtr->type == SelectionNotify) { - register RetrievalInfo *retrPtr; - char *propInfo; - Atom type; - int format, result; - unsigned long numItems, bytesAfter; - - for (retrPtr = pendingRetrievals; ; retrPtr = retrPtr->nextPtr) { - if (retrPtr == NULL) { - return; - } - if ((retrPtr->winPtr == winPtr) - && (eventPtr->xselection.selection == XA_PRIMARY) - && (retrPtr->target == eventPtr->xselection.target) - && (retrPtr->result == -1)) { - if (retrPtr->property == eventPtr->xselection.property) { - break; - } - if (eventPtr->xselection.property == None) { - Tcl_SetResult(retrPtr->interp, (char *) NULL, TCL_STATIC); - Tcl_AppendResult(retrPtr->interp, - "selection doesn't exist or form \"", - Tk_GetAtomName(tkwin, retrPtr->target), - "\" not defined", (char *) NULL); - retrPtr->result = TCL_ERROR; - return; - } - } - } - - propInfo = NULL; - result = XGetWindowProperty(eventPtr->xselection.display, - eventPtr->xselection.requestor, retrPtr->property, - 0, MAX_PROP_WORDS, False, (Atom) AnyPropertyType, - &type, &format, &numItems, &bytesAfter, - (unsigned char **) &propInfo); - if ((result != Success) || (type == None)) { - return; - } - if (bytesAfter != 0) { - Tcl_SetResult(retrPtr->interp, "selection property too large", - TCL_STATIC); - retrPtr->result = TCL_ERROR; - XFree(propInfo); - return; - } - if ((type == XA_STRING) || (type == winPtr->dispPtr->textAtom) - || (type == winPtr->dispPtr->compoundTextAtom)) { - if (format != 8) { - sprintf(retrPtr->interp->result, - "bad format for string selection: wanted \"8\", got \"%d\"", - format); - retrPtr->result = TCL_ERROR; - return; - } - retrPtr->result = (*retrPtr->proc)(retrPtr->clientData, - retrPtr->interp, propInfo); - } else if (type == winPtr->dispPtr->incrAtom) { - - /* - * It's a !?#@!?!! INCR-style reception. Arrange to receive - * the selection in pieces, using the ICCCM protocol, then - * hang around until either the selection is all here or a - * timeout occurs. - */ - - retrPtr->idleTime = 0; - Tk_CreateEventHandler(tkwin, PropertyChangeMask, SelRcvIncrProc, - (ClientData) retrPtr); - XDeleteProperty(Tk_Display(tkwin), Tk_WindowId(tkwin), - retrPtr->property); - while (retrPtr->result == -1) { - Tk_DoOneEvent(0); - } - Tk_DeleteEventHandler(tkwin, PropertyChangeMask, SelRcvIncrProc, - (ClientData) retrPtr); - } else { - char *string; - - if (format != 32) { - sprintf(retrPtr->interp->result, - "bad format for selection: wanted \"32\", got \"%d\"", - format); - retrPtr->result = TCL_ERROR; - return; - } - string = SelCvtFromX((long *) propInfo, (int) numItems, type, - (Tk_Window) winPtr); - retrPtr->result = (*retrPtr->proc)(retrPtr->clientData, - retrPtr->interp, string); - ckfree(string); - } - XFree(propInfo); - return; - } - - /* - * Case #3: SelectionRequest events. Call ConvertSelection to - * do the dirty work. - */ - - if ((eventPtr->type == SelectionRequest) - && (eventPtr->xselectionrequest.selection == XA_PRIMARY)) { - ConvertSelection(winPtr, &eventPtr->xselectionrequest); - return; - } -} - -/* - *-------------------------------------------------------------- - * - * SelGetProc -- - * - * This procedure is invoked to process pieces of the - * selection as they arrive during "selection get" - * commands. - * - * Results: - * Always returns TCL_OK. - * - * Side effects: - * Bytes get appended to the result currently stored - * in interp->result, and its memory area gets - * expanded if necessary. - * - *-------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -SelGetProc(clientData, interp, portion) - ClientData clientData; /* Information about partially- - * assembled result. */ - Tcl_Interp *interp; /* Interpreter used for error - * reporting (not used). */ - char *portion; /* New information to be appended. */ -{ - register GetInfo *getInfoPtr = (GetInfo *) clientData; - int newLength; - - newLength = strlen(portion) + getInfoPtr->bytesUsed; - - /* - * Grow the result area if we've run out of space. - */ - - if (newLength >= getInfoPtr->bytesAvl) { - char *newString; - - getInfoPtr->bytesAvl *= 2; - if (getInfoPtr->bytesAvl <= newLength) { - getInfoPtr->bytesAvl = newLength + 1; - } - newString = (char *) ckalloc((unsigned) getInfoPtr->bytesAvl); - memcpy((VOID *) newString, (VOID *) getInfoPtr->string, - getInfoPtr->bytesUsed); - ckfree(getInfoPtr->string); - getInfoPtr->string = newString; - } - - /* - * Append the new data to what was already there. - */ - - strcpy(getInfoPtr->string + getInfoPtr->bytesUsed, portion); - getInfoPtr->bytesUsed = newLength; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * SelCvtToX -- - * - * Given a selection represented as a string (the normal Tcl form), - * convert it to the ICCCM-mandated format for X, depending on - * the type argument. This procedure and SelCvtFromX are inverses. - * - * Results: - * The return value is a malloc'ed buffer holding a value - * equivalent to "string", but formatted as for "type". It is - * the caller's responsibility to free the string when done with - * it. The word at *numLongsPtr is filled in with the number of - * 32-bit words returned in the result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static long * -SelCvtToX(string, type, tkwin, numLongsPtr) - char *string; /* String representation of selection. */ - Atom type; /* Atom specifying the X format that is - * desired for the selection. Should not - * be XA_STRING (if so, don't bother calling - * this procedure at all). */ - Tk_Window tkwin; /* Window that governs atom conversion. */ - int *numLongsPtr; /* Number of 32-bit words contained in the - * result. */ -{ - register char *p; - char *field; - int numFields; - long *propPtr, *longPtr; -#define MAX_ATOM_NAME_LENGTH 100 - char atomName[MAX_ATOM_NAME_LENGTH+1]; - - /* - * The string is assumed to consist of fields separated by spaces. - * The property gets generated by converting each field to an - * integer number, in one of two ways: - * 1. If type is XA_ATOM, convert each field to its corresponding - * atom. - * 2. If type is anything else, convert each field from an ASCII number - * to a 32-bit binary number. - */ - - numFields = 1; - for (p = string; *p != 0; p++) { - if (isspace(UCHAR(*p))) { - numFields++; - } - } - propPtr = (long *) ckalloc((unsigned) numFields*sizeof(long)); - - /* - * Convert the fields one-by-one. - */ - - for (longPtr = propPtr, *numLongsPtr = 0, p = string; - ; longPtr++, (*numLongsPtr)++) { - while (isspace(UCHAR(*p))) { - p++; - } - if (*p == 0) { - break; - } - field = p; - while ((*p != 0) && !isspace(UCHAR(*p))) { - p++; - } - if (type == XA_ATOM) { - int length; - - length = p - field; - if (length > MAX_ATOM_NAME_LENGTH) { - length = MAX_ATOM_NAME_LENGTH; - } - strncpy(atomName, field, length); - atomName[length] = 0; - *longPtr = (long) Tk_InternAtom(tkwin, atomName); - } else { - char *dummy; - - *longPtr = strtol(field, &dummy, 0); - } - } - return propPtr; -} - -/* - *---------------------------------------------------------------------- - * - * SelCvtFromX -- - * - * Given an X property value, formatted as a collection of 32-bit - * values according to "type" and the ICCCM conventions, convert - * the value to a string suitable for manipulation by Tcl. This - * procedure is the inverse of SelCvtToX. - * - * Results: - * The return value is the string equivalent of "property". It is - * malloc-ed and should be freed by the caller when no longer - * needed. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static char * -SelCvtFromX(propPtr, numValues, type, tkwin) - register long *propPtr; /* Property value from X. */ - int numValues; /* Number of 32-bit values in property. */ - Atom type; /* Type of property Should not be - * XA_STRING (if so, don't bother calling - * this procedure at all). */ - Tk_Window tkwin; /* Window to use for atom conversion. */ -{ - char *result; - int resultSpace, curSize, fieldSize; - char *atomName; - - /* - * Convert each long in the property to a string value, which is - * either the name of an atom (if type is XA_ATOM) or a hexadecimal - * string. Make an initial guess about the size of the result, but - * be prepared to enlarge the result if necessary. - */ - - resultSpace = 12*numValues; - curSize = 0; - atomName = ""; /* Not needed, but eliminates compiler warning. */ - result = (char *) ckalloc((unsigned) resultSpace); - for ( ; numValues > 0; propPtr++, numValues--) { - if (type == XA_ATOM) { - atomName = Tk_GetAtomName(tkwin, (Atom) *propPtr); - fieldSize = strlen(atomName) + 1; - } else { - fieldSize = 12; - } - if (curSize+fieldSize >= resultSpace) { - char *newResult; - - resultSpace *= 2; - if (curSize+fieldSize >= resultSpace) { - resultSpace = curSize + fieldSize + 1; - } - newResult = (char *) ckalloc((unsigned) resultSpace); - strcpy(newResult, result); - ckfree(result); - result = newResult; - } - if (curSize != 0) { - result[curSize] = ' '; - curSize++; - } - if (type == XA_ATOM) { - strcpy(result+curSize, atomName); - } else { - sprintf(result+curSize, "%#x", *propPtr); - } - curSize += strlen(result+curSize); - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * ConvertSelection -- - * - * This procedure is invoked to handle SelectionRequest events. - * It responds to the requests, obeying the ICCCM protocols. - * - * Results: - * None. - * - * Side effects: - * Properties are created for the selection requestor, and a - * SelectionNotify event is generated for the selection - * requestor. In the event of long selections, this procedure - * implements INCR-mode transfers, using the ICCCM protocol. - * - *---------------------------------------------------------------------- - */ - -static void -ConvertSelection(winPtr, eventPtr) - TkWindow *winPtr; /* Window that owns selection. */ - register XSelectionRequestEvent *eventPtr; - /* Event describing request. */ -{ - XSelectionEvent reply; /* Used to notify requestor that - * selection info is ready. */ - int multiple; /* Non-zero means a MULTIPLE request - * is being handled. */ - IncrInfo info; /* State of selection conversion. */ - Atom singleInfo[2]; /* info.multAtoms points here except - * for multiple conversions. */ - int i; - Tk_ErrorHandler errorHandler; - - errorHandler = Tk_CreateErrorHandler(eventPtr->display, -1, -1,-1, - (int (*)()) NULL, (ClientData) NULL); - - /* - * Initialize the reply event. - */ - - reply.type = SelectionNotify; - reply.serial = 0; - reply.send_event = True; - reply.display = eventPtr->display; - reply.requestor = eventPtr->requestor; - reply.selection = XA_PRIMARY; - reply.target = eventPtr->target; - reply.property = eventPtr->property; - if (reply.property == None) { - reply.property = reply.target; - } - reply.time = eventPtr->time; - - /* - * Watch out for races between conversion requests and - * selection ownership changes: reject the conversion - * request if it's for the wrong window or the wrong - * time. - */ - - if ((winPtr->dispPtr->selectionOwner != (Tk_Window) winPtr) - || ((eventPtr->time < winPtr->dispPtr->selectionTime) - && (eventPtr->time != CurrentTime) - && (winPtr->dispPtr->selectionTime != CurrentTime))) { - goto refuse; - } - - /* - * Figure out which kind(s) of conversion to perform. If handling - * a MULTIPLE conversion, then read the property describing which - * conversions to perform. - */ - - info.winPtr = winPtr; - if (eventPtr->target != winPtr->dispPtr->multipleAtom) { - multiple = 0; - singleInfo[0] = reply.target; - singleInfo[1] = reply.property; - info.multAtoms = singleInfo; - info.numConversions = 1; - } else { - Atom type; - int format, result; - unsigned long bytesAfter; - - multiple = 1; - info.multAtoms = NULL; - if (eventPtr->property == None) { - goto refuse; - } - result = XGetWindowProperty(eventPtr->display, - eventPtr->requestor, eventPtr->property, - 0, MAX_PROP_WORDS, False, XA_ATOM, - &type, &format, &info.numConversions, &bytesAfter, - (unsigned char **) &info.multAtoms); - if ((result != Success) || (bytesAfter != 0) || (format != 32) - || (type == None)) { - if (info.multAtoms != NULL) { - XFree((char *) info.multAtoms); - } - goto refuse; - } - info.numConversions /= 2; /* Two atoms per conversion. */ - } - - /* - * Loop through all of the requested conversions, and either return - * the entire converted selection, if it can be returned in a single - * bunch, or return INCR information only (the actual selection will - * be returned below). - */ - - info.offsets = (int *) ckalloc((unsigned) (info.numConversions*sizeof(int))); - info.numIncrs = 0; - for (i = 0; i < info.numConversions; i++) { - Atom target, property; - long buffer[TK_SEL_WORDS_AT_ONCE]; - register TkSelHandler *selPtr; - - target = info.multAtoms[2*i]; - property = info.multAtoms[2*i + 1]; - info.offsets[i] = -1; - - for (selPtr = winPtr->selHandlerList; ; selPtr = selPtr->nextPtr) { - int numItems, format; - char *propPtr; - Atom type; - - if (selPtr == NULL) { - - /* - * Nobody seems to know about this kind of request. If - * it's of a sort that we can handle without any help, do - * it. Otherwise mark the request as an errror. - */ - - numItems = DefaultSelection(winPtr, target, (char *) buffer, - TK_SEL_BYTES_AT_ONCE, &type); - if (numItems >= 0) { - goto gotStuff; - } - info.multAtoms[2*i + 1] = None; - break; - } else if (selPtr->target == target) { - numItems = (*selPtr->proc)(selPtr->clientData, 0, - (char *) buffer, TK_SEL_BYTES_AT_ONCE); - if (numItems < 0) { - info.multAtoms[2*i + 1] = None; - break; - } - if (numItems > TK_SEL_BYTES_AT_ONCE) { - panic("selection handler returned too many bytes"); - } - ((char *) buffer)[numItems] = '\0'; - type = selPtr->format; - } else { - continue; - } - - gotStuff: - if (numItems == TK_SEL_BYTES_AT_ONCE) { - info.numIncrs++; - type = winPtr->dispPtr->incrAtom; - buffer[0] = 10; /* Guess at # items avl. */ - numItems = 1; - propPtr = (char *) buffer; - format = 32; - info.offsets[i] = 0; - } else if (type == XA_STRING) { - propPtr = (char *) buffer; - format = 8; - } else { - propPtr = (char *) SelCvtToX((char *) buffer, - type, (Tk_Window) winPtr, &numItems); - format = 32; - } - XChangeProperty(reply.display, reply.requestor, - property, type, format, PropModeReplace, - (unsigned char *) propPtr, numItems); - if (propPtr != (char *) buffer) { - ckfree(propPtr); - } - break; - } - } - - /* - * Send an event back to the requestor to indicate that the - * first stage of conversion is complete (everything is done - * except for long conversions that have to be done in INCR - * mode). - */ - - if (info.numIncrs > 0) { - XSelectInput(reply.display, reply.requestor, PropertyChangeMask); - info.timeout = Tk_CreateTimerHandler(1000, IncrTimeoutProc, - (ClientData) &info); - info.idleTime = 0; - info.reqWindow = reply.requestor; - info.time = winPtr->dispPtr->selectionTime; - info.nextPtr = pendingIncrs; - pendingIncrs = &info; - } - if (multiple) { - XChangeProperty(reply.display, reply.requestor, reply.property, - XA_ATOM, 32, PropModeReplace, - (unsigned char *) info.multAtoms, - (int) info.numConversions*2); - } else { - - /* - * Not a MULTIPLE request. The first property in "multAtoms" - * got set to None if there was an error in conversion. - */ - - reply.property = info.multAtoms[1]; - } - XSendEvent(reply.display, reply.requestor, False, 0, (XEvent *) &reply); - Tk_DeleteErrorHandler(errorHandler); - - /* - * Handle any remaining INCR-mode transfers. This all happens - * in callbacks to TkSelPropProc, so just wait until the number - * of uncompleted INCR transfers drops to zero. - */ - - if (info.numIncrs > 0) { - IncrInfo *infoPtr2; - - while (info.numIncrs > 0) { - Tk_DoOneEvent(0); - } - Tk_DeleteTimerHandler(info.timeout); - errorHandler = Tk_CreateErrorHandler(winPtr->display, - -1, -1,-1, (int (*)()) NULL, (ClientData) NULL); - XSelectInput(reply.display, reply.requestor, 0L); - Tk_DeleteErrorHandler(errorHandler); - if (pendingIncrs == &info) { - pendingIncrs = info.nextPtr; - } else { - for (infoPtr2 = pendingIncrs; infoPtr2 != NULL; - infoPtr2 = infoPtr2->nextPtr) { - if (infoPtr2->nextPtr == &info) { - infoPtr2->nextPtr = info.nextPtr; - break; - } - } - } - } - - /* - * All done. Cleanup and return. - */ - - ckfree((char *) info.offsets); - if (multiple) { - XFree((char *) info.multAtoms); - } - return; - - /* - * An error occurred. Send back a refusal message. - */ - - refuse: - reply.property = None; - XSendEvent(reply.display, reply.requestor, False, 0, (XEvent *) &reply); - Tk_DeleteErrorHandler(errorHandler); - return; -} - -/* - *---------------------------------------------------------------------- - * - * SelRcvIncrProc -- - * - * This procedure handles the INCR protocol on the receiving - * side. It is invoked in response to property changes on - * the requestor's window (which hopefully are because a new - * chunk of the selection arrived). - * - * Results: - * None. - * - * Side effects: - * If a new piece of selection has arrived, a procedure is - * invoked to deal with that piece. When the whole selection - * is here, a flag is left for the higher-level procedure that - * initiated the selection retrieval. - * - *---------------------------------------------------------------------- - */ - -static void -SelRcvIncrProc(clientData, eventPtr) - ClientData clientData; /* Information about retrieval. */ - register XEvent *eventPtr; /* X PropertyChange event. */ -{ - register RetrievalInfo *retrPtr = (RetrievalInfo *) clientData; - char *propInfo; - Atom type; - int format, result; - unsigned long numItems, bytesAfter; - - if ((eventPtr->xproperty.atom != retrPtr->property) - || (eventPtr->xproperty.state != PropertyNewValue) - || (retrPtr->result != -1)) { - return; - } - propInfo = NULL; - result = XGetWindowProperty(eventPtr->xproperty.display, - eventPtr->xproperty.window, retrPtr->property, 0, MAX_PROP_WORDS, - True, (Atom) AnyPropertyType, &type, &format, &numItems, - &bytesAfter, (unsigned char **) &propInfo); - if ((result != Success) || (type == None)) { - return; - } - if (bytesAfter != 0) { - Tcl_SetResult(retrPtr->interp, "selection property too large", - TCL_STATIC); - retrPtr->result = TCL_ERROR; - goto done; - } - if (numItems == 0) { - retrPtr->result = TCL_OK; - } else if ((type == XA_STRING) - || (type == retrPtr->winPtr->dispPtr->textAtom) - || (type == retrPtr->winPtr->dispPtr->compoundTextAtom)) { - if (format != 8) { - Tcl_SetResult(retrPtr->interp, (char *) NULL, TCL_STATIC); - sprintf(retrPtr->interp->result, - "bad format for string selection: wanted \"8\", got \"%d\"", - format); - retrPtr->result = TCL_ERROR; - goto done; - } - result = (*retrPtr->proc)(retrPtr->clientData, retrPtr->interp, - propInfo); - if (result != TCL_OK) { - retrPtr->result = result; - } - } else { - char *string; - - if (format != 32) { - Tcl_SetResult(retrPtr->interp, (char *) NULL, TCL_STATIC); - sprintf(retrPtr->interp->result, - "bad format for selection: wanted \"32\", got \"%d\"", - format); - retrPtr->result = TCL_ERROR; - goto done; - } - string = SelCvtFromX((long *) propInfo, (int) numItems, type, - (Tk_Window) retrPtr->winPtr); - result = (*retrPtr->proc)(retrPtr->clientData, retrPtr->interp, - string); - if (result != TCL_OK) { - retrPtr->result = result; - } - ckfree(string); - } - - done: - XFree(propInfo); - retrPtr->idleTime = 0; -} - -/* - *---------------------------------------------------------------------- - * - * TkSelPropProc -- - * - * This procedure is invoked when property-change events - * occur on windows not known to the toolkit. Its function - * is to implement the sending side of the INCR selection - * retrieval protocol when the selection requestor deletes - * the property containing a part of the selection. - * - * Results: - * None. - * - * Side effects: - * If the property that is receiving the selection was just - * deleted, then a new piece of the selection is fetched and - * placed in the property, until eventually there's no more - * selection to fetch. - * - *---------------------------------------------------------------------- - */ - -void -TkSelPropProc(eventPtr) - register XEvent *eventPtr; /* X PropertyChange event. */ -{ - register IncrInfo *infoPtr; - int i, format; - Atom target; - register TkSelHandler *selPtr; - long buffer[TK_SEL_WORDS_AT_ONCE]; - int numItems; - char *propPtr; - Tk_ErrorHandler errorHandler; - - /* - * See if this event announces the deletion of a property being - * used for an INCR transfer. If so, then add the next chunk of - * data to the property. - */ - - if (eventPtr->xproperty.state != PropertyDelete) { - return; - } - for (infoPtr = pendingIncrs; infoPtr != NULL; - infoPtr = infoPtr->nextPtr) { - - /* - * To avoid races between selection conversions and - * changes in selection ownership, make sure the window - * and timestamp for the current selection match those - * in the INCR request. - */ - - if ((infoPtr->reqWindow != eventPtr->xproperty.window) - || (infoPtr->winPtr->dispPtr->selectionOwner - != (Tk_Window) infoPtr->winPtr) - || (infoPtr->winPtr->dispPtr->selectionTime - != infoPtr->time)) { - continue; - } - for (i = 0; i < infoPtr->numConversions; i++) { - if ((eventPtr->xproperty.atom != infoPtr->multAtoms[2*i + 1]) - || (infoPtr->offsets[i] == -1)){ - continue; - } - target = infoPtr->multAtoms[2*i]; - infoPtr->idleTime = 0; - for (selPtr = infoPtr->winPtr->selHandlerList; ; - selPtr = selPtr->nextPtr) { - if (selPtr == NULL) { - infoPtr->multAtoms[2*i + 1] = None; - infoPtr->offsets[i] = -1; - infoPtr->numIncrs --; - return; - } - if (selPtr->target == target) { - if (infoPtr->offsets[i] == -2) { - numItems = 0; - ((char *) buffer)[0] = 0; - } else { - numItems = (*selPtr->proc)(selPtr->clientData, - infoPtr->offsets[i], (char *) buffer, - TK_SEL_BYTES_AT_ONCE); - if (numItems > TK_SEL_BYTES_AT_ONCE) { - panic("selection handler returned too many bytes"); - } else { - if (numItems < 0) { - numItems = 0; - } - } - ((char *) buffer)[numItems] = '\0'; - } - if (numItems < TK_SEL_BYTES_AT_ONCE) { - if (numItems <= 0) { - infoPtr->offsets[i] = -1; - infoPtr->numIncrs--; - } else { - infoPtr->offsets[i] = -2; - } - } else { - infoPtr->offsets[i] += numItems; - } - if (selPtr->format == XA_STRING) { - propPtr = (char *) buffer; - format = 8; - } else { - propPtr = (char *) SelCvtToX((char *) buffer, - selPtr->format, - (Tk_Window) infoPtr->winPtr, - &numItems); - format = 32; - } - errorHandler = Tk_CreateErrorHandler( - eventPtr->xproperty.display, -1, -1, -1, - (int (*)()) NULL, (ClientData) NULL); - XChangeProperty(eventPtr->xproperty.display, - eventPtr->xproperty.window, - eventPtr->xproperty.atom, selPtr->format, - format, PropModeReplace, - (unsigned char *) propPtr, numItems); - Tk_DeleteErrorHandler(errorHandler); - if (propPtr != (char *) buffer) { - ckfree(propPtr); - } - return; - } - } - } - } -} - -/* - *---------------------------------------------------------------------- - * - * HandleTclCommand -- - * - * This procedure acts as selection handler for handlers created - * by the "selection handle" command. It invokes a Tcl command to - * retrieve the selection. - * - * Results: - * The return value is a count of the number of bytes actually - * stored at buffer, or -1 if an error occurs while executing - * the Tcl command to retrieve the selection. - * - * Side effects: - * None except for things done by the Tcl command. - * - *---------------------------------------------------------------------- - */ - -static int -HandleTclCommand(clientData, offset, buffer, maxBytes) - ClientData clientData; /* Information about command to execute. */ - int offset; /* Return selection bytes starting at this - * offset. */ - char *buffer; /* Place to store converted selection. */ - int maxBytes; /* Maximum # of bytes to store at buffer. */ -{ - register CommandInfo *cmdInfoPtr = (CommandInfo *) clientData; - char *oldResultString; - Tcl_FreeProc *oldFreeProc; - int spaceNeeded, length; -#define MAX_STATIC_SIZE 100 - char staticSpace[MAX_STATIC_SIZE]; - char *command; - - /* - * First, generate a command by taking the command string - * and appending the offset and maximum # of bytes. - */ - - spaceNeeded = cmdInfoPtr->cmdLength + 30; - if (spaceNeeded < MAX_STATIC_SIZE) { - command = staticSpace; - } else { - command = (char *) ckalloc((unsigned) spaceNeeded); - } - sprintf(command, "%s %d %d", cmdInfoPtr->command, offset, maxBytes); - - /* - * Execute the command. Be sure to restore the state of the - * interpreter after executing the command. - */ - - oldFreeProc = cmdInfoPtr->interp->freeProc; - if (oldFreeProc != 0) { - oldResultString = cmdInfoPtr->interp->result; - } else { - oldResultString = (char *) ckalloc((unsigned) - (strlen(cmdInfoPtr->interp->result) + 1)); - strcpy(oldResultString, cmdInfoPtr->interp->result); - oldFreeProc = TCL_DYNAMIC; - } - cmdInfoPtr->interp->freeProc = 0; - if (TkCopyAndGlobalEval(cmdInfoPtr->interp, command) == TCL_OK) { - length = strlen(cmdInfoPtr->interp->result); - if (length > maxBytes) { - length = maxBytes; - } - memcpy((VOID *) buffer, (VOID *) cmdInfoPtr->interp->result, length); - buffer[length] = '\0'; - } else { - length = -1; - } - Tcl_FreeResult(cmdInfoPtr->interp); - cmdInfoPtr->interp->result = oldResultString; - cmdInfoPtr->interp->freeProc = oldFreeProc; - - if (command != staticSpace) { - ckfree(command); - } - - return length; -} - -/* - *---------------------------------------------------------------------- - * - * SelTimeoutProc -- - * - * This procedure is invoked once every second while waiting for - * the selection to be returned. After a while it gives up and - * aborts the selection retrieval. - * - * Results: - * None. - * - * Side effects: - * A new timer callback is created to call us again in another - * second, unless time has expired, in which case an error is - * recorded for the retrieval. - * - *---------------------------------------------------------------------- - */ - -static void -SelTimeoutProc(clientData) - ClientData clientData; /* Information about retrieval - * in progress. */ -{ - register RetrievalInfo *retrPtr = (RetrievalInfo *) clientData; - - /* - * Make sure that the retrieval is still in progress. Then - * see how long it's been since any sort of response was received - * from the other side. - */ - - if (retrPtr->result != -1) { - return; - } - retrPtr->idleTime++; - if (retrPtr->idleTime >= 5) { - - /* - * Use a careful procedure to store the error message, because - * the result could already be partially filled in with a partial - * selection return. - */ - - Tcl_SetResult(retrPtr->interp, "selection owner didn't respond", - TCL_STATIC); - retrPtr->result = TCL_ERROR; - } else { - retrPtr->timeout = Tk_CreateTimerHandler(1000, SelTimeoutProc, - (ClientData) retrPtr); - } -} - -/* - *---------------------------------------------------------------------- - * - * IncrTimeoutProc -- - * - * This procedure is invoked once a second while sending the - * selection to a requestor in INCR mode. After a while it - * gives up and aborts the selection operation. - * - * Results: - * None. - * - * Side effects: - * A new timeout gets registered so that this procedure gets - * called again in another second, unless too many seconds - * have elapsed, in which case infoPtr is marked as "all done". - * - *---------------------------------------------------------------------- - */ - -static void -IncrTimeoutProc(clientData) - ClientData clientData; /* Information about INCR-mode - * selection retrieval for which - * we are selection owner. */ -{ - register IncrInfo *infoPtr = (IncrInfo *) clientData; - - infoPtr->idleTime++; - if (infoPtr->idleTime >= 5) { - infoPtr->numIncrs = 0; - } else { - infoPtr->timeout = Tk_CreateTimerHandler(1000, IncrTimeoutProc, - (ClientData) infoPtr); - } -} - -/* - *---------------------------------------------------------------------- - * - * DefaultSelection -- - * - * This procedure is called to generate selection information - * for a few standard targets such as TIMESTAMP and TARGETS. - * It is invoked only if no handler has been declared by the - * application. - * - * Results: - * If "target" is a standard target understood by this procedure, - * the selection is converted to that form and stored as a - * character string in buffer. The type of the selection (e.g. - * STRING or ATOM) is stored in *typePtr, and the return value is - * a count of the # of non-NULL bytes at buffer. If the target - * wasn't understood, or if there isn't enough space at buffer - * to hold the entire selection (no INCR-mode transfers for this - * stuff!), then -1 is returned. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -DefaultSelection(winPtr, target, buffer, maxBytes, typePtr) - TkWindow *winPtr; /* Window that owns selection. */ - Atom target; /* Desired form of selection. */ - char *buffer; /* Place to put selection characters. */ - int maxBytes; /* Maximum # of bytes to store at buffer. */ - Atom *typePtr; /* Store here the type of the selection, - * for use in converting to proper X format. */ -{ - if (target == winPtr->dispPtr->timestampAtom) { - if (maxBytes < 20) { - return -1; - } - sprintf(buffer, "%#x", winPtr->dispPtr->selectionTime); - *typePtr = XA_INTEGER; - return strlen(buffer); - } - - if (target == winPtr->dispPtr->targetsAtom) { - register TkSelHandler *selPtr; - char *atomString; - int length, atomLength; - - if (maxBytes < 50) { - return -1; - } - strcpy(buffer, "APPLICATION MULTIPLE TARGETS TIMESTAMP WINDOW_NAME"); - length = strlen(buffer); - for (selPtr = winPtr->selHandlerList; selPtr != NULL; - selPtr = selPtr->nextPtr) { - atomString = Tk_GetAtomName((Tk_Window) winPtr, selPtr->target); - atomLength = strlen(atomString) + 1; - if ((length + atomLength) >= maxBytes) { - return -1; - } - sprintf(buffer+length, " %s", atomString); - length += atomLength; - } - *typePtr = XA_ATOM; - return length; - } - - if (target == winPtr->dispPtr->applicationAtom) { - int length; - char *name = winPtr->mainPtr->winPtr->nameUid; - - length = strlen(name); - if (maxBytes <= length) { - return -1; - } - strcpy(buffer, name); - *typePtr = XA_STRING; - return length; - } - - if (target == winPtr->dispPtr->windowNameAtom) { - int length; - char *name = winPtr->pathName; - - length = strlen(name); - if (maxBytes <= length) { - return -1; - } - strcpy(buffer, name); - *typePtr = XA_STRING; - return length; - } - - return -1; -} - -/* - *---------------------------------------------------------------------- - * - * LostSelection -- - * - * This procedure is invoked when a window has lost ownership of - * the selection and the ownership was claimed with the command - * "selection own". - * - * Results: - * None. - * - * Side effects: - * A Tcl script is executed; it can do almost anything. - * - *---------------------------------------------------------------------- - */ - -static void -LostSelection(clientData) - ClientData clientData; /* Pointer to zCommandInfo structure. */ -{ - LostCommand *lostPtr = (LostCommand *) clientData; - char *oldResultString; - Tcl_FreeProc *oldFreeProc; - - /* - * Execute the command. Save the interpreter's result, if any, and - * restore it after executing the command. - */ - - oldFreeProc = lostPtr->interp->freeProc; - if (oldFreeProc != 0) { - oldResultString = lostPtr->interp->result; - } else { - oldResultString = (char *) ckalloc((unsigned) - (strlen(lostPtr->interp->result) + 1)); - strcpy(oldResultString, lostPtr->interp->result); - oldFreeProc = TCL_DYNAMIC; - } - lostPtr->interp->freeProc = 0; - if (TkCopyAndGlobalEval(lostPtr->interp, lostPtr->command) != TCL_OK) { - Tk_BackgroundError(lostPtr->interp); - } - Tcl_FreeResult(lostPtr->interp); - lostPtr->interp->result = oldResultString; - lostPtr->interp->freeProc = oldFreeProc; - - /* - * Free the storage for the command, since we're done with it now. - */ - - ckfree((char *) lostPtr); -} diff --git a/tk3.6/tkSend.c b/tk3.6/tkSend.c deleted file mode 100644 index f45b031..0000000 --- a/tk3.6/tkSend.c +++ /dev/null @@ -1,1177 +0,0 @@ -/* - * tkSend.c -- - * - * This file provides procedures that implement the "send" - * command, allowing commands to be passed from interpreter - * to interpreter. - * - * 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 - * 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/wish/RCS/tkSend.c,v 1.34 93/10/13 17:17:26 ouster Exp $ SPRITE (Berkeley)"; -#endif - -#include "tkConfig.h" -#include "tkInt.h" - -/* - * The following structure is used to keep track of the - * interpreters registered by this process. - */ - -typedef struct RegisteredInterp { - char *name; /* Interpreter's name (malloc-ed). */ - Tcl_Interp *interp; /* Interpreter associated with - * name. */ - TkDisplay *dispPtr; /* Display associated with name. */ - struct RegisteredInterp *nextPtr; - /* Next in list of names associated - * with interps in this process. - * NULL means end of list. */ -} RegisteredInterp; - -static RegisteredInterp *registry = NULL; - /* List of all interpreters - * registered by this process. */ - -/* - * When a result is being awaited from a sent command, one of - * the following structures is present on a list of all outstanding - * sent commands. The information in the structure is used to - * process the result when it arrives. You're probably wondering - * how there could ever be multiple outstanding sent commands. - * This could happen if interpreters invoke each other recursively. - * It's unlikely, but possible. - */ - -typedef struct PendingCommand { - int serial; /* Serial number expected in - * result. */ - char *target; /* Name of interpreter command is - * being sent to. */ - Tcl_Interp *interp; /* Interpreter from which the send - * was invoked. */ - int code; /* Tcl return code for command - * will be stored here. */ - char *result; /* String result for command (malloc'ed). - * NULL means command still pending. */ - struct PendingCommand *nextPtr; - /* Next in list of all outstanding - * commands. NULL means end of - * list. */ -} PendingCommand; - -static PendingCommand *pendingCommands = NULL; - /* List of all commands currently - * being waited for. */ - -/* - * The information below is used for communication between - * processes during "send" commands. Each process keeps a - * private window, never even mapped, with one property, - * "Comm". When a command is sent to an interpreter, the - * command is appended to the comm property of the communication - * window associated with the interp's process. Similarly, when a - * result is returned from a sent command, it is also appended - * to the comm property. In each case, the property information - * is in the form of an ASCII string. The exact syntaxes are: - * - * Command: - * 'C' space window space serial space interpName '|' command '\0' - * The 'C' character indicates that this is a command and not - * a response. Window is the hex identifier for the comm - * window on which to append the response. Serial is a hex - * integer containing an identifying number assigned by the - * sender; it may be used by the sender to sort out concurrent - * responses. InterpName is the ASCII name of the desired - * interpreter, which must not contain any vertical bar characters - * The interpreter name is delimited by a vertical bar (this - * allows the name to include blanks), and is followed by - * the command to execute. The command is terminated by a - * NULL character. - * - * Response: - * 'R' space serial space code space result '\0' - * The 'R' character indicates that this is a response. Serial - * gives the identifier for the command (same value as in the - * command message). The code field is a decimal integer giving - * the Tcl return code from the command, and result is the string - * result. The result is terminated by a NULL character. - * - * The register of interpreters is kept in a property - * "InterpRegistry" on the root window of the display. It is - * organized as a series of zero or more concatenated strings - * (in no particular order), each of the form - * window space name '\0' - * where "window" is the hex id of the comm. window to use to talk - * to an interpreter named "name". - */ - -/* - * Maximum size property that can be read at one time by - * this module: - */ - -#define MAX_PROP_WORDS 100000 - -/* - * Forward declarations for procedures defined later in this file: - */ - -static int AppendErrorProc _ANSI_ARGS_((ClientData clientData, - XErrorEvent *errorPtr)); -static void AppendPropCarefully _ANSI_ARGS_((Display *display, - Window window, Atom property, char *value, - PendingCommand *pendingPtr)); -static void DeleteProc _ANSI_ARGS_((ClientData clientData)); -static Window LookupName _ANSI_ARGS_((TkDisplay *dispPtr, char *name, - int delete)); -static void SendEventProc _ANSI_ARGS_((ClientData clientData, - XEvent *eventPtr)); -static int SendInit _ANSI_ARGS_((Tcl_Interp *interp, TkDisplay *dispPtr)); -static Bool SendRestrictProc _ANSI_ARGS_((Display *display, - XEvent *eventPtr, char *arg)); -static void TimeoutProc _ANSI_ARGS_((ClientData clientData)); - -/* - *-------------------------------------------------------------- - * - * Tk_RegisterInterp -- - * - * This procedure is called to associate an ASCII name - * with an interpreter. Tk_InitSend must previously - * have been called to set up communication channels - * and specify a display. - * - * Results: - * Zero is returned if the name was registered successfully. - * Non-zero means the name was already in use. - * - * Side effects: - * Registration info is saved, thereby allowing the - * "send" command to be used later to invoke commands - * in the interpreter. The registration will be removed - * automatically when the interpreter is deleted. - * - *-------------------------------------------------------------- - */ - -int -Tk_RegisterInterp(interp, name, tkwin) - Tcl_Interp *interp; /* Interpreter associated with name. */ - char *name; /* The name that will be used to - * refer to the interpreter in later - * "send" commands. Must be globally - * unique. */ - Tk_Window tkwin; /* Token for window associated with - * interp; used to identify display - * for communication. */ -{ -#define TCL_MAX_NAME_LENGTH 1000 - char propInfo[TCL_MAX_NAME_LENGTH + 20]; - register RegisteredInterp *riPtr; - Window w; - TkWindow *winPtr = (TkWindow *) tkwin; - TkDisplay *dispPtr; - - if (strchr(name, '|') != NULL) { - interp->result = - "interpreter name cannot contain '|' character"; - return TCL_ERROR; - } - - dispPtr = winPtr->dispPtr; - if (dispPtr->commWindow == NULL) { - int result; - - result = SendInit(interp, dispPtr); - if (result != TCL_OK) { - return result; - } - } - - /* - * Make sure the name is unique, and append info about it to - * the registry property. It's important to lock the server - * here to prevent conflicting changes to the registry property. - */ - - XGrabServer(dispPtr->display); - w = LookupName(dispPtr, name, 0); - if (w != (Window) 0) { - Status status; - Tk_ErrorHandler handler; - int dummyInt; - unsigned int dummyUns; - Window dummyWin; - - /* - * The name is currently registered. See if the commWindow - * associated with the name exists. If not, or if the commWindow - * is *our* commWindow, then just unregister the old name (this - * could happen if an application dies without cleaning up the - * registry). - */ - - handler = Tk_CreateErrorHandler(dispPtr->display, -1, -1, -1, - (Tk_ErrorProc *) NULL, (ClientData) NULL); - status = XGetGeometry(dispPtr->display, w, &dummyWin, &dummyInt, - &dummyInt, &dummyUns, &dummyUns, &dummyUns, &dummyUns); - Tk_DeleteErrorHandler(handler); - if ((status != 0) && (w != Tk_WindowId(dispPtr->commWindow))) { - Tcl_AppendResult(interp, "interpreter name \"", name, - "\" is already in use", (char *) NULL); - XUngrabServer(dispPtr->display); - XFlush(dispPtr->display); - return TCL_ERROR; - } - (void) LookupName(winPtr->dispPtr, name, 1); - } - sprintf(propInfo, "%x %.*s", Tk_WindowId(dispPtr->commWindow), - TCL_MAX_NAME_LENGTH, name); - XChangeProperty(dispPtr->display, - RootWindow(dispPtr->display, 0), - dispPtr->registryProperty, XA_STRING, 8, PropModeAppend, - (unsigned char *) propInfo, strlen(propInfo)+1); - XUngrabServer(dispPtr->display); - XFlush(dispPtr->display); - - /* - * Add an entry in the local registry of names owned by this - * process. - */ - - riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp)); - riPtr->name = (char *) ckalloc((unsigned) (strlen(name) + 1)); - strcpy(riPtr->name, name); - riPtr->interp = interp; - riPtr->dispPtr = dispPtr; - riPtr->nextPtr = registry; - registry = riPtr; - - /* - * Add the "send" command to this interpreter, and arrange for - * us to be notified when the interpreter is deleted (actually, - * when the "send" command is deleted). - */ - - Tcl_CreateCommand(interp, "send", Tk_SendCmd, (ClientData) riPtr, - DeleteProc); - - return TCL_OK; -} - -/* - *-------------------------------------------------------------- - * - * Tk_SendCmd -- - * - * This procedure is invoked to process the "send" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *-------------------------------------------------------------- - */ - -int -Tk_SendCmd(clientData, interp, argc, argv) - ClientData clientData; /* Information about sender (only - * dispPtr field is used). */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - RegisteredInterp *senderRiPtr = (RegisteredInterp *) clientData; - Window w; -#define STATIC_PROP_SPACE 100 - char *property, staticSpace[STATIC_PROP_SPACE]; - int length; - static int serial = 0; /* Running count of sent commands. - * Used to give each command a - * different serial number. */ - PendingCommand pending; - Tk_TimerToken timeout; - register RegisteredInterp *riPtr; - char *cmd; - int result; - Bool (*prevRestrictProc)(); - char *prevArg; - TkDisplay *dispPtr = senderRiPtr->dispPtr; - - if (dispPtr->commWindow == NULL) { - result = SendInit(interp, dispPtr); - if (result != TCL_OK) { - return result; - } - } - - if (argc < 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " interpName arg ?arg ...?\"", (char *) NULL); - return TCL_ERROR; - } - if (argc == 3) { - cmd = argv[2]; - } else { - cmd = Tcl_Concat(argc-2, argv+2); - } - - /* - * See if the target interpreter is local. If so, execute - * the command directly without going through the X server. - * The only tricky thing is passing the result from the target - * interpreter to the invoking interpreter. Watch out: they - * could be the same! - */ - - for (riPtr = registry; riPtr != NULL; riPtr = riPtr->nextPtr) { - if (strcmp(riPtr->name, argv[1]) != 0) { - continue; - } - if (interp == riPtr->interp) { - result = Tcl_GlobalEval(interp, cmd); - } else { - result = Tcl_GlobalEval(riPtr->interp, cmd); - interp->result = riPtr->interp->result; - interp->freeProc = riPtr->interp->freeProc; - riPtr->interp->freeProc = 0; - Tcl_ResetResult(riPtr->interp); - } - if (cmd != argv[2]) { - ckfree(cmd); - } - return result; - } - - /* - * Bind the interpreter name to a communication window. - */ - - w = LookupName(dispPtr, argv[1], 0); - if (w == 0) { - Tcl_AppendResult(interp, "no registered interpreter named \"", - argv[1], "\"", (char *) NULL); - if (cmd != argv[2]) { - ckfree(cmd); - } - return TCL_ERROR; - } - - /* - * Register the fact that we're waiting for a command to - * complete (this is needed by SendEventProc and by - * AppendErrorProc to pass back the command's results). - */ - - serial++; - pending.serial = serial; - pending.target = argv[1]; - pending.interp = interp; - pending.result = NULL; - pending.nextPtr = pendingCommands; - pendingCommands = &pending; - - /* - * Send the command to target interpreter by appending it to the - * comm window in the communication window. - */ - - length = strlen(argv[1]) + strlen(cmd) + 30; - if (length <= STATIC_PROP_SPACE) { - property = staticSpace; - } else { - property = (char *) ckalloc((unsigned) length); - } - sprintf(property, "C %x %x %s|%s", - Tk_WindowId(dispPtr->commWindow), serial, argv[1], cmd); - (void) AppendPropCarefully(dispPtr->display, w, dispPtr->commProperty, - property, &pending); - if (length > STATIC_PROP_SPACE) { - ckfree(property); - } - if (cmd != argv[2]) { - ckfree(cmd); - } - - /* - * Enter a loop processing X events until the result comes - * in. If no response is received within a few seconds, - * then timeout. While waiting for a result, look only at - * send-related events (otherwise it would be possible for - * additional input events, such as mouse motion, to cause - * other sends, leading eventually to such a large number - * of nested Tcl_Eval calls that the Tcl interpreter panics). - */ - - prevRestrictProc = Tk_RestrictEvents(SendRestrictProc, - (char *) dispPtr->commWindow, &prevArg); - timeout = Tk_CreateTimerHandler(5000, TimeoutProc, - (ClientData) &pending); - while (pending.result == NULL) { - Tk_DoOneEvent(0); - } - Tk_DeleteTimerHandler(timeout); - (void) Tk_RestrictEvents(prevRestrictProc, prevArg, &prevArg); - - /* - * Unregister the information about the pending command - * and return the result. - */ - - if (pendingCommands == &pending) { - pendingCommands = pending.nextPtr; - } else { - PendingCommand *pcPtr; - - for (pcPtr = pendingCommands; pcPtr != NULL; - pcPtr = pcPtr->nextPtr) { - if (pcPtr->nextPtr == &pending) { - pcPtr->nextPtr = pending.nextPtr; - break; - } - } - } - Tcl_SetResult(interp, pending.result, TCL_DYNAMIC); - return pending.code; -} - -/* - *---------------------------------------------------------------------- - * - * TkGetInterpNames -- - * - * This procedure is invoked to fetch a list of all the - * interpreter names currently registered for the display - * of a particular window. - * - * Results: - * A standard Tcl return value. Interp->result will be set - * to hold a list of all the interpreter names defined for - * tkwin's display. If an error occurs, then TCL_ERROR - * is returned and interp->result will hold an error message. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TkGetInterpNames(interp, tkwin) - Tcl_Interp *interp; /* Interpreter for returning a result. */ - Tk_Window tkwin; /* Window whose display is to be used - * for the lookup. */ -{ - TkDisplay *dispPtr = ((TkWindow *) tkwin)->dispPtr; - char *regProp; - register char *p; - int result, actualFormat; - unsigned long numItems, bytesAfter; - Atom actualType; - - /* - * Read the registry property. - */ - - regProp = NULL; - result = XGetWindowProperty(dispPtr->display, - RootWindow(dispPtr->display, 0), - dispPtr->registryProperty, 0, MAX_PROP_WORDS, - False, XA_STRING, &actualType, &actualFormat, - &numItems, &bytesAfter, (unsigned char **) ®Prop); - - if (actualType == None) { - sprintf(interp->result, "couldn't read intepreter registry property"); - return TCL_ERROR; - } - - /* - * If the property is improperly formed, then delete it. - */ - - if ((result != Success) || (actualFormat != 8) - || (actualType != XA_STRING)) { - if (regProp != NULL) { - XFree(regProp); - } - sprintf(interp->result, "intepreter registry property is badly formed"); - return TCL_ERROR; - } - - /* - * Scan all of the names out of the property. - */ - - for (p = regProp; (p-regProp) < numItems; p++) { - while ((*p != 0) && (!isspace(UCHAR(*p)))) { - p++; - } - if (*p != 0) { - Tcl_AppendElement(interp, p+1); - while (*p != 0) { - p++; - } - } - } - XFree(regProp); - return TCL_OK; -} - -/* - *-------------------------------------------------------------- - * - * SendInit -- - * - * This procedure is called to initialize the - * communication channels for sending commands and - * receiving results. - * - * Results: - * The result is a standard Tcl return value, which is - * normally TCL_OK. If an error occurs then an error - * message is left in interp->result and TCL_ERROR is - * returned. - * - * Side effects: - * Sets up various data structures and windows. - * - *-------------------------------------------------------------- - */ - -static int -SendInit(interp, dispPtr) - Tcl_Interp *interp; /* Interpreter to use for error - * reporting. */ - register TkDisplay *dispPtr;/* Display to initialize. */ - -{ - XSetWindowAttributes atts; -#ifndef TK_NO_SECURITY - XHostAddress *addrPtr; - int numHosts; - Bool enabled; -#endif - - /* - * Create the window used for communication, and set up an - * event handler for it. - */ - - dispPtr->commWindow = Tk_CreateWindow(interp, (Tk_Window) NULL, - "_comm", DisplayString(dispPtr->display)); - if (dispPtr->commWindow == NULL) { - return TCL_ERROR; - } - atts.override_redirect = True; - Tk_ChangeWindowAttributes(dispPtr->commWindow, - CWOverrideRedirect, &atts); - Tk_CreateEventHandler(dispPtr->commWindow, PropertyChangeMask, - SendEventProc, (ClientData) dispPtr); - Tk_MakeWindowExist(dispPtr->commWindow); - - /* - * Get atoms used as property names. - */ - - dispPtr->commProperty = XInternAtom(dispPtr->display, - "Comm", False); - dispPtr->registryProperty = XInternAtom(dispPtr->display, - "InterpRegistry", False); - - /* - * See if the server appears to be reasonably secure. It is - * considered to be secure if host-based access control is - * enabled but no hosts are on the access list; this means - * that some other form (presumably more secure) form of - * authorization (such as xauth) must be in use. - */ - -#ifdef TK_NO_SECURITY - dispPtr->serverSecure = 1; -#else - dispPtr->serverSecure = 0; - addrPtr = XListHosts(dispPtr->display, &numHosts, &enabled); - if (enabled && (numHosts == 0)) { - dispPtr->serverSecure = 1; - } - if (addrPtr != NULL) { - XFree((char *) addrPtr); - } -#endif /* TK_NO_SECURITY */ - - - return TCL_OK; -} - -/* - *-------------------------------------------------------------- - * - * LookupName -- - * - * Given an interpreter name, see if the name exists in - * the interpreter registry for a particular display. - * - * Results: - * If the given name is registered, return the ID of - * the window associated with the name. If the name - * isn't registered, then return 0. - * - * Side effects: - * If the registry property is improperly formed, then - * it is deleted. If "delete" is non-zero, then if the - * named interpreter is found it is removed from the - * registry property. - * - *-------------------------------------------------------------- - */ - -static Window -LookupName(dispPtr, name, delete) - register TkDisplay *dispPtr; - /* Display whose registry to check. */ - char *name; /* Name of an interpreter. */ - int delete; /* If non-zero, delete info about name. */ -{ - char *regProp, *entry; - register char *p; - int result, actualFormat; - unsigned long numItems, bytesAfter; - Atom actualType; - Window returnValue; - - /* - * Read the registry property. - */ - - regProp = NULL; - result = XGetWindowProperty(dispPtr->display, - RootWindow(dispPtr->display, 0), - dispPtr->registryProperty, 0, MAX_PROP_WORDS, - False, XA_STRING, &actualType, &actualFormat, - &numItems, &bytesAfter, (unsigned char **) ®Prop); - - if (actualType == None) { - return 0; - } - - /* - * If the property is improperly formed, then delete it. - */ - - if ((result != Success) || (actualFormat != 8) - || (actualType != XA_STRING)) { - if (regProp != NULL) { - XFree(regProp); - } - XDeleteProperty(dispPtr->display, - RootWindow(dispPtr->display, 0), - dispPtr->registryProperty); - return 0; - } - - /* - * Scan the property for the desired name. - */ - - returnValue = (Window) 0; - entry = NULL; /* Not needed, but eliminates compiler warning. */ - for (p = regProp; (p-regProp) < numItems; ) { - entry = p; - while ((*p != 0) && (!isspace(UCHAR(*p)))) { - p++; - } - if ((*p != 0) && (strcmp(name, p+1) == 0)) { - sscanf(entry, "%x", &returnValue); - break; - } - while (*p != 0) { - p++; - } - p++; - } - - /* - * Delete the property, if that is desired (copy down the - * remainder of the registry property to overlay the deleted - * info, then rewrite the property). - */ - - if ((delete) && (returnValue != 0)) { - int count; - - while (*p != 0) { - p++; - } - p++; - count = numItems - (p-regProp); - if (count > 0) { - memcpy((VOID *) entry, (VOID *) p, count); - } - XChangeProperty(dispPtr->display, - RootWindow(dispPtr->display, 0), - dispPtr->registryProperty, XA_STRING, 8, - PropModeReplace, (unsigned char *) regProp, - (int) (numItems - (p-entry))); - XSync(dispPtr->display, False); - } - - XFree(regProp); - return returnValue; -} - -/* - *-------------------------------------------------------------- - * - * SendEventProc -- - * - * This procedure is invoked automatically by the toolkit - * event manager when a property changes on the communication - * window. This procedure reads the property and handles - * command requests and responses. - * - * Results: - * None. - * - * Side effects: - * If there are command requests in the property, they - * are executed. If there are responses in the property, - * their information is saved for the (ostensibly waiting) - * "send" commands. The property is deleted. - * - *-------------------------------------------------------------- - */ - -static void -SendEventProc(clientData, eventPtr) - ClientData clientData; /* Display information. */ - XEvent *eventPtr; /* Information about event. */ -{ - TkDisplay *dispPtr = (TkDisplay *) clientData; - char *propInfo; - register char *p; - int result, actualFormat; - unsigned long numItems, bytesAfter; - Atom actualType; - - if ((eventPtr->xproperty.atom != dispPtr->commProperty) - || (eventPtr->xproperty.state != PropertyNewValue)) { - return; - } - - /* - * Read the comm property and delete it. - */ - - propInfo = NULL; - result = XGetWindowProperty(dispPtr->display, - Tk_WindowId(dispPtr->commWindow), - dispPtr->commProperty, 0, MAX_PROP_WORDS, True, - XA_STRING, &actualType, &actualFormat, - &numItems, &bytesAfter, (unsigned char **) &propInfo); - - /* - * If the property doesn't exist or is improperly formed - * then ignore it. - */ - - if ((result != Success) || (actualType != XA_STRING) - || (actualFormat != 8)) { - if (propInfo != NULL) { - XFree(propInfo); - } - return; - } - - /* - * The property is divided into records separated by null - * characters. Each record represents one command request - * or response. Scan through the property one record at a - * time. - */ - - for (p = propInfo; (p-propInfo) < numItems; ) { - if (*p == 'C') { - Window window; - int serial, resultSize; - char *resultString, *interpName, *returnProp, *end; - register RegisteredInterp *riPtr; - char errorMsg[100]; -#define STATIC_RESULT_SPACE 100 - char staticSpace[STATIC_RESULT_SPACE]; - - /* - *----------------------------------------------------- - * This is an incoming command sent by another window. - * Parse the fields of the command string. If the command - * string isn't properly formed, send back an error message - * if there's enough well-formed information to generate - * a proper reply; otherwise just ignore the message. - *----------------------------------------------------- - */ - - p++; - window = (Window) strtol(p, &end, 16); - if (end == p) { - goto nextRecord; - } - p = end; - if (*p != ' ') { - goto nextRecord; - } - p++; - serial = strtol(p, &end, 16); - if (end == p) { - goto nextRecord; - } - p = end; - if (*p != ' ') { - goto nextRecord; - } - p++; - interpName = p; - while ((*p != 0) && (*p != '|')) { - p++; - } - if (*p != '|') { - result = TCL_ERROR; - resultString = "bad property format for sent command"; - goto returnResult; - } - if (!dispPtr->serverSecure) { - result = TCL_ERROR; - resultString = "X server insecure (must use xauth-style authorization); command ignored"; - goto returnResult; - } - *p = 0; - p++; - - /* - * Locate the interpreter for the command, then - * execute the command. - */ - - for (riPtr = registry; ; riPtr = riPtr->nextPtr) { - if (riPtr == NULL) { - result = TCL_ERROR; - sprintf(errorMsg, - "receiver never heard of interpreter \"%.40s\"", - interpName); - resultString = errorMsg; - goto returnResult; - } - if (strcmp(riPtr->name, interpName) == 0) { - break; - } - } - result = Tcl_GlobalEval(riPtr->interp, p); - resultString = riPtr->interp->result; - - /* - * Return the result to the sender. - */ - - returnResult: - resultSize = strlen(resultString) + 30; - if (resultSize <= STATIC_RESULT_SPACE) { - returnProp = staticSpace; - } else { - returnProp = (char *) ckalloc((unsigned) resultSize); - } - sprintf(returnProp, "R %x %d %s", serial, result, - resultString); - (void) AppendPropCarefully(dispPtr->display, window, - dispPtr->commProperty, returnProp, - (PendingCommand *) NULL); - if (returnProp != staticSpace) { - ckfree(returnProp); - } - } else if (*p == 'R') { - int serial, code; - char *end; - register PendingCommand *pcPtr; - - /* - *----------------------------------------------------- - * This record in the property is a result being - * returned for a command sent from here. First - * parse the fields. - *----------------------------------------------------- - */ - - p++; - serial = strtol(p, &end, 16); - if (end == p) { - goto nextRecord; - } - p = end; - if (*p != ' ') { - goto nextRecord; - } - p++; - code = strtol(p, &end, 10); - if (end == p) { - goto nextRecord; - } - p = end; - if (*p != ' ') { - goto nextRecord; - } - p++; - - /* - * Give the result information to anyone who's - * waiting for it. - */ - - for (pcPtr = pendingCommands; pcPtr != NULL; - pcPtr = pcPtr->nextPtr) { - if ((serial != pcPtr->serial) || (pcPtr->result != NULL)) { - continue; - } - pcPtr->code = code; - pcPtr->result = ckalloc((unsigned) (strlen(p) + 1)); - strcpy(pcPtr->result, p); - break; - } - } - - nextRecord: - while (*p != 0) { - p++; - } - p++; - } - XFree(propInfo); -} - -/* - *-------------------------------------------------------------- - * - * AppendPropCarefully -- - * - * Append a given property to a given window, but set up - * an X error handler so that if the append fails this - * procedure can return an error code rather than having - * Xlib panic. - * - * Results: - * None. - * - * Side effects: - * The given property on the given window is appended to. - * If this operation fails and if pendingPtr is non-NULL, - * then the pending operation is marked as complete with - * an error. - * - *-------------------------------------------------------------- - */ - -static void -AppendPropCarefully(display, window, property, value, pendingPtr) - Display *display; /* Display on which to operate. */ - Window window; /* Window whose property is to - * be modified. */ - Atom property; /* Name of property. */ - char *value; /* Characters (null-terminated) to - * append to property. */ - PendingCommand *pendingPtr; /* Pending command to mark complete - * if an error occurs during the - * property op. NULL means just - * ignore the error. */ -{ - Tk_ErrorHandler handler; - - handler = Tk_CreateErrorHandler(display, -1, -1, -1, AppendErrorProc, - (ClientData) pendingPtr); - XChangeProperty(display, window, property, XA_STRING, 8, - PropModeAppend, (unsigned char *) value, strlen(value)+1); - Tk_DeleteErrorHandler(handler); -} - -/* - * The procedure below is invoked if an error occurs during - * the XChangeProperty operation above. - */ - - /* ARGSUSED */ -static int -AppendErrorProc(clientData, errorPtr) - ClientData clientData; /* Command to mark complete, or NULL. */ - XErrorEvent *errorPtr; /* Information about error. */ -{ - PendingCommand *pendingPtr = (PendingCommand *) clientData; - register PendingCommand *pcPtr; - - if (pendingPtr == NULL) { - return 0; - } - - /* - * Make sure this command is still pending. - */ - - for (pcPtr = pendingCommands; pcPtr != NULL; - pcPtr = pcPtr->nextPtr) { - if ((pcPtr == pendingPtr) && (pcPtr->result == NULL)) { - pcPtr->result = ckalloc((unsigned) (strlen(pcPtr->target) + 50)); - sprintf(pcPtr->result, - "send to \"%s\" failed (no communication window)", - pcPtr->target); - pcPtr->code = TCL_ERROR; - break; - } - } - return 0; -} - -/* - *-------------------------------------------------------------- - * - * TimeoutProc -- - * - * This procedure is invoked when too much time has elapsed - * during the processing of a sent command. - * - * Results: - * None. - * - * Side effects: - * Mark the pending command as complete, with an error - * message signalling the timeout. - * - *-------------------------------------------------------------- - */ - -static void -TimeoutProc(clientData) - ClientData clientData; /* Information about command that - * has been sent but not yet - * responded to. */ -{ - PendingCommand *pcPtr = (PendingCommand *) clientData; - register PendingCommand *pcPtr2; - - /* - * Make sure that the command is still in the pending list - * and that it hasn't already completed. Then register the - * error. - */ - - for (pcPtr2 = pendingCommands; pcPtr2 != NULL; - pcPtr2 = pcPtr2->nextPtr) { - static char msg[] = "remote interpreter did not respond"; - if ((pcPtr2 != pcPtr) || (pcPtr2->result != NULL)) { - continue; - } - pcPtr2->code = TCL_ERROR; - pcPtr2->result = ckalloc((unsigned) (sizeof(msg) + 1)); - strcpy(pcPtr2->result, msg); - return; - } -} - -/* - *-------------------------------------------------------------- - * - * DeleteProc -- - * - * This procedure is invoked by Tcl when a registered - * interpreter is about to be deleted. It unregisters - * the interpreter. - * - * Results: - * None. - * - * Side effects: - * The interpreter given by riPtr is unregistered. - * - *-------------------------------------------------------------- - */ - -static void -DeleteProc(clientData) - ClientData clientData; /* Info about registration, passed - * as ClientData. */ -{ - RegisteredInterp *riPtr = (RegisteredInterp *) clientData; - register RegisteredInterp *riPtr2; - - XGrabServer(riPtr->dispPtr->display); - (void) LookupName(riPtr->dispPtr, riPtr->name, 1); - XUngrabServer(riPtr->dispPtr->display); - XFlush(riPtr->dispPtr->display); - if (registry == riPtr) { - registry = riPtr->nextPtr; - } else { - for (riPtr2 = registry; riPtr2 != NULL; - riPtr2 = riPtr2->nextPtr) { - if (riPtr2->nextPtr == riPtr) { - riPtr2->nextPtr = riPtr->nextPtr; - break; - } - } - } - ckfree((char *) riPtr->name); - ckfree((char *) riPtr); -} - -/* - *---------------------------------------------------------------------- - * - * SendRestrictProc -- - * - * This procedure filters incoming events when a "send" command - * is outstanding. It defers all events except those containing - * send commands and results. - * - * Results: - * False is returned except for property-change events on the - * given commWindow. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static Bool -SendRestrictProc(display, eventPtr, arg) - Display *display; /* Display from which event arrived. */ - register XEvent *eventPtr; /* Event that just arrived. */ - char *arg; /* Comunication window in which - * we're interested. */ -{ - register Tk_Window comm = (Tk_Window) arg; - - if ((display != Tk_Display(comm)) - || (eventPtr->type != PropertyNotify) - || (eventPtr->xproperty.window != Tk_WindowId(comm))) { - return False; - } - return True; -} diff --git a/tk3.6/tkTest.c b/tk3.6/tkTest.c deleted file mode 100644 index 1eaf928..0000000 --- a/tk3.6/tkTest.c +++ /dev/null @@ -1,159 +0,0 @@ -/* - * 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/wish/RCS/tkTest.c,v 1.6 93/08/26 14:38:22 ouster Exp $ SPRITE (Berkeley)"; -#endif /* not lint */ - -#include "tk.h" -#include "tkConfig.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; - -/* - * Forward declarations for procedures defined later in this file: - */ - -static int TestmakeexistCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); - -/* - *---------------------------------------------------------------------- - * - * 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. */ -{ - Tk_Window main; - - main = Tk_MainWindow(interp); - if (main == NULL) { - return TCL_ERROR; - } - - /* - * 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; - } - if (Tk_Init(interp) == TCL_ERROR) { - return TCL_ERROR; - } - - /* - * Create additional commands for testing Tk. - */ - - Tcl_CreateCommand(interp, "testmakeexist", TestmakeexistCmd, - (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL); - - /* - * 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 = "~/.wishrc"; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TestmakeexistCmd -- - * - * This procedure implements the "testmakeexist" command. It calls - * Tk_MakeWindowExist on each of its arguments to force the windows - * to be created. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Creates and deletes interpreters. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -TestmakeexistCmd(clientData, interp, argc, argv) - ClientData clientData; /* Main window for application. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - Tk_Window main = (Tk_Window) clientData; - int i; - Tk_Window tkwin; - - for (i = 1; i < argc; i++) { - tkwin = Tk_NameToWindow(interp, argv[i], main); - if (tkwin == NULL) { - return TCL_ERROR; - } - Tk_MakeWindowExist(tkwin); - } - - return TCL_OK; -} diff --git a/tk3.6/tkText.c b/tk3.6/tkText.c deleted file mode 100644 index d573eac..0000000 --- a/tk3.6/tkText.c +++ /dev/null @@ -1,1491 +0,0 @@ -/* - * tkText.c -- - * - * This module provides a big chunk of the implementation of - * multi-line editable text widgets for Tk. Among other things, - * it provides the Tcl command interfaces to text widgets and - * the display code. The B-tree representation of text is - * implemented elsewhere. - * - * 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. - */ - -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkText.c,v 1.34 93/11/01 15:05:17 ouster Exp $ SPRITE (Berkeley)"; -#endif - -#include "default.h" -#include "tkConfig.h" -#include "tk.h" -#include "tkText.h" - -/* - * Information used to parse text configuration options: - */ - -static Tk_ConfigSpec configSpecs[] = { - {TK_CONFIG_BORDER, "-background", "background", "Background", - DEF_TEXT_BG_COLOR, Tk_Offset(TkText, border), TK_CONFIG_COLOR_ONLY}, - {TK_CONFIG_BORDER, "-background", "background", "Background", - DEF_TEXT_BG_MONO, Tk_Offset(TkText, border), TK_CONFIG_MONO_ONLY}, - {TK_CONFIG_SYNONYM, "-bd", "borderWidth", (char *) NULL, - (char *) NULL, 0, 0}, - {TK_CONFIG_SYNONYM, "-bg", "background", (char *) NULL, - (char *) NULL, 0, 0}, - {TK_CONFIG_PIXELS, "-borderwidth", "borderWidth", "BorderWidth", - DEF_TEXT_BORDER_WIDTH, Tk_Offset(TkText, borderWidth), 0}, - {TK_CONFIG_ACTIVE_CURSOR, "-cursor", "cursor", "Cursor", - DEF_TEXT_CURSOR, Tk_Offset(TkText, cursor), TK_CONFIG_NULL_OK}, - {TK_CONFIG_BOOLEAN, "-exportselection", "exportSelection", - "ExportSelection", DEF_TEXT_EXPORT_SELECTION, - Tk_Offset(TkText, exportSelection), 0}, - {TK_CONFIG_SYNONYM, "-fg", "foreground", (char *) NULL, - (char *) NULL, 0, 0}, - {TK_CONFIG_FONT, "-font", "font", "Font", - DEF_TEXT_FONT, Tk_Offset(TkText, fontPtr), 0}, - {TK_CONFIG_COLOR, "-foreground", "foreground", "Foreground", - DEF_TEXT_FG, Tk_Offset(TkText, fgColor), 0}, - {TK_CONFIG_INT, "-height", "height", "Height", - DEF_TEXT_HEIGHT, Tk_Offset(TkText, height), 0}, - {TK_CONFIG_BORDER, "-insertbackground", "insertBackground", "Foreground", - DEF_TEXT_INSERT_BG, Tk_Offset(TkText, insertBorder), 0}, - {TK_CONFIG_PIXELS, "-insertborderwidth", "insertBorderWidth", "BorderWidth", - DEF_TEXT_INSERT_BD_COLOR, Tk_Offset(TkText, insertBorderWidth), - TK_CONFIG_COLOR_ONLY}, - {TK_CONFIG_PIXELS, "-insertborderwidth", "insertBorderWidth", "BorderWidth", - DEF_TEXT_INSERT_BD_MONO, Tk_Offset(TkText, insertBorderWidth), - TK_CONFIG_MONO_ONLY}, - {TK_CONFIG_INT, "-insertofftime", "insertOffTime", "OffTime", - DEF_TEXT_INSERT_OFF_TIME, Tk_Offset(TkText, insertOffTime), 0}, - {TK_CONFIG_INT, "-insertontime", "insertOnTime", "OnTime", - DEF_TEXT_INSERT_ON_TIME, Tk_Offset(TkText, insertOnTime), 0}, - {TK_CONFIG_PIXELS, "-insertwidth", "insertWidth", "InsertWidth", - DEF_TEXT_INSERT_WIDTH, Tk_Offset(TkText, insertWidth), 0}, - {TK_CONFIG_PIXELS, "-padx", "padX", "Pad", - DEF_TEXT_PADX, Tk_Offset(TkText, padX), 0}, - {TK_CONFIG_PIXELS, "-pady", "padY", "Pad", - DEF_TEXT_PADY, Tk_Offset(TkText, padY), 0}, - {TK_CONFIG_RELIEF, "-relief", "relief", "Relief", - DEF_TEXT_RELIEF, Tk_Offset(TkText, relief), 0}, - {TK_CONFIG_BORDER, "-selectbackground", "selectBackground", "Foreground", - DEF_TEXT_SELECT_COLOR, Tk_Offset(TkText, selBorder), - TK_CONFIG_COLOR_ONLY}, - {TK_CONFIG_BORDER, "-selectbackground", "selectBackground", "Foreground", - DEF_TEXT_SELECT_MONO, Tk_Offset(TkText, selBorder), - TK_CONFIG_MONO_ONLY}, - {TK_CONFIG_PIXELS, "-selectborderwidth", "selectBorderWidth", "BorderWidth", - DEF_TEXT_SELECT_BD_COLOR, Tk_Offset(TkText, selBorderWidth), - TK_CONFIG_COLOR_ONLY}, - {TK_CONFIG_PIXELS, "-selectborderwidth", "selectBorderWidth", "BorderWidth", - DEF_TEXT_SELECT_BD_MONO, Tk_Offset(TkText, selBorderWidth), - TK_CONFIG_MONO_ONLY}, - {TK_CONFIG_COLOR, "-selectforeground", "selectForeground", "Background", - DEF_TEXT_SELECT_FG_COLOR, Tk_Offset(TkText, selFgColorPtr), - TK_CONFIG_COLOR_ONLY}, - {TK_CONFIG_COLOR, "-selectforeground", "selectForeground", "Background", - DEF_TEXT_SELECT_FG_MONO, Tk_Offset(TkText, selFgColorPtr), - TK_CONFIG_MONO_ONLY}, - {TK_CONFIG_BOOLEAN, "-setgrid", "setGrid", "SetGrid", - DEF_TEXT_SET_GRID, Tk_Offset(TkText, setGrid), 0}, - {TK_CONFIG_UID, "-state", "state", "State", - DEF_TEXT_STATE, Tk_Offset(TkText, state), 0}, - {TK_CONFIG_INT, "-width", "width", "Width", - DEF_TEXT_WIDTH, Tk_Offset(TkText, width), 0}, - {TK_CONFIG_UID, "-wrap", "wrap", "Wrap", - DEF_TEXT_WRAP, Tk_Offset(TkText, wrapMode), 0}, - {TK_CONFIG_STRING, "-yscrollcommand", "yScrollCommand", "ScrollCommand", - DEF_TEXT_YSCROLL_COMMAND, Tk_Offset(TkText, yScrollCmd), - TK_CONFIG_NULL_OK}, - {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, - (char *) NULL, 0, 0} -}; - -/* - * The following definition specifies the maximum number of characters - * needed in a string to hold a position specifier. - */ - -#define POS_CHARS 30 - -/* - * Tk_Uid's used to represent text states: - */ - -Tk_Uid tkTextCharUid = NULL; -Tk_Uid tkTextDisabledUid = NULL; -Tk_Uid tkTextNoneUid = NULL; -Tk_Uid tkTextNormalUid = NULL; -Tk_Uid tkTextWordUid = NULL; - -/* - * Forward declarations for procedures defined later in this file: - */ - -static int ConfigureText _ANSI_ARGS_((Tcl_Interp *interp, - TkText *textPtr, int argc, char **argv, int flags)); -static void DeleteChars _ANSI_ARGS_((TkText *textPtr, int line1, - int ch1, int line2, int ch2)); -static void DestroyText _ANSI_ARGS_((ClientData clientData)); -static void InsertChars _ANSI_ARGS_((TkText *textPtr, int line, - int ch, char *string)); -static void TextBlinkProc _ANSI_ARGS_((ClientData clientData)); -static void TextEventProc _ANSI_ARGS_((ClientData clientData, - XEvent *eventPtr)); -static int TextFetchSelection _ANSI_ARGS_((ClientData clientData, - int offset, char *buffer, int maxBytes)); -static int TextMarkCmd _ANSI_ARGS_((TkText *textPtr, - Tcl_Interp *interp, int argc, char **argv)); -static int TextScanCmd _ANSI_ARGS_((TkText *textPtr, - Tcl_Interp *interp, int argc, char **argv)); -static int TextWidgetCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); - -/* - *-------------------------------------------------------------- - * - * Tk_TextCmd -- - * - * This procedure is invoked to process the "text" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *-------------------------------------------------------------- - */ - -int -Tk_TextCmd(clientData, interp, argc, argv) - ClientData clientData; /* Main window associated with - * interpreter. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - Tk_Window tkwin = (Tk_Window) clientData; - Tk_Window new; - register TkText *textPtr; - - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " pathName ?options?\"", (char *) NULL); - return TCL_ERROR; - } - - /* - * Perform once-only initialization: - */ - - if (tkTextNormalUid == NULL) { - tkTextCharUid = Tk_GetUid("char"); - tkTextDisabledUid = Tk_GetUid("disabled"); - tkTextNoneUid = Tk_GetUid("none"); - tkTextNormalUid = Tk_GetUid("normal"); - tkTextWordUid = Tk_GetUid("word"); - } - - /* - * Create the window. - */ - - new = Tk_CreateWindowFromPath(interp, tkwin, argv[1], (char *) NULL); - if (new == NULL) { - return TCL_ERROR; - } - - textPtr = (TkText *) ckalloc(sizeof(TkText)); - textPtr->tkwin = new; - textPtr->display = Tk_Display(new); - textPtr->interp = interp; - textPtr->tree = TkBTreeCreate(); - Tcl_InitHashTable(&textPtr->tagTable, TCL_STRING_KEYS); - textPtr->numTags = 0; - Tcl_InitHashTable(&textPtr->markTable, TCL_STRING_KEYS); - textPtr->state = tkTextNormalUid; - textPtr->border = NULL; - textPtr->borderWidth = 0; - textPtr->padX = 0; - textPtr->padY = 0; - textPtr->relief = TK_RELIEF_FLAT; - textPtr->cursor = None; - textPtr->fgColor = NULL; - textPtr->fontPtr = NULL; - textPtr->wrapMode = tkTextCharUid; - textPtr->width = 0; - textPtr->height = 0; - textPtr->setGrid = 0; - textPtr->prevWidth = Tk_Width(new); - textPtr->prevHeight = Tk_Height(new); - textPtr->topLinePtr = NULL; - TkTextCreateDInfo(textPtr); - TkTextSetView(textPtr, 0, 0); - textPtr->selTagPtr = NULL; - textPtr->selBorder = NULL; - textPtr->selBorderWidth = 0; - textPtr->selFgColorPtr = NULL; - textPtr->exportSelection = 1; - textPtr->selLine = 0; - textPtr->selCh = 0; - textPtr->selOffset = -1; - textPtr->insertAnnotPtr = NULL; - textPtr->insertBorder = NULL; - textPtr->insertWidth = 0; - textPtr->insertBorderWidth = 0; - textPtr->insertOnTime = 0; - textPtr->insertOffTime = 0; - textPtr->insertBlinkHandler = (Tk_TimerToken) NULL; - textPtr->bindingTable = NULL; - textPtr->currentAnnotPtr = NULL; - textPtr->pickEvent.type = LeaveNotify; - textPtr->yScrollCmd = NULL; - textPtr->scanMarkLine = 0; - textPtr->scanMarkY = 0; - textPtr->flags = 0; - - /* - * Create the "sel" tag and the "current" and "insert" marks. - */ - - textPtr->selTagPtr = TkTextCreateTag(textPtr, "sel"); - textPtr->selTagPtr->relief = TK_RELIEF_RAISED; - textPtr->currentAnnotPtr = TkTextSetMark(textPtr, "current", 0, 0); - textPtr->insertAnnotPtr = TkTextSetMark(textPtr, "insert", 0, 0); - - Tk_SetClass(new, "Text"); - Tk_CreateEventHandler(textPtr->tkwin, - ExposureMask|StructureNotifyMask|FocusChangeMask, - TextEventProc, (ClientData) textPtr); - Tk_CreateEventHandler(textPtr->tkwin, KeyPressMask|KeyReleaseMask - |ButtonPressMask|ButtonReleaseMask|EnterWindowMask - |LeaveWindowMask|PointerMotionMask, TkTextBindProc, - (ClientData) textPtr); - Tk_CreateSelHandler(textPtr->tkwin, XA_STRING, TextFetchSelection, - (ClientData) textPtr, XA_STRING); - Tcl_CreateCommand(interp, Tk_PathName(textPtr->tkwin), - TextWidgetCmd, (ClientData) textPtr, (void (*)()) NULL); - if (ConfigureText(interp, textPtr, argc-2, argv+2, 0) != TCL_OK) { - Tk_DestroyWindow(textPtr->tkwin); - return TCL_ERROR; - } - interp->result = Tk_PathName(textPtr->tkwin); - - return TCL_OK; -} - -/* - *-------------------------------------------------------------- - * - * TextWidgetCmd -- - * - * This procedure is invoked to process the Tcl command - * that corresponds to a text widget. See the user - * documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *-------------------------------------------------------------- - */ - -static int -TextWidgetCmd(clientData, interp, argc, argv) - ClientData clientData; /* Information about text widget. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - register TkText *textPtr = (TkText *) clientData; - int result = TCL_OK; - int length; - char c; - int line1, line2, ch1, ch2; - - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " option ?arg arg ...?\"", (char *) NULL); - return TCL_ERROR; - } - Tk_Preserve((ClientData) textPtr); - c = argv[1][0]; - length = strlen(argv[1]); - if ((c == 'c') && (strncmp(argv[1], "compare", length) == 0) - && (length >= 3)) { - int less, equal, greater, value; - char *p; - - if (argc != 5) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " compare index1 op index2\"", (char *) NULL); - result = TCL_ERROR; - goto done; - } - if ((TkTextGetIndex(interp, textPtr, argv[2], &line1, &ch1) != TCL_OK) - || (TkTextGetIndex(interp, textPtr, argv[4], &line2, &ch2) - != TCL_OK)) { - result = TCL_ERROR; - goto done; - } - less = equal = greater = 0; - if (line1 < line2) { - less = 1; - } else if (line1 > line2) { - greater = 1; - } else { - if (ch1 < ch2) { - less = 1; - } else if (ch1 > ch2) { - greater = 1; - } else { - equal = 1; - } - } - p = argv[3]; - if (p[0] == '<') { - value = less; - if ((p[1] == '=') && (p[2] == 0)) { - value = less || equal; - } else if (p[1] != 0) { - compareError: - Tcl_AppendResult(interp, "bad comparison operator \"", - argv[3], "\": must be <, <=, ==, >=, >, or !=", - (char *) NULL); - result = TCL_ERROR; - goto done; - } - } else if (p[0] == '>') { - value = greater; - if ((p[1] == '=') && (p[2] == 0)) { - value = greater || equal; - } else if (p[1] != 0) { - goto compareError; - } - } else if ((p[0] == '=') && (p[1] == '=') && (p[2] == 0)) { - value = equal; - } else if ((p[0] == '!') && (p[1] == '=') && (p[2] == 0)) { - value = !equal; - } else { - goto compareError; - } - interp->result = (value) ? "1" : "0"; - } else if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0) - && (length >= 3)) { - if (argc == 2) { - result = Tk_ConfigureInfo(interp, textPtr->tkwin, configSpecs, - (char *) textPtr, (char *) NULL, 0); - } else if (argc == 3) { - result = Tk_ConfigureInfo(interp, textPtr->tkwin, configSpecs, - (char *) textPtr, argv[2], 0); - } else { - result = ConfigureText(interp, textPtr, argc-2, argv+2, - TK_CONFIG_ARGV_ONLY); - } - } else if ((c == 'd') && (strncmp(argv[1], "debug", length) == 0) - && (length >= 3)) { - if (argc > 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " debug ?on|off?\"", (char *) NULL); - result = TCL_ERROR; - goto done; - } - if (argc == 2) { - interp->result = (tkBTreeDebug) ? "on" : "off"; - } else { - if (Tcl_GetBoolean(interp, argv[2], &tkBTreeDebug) != TCL_OK) { - result = TCL_ERROR; - goto done; - } - } - } else if ((c == 'd') && (strncmp(argv[1], "delete", length) == 0) - && (length >= 3)) { - if ((argc != 3) && (argc != 4)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " delete index1 ?index2?\"", (char *) NULL); - result = TCL_ERROR; - goto done; - } - if (TkTextGetIndex(interp, textPtr, argv[2], &line1, &ch1) != TCL_OK) { - result = TCL_ERROR; - goto done; - } - if (argc == 3) { - line2 = line1; - ch2 = ch1+1; - } else if (TkTextGetIndex(interp, textPtr, argv[3], &line2, &ch2) - != TCL_OK) { - result = TCL_ERROR; - goto done; - } - if (textPtr->state == tkTextNormalUid) { - DeleteChars(textPtr, line1, ch1, line2, ch2); - } - } else if ((c == 'g') && (strncmp(argv[1], "get", length) == 0)) { - register TkTextLine *linePtr; - - if ((argc != 3) && (argc != 4)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " get index1 ?index2?\"", (char *) NULL); - result = TCL_ERROR; - goto done; - } - if (TkTextGetIndex(interp, textPtr, argv[2], &line1, &ch1) != TCL_OK) { - result = TCL_ERROR; - goto done; - } - if (argc == 3) { - line2 = line1; - ch2 = ch1+1; - } else if (TkTextGetIndex(interp, textPtr, argv[3], &line2, &ch2) - != TCL_OK) { - result = TCL_ERROR; - goto done; - } - if (line1 < 0) { - line1 = 0; - ch1 = 0; - } - for (linePtr = TkBTreeFindLine(textPtr->tree, line1); - (linePtr != NULL) && (line1 <= line2); - linePtr = TkBTreeNextLine(linePtr), line1++, ch1 = 0) { - int savedChar, last; - - if (line1 == line2) { - last = ch2; - if (last > linePtr->numBytes) { - last = linePtr->numBytes; - } - } else { - last = linePtr->numBytes; - } - if (ch1 >= last) { - continue; - } - savedChar = linePtr->bytes[last]; - linePtr->bytes[last] = 0; - Tcl_AppendResult(interp, linePtr->bytes+ch1, (char *) NULL); - linePtr->bytes[last] = savedChar; - } - } else if ((c == 'i') && (strncmp(argv[1], "index", length) == 0) - && (length >= 3)) { - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " index index\"", - (char *) NULL); - result = TCL_ERROR; - goto done; - } - if (TkTextGetIndex(interp, textPtr, argv[2], &line1, &ch1) != TCL_OK) { - result = TCL_ERROR; - goto done; - } - TkTextPrintIndex(line1, ch1, interp->result); - } else if ((c == 'i') && (strncmp(argv[1], "insert", length) == 0) - && (length >= 3)) { - if (argc != 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " insert index chars ?chars ...?\"", - (char *) NULL); - result = TCL_ERROR; - goto done; - } - if (TkTextGetIndex(interp, textPtr, argv[2], &line1, &ch1) != TCL_OK) { - result = TCL_ERROR; - goto done; - } - if (textPtr->state == tkTextNormalUid) { - InsertChars(textPtr, line1, ch1, argv[3]); - } - } else if ((c == 'm') && (strncmp(argv[1], "mark", length) == 0)) { - result = TextMarkCmd(textPtr, interp, argc, argv); - } else if ((c == 's') && (strcmp(argv[1], "scan") == 0)) { - result = TextScanCmd(textPtr, interp, argc, argv); - } else if ((c == 't') && (strcmp(argv[1], "tag") == 0)) { - result = TkTextTagCmd(textPtr, interp, argc, argv); - } else if ((c == 'y') && (strncmp(argv[1], "yview", length) == 0)) { - int pickPlace; - - if (argc < 3) { - yviewSyntax: - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " yview ?-pickplace? lineNum|index\"", - (char *) NULL); - result = TCL_ERROR; - goto done; - } - pickPlace = 0; - if (argv[2][0] == '-') { - int switchLength; - - switchLength = strlen(argv[2]); - if ((switchLength >= 2) - && (strncmp(argv[2], "-pickplace", switchLength) == 0)) { - pickPlace = 1; - } - } - if ((pickPlace+3) != argc) { - goto yviewSyntax; - } - if (Tcl_GetInt(interp, argv[2+pickPlace], &line1) != TCL_OK) { - Tcl_ResetResult(interp); - if (TkTextGetIndex(interp, textPtr, argv[2+pickPlace], - &line1, &ch1) != TCL_OK) { - result = TCL_ERROR; - goto done; - } - } - TkTextSetView(textPtr, line1, pickPlace); - } else { - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be compare, configure, debug, delete, get, ", - "index, insert, mark, scan, tag, or yview", - (char *) NULL); - result = TCL_ERROR; - } - - done: - Tk_Release((ClientData) textPtr); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * DestroyText -- - * - * This procedure is invoked by Tk_EventuallyFree or Tk_Release - * to clean up the internal structure of a text at a safe time - * (when no-one is using it anymore). - * - * Results: - * None. - * - * Side effects: - * Everything associated with the text is freed up. - * - *---------------------------------------------------------------------- - */ - -static void -DestroyText(clientData) - ClientData clientData; /* Info about text widget. */ -{ - register TkText *textPtr = (TkText *) clientData; - Tcl_HashSearch search; - Tcl_HashEntry *hPtr; - TkTextTag *tagPtr; - - /* - * Free up all the stuff that requires special handling, then - * let Tk_FreeOptions handle all the standard option-related - * stuff. - */ - - TkBTreeDestroy(textPtr->tree); - for (hPtr = Tcl_FirstHashEntry(&textPtr->tagTable, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - tagPtr = (TkTextTag *) Tcl_GetHashValue(hPtr); - TkTextFreeTag(textPtr, tagPtr); - } - Tcl_DeleteHashTable(&textPtr->tagTable); - for (hPtr = Tcl_FirstHashEntry(&textPtr->markTable, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - ckfree((char *) Tcl_GetHashValue(hPtr)); - } - Tcl_DeleteHashTable(&textPtr->markTable); - TkTextFreeDInfo(textPtr); - if (textPtr->insertBlinkHandler != NULL) { - Tk_DeleteTimerHandler(textPtr->insertBlinkHandler); - } - if (textPtr->bindingTable != NULL) { - Tk_DeleteBindingTable(textPtr->bindingTable); - } - - /* - * NOTE: do NOT free up selBorder or selFgColorPtr: they are - * duplicates of information in the "sel" tag, which was freed - * up as part of deleting the tags above. - */ - - textPtr->selBorder = NULL; - textPtr->selFgColorPtr = NULL; - Tk_FreeOptions(configSpecs, (char *) textPtr, textPtr->display, 0); - ckfree((char *) textPtr); -} - -/* - *---------------------------------------------------------------------- - * - * ConfigureText -- - * - * This procedure is called to process an argv/argc list, plus - * the Tk option database, in order to configure (or - * reconfigure) a text widget. - * - * Results: - * The return value is a standard Tcl result. If TCL_ERROR is - * returned, then interp->result contains an error message. - * - * Side effects: - * Configuration information, such as text string, colors, font, - * etc. get set for textPtr; old resources get freed, if there - * were any. - * - *---------------------------------------------------------------------- - */ - -static int -ConfigureText(interp, textPtr, argc, argv, flags) - Tcl_Interp *interp; /* Used for error reporting. */ - register TkText *textPtr; /* Information about widget; may or may - * not already have values for some fields. */ - int argc; /* Number of valid entries in argv. */ - char **argv; /* Arguments. */ - int flags; /* Flags to pass to Tk_ConfigureWidget. */ -{ - int oldExport = textPtr->exportSelection; - int charWidth, charHeight; - - if (Tk_ConfigureWidget(interp, textPtr->tkwin, configSpecs, - argc, argv, (char *) textPtr, flags) != TCL_OK) { - return TCL_ERROR; - } - - /* - * A few other options also need special processing, such as parsing - * the geometry and setting the background from a 3-D border. - */ - - if ((textPtr->state != tkTextNormalUid) - && (textPtr->state != tkTextDisabledUid)) { - Tcl_AppendResult(interp, "bad state value \"", textPtr->state, - "\": must be normal or disabled", (char *) NULL); - textPtr->state = tkTextNormalUid; - return TCL_ERROR; - } - - if ((textPtr->wrapMode != tkTextCharUid) - && (textPtr->wrapMode != tkTextNoneUid) - && (textPtr->wrapMode != tkTextWordUid)) { - Tcl_AppendResult(interp, "bad wrap mode \"", textPtr->state, - "\": must be char, none, or word", (char *) NULL); - textPtr->wrapMode = tkTextCharUid; - return TCL_ERROR; - } - - Tk_SetBackgroundFromBorder(textPtr->tkwin, textPtr->border); - Tk_SetInternalBorder(textPtr->tkwin, textPtr->borderWidth); - Tk_GeometryRequest(textPtr->tkwin, 200, 100); - - /* - * Make sure that configuration options are properly mirrored - * between the widget record and the "sel" tags. NOTE: we don't - * have to free up information during the mirroring; old - * information was freed when it was replaced in the widget - * record. - */ - - textPtr->selTagPtr->border = textPtr->selBorder; - textPtr->selTagPtr->borderWidth = textPtr->selBorderWidth; - textPtr->selTagPtr->fgColor = textPtr->selFgColorPtr; - - /* - * Claim the selection if we've suddenly started exporting it and there - * are tagged characters. - */ - - if (textPtr->exportSelection && (!oldExport)) { - TkTextSearch search; - - TkBTreeStartSearch(textPtr->tree, 0, 0, TkBTreeNumLines(textPtr->tree), - 0, textPtr->selTagPtr, &search); - if (TkBTreeNextTag(&search)) { - Tk_OwnSelection(textPtr->tkwin, TkTextLostSelection, - (ClientData) textPtr); - textPtr->flags |= GOT_SELECTION; - } - } - - /* - * Register the desired geometry for the window, and arrange for - * the window to be redisplayed. - */ - - if (textPtr->width <= 0) { - textPtr->width = 1; - } - if (textPtr->height <= 0) { - textPtr->height = 1; - } - charWidth = XTextWidth(textPtr->fontPtr, "0", 1); - charHeight = (textPtr->fontPtr->ascent + textPtr->fontPtr->descent); - Tk_GeometryRequest(textPtr->tkwin, - textPtr->width * charWidth + 2*textPtr->borderWidth - + 2*textPtr->padX, - textPtr->height * charHeight + 2*textPtr->borderWidth - + 2*textPtr->padY); - Tk_SetInternalBorder(textPtr->tkwin, textPtr->borderWidth); - if (textPtr->setGrid) { - Tk_SetGrid(textPtr->tkwin, textPtr->width, textPtr->height, - charWidth, charHeight); - } - - TkTextRelayoutWindow(textPtr); - return TCL_OK; -} - -/* - *-------------------------------------------------------------- - * - * TextEventProc -- - * - * This procedure is invoked by the Tk dispatcher on - * structure changes to a text. For texts with 3D - * borders, this procedure is also invoked for exposures. - * - * Results: - * None. - * - * Side effects: - * When the window gets deleted, internal structures get - * cleaned up. When it gets exposed, it is redisplayed. - * - *-------------------------------------------------------------- - */ - -static void -TextEventProc(clientData, eventPtr) - ClientData clientData; /* Information about window. */ - register XEvent *eventPtr; /* Information about event. */ -{ - register TkText *textPtr = (TkText *) clientData; - int lineNum; - - if (eventPtr->type == Expose) { - TkTextRedrawRegion(textPtr, eventPtr->xexpose.x, - eventPtr->xexpose.y, eventPtr->xexpose.width, - eventPtr->xexpose.height); - } else if (eventPtr->type == ConfigureNotify) { - if ((textPtr->prevWidth != Tk_Width(textPtr->tkwin)) - || (textPtr->prevHeight != Tk_Height(textPtr->tkwin))) { - TkTextRelayoutWindow(textPtr); - } - } else if (eventPtr->type == DestroyNotify) { - Tcl_DeleteCommand(textPtr->interp, Tk_PathName(textPtr->tkwin)); - textPtr->tkwin = NULL; - Tk_EventuallyFree((ClientData) textPtr, DestroyText); - } else if ((eventPtr->type == FocusIn) || (eventPtr->type == FocusOut)) { - Tk_DeleteTimerHandler(textPtr->insertBlinkHandler); - if (eventPtr->type == FocusIn) { - textPtr->flags |= GOT_FOCUS | INSERT_ON; - if (textPtr->insertOffTime != 0) { - textPtr->insertBlinkHandler = Tk_CreateTimerHandler( - textPtr->insertOnTime, TextBlinkProc, - (ClientData) textPtr); - } - } else { - textPtr->flags &= ~(GOT_FOCUS | INSERT_ON); - textPtr->insertBlinkHandler = (Tk_TimerToken) NULL; - } - lineNum = TkBTreeLineIndex(textPtr->insertAnnotPtr->linePtr); - TkTextLinesChanged(textPtr, lineNum, lineNum); - } -} - -/* - *---------------------------------------------------------------------- - * - * InsertChars -- - * - * This procedure implements most of the functionality of the - * "insert" widget command. - * - * Results: - * None. - * - * Side effects: - * The characters in "string" get added to the text just before - * the character indicated by "line" and "ch". - * - *---------------------------------------------------------------------- - */ - -static void -InsertChars(textPtr, line, ch, string) - TkText *textPtr; /* Overall information about text widget. */ - int line, ch; /* Identifies character just before which - * new information is to be inserted. */ - char *string; /* Null-terminated string containing new - * information to add to text. */ -{ - register TkTextLine *linePtr; - - /* - * Locate the line where the insertion will occur. - */ - - linePtr = TkTextRoundIndex(textPtr, &line, &ch); - - /* - * Notify the display module that lines are about to change, then do - * the insertion. - */ - - TkTextLinesChanged(textPtr, line, line); - TkBTreeInsertChars(textPtr->tree, linePtr, ch, string); - - /* - * If the line containing the insertion point was textPtr->topLinePtr, - * we must reset this pointer since the line structure was re-allocated. - */ - - if (linePtr == textPtr->topLinePtr) { - TkTextSetView(textPtr, line, 0); - } - - /* - * Invalidate any selection retrievals in progress. - */ - - textPtr->selOffset = -1; -} - -/* - *---------------------------------------------------------------------- - * - * DeleteChars -- - * - * This procedure implements most of the functionality of the - * "delete" widget command. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -DeleteChars(textPtr, line1, ch1, line2, ch2) - TkText *textPtr; /* Overall information about text widget. */ - int line1, ch1; /* Position of first character to delete. */ - int line2, ch2; /* Position of character just after last - * one to delete. */ -{ - register TkTextLine *line1Ptr, *line2Ptr; - int numLines, topLine; - - /* - * The loop below is needed because a LeaveNotify event may be - * generated on the current charcter if it's about to be deleted. - * If this happens, then the bindings that trigger could modify - * the text, invalidating the range information computed here. - * So, go back and recompute all the range information after - * synthesizing a leave event. - */ - - while (1) { - - /* - * Locate the starting and ending lines for the deletion and adjust - * the endpoints if necessary to ensure that they are within valid - * ranges. Adjust the deletion range if necessary to ensure that the - * text (and each invidiual line) always ends in a newline. - */ - - numLines = TkBTreeNumLines(textPtr->tree); - line1Ptr = TkTextRoundIndex(textPtr, &line1, &ch1); - if (line2 < 0) { - return; - } else if (line2 >= numLines) { - line2 = numLines-1; - line2Ptr = TkBTreeFindLine(textPtr->tree, line2); - ch2 = line2Ptr->numBytes; - } else { - line2Ptr = TkBTreeFindLine(textPtr->tree, line2); - if (ch2 < 0) { - ch2 = 0; - } - } - - /* - * If the deletion range ends after the last character of a line, - * do one of three things: - * - * (a) if line2Ptr isn't the last line of the text, just adjust the - * ending point to be just before the 0th character of the next - * line. - * (b) if ch1 is at the beginning of a line, then adjust line1Ptr and - * ch1 to point just after the last character of the previous line. - * (c) otherwise, adjust ch2 so the final newline isn't deleted. - */ - - if (ch2 >= line2Ptr->numBytes) { - if (line2 < (numLines-1)) { - line2++; - line2Ptr = TkBTreeNextLine(line2Ptr); - ch2 = 0; - } else { - ch2 = line2Ptr->numBytes-1; - if ((ch1 == 0) && (line1 > 0)) { - line1--; - line1Ptr = TkBTreeFindLine(textPtr->tree, line1); - ch1 = line1Ptr->numBytes; - ch2 = line2Ptr->numBytes; - } else { - ch2 = line2Ptr->numBytes-1; - } - } - } - - if ((line1 > line2) || ((line1 == line2) && (ch1 >= ch2))) { - return; - } - - /* - * If the current character is within the range being deleted, - * unpick it and synthesize a leave event for its tags, then - * go back and recompute the range ends. - */ - - if (!(textPtr->flags & IN_CURRENT)) { - break; - } - if ((textPtr->currentAnnotPtr->linePtr == line1Ptr) - && (textPtr->currentAnnotPtr->ch < ch1)) { - break; - } - if ((textPtr->currentAnnotPtr->linePtr == line2Ptr) - && (textPtr->currentAnnotPtr->ch >= ch2)) { - break; - } - if (line2 > (line1+1)) { - int currentLine; - - currentLine = TkBTreeLineIndex(textPtr->currentAnnotPtr->linePtr); - if ((currentLine <= line1) || (currentLine >= line2)) { - break; - } - } - TkTextUnpickCurrent(textPtr); - } - - /* - * Tell the display what's about to happen so it can discard - * obsolete display information, then do the deletion. Also, - * check to see if textPtr->topLinePtr is in the range of - * characters deleted. If so, call the display module to reset - * it after doing the deletion. - */ - - topLine = TkBTreeLineIndex(textPtr->topLinePtr); - TkTextLinesChanged(textPtr, line1, line2); - TkBTreeDeleteChars(textPtr->tree, line1Ptr, ch1, line2Ptr, ch2); - if ((topLine >= line1) && (topLine <= line2)) { - numLines = TkBTreeNumLines(textPtr->tree); - TkTextSetView(textPtr, line1, 0); - } - - /* - * Invalidate any selection retrievals in progress. - */ - - textPtr->selOffset = -1; -} - -/* - *---------------------------------------------------------------------- - * - * TextFetchSelection -- - * - * This procedure is called back by Tk when the selection is - * requested by someone. It returns part or all of the selection - * in a buffer provided by the caller. - * - * Results: - * The return value is the number of non-NULL bytes stored - * at buffer. Buffer is filled (or partially filled) with a - * NULL-terminated string containing part or all of the selection, - * as given by offset and maxBytes. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TextFetchSelection(clientData, offset, buffer, maxBytes) - ClientData clientData; /* Information about text widget. */ - int offset; /* Offset within selection of first - * character to be returned. */ - char *buffer; /* Location in which to place - * selection. */ - int maxBytes; /* Maximum number of bytes to place - * at buffer, not including terminating - * NULL character. */ -{ - register TkText *textPtr = (TkText *) clientData; - register TkTextLine *linePtr; - int count, chunkSize; - TkTextSearch search; - - if (!textPtr->exportSelection) { - return -1; - } - - /* - * Find the beginning of the next range of selected text. Note: if - * the selection is being retrieved in multiple pieces (offset != 0) - * and some modification has been made to the text that affects the - * selection (textPtr->selOffset != offset) then reject the selection - * request (make 'em start over again). - */ - - if (offset == 0) { - textPtr->selLine = 0; - textPtr->selCh = 0; - textPtr->selOffset = 0; - } else if (textPtr->selOffset != offset) { - return 0; - } - TkBTreeStartSearch(textPtr->tree, textPtr->selLine, textPtr->selCh+1, - TkBTreeNumLines(textPtr->tree), 0, textPtr->selTagPtr, &search); - if (!TkBTreeCharTagged(search.linePtr, textPtr->selCh, - textPtr->selTagPtr)) { - if (!TkBTreeNextTag(&search)) { - if (offset == 0) { - return -1; - } else { - return 0; - } - } - textPtr->selLine = search.line1; - textPtr->selCh = search.ch1; - } - - /* - * Each iteration through the outer loop below scans one selected range. - * Each iteration through the nested loop scans one line in the - * selected range. - */ - - count = 0; - while (1) { - linePtr = search.linePtr; - - /* - * Find the end of the current range of selected text. - */ - - if (!TkBTreeNextTag(&search)) { - panic("TextFetchSelection couldn't find end of range"); - } - - /* - * Copy information from text lines into the buffer until - * either we run out of space in the buffer or we get to - * the end of this range of text. - */ - - while (1) { - chunkSize = ((linePtr == search.linePtr) ? search.ch1 - : linePtr->numBytes) - textPtr->selCh; - if (chunkSize > maxBytes) { - chunkSize = maxBytes; - } - memcpy((VOID *) buffer, (VOID *) (linePtr->bytes + textPtr->selCh), - chunkSize); - buffer += chunkSize; - maxBytes -= chunkSize; - count += chunkSize; - textPtr->selOffset += chunkSize; - if (maxBytes == 0) { - textPtr->selCh += chunkSize; - goto done; - } - if (linePtr == search.linePtr) { - break; - } - textPtr->selCh = 0; - textPtr->selLine++; - linePtr = TkBTreeNextLine(linePtr); - } - - /* - * Find the beginning of the next range of selected text. - */ - - if (!TkBTreeNextTag(&search)) { - break; - } - textPtr->selLine = search.line1; - textPtr->selCh = search.ch1; - } - - done: - *buffer = 0; - return count; -} - -/* - *---------------------------------------------------------------------- - * - * TkTextLostSelection -- - * - * This procedure is called back by Tk when the selection is - * grabbed away from a text widget. - * - * Results: - * None. - * - * Side effects: - * The "sel" tag is cleared from the window. - * - *---------------------------------------------------------------------- - */ - -void -TkTextLostSelection(clientData) - ClientData clientData; /* Information about text widget. */ -{ - register TkText *textPtr = (TkText *) clientData; - - if (!textPtr->exportSelection) { - return; - } - - /* - * Just remove the "sel" tag from everything in the widget. - */ - - TkTextRedrawTag(textPtr, 0, 0, TkBTreeNumLines(textPtr->tree), - 0, textPtr->selTagPtr, 1); - TkBTreeTag(textPtr->tree, 0, 0, TkBTreeNumLines(textPtr->tree), - 0, textPtr->selTagPtr, 0); - textPtr->flags &= ~GOT_SELECTION; -} - -/* - *-------------------------------------------------------------- - * - * TextMarkCmd -- - * - * This procedure is invoked to process the "mark" options of - * the widget command for text widgets. See the user documentation - * for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *-------------------------------------------------------------- - */ - -static int -TextMarkCmd(textPtr, interp, argc, argv) - register TkText *textPtr; /* Information about text widget. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. Someone else has already - * parsed this command enough to know that - * argv[1] is "mark". */ -{ - int length, line, ch, i; - char c; - Tcl_HashEntry *hPtr; - TkAnnotation *markPtr; - Tcl_HashSearch search; - - if (argc < 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " mark option ?arg arg ...?\"", (char *) NULL); - return TCL_ERROR; - } - c = argv[2][0]; - length = strlen(argv[2]); - if ((c == 'n') && (strncmp(argv[2], "names", length) == 0)) { - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " mark names\"", (char *) NULL); - return TCL_ERROR; - } - for (hPtr = Tcl_FirstHashEntry(&textPtr->markTable, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - Tcl_AppendElement(interp, - Tcl_GetHashKey(&textPtr->markTable, hPtr)); - } - } else if ((c == 's') && (strncmp(argv[2], "set", length) == 0)) { - if (argc != 5) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " mark set markName index\"", (char *) NULL); - return TCL_ERROR; - } - if (TkTextGetIndex(interp, textPtr, argv[4], &line, &ch) != TCL_OK) { - return TCL_ERROR; - } - TkTextSetMark(textPtr, argv[3], line, ch); - } else if ((c == 'u') && (strncmp(argv[2], "unset", length) == 0)) { - if (argc < 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " mark unset markName ?markName ...?\"", - (char *) NULL); - return TCL_ERROR; - } - for (i = 3; i < argc; i++) { - hPtr = Tcl_FindHashEntry(&textPtr->markTable, argv[i]); - if (hPtr != NULL) { - markPtr = (TkAnnotation *) Tcl_GetHashValue(hPtr); - if (markPtr == textPtr->insertAnnotPtr) { - interp->result = "can't delete \"insert\" mark"; - return TCL_ERROR; - } - if (markPtr == textPtr->currentAnnotPtr) { - interp->result = "can't delete \"current\" mark"; - return TCL_ERROR; - } - TkBTreeRemoveAnnotation(markPtr); - Tcl_DeleteHashEntry(hPtr); - ckfree((char *) markPtr); - } - } - } else { - Tcl_AppendResult(interp, "bad mark option \"", argv[2], - "\": must be names, set, or unset", - (char *) NULL); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TkTextSetMark -- - * - * Set a mark to a particular position, creating a new mark if - * one doesn't already exist. - * - * Results: - * The return value is a pointer to the mark that was just set. - * - * Side effects: - * A new mark is created, or an existing mark is moved. - * - *---------------------------------------------------------------------- - */ - -TkAnnotation * -TkTextSetMark(textPtr, name, line, ch) - TkText *textPtr; /* Text widget in which to create mark. */ - char *name; /* Name of mark to set. */ - int line; /* Index of line at which to place mark. */ - int ch; /* Index of character within line at which - * to place mark. */ -{ - Tcl_HashEntry *hPtr; - TkAnnotation *markPtr; - int new; - - hPtr = Tcl_CreateHashEntry(&textPtr->markTable, name, &new); - markPtr = (TkAnnotation *) Tcl_GetHashValue(hPtr); - if (!new) { - /* - * If this is the insertion point that's being moved, be sure - * to force a display update at the old position. - */ - - if (markPtr == textPtr->insertAnnotPtr) { - int oldLine; - - oldLine = TkBTreeLineIndex(markPtr->linePtr); - TkTextLinesChanged(textPtr, oldLine, oldLine); - } - TkBTreeRemoveAnnotation(markPtr); - } else { - markPtr = (TkAnnotation *) ckalloc(sizeof(TkAnnotation)); - markPtr->type = TK_ANNOT_MARK; - markPtr->info.hPtr = hPtr; - Tcl_SetHashValue(hPtr, markPtr); - } - if (line < 0) { - line = 0; - markPtr->ch = 0; - } else if (ch < 0) { - markPtr->ch = 0; - } else { - markPtr->ch = ch; - } - markPtr->linePtr = TkBTreeFindLine(textPtr->tree, line); - if (markPtr->linePtr == NULL) { - line = TkBTreeNumLines(textPtr->tree)-1; - markPtr->linePtr = TkBTreeFindLine(textPtr->tree, line); - markPtr->ch = markPtr->linePtr->numBytes-1; - } else { - if (markPtr->ch >= markPtr->linePtr->numBytes) { - TkTextLine *nextLinePtr; - - nextLinePtr = TkBTreeNextLine(markPtr->linePtr); - if (nextLinePtr == NULL) { - markPtr->ch = markPtr->linePtr->numBytes-1; - } else { - markPtr->linePtr = nextLinePtr; - line++; - markPtr->ch = 0; - } - } - } - TkBTreeAddAnnotation(markPtr); - - /* - * If the mark is the insertion cursor, then update the screen at the - * mark's new location. - */ - - if (markPtr == textPtr->insertAnnotPtr) { - TkTextLinesChanged(textPtr, line, line); - } - return markPtr; -} - -/* - *---------------------------------------------------------------------- - * - * TextBlinkProc -- - * - * This procedure is called as a timer handler to blink the - * insertion cursor off and on. - * - * Results: - * None. - * - * Side effects: - * The cursor gets turned on or off, redisplay gets invoked, - * and this procedure reschedules itself. - * - *---------------------------------------------------------------------- - */ - -static void -TextBlinkProc(clientData) - ClientData clientData; /* Pointer to record describing text. */ -{ - register TkText *textPtr = (TkText *) clientData; - int lineNum; - - if (!(textPtr->flags & GOT_FOCUS) || (textPtr->insertOffTime == 0)) { - return; - } - if (textPtr->flags & INSERT_ON) { - textPtr->flags &= ~INSERT_ON; - textPtr->insertBlinkHandler = Tk_CreateTimerHandler( - textPtr->insertOffTime, TextBlinkProc, (ClientData) textPtr); - } else { - textPtr->flags |= INSERT_ON; - textPtr->insertBlinkHandler = Tk_CreateTimerHandler( - textPtr->insertOnTime, TextBlinkProc, (ClientData) textPtr); - } - lineNum = TkBTreeLineIndex(textPtr->insertAnnotPtr->linePtr); - TkTextLinesChanged(textPtr, lineNum, lineNum); -} - -/* - *-------------------------------------------------------------- - * - * TextScanCmd -- - * - * This procedure is invoked to process the "scan" options of - * the widget command for text widgets. See the user documentation - * for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *-------------------------------------------------------------- - */ - -static int -TextScanCmd(textPtr, interp, argc, argv) - register TkText *textPtr; /* Information about text widget. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. Someone else has already - * parsed this command enough to know that - * argv[1] is "tag". */ -{ - int length, y, line, lastLine; - char c; - - if (argc != 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " scan mark|dragto y\"", (char *) NULL); - return TCL_ERROR; - } - if (Tcl_GetInt(interp, argv[3], &y) != TCL_OK) { - return TCL_ERROR; - } - c = argv[2][0]; - length = strlen(argv[2]); - if ((c == 'd') && (strncmp(argv[2], "dragto", length) == 0)) { - /* - * Amplify the difference between the current y position and the - * mark position to compute how many lines up or down the view - * should shift, then update the mark position to correspond to - * the new view. If we run off the top or bottom of the text, - * reset the mark point so that the current position continues - * to correspond to the edge of the window. This means that the - * picture will start dragging as soon as the mouse reverses - * direction (without this reset, might have to slide mouse a - * long ways back before the picture starts moving again). - */ - - line = textPtr->scanMarkLine + (10*(textPtr->scanMarkY - y)) - / (textPtr->fontPtr->ascent + textPtr->fontPtr->descent); - lastLine = TkBTreeNumLines(textPtr->tree) - 1; - if (line < 0) { - textPtr->scanMarkLine = line = 0; - textPtr->scanMarkY = y; - } else if (line > lastLine) { - textPtr->scanMarkLine = line = lastLine; - textPtr->scanMarkY = y; - } - TkTextSetView(textPtr, line, 0); - } else if ((c == 'm') && (strncmp(argv[2], "mark", length) == 0)) { - textPtr->scanMarkLine = TkBTreeLineIndex(textPtr->topLinePtr); - textPtr->scanMarkY = y; - } else { - Tcl_AppendResult(interp, "bad scan option \"", argv[2], - "\": must be mark or dragto", (char *) NULL); - return TCL_ERROR; - } - return TCL_OK; -} diff --git a/tk3.6/tkText.h b/tk3.6/tkText.h deleted file mode 100644 index b6e6ca4..0000000 --- a/tk3.6/tkText.h +++ /dev/null @@ -1,431 +0,0 @@ -/* - * tkText.h -- - * - * Declarations shared among the files that implement text - * widgets. - * - * 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/wish/RCS/tkText.h,v 1.16 93/11/01 15:05:32 ouster Exp $ SPRITE (Berkeley) - */ - -#ifndef _TKTEXT -#define _TKTEXT - -#ifndef _TK -#include "tk.h" -#endif - -/* - * Opaque types for structures whose guts are only needed by a single - * file: - */ - -typedef struct TkTextBTree *TkTextBTree; - -/* - * The data structure below defines a single line of text (from newline - * to newline, not necessarily what appears on one line of the screen). - */ - -typedef struct TkTextLine { - struct Node *parentPtr; /* Pointer to parent node containing - * line. */ - struct TkTextLine *nextPtr; /* Next in linked list of lines with - * same parent node in B-tree. NULL - * means end of list. */ - struct TkAnnotation *annotPtr; /* First in list of annotations for - * this line. */ - int numBytes; /* Number of bytes in line, including - * newline but not terminating NULL. */ - char bytes[4]; /* Contents of line, null-terminated. - * The actual length of the array will - * be as large as needed to hold the - * line. THIS MUST BE THE LAST FIELD - * OF THE STRUCT. */ -} TkTextLine; - -/* - * The structures below are used to describe annotations to the text - * (such as marks and embedded windows). Annotations are placed at - * a given place in the text and then float to keep their position - * as text is inserted and deleted. Each actual annotation - * contains a standard set of fields, plus a type-specific set of - * fields. The types are as follows: - * - * TK_ANNOT_TOGGLE - Marks the beginning or end of a range of - * characters that have a given tag. - * TK_ANNOT_MARK - Holds information about a given "mark" (see - * user doc. for information on marks). - * TK_ANNOT_WINDOW - Holds information on a window embedded in the - * text. Not implemented yet. - */ - -typedef enum {TK_ANNOT_TOGGLE, TK_ANNOT_MARK, TK_ANNOT_WINDOW} TkAnnotType; - -typedef struct TkAnnotation { - TkAnnotType type; /* Type of annotation. */ - TkTextLine *linePtr; /* Pointer to line structure - * containing this annotation. */ - int ch; /* Index of character that annotation - * is attached to (annotation is - * considered to be just before this - * character). */ - struct TkAnnotation *nextPtr; /* Next in list of annotations for - * same line of text, or NULL if - * end of list. */ - union { /* Type-specific information. */ - struct TkTextTag *tagPtr; /* Type == TK_ANNOT_TOGGLE. */ - Tcl_HashEntry *hPtr; /* Type == TK_ANNOT_MARK. */ - } info; -} TkAnnotation; - -/* - * One data structure of the following type is used for each tag that - * is currently being used in a text widget. These structures are kept - * in textPtr->tagTable and referred to in other structures, like - * TkTagToggles. - */ - -typedef struct TkTextTag { - char *name; /* Name of this tag. This field is actually - * a pointer to the key from the entry in - * textPtr->tagTable, so it needn't be freed - * explicitly. */ - int priority; /* Priority of this tag within widget. 0 - * means lowest priority. Exactly one tag - * has each integer value between 0 and - * numTags-1. */ - - /* - * Information for displaying text with this tag. The information - * belows acts as an override on information specified by lower-priority - * tags. If no value is specified, then the next-lower-priority tag - * on the text determins the value. The text widget itself provides - * defaults if no tag specifies an override. - */ - - Tk_3DBorder border; /* Used for drawing background. NULL means - * no value specified here. */ - int borderWidth; /* Width of 3-D border for background. */ - int relief; /* 3-D relief for background. */ - Pixmap bgStipple; /* Stipple bitmap for background. None - * means no value specified here. */ - XColor *fgColor; /* Foreground color for text. NULL means - * no value specified here. */ - XFontStruct *fontPtr; /* Font for displaying text. NULL means - * no value specified here. */ - Pixmap fgStipple; /* Stipple bitmap for text and other - * foreground stuff. None means no value - * specified here.*/ - int underline; /* Non-zero means draw underline underneath - * text. */ -} TkTextTag; - -/* - * The macro below determines whether or not a particular tag affects - * the way information is displayed on the screen. It's used, for - * example, to determine when to redisplay in response to tag changes. - */ - -#define TK_TAG_AFFECTS_DISPLAY(tagPtr) \ - (((tagPtr)->border != NULL) || ((tagPtr)->bgStipple != None) \ - || ((tagPtr)->fgColor != NULL) || ((tagPtr)->fontPtr != NULL) \ - || ((tagPtr)->fgStipple != None) || ((tagPtr)->underline)) - -/* - * The data structure below is used for searching a B-tree for transitions - * on a single tag (or for all tag transitions). No code outside of - * tkTextBTree.c should ever modify any of the fields in these structures, - * but it's OK to use them for read-only information. - */ - -typedef struct TkTextSearch { - TkTextBTree tree; /* Tree being searched. */ - int line1, ch1; /* Position of last tag returned - * by TkBTreeNextTag. */ - int line2, ch2; /* Stop search after all tags at this - * character position have been - * processed. */ - TkTextTag *tagPtr; /* Tag to search for (or tag found, if - * allTags is non-zero). */ - int allTags; /* Non-zero means ignore tag check: - * search for transitions on all - * tags. */ - TkTextLine *linePtr; /* Line currently being searched. NULL - * means search is over. */ - TkAnnotation *annotPtr; /* Pointer to next annotation to - * consider. NULL means no annotations - * left in current line; must go on - * to next line. */ -} TkTextSearch; - -/* - * A data structure of the following type is kept for each text widget that - * currently exists for this process: - */ - -typedef struct TkText { - Tk_Window tkwin; /* Window that embodies the text. NULL - * means that the window has been destroyed - * but the data structures haven't yet been - * cleaned up.*/ - Display *display; /* Display for widget. Needed, among other - * things, to allow resources to be freed - * even after tkwin has gone away. */ - Tcl_Interp *interp; /* Interpreter associated with widget. Used - * to delete widget command. */ - TkTextBTree tree; /* B-tree representation of text and tags for - * widget. */ - Tcl_HashTable tagTable; /* Hash table that maps from tag names to - * pointers to TkTextTag structures. */ - int numTags; /* Number of tags currently defined for - * widget; needed to keep track of - * priorities. */ - Tcl_HashTable markTable; /* Hash table that maps from mark names to - * pointer to TkAnnotation structures of - * type TK_ANNOT_MARK. */ - Tk_Uid state; /* Normal or disabled. Text is read-only - * when disabled. */ - - /* - * Default information for displaying (may be overridden by tags - * applied to ranges of characters). - */ - - Tk_3DBorder border; /* Structure used to draw 3-D border and - * default background. */ - int borderWidth; /* Width of 3-D border to draw around entire - * widget. */ - int padX, padY; /* Padding between text and window border. */ - int relief; /* 3-d effect for border around entire - * widget: TK_RELIEF_RAISED etc. */ - Cursor cursor; /* Current cursor for window, or None. */ - XColor *fgColor; /* Default foreground color for text. */ - XFontStruct *fontPtr; /* Default font for displaying text. */ - - /* - * Additional information used for displaying: - */ - - Tk_Uid wrapMode; /* How to handle wrap-around. Must be - * tkTextCharUid, tkTextNoneUid, or - * tkTextWordUid. */ - int width, height; /* Desired dimensions for window, measured - * in characters. */ - int setGrid; /* Non-zero means pass gridding information - * to window manager. */ - int prevWidth, prevHeight; /* Last known dimensions of window; used to - * detect changes in size. */ - TkTextLine *topLinePtr; /* Text line that is supposed to be displayed - * at top of the window: set only by - * tkTextDisp.c. */ - struct DInfo *dInfoPtr; /* Additional information maintained by - * tkTextDisp.c. */ - /* - * Information related to selection. - */ - - TkTextTag *selTagPtr; /* Pointer to "sel" tag. Used to tell when - * a new selection has been made. */ - Tk_3DBorder selBorder; /* Border and background for selected - * characters. This is a copy of information - * in *cursorTagPtr, so it shouldn't be - * explicitly freed. */ - int selBorderWidth; /* Width of border around selection. */ - XColor *selFgColorPtr; /* Foreground color for selected text. - * This is a copy of information in - * *cursorTagPtr, so it shouldn't be - * explicitly freed. */ - int exportSelection; /* Non-zero means tie "sel" tag to X - * selection. */ - int selLine, selCh; /* Used during multi-pass selection retrievals. - * These identify the next character to be - * returned from the selection. */ - int selOffset; /* Offset in selection corresponding to - * selLine and selCh. -1 means neither - * this information nor selLine or selCh - * is of any use. */ - - /* - * Information related to insertion cursor: - */ - - TkAnnotation *insertAnnotPtr; - /* Always points to annotation for "insert" - * mark. */ - Tk_3DBorder insertBorder; /* Used to draw vertical bar for insertion - * cursor. */ - int insertWidth; /* Total width of insert cursor. */ - int insertBorderWidth; /* Width of 3-D border around insert cursor. */ - int insertOnTime; /* Number of milliseconds cursor should spend - * in "on" state for each blink. */ - int insertOffTime; /* Number of milliseconds cursor should spend - * in "off" state for each blink. */ - Tk_TimerToken insertBlinkHandler; - /* Timer handler used to blink cursor on and - * off. */ - - /* - * Information used for event bindings associated with tags: - */ - - Tk_BindingTable bindingTable; - /* Table of all bindings currently defined - * for this widget. NULL means that no - * bindings exist, so the table hasn't been - * created. Each "object" used for this - * table is the address of a tag. */ - TkAnnotation *currentAnnotPtr; - /* Pointer to annotation for "current" mark, - * or NULL if none. */ - XEvent pickEvent; /* The event from which the current character - * was chosen. Must be saved so that we - * can repick after insertions and deletions. */ - - /* - * Miscellaneous additional information: - */ - - char *yScrollCmd; /* Prefix of command to issue to update - * vertical scrollbar when view changes. */ - int scanMarkLine; /* Line that was at the top of the window - * when the scan started. */ - int scanMarkY; /* Y-position of mouse at time scan started. */ - int flags; /* Miscellaneous flags; see below for - * definitions. */ -} TkText; - -/* - * Flag values for TkText records: - * - * GOT_SELECTION: Non-zero means we've already claimed the - * selection. - * INSERT_ON: Non-zero means insertion cursor should be - * displayed on screen. - * GOT_FOCUS: Non-zero means this window has the input - * focus. - * BUTTON_DOWN: 1 means that a mouse button is currently - * down; this is used to implement grabs - * for the duration of button presses. - * IN_CURRENT: 1 means that an EnterNotify event has been - * delivered to the current character with - * no matching LeaveNotify event yet. - * UPDATE_SCROLLBARS: Non-zero means scrollbar(s) should be updated - * during next redisplay operation. - */ - -#define GOT_SELECTION 1 -#define INSERT_ON 2 -#define GOT_FOCUS 4 -#define BUTTON_DOWN 8 -#define IN_CURRENT 0x10 -#define UPDATE_SCROLLBARS 0x20 - -/* - * The constant below is used to specify a line when what is really - * wanted is the entire text. For now, just use a very big number. - */ - -#define TK_END_OF_TEXT 1000000 - -/* - * Declarations for variables shared among the text-related files: - */ - -extern int tkBTreeDebug; -extern Tk_Uid tkTextCharUid; -extern Tk_Uid tkTextDisabledUid; -extern Tk_Uid tkTextNoneUid; -extern Tk_Uid tkTextNormalUid; -extern Tk_Uid tkTextWordUid; - -/* - * Declarations for procedures that are used by the text-related files - * but shouldn't be used anywhere else in Tk (or by Tk clients): - */ - -extern void TkBTreeAddAnnotation _ANSI_ARGS_(( - TkAnnotation *annotPtr)); -extern int TkBTreeCharTagged _ANSI_ARGS_((TkTextLine *linePtr, - int index, TkTextTag *tagPtr)); -extern void TkBTreeCheck _ANSI_ARGS_((TkTextBTree tree)); -extern TkTextBTree TkBTreeCreate _ANSI_ARGS_((void)); -extern void TkBTreeDestroy _ANSI_ARGS_((TkTextBTree tree)); -extern void TkBTreeDeleteChars _ANSI_ARGS_((TkTextBTree tree, - TkTextLine *line1Ptr, int ch1, - TkTextLine *line2Ptr, int ch2)); -extern TkTextLine * TkBTreeFindLine _ANSI_ARGS_((TkTextBTree tree, - int line)); -extern TkTextTag ** TkBTreeGetTags _ANSI_ARGS_((TkTextBTree tree, - TkTextLine *linePtr, int ch, int *numTagsPtr)); -extern void TkBTreeInsertChars _ANSI_ARGS_((TkTextBTree tree, - TkTextLine *linePtr, int ch, char *string)); -extern int TkBTreeLineIndex _ANSI_ARGS_((TkTextLine *linePtr)); -extern TkTextLine * TkBTreeNextLine _ANSI_ARGS_((TkTextLine *linePtr)); -extern int TkBTreeNextTag _ANSI_ARGS_((TkTextSearch *searchPtr)); -extern int TkBTreeNumLines _ANSI_ARGS_((TkTextBTree tree)); -extern void TkBTreeRemoveAnnotation _ANSI_ARGS_(( - TkAnnotation *annotPtr)); -extern void TkBTreeStartSearch _ANSI_ARGS_((TkTextBTree tree, - int line1, int ch1, int line2, int ch2, - TkTextTag *tagPtr, TkTextSearch *searchPtr)); -extern void TkBTreeTag _ANSI_ARGS_((TkTextBTree tree, int line1, - int ch1, int line2, int ch2, TkTextTag *tagPtr, - int add)); -extern void TkTextBindProc _ANSI_ARGS_((ClientData clientData, - XEvent *eventPtr)); -extern TkTextLine * TkTextCharAtLoc _ANSI_ARGS_((TkText *textPtr, - int x, int y, int *chPtr)); -extern void TkTextCreateDInfo _ANSI_ARGS_((TkText *textPtr)); -extern TkTextTag * TkTextCreateTag _ANSI_ARGS_((TkText *textPtr, - char *tagName)); -extern void TkTextFreeDInfo _ANSI_ARGS_((TkText *textPtr)); -extern void TkTextFreeTag _ANSI_ARGS_((TkText *textPtr, - TkTextTag *tagPtr)); -extern int TkTextGetIndex _ANSI_ARGS_((Tcl_Interp *interp, - TkText *textPtr, char *string, int *lineIndexPtr, - int *chPtr)); -extern void TkTextLinesChanged _ANSI_ARGS_((TkText *textPtr, - int first, int last)); -extern void TkTextLostSelection _ANSI_ARGS_(( - ClientData clientData)); -extern void TkTextPickCurrent _ANSI_ARGS_((TkText *textPtr, - XEvent *eventPtr)); -extern void TkTextPrintIndex _ANSI_ARGS_((int line, int ch, - char *string)); -extern TkTextLine * TkTextRoundIndex _ANSI_ARGS_((TkText *textPtr, - int *lineIndexPtr, int *chPtr)); -extern void TkTextRedrawRegion _ANSI_ARGS_((TkText *textPtr, - int x, int y, int width, int height)); -extern void TkTextRedrawTag _ANSI_ARGS_((TkText *textPtr, - int line1, int ch1, int line2, int ch2, - TkTextTag *tagPtr, int withTag)); -extern void TkTextRelayoutWindow _ANSI_ARGS_((TkText *textPtr)); -extern TkAnnotation * TkTextSetMark _ANSI_ARGS_((TkText *textPtr, char *name, - int line, int ch)); -extern void TkTextSetView _ANSI_ARGS_((TkText *textPtr, - int line, int pickPlace)); -extern int TkTextTagCmd _ANSI_ARGS_((TkText *textPtr, - Tcl_Interp *interp, int argc, char **argv)); -extern void TkTextUnpickCurrent _ANSI_ARGS_((TkText *textPtr)); - -#endif /* _TKTEXT */ diff --git a/tk3.6/tkTextBTree.c b/tk3.6/tkTextBTree.c deleted file mode 100644 index e2e7999..0000000 --- a/tk3.6/tkTextBTree.c +++ /dev/null @@ -1,2383 +0,0 @@ -/* - * tkTextBTree.c -- - * - * This file contains code that manages the B-tree representation - * of text for Tk's text widget. The B-tree holds both the text - * and tag information related to the text. - * - * 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. - */ - -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkTextBTree.c,v 1.19 93/10/11 16:55:21 ouster Exp $ SPRITE (Berkeley)"; -#endif /* not lint */ - -#include "tkInt.h" -#include "tkConfig.h" -#include "tkText.h" - - -/* - * The data structure below keeps summary information about one tag as part - * of the tag information in a node. - */ - -typedef struct Summary { - TkTextTag *tagPtr; /* Handle for tag. */ - int toggleCount; /* Number of transitions into or - * out of this tag that occur in - * the subtree rooted at this node. */ - struct Summary *nextPtr; /* Next in list of all tags for same - * node, or NULL if at end of list. */ -} Summary; - -/* - * The data structure below defines a node in the B-tree representing - * all of the lines in a text widget. - */ - -typedef struct Node { - struct Node *parentPtr; /* Pointer to parent node, or NULL if - * this is the root. */ - struct Node *nextPtr; /* Next in list of children of the - * same parent node, or NULL for end - * of list. */ - Summary *summaryPtr; /* First in malloc-ed list of info - * about tags in this subtree (NULL if - * no tag info in the subtree). */ - int level; /* Level of this node in the B-tree. - * 0 refers to the bottom of the tree - * (children are lines, not nodes). */ - union { /* First in linked list of children. */ - struct Node *nodePtr; /* Used if level > 0. */ - TkTextLine *linePtr; /* Used if level == 0. */ - } children; - int numChildren; /* Number of children of this node. */ - int numLines; /* Total number of lines (leaves) in - * the subtree rooted here. */ -} Node; - -/* - * Upper and lower bounds on how many children a node may have: - * rebalance when either of these limits is exceeded. MAX_CHILDREN - * should be twice MIN_CHILDREN and MIN_CHILDREN must be >= 2. - */ - -#define MAX_CHILDREN 12 -#define MIN_CHILDREN 6 - -/* - * The data structure below defines an entire B-tree. - */ - -typedef struct BTree { - Node *rootPtr; /* Pointer to root of B-tree. */ -} BTree; - -/* - * The structure below is used to pass information between - * TkBTreeGetTags and IncCount: - */ - -typedef struct TagInfo { - int numTags; /* Number of tags for which there - * is currently information in - * tags and counts. */ - int arraySize; /* Number of entries allocated for - * tags and counts. */ - TkTextTag **tagPtrs; /* Array of tags seen so far. - * Malloc-ed. */ - int *counts; /* Toggle count (so far) for each - * entry in tags. Malloc-ed. */ -} TagInfo; - -/* - * Macro to compute the space needed for a line that holds n non-null - * characters: - */ - -#define LINE_SIZE(n) ((unsigned) (sizeof(TkTextLine) - 3 + (n))) - -/* - * Variable that indicates whether to enable consistency checks for - * debugging. - */ - -int tkBTreeDebug = 0; - -/* - * Forward declarations for procedures defined in this file: - */ - -static void AddToggleToLine _ANSI_ARGS_((TkTextLine *linePtr, - int index, TkTextTag *tagPtr)); -static void ChangeNodeToggleCount _ANSI_ARGS_((Node *nodePtr, - TkTextTag *tagPtr, int delta)); -static void CheckNodeConsistency _ANSI_ARGS_((Node *nodePtr)); -static void DeleteSummaries _ANSI_ARGS_((Summary *tagPtr)); -static void DestroyNode _ANSI_ARGS_((Node *nodePtr)); -static void IncCount _ANSI_ARGS_((TkTextTag *tagPtr, int inc, - TagInfo *tagInfoPtr)); -static void Rebalance _ANSI_ARGS_((BTree *treePtr, Node *nodePtr)); -static void RecomputeNodeCounts _ANSI_ARGS_((Node *nodePtr)); - -/* - *---------------------------------------------------------------------- - * - * TkBTreeCreate -- - * - * This procedure is called to create a new text B-tree. - * - * Results: - * The return value is a pointer to a new B-tree containing - * one line with nothing but a newline character. - * - * Side effects: - * Memory is allocated and initialized. - * - *---------------------------------------------------------------------- - */ - -TkTextBTree -TkBTreeCreate() -{ - register BTree *treePtr; - register Node *rootPtr; - register TkTextLine *linePtr; - - rootPtr = (Node *) ckalloc(sizeof(Node)); - linePtr = (TkTextLine *) ckalloc(LINE_SIZE(1)); - rootPtr->parentPtr = NULL; - rootPtr->nextPtr = NULL; - rootPtr->summaryPtr = NULL; - rootPtr->level = 0; - rootPtr->children.linePtr = linePtr; - rootPtr->numChildren = 1; - rootPtr->numLines = 1; - - linePtr->parentPtr = rootPtr; - linePtr->nextPtr = NULL; - linePtr->annotPtr = NULL; - linePtr->numBytes = 1; - linePtr->bytes[0] = '\n'; - linePtr->bytes[1] = 0; - - treePtr = (BTree *) ckalloc(sizeof(BTree)); - treePtr->rootPtr = rootPtr; - - return (TkTextBTree) treePtr; -} - -/* - *---------------------------------------------------------------------- - * - * TkBTreeDestroy -- - * - * Delete a B-tree, recycling all of the storage it contains. - * - * Results: - * The tree given by treePtr is deleted. TreePtr should never - * again be used. - * - * Side effects: - * Memory is freed. - * - *---------------------------------------------------------------------- - */ - -void -TkBTreeDestroy(tree) - TkTextBTree tree; /* Pointer to tree to delete. */ -{ - BTree *treePtr = (BTree *) tree; - - DestroyNode(treePtr->rootPtr); - ckfree((char *) treePtr); -} - -/* - *---------------------------------------------------------------------- - * - * DestroyNode -- - * - * This is a recursive utility procedure used during the deletion - * of a B-tree. - * - * Results: - * None. - * - * Side effects: - * All the storage for nodePtr and its descendants is freed. - * - *---------------------------------------------------------------------- - */ - -static void -DestroyNode(nodePtr) - register Node *nodePtr; -{ - if (nodePtr->level == 0) { - register TkTextLine *curPtr, *nextLinePtr; - register TkAnnotation *annotPtr, *nextAnnotPtr; - - for (curPtr = nodePtr->children.linePtr; curPtr != NULL; ) { - nextLinePtr = curPtr->nextPtr; - for (annotPtr = curPtr->annotPtr; annotPtr != NULL; ) { - nextAnnotPtr = annotPtr->nextPtr; - if (annotPtr->type == TK_ANNOT_TOGGLE) { - ckfree((char *) annotPtr); - } - annotPtr = nextAnnotPtr; - } - ckfree((char *) curPtr); - curPtr = nextLinePtr; - } - } else { - register Node *curPtr, *nextPtr; - - for (curPtr = nodePtr->children.nodePtr; curPtr != NULL; ) { - nextPtr = curPtr->nextPtr; - DestroyNode(curPtr); - curPtr = nextPtr; - } - } - DeleteSummaries(nodePtr->summaryPtr); - ckfree((char *) nodePtr); -} - -/* - *---------------------------------------------------------------------- - * - * DeleteSummaries -- - * - * Free up all of the memory in a list of tag summaries associated - * with a node. - * - * Results: - * None. - * - * Side effects: - * Storage is released. - * - *---------------------------------------------------------------------- - */ - -static void -DeleteSummaries(summaryPtr) - register Summary *summaryPtr; /* First in list of node's tag - * summaries. */ -{ - register Summary *nextPtr; - while (summaryPtr != NULL) { - nextPtr = summaryPtr->nextPtr; - ckfree((char *) summaryPtr); - summaryPtr = nextPtr; - } -} - -/* - *---------------------------------------------------------------------- - * - * TkBTreeInsertChars -- - * - * Insert characters at a given position in a B-tree. - * - * Results: - * None. - * - * Side effects: - * NumBytes characters are added to the B-tree at the given - * character position. This can cause the structure of the - * B-tree to change. - * - *---------------------------------------------------------------------- - */ - -void -TkBTreeInsertChars(tree, linePtr, ch, string) - TkTextBTree tree; /* B-tree in which to insert. */ - register TkTextLine *linePtr; /* Pointer to line in which to - * insert. */ - int ch; /* Index of character before which - * to insert. Must not be after - * last character in line.*/ - char *string; /* Pointer to bytes to insert (may - * contain newlines, must be null- - * terminated). */ -{ - BTree *treePtr = (BTree *) tree; - register Node *nodePtr; - register TkAnnotation *annotPtr; - TkTextLine *prevPtr; - int newChunkLength; /* # chars in current line being - * inserted. */ - register char *eol; /* Pointer to last character in - * current line being inserted. */ - int changeToLineCount; /* Counts change to total number of - * lines in file. */ - TkAnnotation *afterPtr; /* List of annotations that occur - * at or after the insertion point - * in the line of the insertion. */ - int prefixLength, suffixLength, totalLength; - register TkTextLine *newPtr; - - /* - * Find the line just before the one where the insertion will occur - * but with the same parent node (if there is one). This is needed - * so we can replace the insertion line with a new one. Remove this - * line from the list for its parent, since it's going to be discarded - * when we're all done). - */ - - nodePtr = linePtr->parentPtr; - prevPtr = nodePtr->children.linePtr; - if (prevPtr == linePtr) { - prevPtr = NULL; - nodePtr->children.linePtr = linePtr->nextPtr; - } else { - for ( ; prevPtr->nextPtr != linePtr; prevPtr = prevPtr->nextPtr) { - /* Empty loop body. */ - } - prevPtr->nextPtr = linePtr->nextPtr; - } - - /* - * Break up the annotations for the insertion line into two pieces: - * those before the insertion point, and those at or after the insertion - * point. - */ - - afterPtr = NULL; - if ((linePtr->annotPtr != NULL) && (linePtr->annotPtr->ch >= ch)) { - afterPtr = linePtr->annotPtr; - linePtr->annotPtr = NULL; - } else { - for (annotPtr = linePtr->annotPtr; annotPtr != NULL; - annotPtr = annotPtr->nextPtr) { - if ((annotPtr->nextPtr != NULL) - && (annotPtr->nextPtr->ch >= ch)) { - afterPtr = annotPtr->nextPtr; - annotPtr->nextPtr = NULL; - break; - } - } - } - - /* - * Chop the string up into lines and insert each line individually. - */ - - changeToLineCount = -1; - prefixLength = ch; - while (1) { - for (newChunkLength = 0, eol = string; *eol != 0; eol++) { - newChunkLength++; - if (*eol == '\n') { - break; - } - } - - /* - * Create a new line consisting of up to three parts: a prefix - * from linePtr, some material from string, and a suffix from - * linePtr. - */ - - if ((newChunkLength == 0) || (*eol != '\n')) { - suffixLength = linePtr->numBytes - ch; - } else { - suffixLength = 0; - } - totalLength = prefixLength + newChunkLength + suffixLength; - newPtr = (TkTextLine *) ckalloc(LINE_SIZE(totalLength)); - newPtr->parentPtr = nodePtr; - if (prevPtr == NULL) { - newPtr->nextPtr = nodePtr->children.linePtr; - nodePtr->children.linePtr = newPtr; - } else { - newPtr->nextPtr = prevPtr->nextPtr; - prevPtr->nextPtr = newPtr; - } - if (linePtr->annotPtr != NULL) { - newPtr->annotPtr = linePtr->annotPtr; - for (annotPtr = newPtr->annotPtr; annotPtr != NULL; - annotPtr = annotPtr->nextPtr) { - annotPtr->linePtr = newPtr; - } - linePtr->annotPtr = NULL; - } else { - newPtr->annotPtr = NULL; - } - newPtr->numBytes = totalLength; - if (prefixLength != 0) { - memcpy((VOID *) newPtr->bytes, (VOID *) linePtr->bytes, - prefixLength); - } - if (newChunkLength != 0) { - memcpy((VOID *) (newPtr->bytes + prefixLength), (VOID *) string, - newChunkLength); - } - if (suffixLength != 0) { - memcpy((VOID *) (newPtr->bytes + prefixLength + newChunkLength), - (VOID *) (linePtr->bytes + ch), suffixLength); - } - newPtr->bytes[totalLength] = 0; - changeToLineCount += 1; - - /* - * Quit after the suffix has been output (there is always at least - * one character of suffix: the newline). Before jumping out of the - * loop, put back the annotations that pertain to the suffix. - * Careful! If no newlines were inserted, there could already be - * annotations at the beginning of the line; add back to the end. - */ - - if (suffixLength != 0) { - if (newPtr->annotPtr == NULL) { - newPtr->annotPtr = afterPtr; - } else { - for (annotPtr = newPtr->annotPtr; annotPtr->nextPtr != NULL; - annotPtr = annotPtr->nextPtr) { - /* Empty loop body. */ - } - annotPtr->nextPtr = afterPtr; - } - for (annotPtr = afterPtr; annotPtr != NULL; - annotPtr = annotPtr->nextPtr) { - annotPtr->linePtr = newPtr; - annotPtr->ch += prefixLength+newChunkLength-ch; - } - break; - } - - /* - * Advance to insert the next line chunk. - */ - - string += newChunkLength; - prefixLength = 0; - prevPtr = newPtr; - } - - /* - * Increment the line counts in all the parent nodes of the insertion - * point, then rebalance the tree if necessary. - */ - - for ( ; nodePtr != NULL; nodePtr = nodePtr->parentPtr) { - nodePtr->numLines += changeToLineCount; - } - nodePtr = linePtr->parentPtr; - nodePtr->numChildren += changeToLineCount; - if (nodePtr->numChildren > MAX_CHILDREN) { - Rebalance(treePtr, nodePtr); - } - - ckfree((char *) linePtr); - if (tkBTreeDebug) { - TkBTreeCheck(tree); - } -} - -/* - *---------------------------------------------------------------------- - * - * TkBTreeDeleteChars -- - * - * Delete a range of characters from a B-tree. - * - * Results: - * None. - * - * Side effects: - * Information is deleted from the B-tree. This can cause the - * internal structure of the B-tree to change. Note: the two - * lines given by line1Ptr and line2Ptr will be replaced with - * a single line containing the undeleted parts of the original - * lines. This could potentially result in an empty line; - * normally the caller should adjust the deletion range to prevent - * this sort of behavior. - * - *---------------------------------------------------------------------- - */ - -void -TkBTreeDeleteChars(tree, line1Ptr, ch1, line2Ptr, ch2) - TkTextBTree tree; /* B-tree in which to delete. */ - register TkTextLine *line1Ptr; /* Line containing first character - * to delete. */ - int ch1; /* Index within linePtr1 of first - * character to delete. */ - register TkTextLine *line2Ptr; /* Line containing character just - * after last one to delete. */ - int ch2; /* Index within linePtr2 of character - * just after last one to delete. */ -{ - BTree *treePtr = (BTree *) tree; - TkTextLine *linePtr, *nextPtr, *prevLinePtr; - Node *nodePtr, *parentPtr, *nextNodePtr; - TkAnnotation *annotPtr, *annotPtr2; - int ch; - int linesDeleted; /* Counts lines deleted from current - * level-0 node. */ - - /* - * Work through the tree deleting all of the lines between line1Ptr - * and line2Ptr (but don't delete line1Ptr or line2Ptr yet). Also - * delete any nodes in the B-tree that become empty because of - * this process. - */ - - linePtr = line1Ptr->nextPtr; - nodePtr = line1Ptr->parentPtr; - if (line1Ptr == line2Ptr) { - goto middleLinesDeleted; - } - while (1) { - - /* - * Delete all relevant lines within the same level-0 node. - */ - - linesDeleted = 0; - while ((linePtr != line2Ptr) && (linePtr != NULL)) { - /* - * Move any annotations in this line to the end of the - * deletion range. If both the starting and ending toggle - * for a tagged range get moved, they'll cancel each other - * automatically and be dropped, which is the right behavior. - */ - - for (annotPtr = linePtr->annotPtr, linePtr->annotPtr = NULL; - annotPtr != NULL; annotPtr = annotPtr2) { - if (annotPtr->type == TK_ANNOT_TOGGLE) { - AddToggleToLine(line2Ptr, ch2, annotPtr->info.tagPtr); - ChangeNodeToggleCount(nodePtr, annotPtr->info.tagPtr, -1); - annotPtr2 = annotPtr->nextPtr; - ckfree((char *) annotPtr); - } else { - annotPtr2 = annotPtr->nextPtr; - annotPtr->linePtr = line2Ptr; - annotPtr->ch = ch2; - TkBTreeAddAnnotation(annotPtr); - } - } - nextPtr = linePtr->nextPtr; - ckfree((char *) linePtr); - linesDeleted++; - linePtr = nextPtr; - } - if (nodePtr == line1Ptr->parentPtr) { - line1Ptr->nextPtr = linePtr; - } else { - nodePtr->children.linePtr = linePtr; - } - for (parentPtr = nodePtr; parentPtr != NULL; - parentPtr = parentPtr->parentPtr) { - parentPtr->numLines -= linesDeleted; - } - nodePtr->numChildren -= linesDeleted; - if (linePtr == line2Ptr) { - break; - } - - /* - * Find the next level-0 node to visit, and its first line (but - * remember the current node so we can come back to delete it if - * it's empty). - */ - - nextNodePtr = nodePtr; - while (nextNodePtr->nextPtr == NULL) { - nextNodePtr = nextNodePtr->parentPtr; - } - nextNodePtr = nextNodePtr->nextPtr; - while (nextNodePtr->level > 0) { - nextNodePtr = nextNodePtr->children.nodePtr; - } - linePtr = nextNodePtr->children.linePtr; - - /* - * Now go back to the node we just left and delete it if - * it's empty, along with any of its ancestors that are - * empty. It may seem funny to go back like this, but it's - * simpler to find the next place to visit before modifying - * the tree structure. - */ - - while (nodePtr->numChildren == 0) { - parentPtr = nodePtr->parentPtr; - if (parentPtr->children.nodePtr == nodePtr) { - parentPtr->children.nodePtr = nodePtr->nextPtr; - } else { - Node *prevPtr; - - for (prevPtr = parentPtr->children.nodePtr; - prevPtr->nextPtr != nodePtr; - prevPtr = prevPtr->nextPtr) { - } - prevPtr->nextPtr = nodePtr->nextPtr; - } - parentPtr->numChildren--; - DeleteSummaries(nodePtr->summaryPtr); - ckfree((char *) nodePtr); - nodePtr = parentPtr; - } - nodePtr = nextNodePtr; - } - - /* - * Make a new line that consists of the first part of the first - * line of the deletion range and the last part of the last line - * of the deletion range. - */ - - middleLinesDeleted: - nodePtr = line1Ptr->parentPtr; - linePtr = (TkTextLine *) ckalloc(LINE_SIZE(ch1 + line2Ptr->numBytes - ch2)); - linePtr->parentPtr = nodePtr; - linePtr->nextPtr = line1Ptr->nextPtr; - linePtr->annotPtr = NULL; - linePtr->numBytes = ch1 + line2Ptr->numBytes - ch2; - if (ch1 != 0) { - memcpy((VOID *) linePtr->bytes, (VOID *) line1Ptr->bytes, ch1); - } - strcpy(linePtr->bytes + ch1, line2Ptr->bytes + ch2); - - /* - * Process the annotations for the starting and ending lines. Enter - * a new annotation on linePtr (the joined line) for each of these - * annotations, then delete the originals. The code below is a little - * tricky (e.g. the "break" in the first loop) to handle the case where - * the starting and ending lines are the same. - */ - - for (annotPtr = line1Ptr->annotPtr; annotPtr != NULL; - annotPtr = line1Ptr->annotPtr) { - if (annotPtr->ch <= ch1) { - ch = annotPtr->ch; - } else { - if (line1Ptr == line2Ptr) { - break; - } - ch = ch1; - } - line1Ptr->annotPtr = annotPtr->nextPtr; - if (annotPtr->type == TK_ANNOT_TOGGLE) { - AddToggleToLine(linePtr, ch, annotPtr->info.tagPtr); - ChangeNodeToggleCount(line1Ptr->parentPtr, annotPtr->info.tagPtr, - -1); - ckfree((char *) annotPtr); - } else { - annotPtr->linePtr = linePtr; - annotPtr->ch = ch; - TkBTreeAddAnnotation(annotPtr); - } - } - for (annotPtr = line2Ptr->annotPtr; annotPtr != NULL; - annotPtr = line2Ptr->annotPtr) { - if (annotPtr->ch >= ch2) { - ch = annotPtr->ch - ch2 + ch1; - } else { - ch = ch1; - } - line2Ptr->annotPtr = annotPtr->nextPtr; - if (annotPtr->type == TK_ANNOT_TOGGLE) { - AddToggleToLine(linePtr, ch, annotPtr->info.tagPtr); - ChangeNodeToggleCount(line2Ptr->parentPtr, annotPtr->info.tagPtr, - -1); - ckfree((char *) annotPtr); - } else { - annotPtr->linePtr = linePtr; - annotPtr->ch = ch; - TkBTreeAddAnnotation(annotPtr); - } - } - - /* - * Delete the original starting and stopping lines (don't forget - * that the annotations have already been deleted) and insert the - * new line in place of line1Ptr. - */ - - nodePtr = line1Ptr->parentPtr; - if (nodePtr->children.linePtr == line1Ptr) { - nodePtr->children.linePtr = linePtr; - } else { - for (prevLinePtr = nodePtr->children.linePtr; - prevLinePtr->nextPtr != line1Ptr; - prevLinePtr = prevLinePtr->nextPtr) { - /* Empty loop body. */ - } - prevLinePtr->nextPtr = linePtr; - } - ckfree((char *) line1Ptr); - if (line2Ptr != line1Ptr) { - nodePtr = line2Ptr->parentPtr; - if (nodePtr->children.linePtr == line2Ptr) { - nodePtr->children.linePtr = line2Ptr->nextPtr; - } else { - for (prevLinePtr = nodePtr->children.linePtr; - prevLinePtr->nextPtr != line2Ptr; - prevLinePtr = prevLinePtr->nextPtr) { - /* Empty loop body. */ - } - prevLinePtr->nextPtr = line2Ptr->nextPtr; - } - ckfree((char *) line2Ptr); - for (parentPtr = nodePtr; parentPtr != NULL; - parentPtr = parentPtr->parentPtr) { - parentPtr->numLines--; - } - nodePtr->numChildren--; - } - - /* - * Rebalance the tree, starting from each of the endpoints of the - * deletion range. This code is a tricky, because the act of - * rebalancing the parent of one endpoint can cause the parent of - * the other endpoint to be reallocated. The only thing it's safe - * to hold onto is a pointer to a line. Thus, rebalance line2Ptr's - * parent first, then use linePtr find the second parent to rebalance - * second. - */ - - if (nodePtr != linePtr->parentPtr) { - Rebalance(treePtr, nodePtr); - } - Rebalance(treePtr, linePtr->parentPtr); - if (tkBTreeDebug) { - TkBTreeCheck(tree); - } -} - -/* - *---------------------------------------------------------------------- - * - * TkBTreeTag -- - * - * Turn a given tag on or off for a given range of characters in - * a B-tree of text. - * - * Results: - * None. - * - * Side effects: - * The given tag is added to the given range of characters - * in the tree or removed from all those characters, depending - * on the "add" argument. - * - *---------------------------------------------------------------------- - */ - -void -TkBTreeTag(tree, line1, ch1, line2, ch2, tagPtr, add) - TkTextBTree tree; /* B-tree in which to add tag - * information. */ - int line1, ch1; /* Position of first character to - * tag. */ - int line2, ch2; /* Position of character just after - * last one to tag. */ - TkTextTag *tagPtr; /* Tag to associate with the range - * of characters. */ - int add; /* One means add tag to the given - * range of characters; zero means - * remove the tag from the range. */ -{ - BTree *treePtr = (BTree *) tree; - register TkTextLine *line1Ptr, *line2Ptr; - TkTextSearch search; - int oldState; - - /* - * Find the lines containing the first and last characters to be tagged, - * and adjust the starting and stopping locations if they don't already - * point within lines. If the range would have started or stopped at the - * end of a line, round it up to the beginning of the next line (right - * now this restriction keeps the final newline from being tagged). - */ - - if (line1 < 0) { - line1 = 0; - ch1 = 0; - } - line1Ptr = TkBTreeFindLine(tree, line1); - if (line1Ptr == NULL) { - return; - } - if (ch1 >= line1Ptr->numBytes) { - TkTextLine *nextLinePtr; - - nextLinePtr = TkBTreeNextLine(line1Ptr); - if (nextLinePtr == NULL) { - return; - } else { - line1Ptr = nextLinePtr; - line1++; - ch1 = 0; - } - } - if (line2 < 0) { - return; - } - line2Ptr = TkBTreeFindLine(tree, line2); - if (line2Ptr == NULL) { - line2Ptr = TkBTreeFindLine(tree, treePtr->rootPtr->numLines-1); - ch2 = line2Ptr->numBytes-1; - } - if (ch2 >= line2Ptr->numBytes) { - TkTextLine *nextLinePtr; - - nextLinePtr = TkBTreeNextLine(line2Ptr); - if (nextLinePtr == NULL) { - ch2 = line2Ptr->numBytes-1; - } else { - line2Ptr = nextLinePtr; - line2++; - ch2 = 0; - } - } - - /* - * See if the tag is already present or absent at the start of the - * range. If the state doesn't already match what we want then add - * a toggle there. - */ - - oldState = TkBTreeCharTagged(line1Ptr, ch1, tagPtr); - if ((add != 0) ^ oldState) { - AddToggleToLine(line1Ptr, ch1, tagPtr); - } - - /* - * Scan the range of characters covered by the change and delete - * any existing tag transitions except those on the first and - * last characters. Keep track of whether the old state just before - * the last character (not including any tags on it) is what we - * want now; if not, then add a tag toggle there. - */ - - TkBTreeStartSearch(tree, line1, ch1+1, line2, ch2, tagPtr, &search); - while (TkBTreeNextTag(&search)) { - if ((search.linePtr == line2Ptr) && (search.ch1 == ch2)) { - break; - } - oldState ^= 1; - AddToggleToLine(search.linePtr, search.ch1, tagPtr); - } - if ((add != 0) ^ oldState) { - AddToggleToLine(line2Ptr, ch2, tagPtr); - } - - if (tkBTreeDebug) { - TkBTreeCheck(tree); - } -} - -/* - *---------------------------------------------------------------------- - * - * TkBTreeAddAnnotation -- - * - * Given a filled in annotation, this procedure links it into - * a B-tree structure so that it will track changes to the B-tree. - * - * Results: - * None. - * - * Side effects: - * AnnotPtr will be linked into its tree. Note: the storage for - * annotPtr is assumed to have been malloc'ed by the caller. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -void -TkBTreeAddAnnotation(annotPtr) - TkAnnotation *annotPtr; /* Pointer to annotation. The caller must - * have filled in all the fields except the - * "nextPtr" field. The type should NOT be - * TK_ANNOT_TOGGLE; these annotations are - * managed by the TkBTreeTag procedure. */ -{ - register TkAnnotation *annotPtr2, *prevPtr; - - for (prevPtr = NULL, annotPtr2 = annotPtr->linePtr->annotPtr; - annotPtr2 != NULL; - prevPtr = annotPtr2, annotPtr2 = annotPtr2->nextPtr) { - if (annotPtr2->ch > annotPtr->ch) { - break; - } - } - if (prevPtr == NULL) { - annotPtr->nextPtr = annotPtr->linePtr->annotPtr; - annotPtr->linePtr->annotPtr = annotPtr; - } else { - annotPtr->nextPtr = prevPtr->nextPtr; - prevPtr->nextPtr = annotPtr; - } -} - -/* - *---------------------------------------------------------------------- - * - * TkBTreeRemoveAnnotation -- - * - * This procedure unlinks an annotation from a B-tree so that - * the annotation will no longer be managed by the B-tree code. - * - * Results: - * None. - * - * Side effects: - * AnnotPtr will be unlinked from its tree. Note: it is up to the - * caller to free the storage for annotPtr, if that is desired. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -void -TkBTreeRemoveAnnotation(annotPtr) - TkAnnotation *annotPtr; /* Pointer to annotation, which must - * have been linked into tree by a previous - * call to TkBTreeAddAnnotation. */ -{ - register TkAnnotation *prevPtr; - - if (annotPtr->linePtr->annotPtr == annotPtr) { - annotPtr->linePtr->annotPtr = annotPtr->nextPtr; - } else { - for (prevPtr = annotPtr->linePtr->annotPtr; - prevPtr->nextPtr != annotPtr; - prevPtr = prevPtr->nextPtr) { - /* Empty loop body. */ - } - prevPtr->nextPtr = annotPtr->nextPtr; - } -} - -/* - *---------------------------------------------------------------------- - * - * TkBTreeFindLine -- - * - * Find a particular line in a B-tree based on its line number. - * - * Results: - * The return value is a pointer to the line structure for the - * line whose index is "line", or NULL if no such line exists. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -TkTextLine * -TkBTreeFindLine(tree, line) - TkTextBTree tree; /* B-tree in which to find line. */ - int line; /* Index of desired line. */ -{ - BTree *treePtr = (BTree *) tree; - register Node *nodePtr; - register TkTextLine *linePtr; - int linesLeft; - - nodePtr = treePtr->rootPtr; - linesLeft = line; - if ((line < 0) || (line >= nodePtr->numLines)) { - return NULL; - } - - /* - * Work down through levels of the tree until a node is found at - * level 0. - */ - - while (nodePtr->level != 0) { - for (nodePtr = nodePtr->children.nodePtr; - nodePtr->numLines <= linesLeft; - nodePtr = nodePtr->nextPtr) { - if (nodePtr == NULL) { - panic("TkBTreeFindLine ran out of nodes"); - } - linesLeft -= nodePtr->numLines; - } - } - - /* - * Work through the lines attached to the level-0 node. - */ - - for (linePtr = nodePtr->children.linePtr; linesLeft > 0; - linePtr = linePtr->nextPtr) { - if (linePtr == NULL) { - panic("TkBTreeFindLine ran out of lines"); - } - linesLeft -= 1; - } - return linePtr; -} - -/* - *---------------------------------------------------------------------- - * - * TkBTreeNextLine -- - * - * Given an existing line in a B-tree, this procedure locates the - * next line in the B-tree. This procedure is used for scanning - * through the B-tree. - * - * Results: - * The return value is a pointer to the line that immediately - * follows linePtr, or NULL if there is no such line. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -TkTextLine * -TkBTreeNextLine(linePtr) - register TkTextLine *linePtr; /* Pointer to existing line in - * B-tree. */ -{ - register Node *nodePtr; - - if (linePtr->nextPtr != NULL) { - return linePtr->nextPtr; - } - - /* - * This was the last line associated with the particular parent node. - * Search up the tree for the next node, then search down from that - * node to find the first line, - */ - - for (nodePtr = linePtr->parentPtr; ; nodePtr = nodePtr->parentPtr) { - if (nodePtr->nextPtr != NULL) { - nodePtr = nodePtr->nextPtr; - break; - } - if (nodePtr->parentPtr == NULL) { - return (TkTextLine *) NULL; - } - } - while (nodePtr->level > 0) { - nodePtr = nodePtr->children.nodePtr; - } - return nodePtr->children.linePtr; -} - -/* - *---------------------------------------------------------------------- - * - * TkBTreeLineIndex -- - * - * Given a pointer to a line in a B-tree, return the numerical - * index of that line. - * - * Results: - * The result is the index of linePtr within the tree, where 0 - * corresponds to the first line in the tree. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TkBTreeLineIndex(linePtr) - TkTextLine *linePtr; /* Pointer to existing line in - * B-tree. */ -{ - register TkTextLine *linePtr2; - register Node *nodePtr, *parentPtr, *nodePtr2; - int index; - - /* - * First count how many lines precede this one in its level-0 - * node. - */ - - nodePtr = linePtr->parentPtr; - index = 0; - for (linePtr2 = nodePtr->children.linePtr; linePtr2 != linePtr; - linePtr2 = linePtr2->nextPtr) { - if (linePtr2 == NULL) { - panic("TkBTreeLineIndex couldn't find line"); - } - index += 1; - } - - /* - * Now work up through the levels of the tree one at a time, - * counting how many lines are in nodes preceding the current - * node. - */ - - for (parentPtr = nodePtr->parentPtr ; parentPtr != NULL; - nodePtr = parentPtr, parentPtr = parentPtr->parentPtr) { - for (nodePtr2 = parentPtr->children.nodePtr; nodePtr2 != nodePtr; - nodePtr2 = nodePtr2->nextPtr) { - if (nodePtr2 == NULL) { - panic("TkBTreeLineIndex couldn't find node"); - } - index += nodePtr2->numLines; - } - } - return index; -} - -/* - *---------------------------------------------------------------------- - * - * TkBTreeStartSearch -- - * - * This procedure sets up a search for tag transitions involving - * a given tag (or all tags) in a given range of the text. - * - * Results: - * None. - * - * Side effects: - * The information at *searchPtr is set up so that subsequent calls - * to TkBTreeNextTag will return information about the locations of - * tag transitions. Note that TkBTreeNextTag must be called to get - * the first transition. - * - *---------------------------------------------------------------------- - */ - -void -TkBTreeStartSearch(tree, line1, ch1, line2, ch2, tagPtr, searchPtr) - TkTextBTree tree; /* Tree to search. */ - int line1, ch1; /* Character position at which to * start search (tags at this position - * will be returned). */ - int line2, ch2; /* Character position at which to * stop search (tags at this position - * will be returned). */ - TkTextTag *tagPtr; /* Tag to search for. NULL means - * search for any tag. */ - register TkTextSearch *searchPtr; /* Where to store information about - * search's progress. */ -{ - register TkAnnotation *annotPtr; - - searchPtr->tree = tree; - if (line1 < 0) { - searchPtr->line1 = 0; - searchPtr->ch1 = 0; - } else { - searchPtr->line1 = line1; - searchPtr->ch1 = ch1; - } - searchPtr->line2 = line2; - searchPtr->ch2 = ch2; - searchPtr->tagPtr = tagPtr; - searchPtr->allTags = (tagPtr == NULL); - - searchPtr->linePtr = TkBTreeFindLine(searchPtr->tree, searchPtr->line1); - if (searchPtr->linePtr == NULL) { - searchPtr->line1 = searchPtr->line2; - searchPtr->ch1 = searchPtr->ch2; - searchPtr->annotPtr = NULL; - } else { - for (annotPtr = searchPtr->linePtr->annotPtr; - (annotPtr != NULL) && (annotPtr->ch < ch1); - annotPtr = annotPtr->nextPtr) { - /* Empty loop body. */ - } - searchPtr->annotPtr = annotPtr; - } -} - -/* - *---------------------------------------------------------------------- - * - * TkBTreeNextTag -- - * - * Once a tag search has begun, successive calls to this procedure - * return successive tag toggles. Note: it is NOT SAFE to call this - * procedure if characters have been inserted into or deleted from - * the B-tree since the call to TkBTreeStartSearch. - * - * Results: - * The return value is 1 if another toggle was found that met the - * criteria specified in the call to TkBTreeStartSearch. 0 is - * returned if no more matching tag transitions were found. - * - * Side effects: - * Information in *searchPtr is modified to update the state of the - * search and indicate where the next tag toggle is located. - * - *---------------------------------------------------------------------- - */ - -int -TkBTreeNextTag(searchPtr) - register TkTextSearch *searchPtr; /* Information about search in - * progress; must have been set up by - * call to TkBTreeStartSearch. */ -{ - register TkAnnotation *annotPtr; - register Node *nodePtr; - register Summary *summaryPtr; - - if (searchPtr->linePtr == NULL) { - return 0; - } - - /* - * The outermost loop iterates over lines that may potentially contain - * a relevant tag transition, starting from the current line and tag. - */ - - while (1) { - /* - * See if there are more tags on the current line that are relevant. - */ - - for (annotPtr = searchPtr->annotPtr; annotPtr != NULL; - annotPtr = annotPtr->nextPtr) { - if ((annotPtr->type == TK_ANNOT_TOGGLE) - && (searchPtr->allTags - || (annotPtr->info.tagPtr == searchPtr->tagPtr))) { - if ((searchPtr->line1 == searchPtr->line2) - && (annotPtr->ch > searchPtr->ch2)) { - goto searchOver; - } - searchPtr->tagPtr = annotPtr->info.tagPtr; - searchPtr->ch1 = annotPtr->ch; - searchPtr->annotPtr = annotPtr->nextPtr; - return 1; - } - } - - /* - * See if there are more lines associated with the current parent - * node. If so, go back to the top of the loop to search the next - * one of them. - */ - - if (searchPtr->line1 >= searchPtr->line2) { - goto searchOver; - } - searchPtr->line1++; - if (searchPtr->linePtr->nextPtr != NULL) { - searchPtr->linePtr = searchPtr->linePtr->nextPtr; - searchPtr->annotPtr = searchPtr->linePtr->annotPtr; - continue; - } - - /* - * Search across and up through the B-tree's node hierarchy looking - * for the next node that has a relevant tag transition somewhere in - * its subtree. Be sure to update the current line number as we - * skip over large chunks of lines. - */ - - nodePtr = searchPtr->linePtr->parentPtr; - while (1) { - while (nodePtr->nextPtr == NULL) { - if (nodePtr->parentPtr == NULL) { - goto searchOver; - } - nodePtr = nodePtr->parentPtr; - } - nodePtr = nodePtr->nextPtr; - for (summaryPtr = nodePtr->summaryPtr; summaryPtr != NULL; - summaryPtr = summaryPtr->nextPtr) { - if ((searchPtr->allTags) || - (summaryPtr->tagPtr == searchPtr->tagPtr)) { - goto gotNodeWithTag; - } - } - searchPtr->line1 += nodePtr->numLines; - } - - /* - * At this point we've found a subtree that has a relevant tag - * transition. Now search down (and across) through that subtree - * to find the first level-0 node that has a relevant tag transition. - */ - - gotNodeWithTag: - while (nodePtr->level > 0) { - for (nodePtr = nodePtr->children.nodePtr; ; - nodePtr = nodePtr->nextPtr) { - for (summaryPtr = nodePtr->summaryPtr; summaryPtr != NULL; - summaryPtr = summaryPtr->nextPtr) { - if ((searchPtr->allTags) - || (summaryPtr->tagPtr == searchPtr->tagPtr)) { - goto nextChild; - } - } - searchPtr->line1 += nodePtr->numLines; - if (nodePtr->nextPtr == NULL) { - panic("TkBTreeNextTag found incorrect tag summary info."); - } - } - nextChild: - continue; - } - - /* - * Now we're down to a level-0 node that contains a line that contains - * a relevant tag transition. Set up line information and go back to - * the beginning of the loop to search through lines. - */ - - searchPtr->linePtr = nodePtr->children.linePtr; - searchPtr->annotPtr = searchPtr->linePtr->annotPtr; - if (searchPtr->line1 > searchPtr->line2) { - goto searchOver; - } - continue; - } - - searchOver: - searchPtr->line1 = searchPtr->line2; - searchPtr->ch1 = searchPtr->ch2; - searchPtr->annotPtr = NULL; - searchPtr->linePtr = NULL; - return 0; -} - -/* - *---------------------------------------------------------------------- - * - * TkBTreeCheck -- - * - * This procedure runs a set of consistency checks over a B-tree - * and panics if any inconsistencies are found. - * - * Results: - * None. - * - * Side effects: - * If a structural defect is found, the procedure panics with an - * error message. - * - *---------------------------------------------------------------------- - */ - -void -TkBTreeCheck(tree) - TkTextBTree tree; /* Tree to check. */ -{ - BTree *treePtr = (BTree *) tree; - register Summary *summaryPtr; - - /* - * Make sure that overall there is an even count of tag transitions - * for the whole text. - */ - - for (summaryPtr = treePtr->rootPtr->summaryPtr; summaryPtr != NULL; - summaryPtr = summaryPtr->nextPtr) { - if (summaryPtr->toggleCount & 1) { - panic("TkBTreeCheck found odd toggle count for \"%s\" (%d)", - summaryPtr->tagPtr->name, summaryPtr->toggleCount); - } - } - - /* - * Call a recursive procedure to do all of the rest of the checks. - */ - - CheckNodeConsistency(treePtr->rootPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Rebalance -- - * - * This procedure is called when a node of a B-tree appears to be - * out of balance (too many children, or too few). It rebalances - * that node and all of its ancestors in the tree. - * - * Results: - * None. - * - * Side effects: - * The internal structure of treePtr may change. - * - *---------------------------------------------------------------------- - */ - -static void -Rebalance(treePtr, nodePtr) - BTree *treePtr; /* Tree that is being rebalanced. */ - register Node *nodePtr; /* Node that may be out of balance. */ -{ - /* - * Loop over the entire ancestral chain of the node, working up - * through the tree one node at a time until the root node has - * been processed. - */ - - for ( ; nodePtr != NULL; nodePtr = nodePtr->parentPtr) { - register Node *newPtr, *childPtr; - register TkTextLine *linePtr; - int i; - - /* - * Check to see if the node has too many children. If it does, - * then split off all but the first MIN_CHILDREN into a separate - * node following the original one. Then repeat until the - * node has a decent size. - */ - - if (nodePtr->numChildren > MAX_CHILDREN) { - while (1) { - /* - * If the node being split is the root node, then make a - * new root node above it first. - */ - - if (nodePtr->parentPtr == NULL) { - newPtr = (Node *) ckalloc(sizeof(Node)); - newPtr->parentPtr = NULL; - newPtr->nextPtr = NULL; - newPtr->summaryPtr = NULL; - newPtr->level = nodePtr->level + 1; - newPtr->children.nodePtr = nodePtr; - newPtr->numChildren = 1; - newPtr->numLines = nodePtr->numLines; - RecomputeNodeCounts(newPtr); - treePtr->rootPtr = newPtr; - } - newPtr = (Node *) ckalloc(sizeof(Node)); - newPtr->parentPtr = nodePtr->parentPtr; - newPtr->nextPtr = nodePtr->nextPtr; - nodePtr->nextPtr = newPtr; - newPtr->summaryPtr = NULL; - newPtr->level = nodePtr->level; - newPtr->numChildren = nodePtr->numChildren - MIN_CHILDREN; - if (nodePtr->level == 0) { - for (i = MIN_CHILDREN-1, - linePtr = nodePtr->children.linePtr; - i > 0; i--, linePtr = linePtr->nextPtr) { - /* Empty loop body. */ - } - newPtr->children.linePtr = linePtr->nextPtr; - linePtr->nextPtr = NULL; - } else { - for (i = MIN_CHILDREN-1, - childPtr = nodePtr->children.nodePtr; - i > 0; i--, childPtr = childPtr->nextPtr) { - /* Empty loop body. */ - } - newPtr->children.nodePtr = childPtr->nextPtr; - childPtr->nextPtr = NULL; - } - RecomputeNodeCounts(nodePtr); - nodePtr->parentPtr->numChildren++; - nodePtr = newPtr; - if (nodePtr->numChildren <= MAX_CHILDREN) { - RecomputeNodeCounts(nodePtr); - break; - } - } - } - - while (nodePtr->numChildren < MIN_CHILDREN) { - register Node *otherPtr; - Node *halfwayNodePtr = NULL; /* Initialization needed only */ - TkTextLine *halfwayLinePtr = NULL; /* to prevent cc warnings. */ - int totalChildren, firstChildren, i; - - /* - * Too few children for this node. If this is the root, - * it's OK for it to have less than MIN_CHILDREN children - * as long as it's got at least two. If it has only one - * (and isn't at level 0), then chop the root node out of - * the tree and use its child as the new root. - */ - - if (nodePtr->parentPtr == NULL) { - if ((nodePtr->numChildren == 1) && (nodePtr->level > 0)) { - treePtr->rootPtr = nodePtr->children.nodePtr; - treePtr->rootPtr->parentPtr = NULL; - DeleteSummaries(nodePtr->summaryPtr); - ckfree((char *) nodePtr); - } - return; - } - - /* - * Not the root. Make sure that there are siblings to - * balance with. - */ - - if (nodePtr->parentPtr->numChildren < 2) { - Rebalance(treePtr, nodePtr->parentPtr); - continue; - } - - /* - * Find a sibling to borrow from, and arrange for nodePtr to - * be the earlier of the pair. - */ - - if (nodePtr->nextPtr == NULL) { - for (otherPtr = nodePtr->parentPtr->children.nodePtr; - otherPtr->nextPtr != nodePtr; - otherPtr = otherPtr->nextPtr) { - /* Empty loop body. */ - } - nodePtr = otherPtr; - } - otherPtr = nodePtr->nextPtr; - - /* - * We're going to either merge the two siblings together - * into one node or redivide the children among them to - * balance their loads. As preparation, join their two - * child lists into a single list and remember the half-way - * point in the list. - */ - - totalChildren = nodePtr->numChildren + otherPtr->numChildren; - firstChildren = totalChildren/2; - if (nodePtr->children.nodePtr == NULL) { - nodePtr->children = otherPtr->children; - otherPtr->children.nodePtr = NULL; - otherPtr->children.linePtr = NULL; - } - if (nodePtr->level == 0) { - register TkTextLine *linePtr; - - for (linePtr = nodePtr->children.linePtr, i = 1; - linePtr->nextPtr != NULL; - linePtr = linePtr->nextPtr, i++) { - if (i == firstChildren) { - halfwayLinePtr = linePtr; - } - } - linePtr->nextPtr = otherPtr->children.linePtr; - while (i <= firstChildren) { - halfwayLinePtr = linePtr; - linePtr = linePtr->nextPtr; - i++; - } - } else { - register Node *childPtr; - - for (childPtr = nodePtr->children.nodePtr, i = 1; - childPtr->nextPtr != NULL; - childPtr = childPtr->nextPtr, i++) { - if (i <= firstChildren) { - if (i == firstChildren) { - halfwayNodePtr = childPtr; - } - } - } - childPtr->nextPtr = otherPtr->children.nodePtr; - while (i <= firstChildren) { - halfwayNodePtr = childPtr; - childPtr = childPtr->nextPtr; - i++; - } - } - - /* - * If the two siblings can simply be merged together, do it. - */ - - if (totalChildren <= MAX_CHILDREN) { - RecomputeNodeCounts(nodePtr); - nodePtr->nextPtr = otherPtr->nextPtr; - nodePtr->parentPtr->numChildren--; - DeleteSummaries(otherPtr->summaryPtr); - ckfree((char *) otherPtr); - continue; - } - - /* - * The siblings can't be merged, so just divide their - * children evenly between them. - */ - - if (nodePtr->level == 0) { - otherPtr->children.linePtr = halfwayLinePtr->nextPtr; - halfwayLinePtr->nextPtr = NULL; - } else { - otherPtr->children.nodePtr = halfwayNodePtr->nextPtr; - halfwayNodePtr->nextPtr = NULL; - } - RecomputeNodeCounts(nodePtr); - RecomputeNodeCounts(otherPtr); - } - } -} - -/* - *---------------------------------------------------------------------- - * - * RecomputeNodeCounts -- - * - * This procedure is called to recompute all the counts in a node - * (tags, child information, etc.) by scaning the information in - * its descendants. This procedure is called during rebalancing - * when a node's child structure has changed. - * - * Results: - * None. - * - * Side effects: - * The tag counts for nodePtr are modified to reflect its current - * child structure, as are its numChildren and numLines fields. - * Also, all of the children's parentPtr fields are made to point - * to nodePtr. - * - *---------------------------------------------------------------------- - */ - -static void -RecomputeNodeCounts(nodePtr) - register Node *nodePtr; /* Node whose tag summary information - * must be recomputed. */ -{ - register Summary *summaryPtr, *summaryPtr2; - register Node *childPtr; - register TkTextLine *linePtr; - register TkAnnotation *annotPtr; - - /* - * Zero out all the existing counts for the node, but don't delete - * the existing Summary records (most of them will probably be reused). - */ - - for (summaryPtr = nodePtr->summaryPtr; summaryPtr != NULL; - summaryPtr = summaryPtr->nextPtr) { - summaryPtr->toggleCount = 0; - } - nodePtr->numChildren = 0; - nodePtr->numLines = 0; - - /* - * Scan through the children, adding the childrens' tag counts into - * the node's tag counts and adding new Summarys to the node if - * necessary. - */ - - if (nodePtr->level == 0) { - for (linePtr = nodePtr->children.linePtr; linePtr != NULL; - linePtr = linePtr->nextPtr) { - nodePtr->numChildren++; - nodePtr->numLines++; - linePtr->parentPtr = nodePtr; - for (annotPtr = linePtr->annotPtr; annotPtr != NULL; - annotPtr = annotPtr->nextPtr) { - if (annotPtr->type != TK_ANNOT_TOGGLE) { - continue; - } - for (summaryPtr = nodePtr->summaryPtr; ; - summaryPtr = summaryPtr->nextPtr) { - if (summaryPtr == NULL) { - summaryPtr = (Summary *) ckalloc(sizeof(Summary)); - summaryPtr->tagPtr = annotPtr->info.tagPtr; - summaryPtr->toggleCount = 1; - summaryPtr->nextPtr = nodePtr->summaryPtr; - nodePtr->summaryPtr = summaryPtr; - break; - } - if (summaryPtr->tagPtr == annotPtr->info.tagPtr) { - summaryPtr->toggleCount++; - break; - } - } - } - } - } else { - for (childPtr = nodePtr->children.nodePtr; childPtr != NULL; - childPtr = childPtr->nextPtr) { - nodePtr->numChildren++; - nodePtr->numLines += childPtr->numLines; - childPtr->parentPtr = nodePtr; - for (summaryPtr2 = childPtr->summaryPtr; summaryPtr2 != NULL; - summaryPtr2 = summaryPtr2->nextPtr) { - for (summaryPtr = nodePtr->summaryPtr; ; - summaryPtr = summaryPtr->nextPtr) { - if (summaryPtr == NULL) { - summaryPtr = (Summary *) ckalloc(sizeof(Summary)); - summaryPtr->tagPtr = summaryPtr2->tagPtr; - summaryPtr->toggleCount = summaryPtr2->toggleCount; - summaryPtr->nextPtr = nodePtr->summaryPtr; - nodePtr->summaryPtr = summaryPtr; - break; - } - if (summaryPtr->tagPtr == summaryPtr2->tagPtr) { - summaryPtr->toggleCount += summaryPtr2->toggleCount; - break; - } - } - } - } - } - - /* - * Scan through the node's tag records again and delete any Summary - * records that still have a zero count. - */ - - summaryPtr2 = NULL; - for (summaryPtr = nodePtr->summaryPtr; summaryPtr != NULL; ) { - if (summaryPtr->toggleCount > 0) { - summaryPtr2 = summaryPtr; - summaryPtr = summaryPtr->nextPtr; - continue; - } - if (summaryPtr2 != NULL) { - summaryPtr2->nextPtr = summaryPtr->nextPtr; - ckfree((char *) summaryPtr); - summaryPtr = summaryPtr2->nextPtr; - } else { - nodePtr->summaryPtr = summaryPtr->nextPtr; - ckfree((char *) summaryPtr); - summaryPtr = nodePtr->summaryPtr; - } - } -} - -/* - *---------------------------------------------------------------------- - * - * AddToggleToLine -- - * - * Insert a tag transition at a particular point in a particular - * line. - * - * Results: - * None. - * - * Side effects: - * LinePtr and all its ancestors in the B-tree stucture are modified - * to indicate the presence of a transition (either on or off) on - * tag at the given place in the given line. - * - *---------------------------------------------------------------------- - */ - -static void -AddToggleToLine(linePtr, index, tagPtr) - TkTextLine *linePtr; /* Line within which to add - * transition. */ - int index; /* Character before which to - * add transition. */ - TkTextTag *tagPtr; /* Information about tag. */ -{ - register TkAnnotation *annotPtr, *prevPtr; - int delta = 1; - - /* - * Find the position where the toggle should be inserted into - * the array (just after prevPtr), and see if there is already - * a toggle at exactly the point where we're going to insert a - * new toggle. If so then the two toggles cancel; just delete - * the existing toggle. - */ - - for (prevPtr = NULL, annotPtr = linePtr->annotPtr; annotPtr != NULL; - prevPtr = annotPtr, annotPtr = annotPtr->nextPtr) { - if (annotPtr->ch > index) { - break; - } - if ((annotPtr->type == TK_ANNOT_TOGGLE) - && (annotPtr->ch == index) - && (annotPtr->info.tagPtr == tagPtr)) { - if (prevPtr == NULL) { - linePtr->annotPtr = annotPtr->nextPtr; - } else { - prevPtr->nextPtr = annotPtr->nextPtr; - } - ckfree((char *) annotPtr); - delta = -1; - goto updateNodes; - } - } - - /* - * Create a new toggle and insert it into the list. - */ - - annotPtr = (TkAnnotation *) ckalloc(sizeof(TkAnnotation)); - annotPtr->type = TK_ANNOT_TOGGLE; - annotPtr->linePtr = linePtr; - annotPtr->ch = index; - annotPtr->info.tagPtr = tagPtr; - if (prevPtr == NULL) { - annotPtr->nextPtr = linePtr->annotPtr; - linePtr->annotPtr = annotPtr; - } else { - annotPtr->nextPtr = prevPtr->nextPtr; - prevPtr->nextPtr = annotPtr; - } - - /* - * Update all the nodes above this line to reflect the change in - * toggle structure. - */ - - updateNodes: - ChangeNodeToggleCount(linePtr->parentPtr, tagPtr, delta); -} - -/* - *---------------------------------------------------------------------- - * - * ChangeNodeToggleCount -- - * - * This procedure increments or decrements the toggle count for - * a particular tag in a particular node and all its ancestors. - * - * Results: - * None. - * - * Side effects: - * The toggle count for tag is adjusted up or down by "delta" in - * nodePtr. - * - *---------------------------------------------------------------------- - */ - -static void -ChangeNodeToggleCount(nodePtr, tagPtr, delta) - register Node *nodePtr; /* Node whose toggle count for a tag - * must be changed. */ - TkTextTag *tagPtr; /* Information about tag. */ - int delta; /* Amount to add to current toggle - * count for tag (may be negative). */ -{ - register Summary *summaryPtr, *prevPtr; - - /* - * Iterate over the node and all of its ancestors. - */ - - for ( ; nodePtr != NULL; nodePtr = nodePtr->parentPtr) { - /* - * See if there's already an entry for this tag for this node. If so, - * perhaps all we have to do is adjust its count. - */ - - for (prevPtr = NULL, summaryPtr = nodePtr->summaryPtr; - summaryPtr != NULL; - prevPtr = summaryPtr, summaryPtr = summaryPtr->nextPtr) { - if (summaryPtr->tagPtr != tagPtr) { - continue; - } - summaryPtr->toggleCount += delta; - if (summaryPtr->toggleCount > 0) { - goto nextAncestor; - } - if (summaryPtr->toggleCount < 0) { - panic("ChangeNodeToggleCount: negative toggle count"); - } - - /* - * Zero count; must remove this tag from the list. - */ - - if (prevPtr == NULL) { - nodePtr->summaryPtr = summaryPtr->nextPtr; - } else { - prevPtr->nextPtr = summaryPtr->nextPtr; - } - ckfree((char *) summaryPtr); - goto nextAncestor; - } - - /* - * This tag isn't in the list. Add a new entry to the list. - */ - - if (delta < 0) { - panic("ChangeNodeToggleCount: negative delta, no tag entry"); - } - summaryPtr = (Summary *) ckalloc(sizeof(Summary)); - summaryPtr->tagPtr = tagPtr; - summaryPtr->toggleCount = delta; - summaryPtr->nextPtr = nodePtr->summaryPtr; - nodePtr->summaryPtr = summaryPtr; - - nextAncestor: - continue; - } -} - -/* - *---------------------------------------------------------------------- - * - * TkBTreeCharTagged -- - * - * Determine whether a particular character has a particular tag. - * - * Results: - * The return value is 1 if the given tag is in effect at the - * character given by linePtr and ch, and 0 otherwise. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TkBTreeCharTagged(linePtr, ch, tagPtr) - TkTextLine *linePtr; /* Line containing character of - * interest. */ - int ch; /* Index of character in linePtr. */ - TkTextTag *tagPtr; /* Tag of interest. */ -{ - register Node *nodePtr; - register TkTextLine *siblingLinePtr; - int toggles; - - /* - * Count the number of toggles for the tag at the line level (i.e. - * in all the sibling lines that precede this one, plus in this line - * up to the character of interest. - */ - - toggles = 0; - for (siblingLinePtr = linePtr->parentPtr->children.linePtr; ; - siblingLinePtr = siblingLinePtr->nextPtr) { - register TkAnnotation *annotPtr; - - for (annotPtr = siblingLinePtr->annotPtr; - (annotPtr != NULL) && ((siblingLinePtr != linePtr) - || (annotPtr->ch <= ch)); - annotPtr = annotPtr->nextPtr) { - if ((annotPtr->type == TK_ANNOT_TOGGLE) - && (annotPtr->info.tagPtr == tagPtr)) { - toggles++; - } - } - if (siblingLinePtr == linePtr) { - break; - } - } - - /* - * For each node in the ancestry of this line, count the number of - * toggles of the given tag in siblings that precede that node. - */ - - for (nodePtr = linePtr->parentPtr; nodePtr->parentPtr != NULL; - nodePtr = nodePtr->parentPtr) { - register Node *siblingPtr; - register Summary *summaryPtr; - - for (siblingPtr = nodePtr->parentPtr->children.nodePtr; - siblingPtr != nodePtr; siblingPtr = siblingPtr->nextPtr) { - for (summaryPtr = siblingPtr->summaryPtr; summaryPtr != NULL; - summaryPtr = summaryPtr->nextPtr) { - if (summaryPtr->tagPtr == tagPtr) { - toggles += summaryPtr->toggleCount; - } - } - } - } - - /* - * An odd number of toggles means that the tag is present at the - * given point. - */ - - return toggles & 1; -} - -/* - *---------------------------------------------------------------------- - * - * TkBTreeGetTags -- - * - * Return information about all of the tags that are associated - * with a particular character in a B-tree of text. - * - * Results: - * The return value is a malloc-ed array containing pointers to - * information for each of the tags that is associated with - * the character at the position given by linePtr and ch. The - * word at *numTagsPtr is filled in with the number of pointers - * in the array. It is up to the caller to free the array by - * passing it to free. If there are no tags at the given character - * then a NULL pointer is returned and *numTagsPtr will be set to 0. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -TkTextTag ** -TkBTreeGetTags(tree, linePtr, ch, numTagsPtr) - TkTextBTree tree; /* Tree to check. */ - TkTextLine *linePtr; /* Line containing character of interest. */ - int ch; /* Index within linePtr of character for - * which tag information is wanted. */ - int *numTagsPtr; /* Store number of tags found at this - * location. */ -{ - register Node *nodePtr; - register TkTextLine *siblingLinePtr; - int src, dst; - TagInfo tagInfo; -#define NUM_TAG_INFOS 10 - - tagInfo.numTags = 0; - tagInfo.arraySize = NUM_TAG_INFOS; - tagInfo.tagPtrs = (TkTextTag **) ckalloc((unsigned) - NUM_TAG_INFOS*sizeof(TkTextTag *)); - tagInfo.counts = (int *) ckalloc((unsigned) - NUM_TAG_INFOS*sizeof(int)); - - /* - * Record tag toggles at the line level (i.e. in all the sibling - * lines that precede this one, plus in this line up to the character - * of interest. - */ - - for (siblingLinePtr = linePtr->parentPtr->children.linePtr; ; - siblingLinePtr = siblingLinePtr->nextPtr) { - register TkAnnotation *annotPtr; - - for (annotPtr = siblingLinePtr->annotPtr; - (annotPtr != NULL) && ((siblingLinePtr != linePtr) - || (annotPtr->ch <= ch)); - annotPtr = annotPtr->nextPtr) { - if (annotPtr->type == TK_ANNOT_TOGGLE) { - IncCount(annotPtr->info.tagPtr, 1, &tagInfo); - } - } - if (siblingLinePtr == linePtr) { - break; - } - } - - /* - * For each node in the ancestry of this line, record tag toggles - * for all siblings that precede that node. - */ - - for (nodePtr = linePtr->parentPtr; nodePtr->parentPtr != NULL; - nodePtr = nodePtr->parentPtr) { - register Node *siblingPtr; - register Summary *summaryPtr; - - for (siblingPtr = nodePtr->parentPtr->children.nodePtr; - siblingPtr != nodePtr; siblingPtr = siblingPtr->nextPtr) { - for (summaryPtr = siblingPtr->summaryPtr; summaryPtr != NULL; - summaryPtr = summaryPtr->nextPtr) { - IncCount(summaryPtr->tagPtr, summaryPtr->toggleCount, &tagInfo); - } - } - } - - /* - * Go through the tag information and squash out all of the tags - * that have even toggle counts (these tags exist before the point - * of interest, but not at the desired character itself). - */ - - for (src = 0, dst = 0; src < tagInfo.numTags; src++) { - if (tagInfo.counts[src] & 1) { - tagInfo.tagPtrs[dst] = tagInfo.tagPtrs[src]; - dst++; - } - } - *numTagsPtr = dst; - ckfree((char *) tagInfo.counts); - if (dst == 0) { - ckfree((char *) tagInfo.tagPtrs); - return NULL; - } - return tagInfo.tagPtrs; -} - -/* - *---------------------------------------------------------------------- - * - * IncCount -- - * - * This is a utility procedure used by TkBTreeGetTags. It - * increments the count for a particular tag, adding a new - * entry for that tag if there wasn't one previously. - * - * Results: - * None. - * - * Side effects: - * The information at *tagInfoPtr may be modified, and the arrays - * may be reallocated to make them larger. - * - *---------------------------------------------------------------------- - */ - -static void -IncCount(tagPtr, inc, tagInfoPtr) - TkTextTag *tagPtr; /* Handle for tag. */ - int inc; /* Amount by which to increment tag count. */ - TagInfo *tagInfoPtr; /* Holds cumulative information about tags; - * increment count here. */ -{ - register TkTextTag **tagPtrPtr; - int count; - - for (tagPtrPtr = tagInfoPtr->tagPtrs, count = tagInfoPtr->numTags; - count > 0; tagPtrPtr++, count--) { - if (*tagPtrPtr == tagPtr) { - tagInfoPtr->counts[tagInfoPtr->numTags-count] += inc; - return; - } - } - - /* - * There isn't currently an entry for this tag, so we have to - * make a new one. If the arrays are full, then enlarge the - * arrays first. - */ - - if (tagInfoPtr->numTags == tagInfoPtr->arraySize) { - TkTextTag **newTags; - int *newCounts, newSize; - - newSize = 2*tagInfoPtr->arraySize; - newTags = (TkTextTag **) ckalloc((unsigned) - (newSize*sizeof(TkTextTag *))); - memcpy((VOID *) newTags, (VOID *) tagInfoPtr->tagPtrs, - tagInfoPtr->arraySize * sizeof(TkTextTag *)); - ckfree((char *) tagInfoPtr->tagPtrs); - tagInfoPtr->tagPtrs = newTags; - newCounts = (int *) ckalloc((unsigned) (newSize*sizeof(int))); - memcpy((VOID *) newCounts, (VOID *) tagInfoPtr->counts, - tagInfoPtr->arraySize * sizeof(int)); - ckfree((char *) tagInfoPtr->counts); - tagInfoPtr->counts = newCounts; - tagInfoPtr->arraySize = newSize; - } - - tagInfoPtr->tagPtrs[tagInfoPtr->numTags] = tagPtr; - tagInfoPtr->counts[tagInfoPtr->numTags] = inc; - tagInfoPtr->numTags++; -} - -/* - *---------------------------------------------------------------------- - * - * CheckNodeConsistency -- - * - * This procedure is called as part of consistency checking for - * B-trees: it checks several aspects of a node and also runs - * checks recursively on the node's children. - * - * Results: - * None. - * - * Side effects: - * If anything suspicious is found in the tree structure, the - * procedure panics. - * - *---------------------------------------------------------------------- - */ - -static void -CheckNodeConsistency(nodePtr) - register Node *nodePtr; /* Node whose subtree should be - * checked. */ -{ - register Node *childNodePtr; - register Summary *summaryPtr, *summaryPtr2; - register TkAnnotation *annotPtr; - register TkTextLine *linePtr; - register char *p; - int numChildren, numLines, toggleCount, minChildren, index, numBytes; - - if (nodePtr->parentPtr != NULL) { - minChildren = MIN_CHILDREN; - } else if (nodePtr->level > 0) { - minChildren = 2; - } else { - minChildren = 1; - } - if ((nodePtr->numChildren < minChildren) - || (nodePtr->numChildren > MAX_CHILDREN)) { - panic("CheckNodeConsistency found bad child count (%d)", - nodePtr->numChildren); - } - - numChildren = 0; - numLines = 0; - if (nodePtr->level == 0) { - for (linePtr = nodePtr->children.linePtr; linePtr != NULL; - linePtr = linePtr->nextPtr) { - if (linePtr->parentPtr != nodePtr) { - panic("CheckNodeConsistency found line that %s", - "didn't point to parent"); - } - for (p = linePtr->bytes, numBytes = 0; *p != 0; p++, numBytes++) { - if ((*p == '\n') && (numBytes != linePtr->numBytes-1)) { - panic("CheckNodeConsistency found line with extra newline"); - } - } - if (numBytes != linePtr->numBytes) { - panic("CheckNodeConsistency found line with bad numBytes"); - } - if (linePtr->bytes[numBytes-1] != '\n') { - panic("CheckNodeConsistency found line with no newline"); - } - index = 0; - for (annotPtr = linePtr->annotPtr; annotPtr != NULL; - annotPtr = annotPtr->nextPtr) { - if (annotPtr->ch < index) { - panic("CheckNodeConsistency found %s (%d %d)", - "out-of-order tag indices", index, - annotPtr->ch); - } - index = annotPtr->ch; - if (annotPtr->type == TK_ANNOT_TOGGLE) { - for (summaryPtr = nodePtr->summaryPtr; ; - summaryPtr = summaryPtr->nextPtr) { - if (summaryPtr == NULL) { - panic("CheckNodeConsistency found line %s", - "tag with no node tag: %s", - summaryPtr->tagPtr->name); - } - if (summaryPtr->tagPtr == annotPtr->info.tagPtr) { - break; - } - } - } - } - numChildren++; - numLines++; - } - } else { - for (childNodePtr = nodePtr->children.nodePtr; childNodePtr != NULL; - childNodePtr = childNodePtr->nextPtr) { - CheckNodeConsistency(childNodePtr); - for (summaryPtr = childNodePtr->summaryPtr; summaryPtr != NULL; - summaryPtr = summaryPtr->nextPtr) { - for (summaryPtr2 = nodePtr->summaryPtr; ; - summaryPtr2 = summaryPtr2->nextPtr) { - if (summaryPtr2 == NULL) { - panic("CheckNodeConsistency found %s (%s)", - "node tag with no parent tag", - summaryPtr->tagPtr->name); - } - if (summaryPtr->tagPtr == summaryPtr2->tagPtr) { - break; - } - } - } - numChildren++; - numLines += childNodePtr->numLines; - if (childNodePtr->parentPtr != nodePtr) { - panic("CheckNodeConsistency found node that %s", - "didn't point to parent"); - } - if (childNodePtr->level != (nodePtr->level-1)) { - panic("CheckNodeConsistency found level mismatch (%d %d)", - nodePtr->level, childNodePtr->level); - } - } - } - if (numChildren != nodePtr->numChildren) { - panic("CheckNodeConsistency found mismatch in numChildren (%d %d)", - numChildren, nodePtr->numChildren); - } - if (numLines != nodePtr->numLines) { - panic("CheckNodeConsistency found mismatch in numLines (%d %d)", - numLines, nodePtr->numLines); - } - - for (summaryPtr = nodePtr->summaryPtr; summaryPtr != NULL; - summaryPtr = summaryPtr->nextPtr) { - toggleCount = 0; - if (nodePtr->level == 0) { - for (linePtr = nodePtr->children.linePtr; linePtr != NULL; - linePtr = linePtr->nextPtr) { - for (annotPtr = linePtr->annotPtr; annotPtr != NULL; - annotPtr = annotPtr->nextPtr) { - if (annotPtr->info.tagPtr == summaryPtr->tagPtr) { - toggleCount++; - } - } - } - } else { - for (childNodePtr = nodePtr->children.nodePtr; - childNodePtr != NULL; - childNodePtr = childNodePtr->nextPtr) { - for (summaryPtr2 = childNodePtr->summaryPtr; - summaryPtr2 != NULL; - summaryPtr2 = summaryPtr2->nextPtr) { - if (summaryPtr2->tagPtr == summaryPtr->tagPtr) { - toggleCount += summaryPtr2->toggleCount; - } - } - } - } - if (toggleCount != summaryPtr->toggleCount) { - panic("CheckNodeConsistency found mismatch in toggleCount (%d %d)", - toggleCount, summaryPtr->toggleCount); - } - for (summaryPtr2 = summaryPtr->nextPtr; summaryPtr2 != NULL; - summaryPtr2 = summaryPtr2->nextPtr) { - if (summaryPtr2->tagPtr == summaryPtr->tagPtr) { - panic("CheckNodeConsistency found duplicated node tag: %s", - summaryPtr->tagPtr->name); - } - } - } -} - -/* - *---------------------------------------------------------------------- - * - * TkBTreeNumLines -- - * - * This procedure returns a count of the number of lines of - * text present in a given B-tree. - * - * Results: - * The return value is a count of the number of lines in tree. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TkBTreeNumLines(tree) - TkTextBTree tree; /* Information about tree. */ -{ - BTree *treePtr = (BTree *) tree; - return treePtr->rootPtr->numLines; -} diff --git a/tk3.6/tkTextDisp.c b/tk3.6/tkTextDisp.c deleted file mode 100644 index 4280341..0000000 --- a/tk3.6/tkTextDisp.c +++ /dev/null @@ -1,2103 +0,0 @@ -/* - * tkTextDisp.c -- - * - * This module provides facilities to display text widgets. It is - * the only place where information is kept about the screen layout - * of text widgets. - * - * 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. - */ - -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkTextDisp.c,v 1.38 93/11/01 15:05:54 ouster Exp $ SPRITE (Berkeley)"; -#endif - -#include "tkConfig.h" -#include "tkInt.h" -#include "tkText.h" - -/* - * The following structure describes how to display a range of characters. - * The information is generated by scanning all of the tags associated - * with the characters and combining that with default information for - * the overall widget. These structures form the hash keys for - * dInfoPtr->styleTable. - */ - -typedef struct StyleValues { - Tk_3DBorder border; /* Used for drawing background under text. - * NULL means use widget background. */ - int borderWidth; /* Width of 3-D border for background. */ - int relief; /* 3-D relief for background. */ - Pixmap bgStipple; /* Stipple bitmap for background. None - * means draw solid. */ - XColor *fgColor; /* Foreground color for text. */ - XFontStruct *fontPtr; /* Font for displaying text. */ - Pixmap fgStipple; /* Stipple bitmap for text and other - * foreground stuff. None means draw - * solid.*/ - int underline; /* Non-zero means draw underline underneath - * text. */ -} StyleValues; - -/* - * The following structure extends the StyleValues structure above with - * graphics contexts used to actually draw the characters. The entries - * in dInfoPtr->styleTable point to structures of this type. - */ - -typedef struct Style { - int refCount; /* Number of times this structure is - * referenced in Chunks. */ - GC bgGC; /* Graphics context for background. None - * unless background is stippled. */ - GC fgGC; /* Graphics context for foreground. */ - StyleValues *sValuePtr; /* Raw information from which GCs were - * derived. */ - Tcl_HashEntry *hPtr; /* Pointer to entry in styleTable. Used - * to delete entry. */ -} Style; - -/* - * The following structure describes a range of characters, all on the - * same line of the display (which also means the same line of the text - * widget) and all having the same display attributes. - */ - -typedef struct Chunk { - char *text; /* Characters to display. */ - int numChars; /* Number of characters to display. */ - Style *stylePtr; /* Style information used to display - * characters. */ - int x; /* X-coordinate of pixel at which to display - * the characters. */ - struct Chunk *nextPtr; /* Next in list of all chunks displayed on the - * same display line. */ -} Chunk; - -/* - * The following structure describes one line of the display, which may - * be either part or all of one line of the text. - */ - -typedef struct DLine { - TkTextLine *linePtr; /* Pointer to structure in B-tree that - * contains characters displayed in this - * line. */ - int y; /* Y-position at which line is supposed to - * be drawn (topmost pixel of rectangular - * area occupied by line). */ - int oldY; /* Y-position at which line currently - * appears on display. -1 means line isn't - * currently visible on display. This is - * used to move lines by scrolling rather - * than re-drawing. */ - int height; /* Height of line, in pixels. */ - int baseline; /* Offset of text baseline from y. */ - Chunk *chunkPtr; /* Pointer to first chunk in list of all - * of those that are displayed on this - * line of the screen. */ - struct DLine *nextPtr; /* Next in list of all display lines for - * this window. The list is sorted in - * order from top to bottom. Note: the - * next DLine doesn't always correspond - * to the next line of text: (a) can have - * multiple DLines for one text line, and - * (b) can have gaps where DLine's have been - * deleted because they're out of date. */ -} DLine; - -/* - * Overall display information for a text widget: - */ - -typedef struct DInfo { - Tcl_HashTable styleTable; /* Hash table that maps from StyleValues to - * Styles for this widget. */ - DLine *dLinePtr; /* First in list of all display lines for - * this widget, in order from top to bottom. */ - GC copyGC; /* Graphics context for copying from off- - * screen pixmaps onto screen. */ - GC scrollGC; /* Graphics context for copying from one place - * in the window to another (scrolling): - * differs from copyGC in that we need to get - * GraphicsExpose events. */ - int x; /* First x-coordinate that may be used for - * actually displaying line information. - * Leaves space for border, etc. */ - int y; /* First y-coordinate that may be used for - * actually displaying line information. - * Leaves space for border, etc. */ - int maxX; /* First x-coordinate to right of available - * space for displaying lines. */ - int maxY; /* First y-coordinate below available - * space for displaying lines. */ - int topOfEof; /* Top-most pixel (lowest y-value) that has - * been drawn in the appropriate fashion for - * the portion of the window after the last - * line of the text. This field is used to - * figure out when to redraw part or all of - * the eof field. */ - int flags; /* Various flag values: see below for - * definitions. */ -} DInfo; - -/* - * Flag values for DInfo structures: - * - * DINFO_OUT_OF_DATE: Non-zero means that the DLine structures - * for this window are partially or completely - * out of date and need to be recomputed. - * REDRAW_PENDING: Means that a when-idle handler has been - * scheduled to update the display. - * REDRAW_BORDERS: Means window border or pad area has - * potentially been damaged and must be redrawn. - * REPICK_NEEDED: 1 means that the widget has been modified - * in a way that could change the current - * character (a different character might be - * under the mouse cursor now). Need to - * recompute the current character before - * the next redisplay. - */ - -#define DINFO_OUT_OF_DATE 1 -#define REDRAW_PENDING 2 -#define REDRAW_BORDERS 4 -#define REPICK_NEEDED 8 - -/* - * Structures of the type defined below are used to keep track of - * tags while scanning through the text to create DLine structures. - */ - -typedef struct TagInfo { - int numTags; /* Number of tags currently active (the first - * entries at *tagPtr). */ - int arraySize; /* Total number of entries at *tagPtr. We - * over-allocate the array to avoid continual - * reallocations. */ - TkTextTag **tagPtrs; /* Pointer to array of pointers to active tags. - * Array has space for arraySize tags, and - * the first numTags are slots identify the - * active tags. Malloc'ed (but may be NULL). */ - TkTextSearch search; /* Used to scan for tag transitions. Current - * state identifies next tag transition. */ -} TagInfo; - -/* - * The following counters keep statistics about redisplay that can be - * checked to see how clever this code is at reducing redisplays. - */ - -static int numRedisplays; /* Number of calls to DisplayText. */ -static int linesRedrawn; /* Number of calls to DisplayDLine. */ -static int numCopies; /* Number of calls to XCopyArea to copy part - * of the screen. */ -static int damagedCopies; /* Number of times that XCopyAreas didn't - * completely work because some of the source - * information was damaged. */ - -/* - * Forward declarations for procedures defined later in this file: - */ - -static void ComputeStyleValues _ANSI_ARGS_((TkText *textPtr, - int numTags, TkTextTag **tagPtr, - StyleValues *sValuePtr)); -static void DisplayDLine _ANSI_ARGS_((TkText *textPtr, - DLine *dlPtr, Pixmap pixmap)); -static void DisplayText _ANSI_ARGS_((ClientData clientData)); -static DLine * FindDLine _ANSI_ARGS_((DLine *dlPtr, int line)); -static void FreeDLines _ANSI_ARGS_((TkText *textPtr, - DLine *firstPtr, DLine *lastPtr, int unlink)); -static void FreeStyle _ANSI_ARGS_((TkText *textPtr, - Style *stylePtr)); -static Style * GetStyle _ANSI_ARGS_((TkText *textPtr, - StyleValues *sValuePtr)); -static DLine * LayoutLine _ANSI_ARGS_((TkText *textPtr, int line, - TkTextLine *linePtr, TagInfo *tInfoPtr)); -static void ToggleTag _ANSI_ARGS_((TagInfo *tInfoPtr, - TkTextTag *tagPtr)); -static void UpdateDisplayInfo _ANSI_ARGS_((TkText *textPtr)); - -/* - *---------------------------------------------------------------------- - * - * TkTextCreateDInfo -- - * - * This procedure is called when a new text widget is created. - * Its job is to set up display-related information for the widget. - * - * Results: - * None. - * - * Side effects: - * A DInfo data structure is allocated and initialized and attached - * to textPtr. - * - *---------------------------------------------------------------------- - */ - -void -TkTextCreateDInfo(textPtr) - TkText *textPtr; /* Overall information for text widget. */ -{ - register DInfo *dInfoPtr; - XGCValues gcValues; - - dInfoPtr = (DInfo *) ckalloc(sizeof(DInfo)); - Tcl_InitHashTable(&dInfoPtr->styleTable, sizeof(StyleValues)/sizeof(int)); - dInfoPtr->dLinePtr = NULL; - gcValues.graphics_exposures = False; - dInfoPtr->copyGC = Tk_GetGC(textPtr->tkwin, GCGraphicsExposures, &gcValues); - gcValues.graphics_exposures = True; - dInfoPtr->scrollGC = Tk_GetGC(textPtr->tkwin, GCGraphicsExposures, - &gcValues); - dInfoPtr->topOfEof = 0; - dInfoPtr->flags = DINFO_OUT_OF_DATE; - textPtr->dInfoPtr = dInfoPtr; -} - -/* - *---------------------------------------------------------------------- - * - * TkTextFreeDInfo -- - * - * This procedure is called to free up all of the private display - * information kept by this file for a text widget. - * - * Results: - * None. - * - * Side effects: - * Lots of resources get freed. - * - *---------------------------------------------------------------------- - */ - -void -TkTextFreeDInfo(textPtr) - TkText *textPtr; /* Overall information for text widget. */ -{ - register DInfo *dInfoPtr = textPtr->dInfoPtr; - - /* - * Be careful to free up styleTable *after* freeing up all the - * DLines, so that the hash table is still intact to free up the - * style-related information from the lines. Once the lines are - * all free then styleTable will be empty. - */ - - FreeDLines(textPtr, dInfoPtr->dLinePtr, (DLine *) NULL, 1); - Tcl_DeleteHashTable(&dInfoPtr->styleTable); - Tk_FreeGC(textPtr->display, dInfoPtr->copyGC); - Tk_FreeGC(textPtr->display, dInfoPtr->scrollGC); - if (dInfoPtr->flags & REDRAW_PENDING) { - Tk_CancelIdleCall(DisplayText, (ClientData) textPtr); - } - ckfree((char *) dInfoPtr); -} - -/* - *---------------------------------------------------------------------- - * - * GetStyle -- - * - * This procedure creates graphics contexts needed to display - * text in a particular style, determined by "sValuePtr". It - * attempts to share style information as much as possible. - * - * Results: - * The return value is a pointer to a Style structure that - * corresponds to *sValuePtr. - * - * Side effects: - * A new entry may be created in the style table for the widget. - * - *---------------------------------------------------------------------- - */ - -static Style * -GetStyle(textPtr, sValuePtr) - TkText *textPtr; /* Overall information about text widget. */ - StyleValues *sValuePtr; /* Information about desired style. */ -{ - Style *stylePtr; - Tcl_HashEntry *hPtr; - int new; - XGCValues gcValues; - unsigned long mask; - - /* - * Use an existing style if there's one around that matches. - */ - - hPtr = Tcl_CreateHashEntry(&textPtr->dInfoPtr->styleTable, - (char *) sValuePtr, &new); - if (!new) { - stylePtr = (Style *) Tcl_GetHashValue(hPtr); - stylePtr->refCount++; - return stylePtr; - } - - /* - * No existing style matched. Make a new one. - */ - - stylePtr = (Style *) ckalloc(sizeof(Style)); - stylePtr->refCount = 1; - if ((sValuePtr->border != NULL) && (sValuePtr->bgStipple != None)) { - gcValues.foreground = Tk_3DBorderColor(sValuePtr->border)->pixel; - gcValues.stipple = sValuePtr->bgStipple; - gcValues.fill_style = FillStippled; - stylePtr->bgGC = Tk_GetGC(textPtr->tkwin, - GCForeground|GCStipple|GCFillStyle, &gcValues); - } else { - stylePtr->bgGC = None; - } - mask = GCForeground|GCFont; - gcValues.foreground = sValuePtr->fgColor->pixel; - gcValues.font = sValuePtr->fontPtr->fid; - if (sValuePtr->fgStipple != None) { - gcValues.stipple = sValuePtr->fgStipple; - gcValues.fill_style = FillStippled; - mask |= GCStipple|GCFillStyle; - } - stylePtr->fgGC = Tk_GetGC(textPtr->tkwin, mask, &gcValues); - stylePtr->sValuePtr = (StyleValues *) - Tcl_GetHashKey(&textPtr->dInfoPtr->styleTable, hPtr); - stylePtr->hPtr = hPtr; - Tcl_SetHashValue(hPtr, stylePtr); - return stylePtr; -} - -/* - *---------------------------------------------------------------------- - * - * FreeStyle -- - * - * This procedure is called when a Style structure is no longer - * needed. It decrements the reference count and frees up the - * space for the style structure if the reference count is 0. - * - * Results: - * None. - * - * Side effects: - * The storage and other resources associated with the style - * are freed up if no-one's still using it. - * - *---------------------------------------------------------------------- - */ - -static void -FreeStyle(textPtr, stylePtr) - TkText *textPtr; /* Information about overall widget. */ - register Style *stylePtr; /* Information about style to be freed. */ - -{ - stylePtr->refCount--; - if (stylePtr->refCount == 0) { - if (stylePtr->bgGC != None) { - Tk_FreeGC(textPtr->display, stylePtr->bgGC); - } - Tk_FreeGC(textPtr->display, stylePtr->fgGC); - Tcl_DeleteHashEntry(stylePtr->hPtr); - ckfree((char *) stylePtr); - } -} - -/* - *---------------------------------------------------------------------- - * - * ComputeStyleValues -- - * - * Given a list of tags that apply at a particular point, compute - * the StyleValues that correspond to that set of tags. - * - * Results: - * All of the fields of *sValuePtr get filled in to hold the - * appropriate display information for the given set of tags - * in the given widget. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -ComputeStyleValues(textPtr, numTags, tagPtrPtr, sValuePtr) - TkText *textPtr; /* Overall information for widget. */ - int numTags; /* Number of tags at *tagPtr. */ - register TkTextTag **tagPtrPtr; /* Pointer to array of tag pointers. */ - register StyleValues *sValuePtr; /* Pointer to structure to fill in. */ -{ - register TkTextTag *tagPtr; - - /* - * The variables below keep track of the highest-priority specification - * that has occurred for each of the various fields of the StyleValues. - */ - - int borderPrio, bgStipplePrio; - int fgPrio, fontPrio, fgStipplePrio; - - borderPrio = bgStipplePrio = -1; - fgPrio = fontPrio = fgStipplePrio = -1; - memset((VOID *) sValuePtr, 0, sizeof(StyleValues)); - sValuePtr->fgColor = textPtr->fgColor; - sValuePtr->fontPtr = textPtr->fontPtr; - - /* - * Scan through all of the tags, updating the StyleValues to hold - * the highest-priority information. - */ - - for ( ; numTags > 0; tagPtrPtr++, numTags--) { - tagPtr = *tagPtrPtr; - if ((tagPtr->border != NULL) && (tagPtr->priority > borderPrio)) { - sValuePtr->border = tagPtr->border; - sValuePtr->borderWidth = tagPtr->borderWidth; - sValuePtr->relief = tagPtr->relief; - borderPrio = tagPtr->priority; - } - if ((tagPtr->bgStipple != None) - && (tagPtr->priority > bgStipplePrio)) { - sValuePtr->bgStipple = tagPtr->bgStipple; - bgStipplePrio = tagPtr->priority; - } - if ((tagPtr->fgColor != None) && (tagPtr->priority > fgPrio)) { - sValuePtr->fgColor = tagPtr->fgColor; - fgPrio = tagPtr->priority; - } - if ((tagPtr->fontPtr != None) && (tagPtr->priority > fontPrio)) { - sValuePtr->fontPtr = tagPtr->fontPtr; - fontPrio = tagPtr->priority; - } - if ((tagPtr->fgStipple != None) - && (tagPtr->priority > fgStipplePrio)) { - sValuePtr->fgStipple = tagPtr->fgStipple; - fgStipplePrio = tagPtr->priority; - } - if (tagPtr->underline) { - sValuePtr->underline = 1; - } - } -} - -/* - *---------------------------------------------------------------------- - * - * LayoutLine -- - * - * This procedure generates a linked list of one or more DLine - * structures, which describe how to display everything in one - * line of the text. - * - * Results: - * The return value is a pointer to one or more DLine structures - * linked into a linked list. The structures are completely filled - * in except for the y field, which the caller must supply. Also, - * the information at *tInfoPtr gets updated to refer to the state - * just after the last character of the line. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static DLine * -LayoutLine(textPtr, line, linePtr, tInfoPtr) - TkText *textPtr; /* Overall information about text widget. */ - int line; /* Index of line to layout. */ - TkTextLine *linePtr; /* Line to layout (corresponds to line). */ - TagInfo *tInfoPtr; /* Information to help keep track of tags. - * Caller must have initialized to correspond - * to state just before start of line. */ -{ - DLine *firstLinePtr; - DLine *lastLinePtr = NULL; /* Initializations needed only to stop */ - Chunk *lastChunkPtr = NULL; /* compiler warnings. */ - register DLine *dlPtr; - register Chunk *chunkPtr; - StyleValues styleValues; - int ch, charsThatFit, ascent, descent, x, maxX; - - firstLinePtr = NULL; - - /* - * Each iteration of the loop below creates one DLine structure. - */ - - ch = 0; - while (1) { - - /* - * Create and initialize a new DLine structure. - */ - - dlPtr = (DLine *) ckalloc(sizeof(DLine)); - dlPtr->linePtr = linePtr; - dlPtr->y = 0; - dlPtr->oldY = -1; - dlPtr->chunkPtr = NULL; - dlPtr->nextPtr = NULL; - if (firstLinePtr == NULL) { - firstLinePtr = dlPtr; - } else { - lastLinePtr->nextPtr = dlPtr; - } - lastLinePtr = dlPtr; - - /* - * Each iteration of the loop below creates one Chunk for the - * new display line. Be sure always to create at least one chunk. - */ - - x = textPtr->dInfoPtr->x; - maxX = textPtr->dInfoPtr->maxX; - ascent = descent = 0; - do { - chunkPtr = (Chunk *) ckalloc(sizeof(Chunk)); - chunkPtr->numChars = linePtr->numBytes - ch; - chunkPtr->text = linePtr->bytes + ch; - chunkPtr->x = x; - chunkPtr->nextPtr = NULL; - if (dlPtr->chunkPtr == NULL) { - dlPtr->chunkPtr = chunkPtr; - } else { - lastChunkPtr->nextPtr = chunkPtr; - } - lastChunkPtr = chunkPtr; - - /* - * Update the tag array to include any tag transitions up - * through the current position, then find the next position - * with a transition on a tag that impacts the way things are - * displayed. - */ - - while (1) { - int affectsDisplay; - TkTextTag *tagPtr; - - if ((tInfoPtr->search.linePtr == NULL) - || (tInfoPtr->search.line1 > line)) { - break; - } - tagPtr = tInfoPtr->search.tagPtr; - affectsDisplay = TK_TAG_AFFECTS_DISPLAY(tagPtr); - if ((tInfoPtr->search.line1 < line) - || (tInfoPtr->search.ch1 <= ch)) { - if (affectsDisplay) { - ToggleTag(tInfoPtr, tagPtr); - } - } else { - if (affectsDisplay) { - chunkPtr->numChars = tInfoPtr->search.ch1 - ch; - break; - } - } - (void) TkBTreeNextTag(&tInfoPtr->search); - } - - /* - * Create style information for this chunk. - */ - - ComputeStyleValues(textPtr, tInfoPtr->numTags, tInfoPtr->tagPtrs, - &styleValues); - chunkPtr->stylePtr = GetStyle(textPtr, &styleValues); - - /* - * See how many characters will fit on the line. If they don't - * all fit, then a number of compensations may have to be made. - * - * 1. Make sure that at least one character is displayed on - * each line. - * 2. In wrap mode "none", allow a partial character to be - * displayed at the end of an incomplete line. - * 3. In wrap mode "word", search back to find the last space - * character, and terminate the line just after that space - * character. This involves a couple of extra complexities: - * - the last space may be several chunks back; in this - * case, delete all the chunks that are after the - * space. - * - if no words fit at all, then use character-wrap for - * this DLine. - * - have to reinitialize the tag search information, since - * we may back up over tag toggles (they'll need to be - * reconsidered on the next DLine). - */ - - charsThatFit = TkMeasureChars(styleValues.fontPtr, - chunkPtr->text, chunkPtr->numChars, chunkPtr->x, - maxX, 0, &x); - if ((charsThatFit < chunkPtr->numChars) || (x >= maxX)) { - x = maxX; - chunkPtr->numChars = charsThatFit; - ch += charsThatFit; - if (ch < (linePtr->numBytes - 1)) { - if ((charsThatFit == 0) && (chunkPtr == dlPtr->chunkPtr)) { - chunkPtr->numChars = 1; - ch++; - } else if (textPtr->wrapMode == tkTextWordUid) { - if (isspace(UCHAR(chunkPtr->text[charsThatFit]))) { - ch += 1; /* Include space on this line. */ - } else { - register Chunk *chunkPtr2; - register char *p; - Chunk *spaceChunkPtr; - int count, space; - - spaceChunkPtr = NULL; - space = 0; - for (chunkPtr2 = dlPtr->chunkPtr; - chunkPtr2 != NULL; - chunkPtr2 = chunkPtr2->nextPtr) { - for (count = chunkPtr2->numChars - 1, - p = chunkPtr2->text + count; - count >= 0; count--, p--) { - if (isspace(UCHAR(*p))) { - spaceChunkPtr = chunkPtr2; - space = count; - break; - } - } - } - if (spaceChunkPtr != NULL) { - spaceChunkPtr->numChars = space; - ch = (spaceChunkPtr->text + space + 1) - - linePtr->bytes; - if (chunkPtr != spaceChunkPtr) { - chunkPtr = spaceChunkPtr; - if (tInfoPtr->tagPtrs != NULL) { - ckfree((char *) tInfoPtr->tagPtrs); - } - tInfoPtr->tagPtrs = TkBTreeGetTags( - textPtr->tree, dlPtr->linePtr, ch, - &tInfoPtr->numTags); - TkBTreeStartSearch(textPtr->tree, line, - ch+1, - TkBTreeNumLines(textPtr->tree), 0, - (TkTextTag *) NULL, - &tInfoPtr->search); - (void) TkBTreeNextTag(&tInfoPtr->search); - tInfoPtr->arraySize = tInfoPtr->numTags; - while (chunkPtr->nextPtr != NULL) { - chunkPtr2 = chunkPtr->nextPtr; - chunkPtr->nextPtr = chunkPtr2->nextPtr; - FreeStyle(textPtr, chunkPtr2->stylePtr); - ckfree((char *) chunkPtr2); - } - } - } - } - } else if (textPtr->wrapMode == tkTextNoneUid) { - chunkPtr->numChars++; - ch++; - } - } - } else { - ch += chunkPtr->numChars; - } - - /* - * Update height information for use later in computing - * line's overall height and baseline. - */ - - if (styleValues.fontPtr->ascent > ascent) { - ascent = styleValues.fontPtr->ascent; - } - if (styleValues.fontPtr->descent > descent) { - descent = styleValues.fontPtr->descent; - } - } while (x < maxX); - - dlPtr->height = ascent + descent; - dlPtr->baseline = ascent; - - /* - * Quit when every character but the last character (the newline) - * has been accounted for. Also quit if the wrap mode is "none": - * this ignores all the characters that don't fit on the first - * line. - */ - - if ((ch >= (linePtr->numBytes-1)) - || (textPtr->wrapMode == tkTextNoneUid)) { - break; - } - } - return firstLinePtr; -} - -/* - *---------------------------------------------------------------------- - * - * ToggleTag -- - * - * Update information about tags to reflect a transition on a - * particular tag. - * - * Results: - * The array at *tInfoPtr is modified to include tagPtr if it - * didn't already or to exclude it if it used to include it. - * The array will be reallocated to a larger size if needed. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -ToggleTag(tInfoPtr, tagPtr) - register TagInfo *tInfoPtr; /* Tag information to be updated. */ - TkTextTag *tagPtr; /* Tag to be toggled into or out of - * *tInfoPtr. */ -{ - register TkTextTag **tagPtrPtr; - int i; - - for (i = tInfoPtr->numTags, tagPtrPtr = tInfoPtr->tagPtrs; - i > 0; i--, tagPtrPtr++) { - if (*tagPtrPtr == tagPtr) { - tInfoPtr->numTags--; - *tagPtrPtr = tInfoPtr->tagPtrs[tInfoPtr->numTags]; - return; - } - } - - /* - * Tag not currently in array. Grow the array if necessary, then - * add the tag to it. - */ - - if (tInfoPtr->numTags == tInfoPtr->arraySize) { - TkTextTag **newPtrs; - - newPtrs = (TkTextTag **) ckalloc((unsigned) - ((tInfoPtr->arraySize+10) * sizeof(TkTextTag *))); - if (tInfoPtr->tagPtrs != NULL) { - memcpy((VOID *) newPtrs, (VOID *) tInfoPtr->tagPtrs, - tInfoPtr->arraySize * sizeof(TkTextTag *)); - ckfree((char *) tInfoPtr->tagPtrs); - } - tInfoPtr->tagPtrs = newPtrs; - tInfoPtr->arraySize += 10; - } - tInfoPtr->tagPtrs[tInfoPtr->numTags] = tagPtr; - tInfoPtr->numTags++; -} - -/* - *---------------------------------------------------------------------- - * - * UpdateDisplayInfo -- - * - * This procedure is invoked to recompute some or all of the - * DLine structures for a text widget. At the time it is called - * the DLine structures still left in the widget are guaranteed - * to be correct (except for their y-coordinates), but there may - * be missing structures (the DLine structures get removed as - * soon as they are potentially out-of-date). - * - * Results: - * None. - * - * Side effects: - * Upon return, the DLine information for textPtr correctly reflects - * the positions where characters will be displayed. However, this - * procedure doesn't actually bring the display up-to-date. - * - *---------------------------------------------------------------------- - */ - -static void -UpdateDisplayInfo(textPtr) - TkText *textPtr; /* Text widget to update. */ -{ - register DInfo *dInfoPtr = textPtr->dInfoPtr; - register DLine *dlPtr, *prevPtr, *dlPtr2; - TkTextLine *linePtr; - TagInfo tagInfo; - int line, y, maxY; - - if (!(dInfoPtr->flags & DINFO_OUT_OF_DATE)) { - return; - } - dInfoPtr->flags &= ~DINFO_OUT_OF_DATE; - - linePtr = textPtr->topLinePtr; - dlPtr = dInfoPtr->dLinePtr; - tagInfo.tagPtrs = TkBTreeGetTags(textPtr->tree, linePtr, 0, - &tagInfo.numTags); - tagInfo.arraySize = tagInfo.numTags; - - /* - * Tricky point: initialize the tag search just *after* the first - * character in the line, since the tagInfo structure already has all - * the tags for the first character. - */ - - line = TkBTreeLineIndex(linePtr); - TkBTreeStartSearch(textPtr->tree, line, 1, TkBTreeNumLines(textPtr->tree), - 0, (TkTextTag *) NULL, &tagInfo.search); - TkBTreeNextTag(&tagInfo.search); - prevPtr = NULL; - y = dInfoPtr->y; - maxY = dInfoPtr->maxY; - while (linePtr != NULL) { - register DLine *newPtr; - /* - * See if the next DLine matches the next line we want to - * appear on the screen. If so then we can just use its - * information. If not then create new DLine structures - * for the desired line and insert them into the list. - */ - - if ((dlPtr == NULL) || (dlPtr->linePtr != linePtr)) { - newPtr = LayoutLine(textPtr, line, linePtr, &tagInfo); - if (prevPtr == NULL) { - dInfoPtr->dLinePtr = newPtr; - } else { - prevPtr->nextPtr = newPtr; - } - for (dlPtr2 = newPtr; dlPtr2->nextPtr != NULL; - dlPtr2 = dlPtr2->nextPtr) { - /* Empty loop body. */ - } - dlPtr2->nextPtr = dlPtr; - dlPtr = newPtr; - } - - /* - * Skip to the next line, and update the y-position while - * skipping. - */ - - do { - dlPtr->y = y; - y += dlPtr->height; - prevPtr = dlPtr; - dlPtr = dlPtr->nextPtr; - } while ((dlPtr != NULL) && (dlPtr->linePtr == linePtr)); - linePtr = TkBTreeNextLine(linePtr); - line++; - - /* - * It's important to have the following check here rather than in - * the while statement for the loop, so that there's always at least - * one DLine generated, regardless of how small the window is. This - * keeps a lot of other code from breaking. - */ - - if (y >= maxY) { - break; - } - } - - /* - * Delete any DLine structures that don't fit on the screen and free - * up the tag array. - */ - - FreeDLines(textPtr, dlPtr, (DLine *) NULL, 1); - if (tagInfo.tagPtrs != NULL) { - ckfree((char *) tagInfo.tagPtrs); - } - - /* - * Arrange for scrollbars to be updated. - */ - - textPtr->flags |= UPDATE_SCROLLBARS; -} - -/* - *---------------------------------------------------------------------- - * - * FreeDLines -- - * - * This procedure is called to free up all of the resources - * associated with one or more DLine structures. - * - * Results: - * None. - * - * Side effects: - * Memory gets freed and various other resources are released. - * - *---------------------------------------------------------------------- - */ - -static void -FreeDLines(textPtr, firstPtr, lastPtr, unlink) - TkText *textPtr; /* Information about overall text - * widget. */ - register DLine *firstPtr; /* Pointer to first DLine to free up. */ - DLine *lastPtr; /* Pointer to DLine just after last - * one to free (NULL means everything - * starting with firstPtr). */ - int unlink; /* 1 means DLines are currently linked - * into the list rooted at - * textPtr->dInfoPtr->dLinePtr and - * they have to be unlinked. 0 means - * just free without unlinking. */ -{ - register Chunk *chunkPtr, *nextChunkPtr; - register DLine *nextDLinePtr; - - if (unlink) { - if (textPtr->dInfoPtr->dLinePtr == firstPtr) { - textPtr->dInfoPtr->dLinePtr = lastPtr; - } else { - register DLine *prevPtr; - for (prevPtr = textPtr->dInfoPtr->dLinePtr; - prevPtr->nextPtr != firstPtr; prevPtr = prevPtr->nextPtr) { - /* Empty loop body. */ - } - prevPtr->nextPtr = lastPtr; - } - } - while (firstPtr != lastPtr) { - nextDLinePtr = firstPtr->nextPtr; - for (chunkPtr = firstPtr->chunkPtr; chunkPtr != NULL; - chunkPtr = nextChunkPtr) { - FreeStyle(textPtr, chunkPtr->stylePtr); - nextChunkPtr = chunkPtr->nextPtr; - ckfree((char *) chunkPtr); - } - ckfree((char *) firstPtr); - firstPtr = nextDLinePtr; - } -} - -/* - *---------------------------------------------------------------------- - * - * DisplayDLine -- - * - * This procedure is invoked to draw a single line on the - * screen. - * - * Results: - * None. - * - * Side effects: - * The line given by dlPtr is drawn at its correct position in - * textPtr's window. Note that this is one *display* line, not - * one *text* line. - * - *---------------------------------------------------------------------- - */ - -static void -DisplayDLine(textPtr, dlPtr, pixmap) - TkText *textPtr; /* Text widget in which to draw line. */ - register DLine *dlPtr; /* Information about line to draw. */ - Pixmap pixmap; /* Pixmap to use for double-buffering. - * Caller must make sure it's large enough - * to hold line. */ -{ - register Style *stylePtr; - register StyleValues *sValuePtr; - register Chunk *chunkPtr; - DInfo *dInfoPtr = textPtr->dInfoPtr; - Display *display; - int width, height, count, x; - XFontStruct *fontPtr; - - /* - * First, clear the area of the line to the background color for the - * text widget. - */ - - display = Tk_Display(textPtr->tkwin); - Tk_Fill3DRectangle(display, pixmap, textPtr->border, 0, 0, - Tk_Width(textPtr->tkwin), dlPtr->height, 0, TK_RELIEF_FLAT); - - /* - * Next, cycle through all of the chunks in the line displaying - * backgrounds. We need to do two passes, one for the backgrounds - * and one for the characters, because some characters (e.g. italics - * with heavy slants) may cross background boundaries. If some - * backgrounds are drawn after some text, the later backgrounds may - * obliterate parts of earlier characters. - */ - - for (chunkPtr = dlPtr->chunkPtr; chunkPtr != NULL; - chunkPtr = chunkPtr->nextPtr) { - - /* - * Draw a special background for this chunk if one is specified - * in its style. Two tricks here: - * 1. if this is the last chunk in the line then extend the - * background across to the end of the line. - * 2. if the background is stippled, then we have to draw the - * stippled part specially, since Tk_Fill3DRectangle doesn't - * do stipples. - */ - - stylePtr = chunkPtr->stylePtr; - sValuePtr = stylePtr->sValuePtr; - if (sValuePtr->border != NULL) { - if (chunkPtr->nextPtr != NULL) { - width = chunkPtr->nextPtr->x - chunkPtr->x; - } else { - width = Tk_Width(textPtr->tkwin) - chunkPtr->x; - } - if (stylePtr->bgGC != None) { - XFillRectangle(display, pixmap, stylePtr->bgGC, chunkPtr->x, - 0, (unsigned int) width, (unsigned int) dlPtr->height); - Tk_Draw3DRectangle(display, pixmap, sValuePtr->border, - chunkPtr->x, 0, width, dlPtr->height, - sValuePtr->borderWidth, sValuePtr->relief); - } else { - Tk_Fill3DRectangle(display, pixmap, sValuePtr->border, - chunkPtr->x, 0, width, dlPtr->height, - sValuePtr->borderWidth, sValuePtr->relief); - } - } - } - - /* - * If the insertion cursor is displayed on this line, then draw it - * now, on top of the background but before the text. As a special - * hack to keep the cursor visible on mono displays, write the default - * background in the cursor area (instead of nothing) when the cursor - * isn't on. Otherwise the selection would hide the cursor. - */ - - if ((textPtr->insertAnnotPtr->linePtr == dlPtr->linePtr) - && (textPtr->state == tkTextNormalUid) - && (textPtr->flags & GOT_FOCUS)) { - for (chunkPtr = dlPtr->chunkPtr; chunkPtr != NULL; - chunkPtr = chunkPtr->nextPtr) { - count = textPtr->insertAnnotPtr->ch - - (chunkPtr->text - dlPtr->linePtr->bytes); - if (count < 0) { - break; - } - if (count > chunkPtr->numChars) { - continue; - } - - /* - * Deciding whether to display the cursor just after the last - * character in a line is tricky because of various wrap - * modes. Do it unless we're in character wrap mode and - * this line wraps, in which case it's better to display the - * cursor on the next line. For word wrap, there's an - * undisplayed space character that the user must be able to - * position the cursor in front of. For no wrap, there's no - * next line on which to display the cursor. - */ - if ((count == chunkPtr->numChars) - && (textPtr->wrapMode == tkTextCharUid) - && (chunkPtr->text[count] != '\n')) { - continue; - } - fontPtr = chunkPtr->stylePtr->sValuePtr->fontPtr; - TkMeasureChars(fontPtr, chunkPtr->text, count, chunkPtr->x, - (int) 1000000, 0, &x); - if (textPtr->flags & INSERT_ON) { - Tk_Fill3DRectangle(display, pixmap, textPtr->insertBorder, - x - textPtr->insertWidth/2, - dlPtr->baseline - fontPtr->ascent, - textPtr->insertWidth, - fontPtr->ascent + fontPtr->descent, - textPtr->insertBorderWidth, TK_RELIEF_RAISED); - } else if (Tk_GetColorModel(textPtr->tkwin) != TK_COLOR) { - Tk_Fill3DRectangle(display, pixmap, textPtr->border, - x - textPtr->insertWidth/2, - dlPtr->baseline - fontPtr->ascent, - textPtr->insertWidth, - fontPtr->ascent + fontPtr->descent, - 0, TK_RELIEF_FLAT); - } - - } - } - - /* - * Make another pass through all of the chunks to redraw all of - * the text (and underlines, etc., if they're wanted). - */ - - for (chunkPtr = dlPtr->chunkPtr; chunkPtr != NULL; - chunkPtr = chunkPtr->nextPtr) { - stylePtr = chunkPtr->stylePtr; - sValuePtr = stylePtr->sValuePtr; - if (chunkPtr->numChars > 0) { - TkDisplayChars(display, pixmap, stylePtr->fgGC, sValuePtr->fontPtr, - chunkPtr->text, chunkPtr->numChars, chunkPtr->x, - dlPtr->baseline, 0); - if (sValuePtr->underline) { - TkUnderlineChars(display, pixmap, stylePtr->fgGC, - sValuePtr->fontPtr, chunkPtr->text, chunkPtr->x, - dlPtr->baseline, 0, 0, chunkPtr->numChars-1); - } - } - } - - /* - * Copy the pixmap onto the screen. If this is the last line on - * the screen, only copy a piece of the line, so that it doesn't - * overflow into the border area. Another special trick: copy the - * padding area to the left of the line; this is because the - * insertion cursor sometimes overflows onto that area and we want - * to get as much of the cursor as possible. - */ - - height = dlPtr->height; - if ((height + dlPtr->y) > dInfoPtr->maxY) { - height = dInfoPtr->maxY - dlPtr->y; - } - XCopyArea(display, pixmap, Tk_WindowId(textPtr->tkwin), - dInfoPtr->copyGC, dInfoPtr->x - textPtr->padX, 0, - dInfoPtr->maxX - (dInfoPtr->x - textPtr->padX), - height, dInfoPtr->x - textPtr->padX, dlPtr->y); - linesRedrawn++; -} - -/* - *---------------------------------------------------------------------- - * - * DisplayText -- - * - * This procedure is invoked as a when-idle handler to update the - * display. It only redisplays the parts of the text widget that - * are out of date. - * - * Results: - * None. - * - * Side effects: - * Information is redrawn on the screen. - * - *---------------------------------------------------------------------- - */ - -static void -DisplayText(clientData) - ClientData clientData; /* Information about widget. */ -{ - register TkText *textPtr = (TkText *) clientData; - DInfo *dInfoPtr = textPtr->dInfoPtr; - Tk_Window tkwin; - register DLine *dlPtr; - Pixmap pixmap; - int maxHeight; - int bottomY = 0; /* Initialization needed only to stop - * compiler warnings. */ - - if ((textPtr->tkwin == NULL) || !Tk_IsMapped(textPtr->tkwin) - || (dInfoPtr->maxX <= dInfoPtr->x) - || (dInfoPtr->maxY <= dInfoPtr->y)) { - UpdateDisplayInfo(textPtr); - goto doScrollbars; - } - numRedisplays++; - - /* - * Choose a new current item if that is needed (this could cause - * event handlers to be invoked, hence the preserve/release calls - * and the loop, since the handlers could conceivably necessitate - * yet another current item calculation). The tkwin check is because - * the whole window could go away in the Tk_Release call. - */ - - while (dInfoPtr->flags & REPICK_NEEDED) { - Tk_Preserve((ClientData) textPtr); - dInfoPtr->flags &= ~REPICK_NEEDED; - TkTextPickCurrent(textPtr, &textPtr->pickEvent); - tkwin = textPtr->tkwin; - Tk_Release((ClientData) textPtr); - if (tkwin == NULL) { - return; - } - } - - /* - * First recompute what's supposed to be displayed. - */ - - UpdateDisplayInfo(textPtr); - - /* - * Redraw the borders if that's needed. - */ - - if (dInfoPtr->flags & REDRAW_BORDERS) { - Tk_Draw3DRectangle(Tk_Display(textPtr->tkwin), - Tk_WindowId(textPtr->tkwin), textPtr->border, - 0, 0, Tk_Width(textPtr->tkwin), Tk_Height(textPtr->tkwin), - textPtr->borderWidth, textPtr->relief); - } - - /* - * See if it's possible to bring some parts of the screen up-to-date - * by scrolling (copying from other parts of the screen). - */ - - for (dlPtr = dInfoPtr->dLinePtr; dlPtr != NULL; dlPtr = dlPtr->nextPtr) { - register DLine *dlPtr2; - int offset, height, y; - - if ((dlPtr->oldY == -1) || (dlPtr->y == dlPtr->oldY) - || ((dlPtr->oldY + dlPtr->height) > dInfoPtr->maxY)) { - continue; - } - - /* - * This line is already drawn somewhere in the window so it only - * needs to be copied to its new location. See if there's a group - * of lines that can all be copied together. - */ - - offset = dlPtr->y - dlPtr->oldY; - height = dlPtr->height; - y = dlPtr->y; - for (dlPtr2 = dlPtr->nextPtr; dlPtr2 != NULL; - dlPtr2 = dlPtr2->nextPtr) { - if ((dlPtr2->oldY == -1) - || ((dlPtr2->oldY + offset) != dlPtr2->y) - || ((dlPtr2->oldY + dlPtr2->height) > dInfoPtr->maxY)) { - break; - } - height += dlPtr2->height; - } - - /* - * Copy the information and update the lines to show that they've - * been copied. Reduce the height of the area being copied if - * necessary to avoid overwriting the border area. - */ - - if ((y + height) > dInfoPtr->maxY) { - height = dInfoPtr->maxY -y; - } - XCopyArea(Tk_Display(textPtr->tkwin), Tk_WindowId(textPtr->tkwin), - Tk_WindowId(textPtr->tkwin), dInfoPtr->scrollGC, - dInfoPtr->x - textPtr->padX, dlPtr->oldY, - dInfoPtr->maxX - (dInfoPtr->x - textPtr->padX), - height, dInfoPtr->x - textPtr->padX, y); - numCopies++; - while (1) { - dlPtr->oldY = dlPtr->y; - if (dlPtr->nextPtr == dlPtr2) { - break; - } - dlPtr = dlPtr->nextPtr; - } - - /* - * Scan through the lines following the copied ones to see if - * we just overwrote them with the copy operation. If so, mark - * them for redisplay. - */ - - for ( ; dlPtr2 != NULL; dlPtr2 = dlPtr2->nextPtr) { - if ((dlPtr2->oldY != -1) - && ((dlPtr2->oldY + dlPtr2->height) > y) - && (dlPtr2->oldY < (y + height))) { - dlPtr2->oldY = -1; - } - } - - /* - * It's possible that part of the area copied above was obscured. - * To handle this situation, read expose-related events generated - * during the XCopyArea operation. - */ - - while (1) { - XEvent event; - - XWindowEvent(Tk_Display(textPtr->tkwin), - Tk_WindowId(textPtr->tkwin), ExposureMask, &event); - if (event.type == NoExpose) { - break; - } else if (event.type == GraphicsExpose) { - TkTextRedrawRegion(textPtr, event.xgraphicsexpose.x, - event.xgraphicsexpose.y, event.xgraphicsexpose.width, - event.xgraphicsexpose.height); - if (event.xgraphicsexpose.count == 0) { - damagedCopies++; - break; - } - } else if (event.type == Expose) { - /* - * A tricky situation. This event must already have been - * queued up before the XCopyArea was issued. If the area - * in this event overlaps the area copied, then some of the - * bits that were copied were bogus. The easiest way to - * handle this is to issue two redisplays: one for the - * original area and one for the area shifted as if it was - * in the copied area. - */ - - TkTextRedrawRegion(textPtr, event.xexpose.x, - event.xexpose.y, event.xexpose.width, - event.xexpose.height); - TkTextRedrawRegion(textPtr, event.xexpose.x, - event.xexpose.y + offset, event.xexpose.width, - event.xexpose.height); - } else { - panic("DisplayText received unknown exposure event"); - } - } - } - - /* - * Now we have to redraw the lines that couldn't be updated by - * scrolling. First, compute the height of the largest line and - * allocate an off-screen pixmap to use for double-buffered - * displays. - */ - - maxHeight = -1; - for (dlPtr = dInfoPtr->dLinePtr; dlPtr != NULL; - dlPtr = dlPtr->nextPtr) { - if ((dlPtr->height > maxHeight) && (dlPtr->oldY != dlPtr->y)) { - maxHeight = dlPtr->height; - } - bottomY = dlPtr->y + dlPtr->height; - } - if (maxHeight > dInfoPtr->maxY) { - maxHeight = dInfoPtr->maxY; - } - if (maxHeight >= 0) { - pixmap = XCreatePixmap(Tk_Display(textPtr->tkwin), - Tk_WindowId(textPtr->tkwin), Tk_Width(textPtr->tkwin), - maxHeight, Tk_Depth(textPtr->tkwin)); - for (dlPtr = textPtr->dInfoPtr->dLinePtr; - (dlPtr != NULL) && (dlPtr->y < dInfoPtr->maxY); - dlPtr = dlPtr->nextPtr) { - if (dlPtr->oldY != dlPtr->y) { - DisplayDLine(textPtr, dlPtr, pixmap); - dlPtr->oldY = dlPtr->y; - } - } - XFreePixmap(Tk_Display(textPtr->tkwin), pixmap); - } - - /* - * Lastly, see if we need to refresh the part of the window below - * the last line of text (if there is any such area). Refresh the - * padding area on the left too, since the insertion cursor might - * have been displayed there previously). - */ - - if (dInfoPtr->topOfEof > dInfoPtr->maxY) { - dInfoPtr->topOfEof = dInfoPtr->maxY; - } - if (bottomY < dInfoPtr->topOfEof) { - Tk_Fill3DRectangle(Tk_Display(textPtr->tkwin), - Tk_WindowId(textPtr->tkwin), textPtr->border, - dInfoPtr->x - textPtr->padX, bottomY, - dInfoPtr->maxX - (dInfoPtr->x - textPtr->padX), - dInfoPtr->topOfEof-bottomY, 0, TK_RELIEF_FLAT); - } - dInfoPtr->topOfEof = bottomY; - if (dInfoPtr->topOfEof > dInfoPtr->maxY) { - dInfoPtr->topOfEof = dInfoPtr->maxY; - } - - doScrollbars: - - /* - * Update the vertical scrollbar, if there is one. - */ - - if ((textPtr->flags & UPDATE_SCROLLBARS) && (textPtr->yScrollCmd != NULL)) { - int numLines, first, result, maxY, height; - TkTextLine *linePtr; - char string[60]; - - /* - * Count the number of text lines on the screen. - */ - - textPtr->flags &= ~UPDATE_SCROLLBARS; - maxY = 0; - for (numLines = 0, linePtr = NULL, dlPtr = dInfoPtr->dLinePtr; - dlPtr != NULL; dlPtr = dlPtr->nextPtr) { - if (dlPtr->linePtr != linePtr) { - numLines++; - linePtr = dlPtr->linePtr; - } - maxY = dlPtr->y + dlPtr->height; - } - - /* - * If the screen isn't completely full, then estimate the number of - * lines that would fit on it if it were full. - */ - - height = dInfoPtr->maxY - dInfoPtr->y; - if (numLines == 0) { - numLines = height / - (textPtr->fontPtr->ascent + textPtr->fontPtr->descent); - } else if (maxY < height) { - numLines = (numLines * height)/maxY; - } - first = TkBTreeLineIndex(dInfoPtr->dLinePtr->linePtr); - sprintf(string, " %d %d %d %d", TkBTreeNumLines(textPtr->tree), - numLines, first, first+numLines-1); - result = Tcl_VarEval(textPtr->interp, textPtr->yScrollCmd, string, - (char *) NULL); - if (result != TCL_OK) { - Tcl_AddErrorInfo(textPtr->interp, - "\n (horizontal scrolling command executed by text)"); - Tk_BackgroundError(textPtr->interp); - } - } - - dInfoPtr->flags &= ~(REDRAW_PENDING|REDRAW_BORDERS); -} - -/* - *---------------------------------------------------------------------- - * - * TkTextRedrawRegion -- - * - * This procedure is invoked to schedule a redisplay for a given - * region of a text widget. The redisplay itself may not occur - * immediately: it's scheduled as a when-idle handler. - * - * Results: - * None. - * - * Side effects: - * Information will eventually be redrawn on the screen. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -void -TkTextRedrawRegion(textPtr, x, y, width, height) - TkText *textPtr; /* Widget record for text widget. */ - int x, y; /* Coordinates of upper-left corner of area - * to be redrawn, in pixels relative to - * textPtr's window. */ - int width, height; /* Width and height of area to be redrawn. */ -{ - register DLine *dlPtr; - DInfo *dInfoPtr = textPtr->dInfoPtr; - int maxY; - - /* - * Find all lines that overlap the given region and mark them for - * redisplay. - */ - - maxY = y + height; - for (dlPtr = dInfoPtr->dLinePtr; dlPtr != NULL; - dlPtr = dlPtr->nextPtr) { - if (((dlPtr->y + dlPtr->height) > y) && (dlPtr->y < maxY)) { - dlPtr->oldY = -1; - } - } - if (dInfoPtr->topOfEof < maxY) { - dInfoPtr->topOfEof = maxY; - } - - /* - * Schedule the redisplay operation if there isn't one already - * scheduled. - */ - - if (!(dInfoPtr->flags & REDRAW_PENDING)) { - dInfoPtr->flags |= REDRAW_PENDING; - Tk_DoWhenIdle(DisplayText, (ClientData) textPtr); - } - if ((x < dInfoPtr->x) || (y < dInfoPtr->y) - || ((x + width) > dInfoPtr->maxX) || (maxY > dInfoPtr->maxY)) { - dInfoPtr->flags |= REDRAW_BORDERS; - } -} - -/* - *---------------------------------------------------------------------- - * - * TkTextLinesChanged -- - * - * This procedure is invoked when lines in a text widget are about - * to be modified in a way that changes how they are displayed (e.g. - * characters were inserted, the line was deleted, or tag information - * was changed). This procedure must be called *before* a change is - * made, so that pointers to TkTextLines in the display information - * are still valid. - * - * Results: - * None. - * - * Side effects: - * The indicated lines will be redisplayed at some point in the - * future (the actual redisplay is scheduled as a when-idle handler). - * - *---------------------------------------------------------------------- - */ - -void -TkTextLinesChanged(textPtr, first, last) - TkText *textPtr; /* Widget record for text widget. */ - int first; /* Index of first line that must be - * redisplayed. */ - int last; /* Index of last line to redisplay. */ -{ - DInfo *dInfoPtr = textPtr->dInfoPtr; - DLine *firstPtr, *lastPtr; - - /* - * Find the DLines corresponding to first and last+1. - */ - - firstPtr = FindDLine(dInfoPtr->dLinePtr, first); - if (firstPtr == NULL) { - return; - } - lastPtr = FindDLine(dInfoPtr->dLinePtr, last+1); - if (firstPtr == lastPtr) { - return; - } - - /* - * Delete all the DLines from first up through last (but not including - * lastPtr, which points to the first line *outside* the range). - */ - - FreeDLines(textPtr, firstPtr, lastPtr, 1); - - /* - * Schedule both a redisplay and a recomputation of display information. - */ - - if (!(dInfoPtr->flags & REDRAW_PENDING)) { - Tk_DoWhenIdle(DisplayText, (ClientData) textPtr); - } - dInfoPtr->flags |= REDRAW_PENDING|DINFO_OUT_OF_DATE|REPICK_NEEDED; -} - -/* - *---------------------------------------------------------------------- - * - * TkTextRedrawTag -- - * - * This procedure is invoked to request a redraw of all characters - * in a given range of characters that have a particular tag on or - * off. It's called, for example, when characters are tagged or - * untagged, or when tag options change. - * - * Results: - * None. - * - * Side effects: - * Information on the screen may be redrawn, and the layout of - * the screen may change. - * - *---------------------------------------------------------------------- - */ - -void -TkTextRedrawTag(textPtr, line1, ch1, line2, ch2, tagPtr, withTag) - TkText *textPtr; /* Widget record for text widget. */ - int line1, ch1; /* Index of first character in range of - * interest. */ - int line2, ch2; /* Index of character just after last one - * in range of interest. */ - TkTextTag *tagPtr; /* Information about tag. */ - int withTag; /* 1 means redraw characters that have the - * tag, 0 means redraw those without. */ -{ - register DLine *dlPtr; - DLine *endPtr; - int topLine, tagOn; - TkTextSearch search; - DInfo *dInfoPtr = textPtr->dInfoPtr; - - /* - * Round up the starting position if it's before the first line - * visible on the screen (we only care about what's on the screen). - */ - - dlPtr = dInfoPtr->dLinePtr; - if (dlPtr == NULL) { - return; - } - topLine = TkBTreeLineIndex(dlPtr->linePtr); - if (topLine > line1) { - line1 = topLine; - ch1 = 0; - } - - /* - * Initialize a search through all transitions on the tag, starting - * with the first transition where the tag's current state is different - * from what it will eventually be. - */ - - TkBTreeStartSearch(textPtr->tree, line1, ch1+1, line2, ch2, - tagPtr, &search); - if (search.linePtr == NULL) { - return; - } - tagOn = TkBTreeCharTagged(search.linePtr, ch1, tagPtr); - if (tagOn != withTag) { - if (!TkBTreeNextTag(&search)) { - return; - } - } - - /* - * Each loop through the loop below is for one range of characters - * where the tag's current state is different than its eventual - * state. At the top of the loop, search contains information about - * the first character in the range. - */ - - while (1) { - /* - * Find the first DLine structure in the range. - */ - - dlPtr = FindDLine(dlPtr, search.line1); - if (dlPtr == NULL) { - break; - } - - /* - * Find the first DLine structure that's past the end of the range. - */ - - if (TkBTreeNextTag(&search)) { - endPtr = FindDLine(dlPtr, - (search.ch1 > 0) ? (search.line1 + 1) : search.line1); - } else { - endPtr = FindDLine(dlPtr, - (ch2 > 0) ? (search.line2 + 1) : search.line2); - } - - /* - * Delete all of the display lines in the range, so that they'll - * be re-layed out and redrawn. - */ - - FreeDLines(textPtr, dlPtr, endPtr, 1); - dlPtr = endPtr; - - /* - * Find the first text line in the next range. - */ - - if (!TkBTreeNextTag(&search)) { - break; - } - } - - /* - * Lastly, schedule a redisplay and layout recalculation if they - * aren't already pending. - */ - - if (!(dInfoPtr->flags & REDRAW_PENDING)) { - Tk_DoWhenIdle(DisplayText, (ClientData) textPtr); - } - dInfoPtr->flags |= REDRAW_PENDING|DINFO_OUT_OF_DATE|REPICK_NEEDED; -} - -/* - *---------------------------------------------------------------------- - * - * TkTextRelayoutWindow -- - * - * This procedure is called when something has happened that - * invalidates the whole layout of characters on the screen, such - * as a change in a configuration option for the overall text - * widget or a change in the window size. It causes all display - * information to be recomputed and the window to be redrawn. - * - * Results: - * None. - * - * Side effects: - * All the display information will be recomputed for the window - * and the window will be redrawn. - * - *---------------------------------------------------------------------- - */ - -void -TkTextRelayoutWindow(textPtr) - TkText *textPtr; /* Widget record for text widget. */ -{ - DInfo *dInfoPtr = textPtr->dInfoPtr; - - /* - * Throw away all the current layout information. - */ - - FreeDLines(textPtr, dInfoPtr->dLinePtr, (DLine *) NULL, 1); - dInfoPtr->dLinePtr = NULL; - - /* - * Recompute some overall things for the layout. - */ - - dInfoPtr->x = textPtr->borderWidth + textPtr->padX; - dInfoPtr->y = textPtr->borderWidth + textPtr->padY; - dInfoPtr->maxX = Tk_Width(textPtr->tkwin) - dInfoPtr->x; - dInfoPtr->maxY = Tk_Height(textPtr->tkwin) - dInfoPtr->y; - dInfoPtr->topOfEof = dInfoPtr->maxY; - - if (!(dInfoPtr->flags & REDRAW_PENDING)) { - Tk_DoWhenIdle(DisplayText, (ClientData) textPtr); - } - dInfoPtr->flags |= REDRAW_PENDING|REDRAW_BORDERS|DINFO_OUT_OF_DATE - |REPICK_NEEDED; -} - -/* - *---------------------------------------------------------------------- - * - * TkTextSetView -- - * - * This procedure is called to specify what lines are to be - * displayed in a text widget. - * - * Results: - * None. - * - * Side effects: - * The display will (eventually) be updated so that the line - * given by "line" is visible on the screen at the position - * determined by "pickPlace". - * - *---------------------------------------------------------------------- - */ - -void -TkTextSetView(textPtr, line, pickPlace) - TkText *textPtr; /* Widget record for text widget. */ - int line; /* Number of line that is to appear somewhere - * in the window. */ - int pickPlace; /* 0 means topLine must appear at top of - * screen. 1 means we get to pick where it - * appears: minimize screen motion or else - * display line at center of screen. */ -{ - DInfo *dInfoPtr = textPtr->dInfoPtr; - register DLine *dlPtr, *dlPtr2; - TkTextLine *linePtr; - int curTopLine, curBotLine, numLines; - int bottomY; - TagInfo tagInfo; -#define CLOSE_LINES 5 - - numLines = TkBTreeNumLines(textPtr->tree); - if (line >= numLines) { - line = numLines-1; - } - if (line < 0) { - line = 0; - } - linePtr = TkBTreeFindLine(textPtr->tree, line); - - if (!pickPlace) { - /* - * The line must go at the top of the screen. See if the new - * topmost line is already somewhere on the screen. If so then - * delete all the DLine structures ahead of it. Otherwise just - * leave all the DLine's alone (if the new topmost line is above - * the top of the current window, i.e. we're scrolling back towards - * the beginning of the file we may be able to reuse some of the - * information that's currently on the screen without redisplaying - * it all. - */ - - dlPtr = FindDLine(dInfoPtr->dLinePtr, line); - if ((dlPtr != NULL) && (dlPtr != dInfoPtr->dLinePtr)) { - FreeDLines(textPtr, dInfoPtr->dLinePtr, dlPtr, 1); - } - - textPtr->topLinePtr = linePtr; - goto scheduleUpdate; - } - - /* - * We have to pick where to display the given line. First, bring - * the display information up to date and see if the line will be - * completely visible in the current screen configuration. If so - * then there's nothing to do. - */ - - if (dInfoPtr->flags & DINFO_OUT_OF_DATE) { - UpdateDisplayInfo(textPtr); - } - for (dlPtr = dInfoPtr->dLinePtr; ; dlPtr = dlPtr->nextPtr) { - if (dlPtr->nextPtr == NULL) { - break; - } - if ((dlPtr->linePtr == linePtr) - && (dlPtr->nextPtr->linePtr != linePtr)) { - break; - } - } - if ((dlPtr->linePtr == linePtr) - && ((dlPtr->y + dlPtr->height) <= dInfoPtr->maxY)) { - return; - } - - /* - * The desired line isn't already on-screen. See if it is within - * a few lines of the top of the window. If so then just make it - * the top line on the screen. - */ - - bottomY = (dInfoPtr->y + dInfoPtr->maxY)/2; - curTopLine = TkBTreeLineIndex(dInfoPtr->dLinePtr->linePtr); - if (line < curTopLine) { - if (line >= (curTopLine-CLOSE_LINES)) { - textPtr->topLinePtr = TkBTreeFindLine(textPtr->tree, line); - goto scheduleUpdate; - } - } else { - /* - * The desired line is below the bottom of the screen. If it is - * within a few lines of the bottom of the screen then position - * it at the bottom of the screen. (At this point dlPtr points to - * the last line on the screen) - */ - - curBotLine = TkBTreeLineIndex(dlPtr->linePtr); - if (line <= (curBotLine+5)) { - bottomY = dInfoPtr->maxY; - } - } - - /* - * Our job now is arrange the display so that "line" appears as - * low on the screen as possible but with its bottom no lower - * than bottomY (bottomY is the bottom of the window if the - * desired line is just below the current screen, otherwise it - * is the center of the window. Work upwards (through smaller - * line numbers) computing how much space lines take, until we - * fine the line that should be at the top of the screen. - */ - - for (textPtr->topLinePtr = linePtr = TkBTreeFindLine(textPtr->tree, line); - ; line--, textPtr->topLinePtr = linePtr, - linePtr = TkBTreeFindLine(textPtr->tree, line)) { - tagInfo.tagPtrs = TkBTreeGetTags(textPtr->tree, linePtr, 0, - &tagInfo.numTags); - tagInfo.arraySize = tagInfo.numTags; - TkBTreeStartSearch(textPtr->tree, line, 1, line+1, 0, - (TkTextTag *) NULL, &tagInfo.search); - TkBTreeNextTag(&tagInfo.search); - dlPtr = LayoutLine(textPtr, line, linePtr, &tagInfo); - for (dlPtr2 = dlPtr; dlPtr2 != NULL; dlPtr2 = dlPtr2->nextPtr) { - bottomY -= dlPtr2->height; - } - FreeDLines(textPtr, dlPtr, (DLine *) NULL, 0); - if (tagInfo.tagPtrs != NULL) { - ckfree((char *) tagInfo.tagPtrs); - } - if ((bottomY <= 0) || (line <= 0)) { - break; - } - } - - scheduleUpdate: - if (!(dInfoPtr->flags & REDRAW_PENDING)) { - Tk_DoWhenIdle(DisplayText, (ClientData) textPtr); - } - dInfoPtr->flags |= REDRAW_PENDING|DINFO_OUT_OF_DATE|REPICK_NEEDED; -} - -/* - *---------------------------------------------------------------------- - * - * FindDLine -- - * - * This procedure is called to find the DLine corresponding to a - * given text line. - * - * Results: - * The return value is a pointer to the first DLine found in the - * list headed by dlPtr whose line number is greater or equal to - * line. If there is no such line in the list then NULL is returned. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static DLine * -FindDLine(dlPtr, line) - register DLine *dlPtr; /* Pointer to first in list of DLines - * to search. */ - int line; /* Line number in text that is desired. */ -{ - TkTextLine *linePtr; - int thisLine; - - if (dlPtr == NULL) { - return NULL; - } - thisLine = TkBTreeLineIndex(dlPtr->linePtr); - while (thisLine < line) { - /* - * This DLine isn't the right one. Go on to the next DLine - * (skipping multiple DLine's for the same text line). - */ - - linePtr = dlPtr->linePtr; - do { - dlPtr = dlPtr->nextPtr; - if (dlPtr == NULL) { - return NULL; - } - } while (dlPtr->linePtr == linePtr); - - /* - * Step through text lines, keeping track of the line number - * we're on, until we catch up to dlPtr (remember, there could - * be gaps in the DLine list where DLine's have been deleted). - */ - - do { - linePtr = TkBTreeNextLine(linePtr); - thisLine++; - if (linePtr == NULL) { - panic("FindDLine reached end of text"); - } - } while (linePtr != dlPtr->linePtr); - } - return dlPtr; -} - -/* - *---------------------------------------------------------------------- - * - * TkTextCharAtLoc -- - * - * Given an (x,y) coordinate on the screen, find the location of - * the closest character to that location. - * - * Results: - * The return value is a pointer to the text line containing the - * character displayed closest to (x,y). The value at *chPtr is - * overwritten with the index with that line of the closest - * character. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -TkTextLine * -TkTextCharAtLoc(textPtr, x, y, chPtr) - TkText *textPtr; /* Widget record for text widget. */ - int x, y; /* Pixel coordinates of point in widget's - * window. */ - int *chPtr; /* Place to store index-within-line of - * closest character. */ -{ - DInfo *dInfoPtr = textPtr->dInfoPtr; - register DLine *dlPtr; - register Chunk *chunkPtr; - int count; - int endX; - - /* - * Make sure that all of the layout information about what's - * displayed where on the screen is up-to-date. - */ - - if (dInfoPtr->flags & DINFO_OUT_OF_DATE) { - UpdateDisplayInfo(textPtr); - } - - /* - * If the coordinates are above the top of the window, then adjust - * them to refer to the upper-right corner of the window. - */ - - if (y < dInfoPtr->y) { - y = dInfoPtr->y; - x = dInfoPtr->x; - } else if (y >= dInfoPtr->topOfEof) { - y = dInfoPtr->topOfEof; - x = dInfoPtr->maxX; - } - for (dlPtr = dInfoPtr->dLinePtr; dlPtr != NULL; dlPtr = dlPtr->nextPtr) { - if (y > (dlPtr->y + dlPtr->height)) { - if (dlPtr->nextPtr != NULL) { - continue; - } - - /* - * The coordinates are off the bottom of the window. Adjust - * them to refer to the lower-right character on the window. - */ - - y = dlPtr->y; - x = dInfoPtr->maxX; - } - for (chunkPtr = dlPtr->chunkPtr; ; chunkPtr = chunkPtr->nextPtr) { - if ((chunkPtr->nextPtr == NULL) || (chunkPtr->nextPtr->x > x)) { - break; - } - } - count = TkMeasureChars(chunkPtr->stylePtr->sValuePtr->fontPtr, - chunkPtr->text, chunkPtr->numChars, chunkPtr->x, x, 0, &endX); - if (count >= chunkPtr->numChars) { - /* - * The point is off the end of the line. Return the character - * after the last one that fit, unless that character appears - * as the first character on the next DLine or unless the last - * one that fit extends beyond the edge of the window. - */ - - if ((dlPtr->nextPtr != NULL) - && (dlPtr->nextPtr->chunkPtr->text - == (chunkPtr->text + chunkPtr->numChars))) { - count = chunkPtr->numChars-1; - } - if (endX >= dInfoPtr->maxX) { - count = chunkPtr->numChars-1; - } - } - *chPtr = count + (chunkPtr->text - dlPtr->linePtr->bytes); - return dlPtr->linePtr; - } - panic("TkTextCharAtLoc ran out of lines"); - return (TkTextLine *) NULL; -} diff --git a/tk3.6/tkTextIndex.c b/tk3.6/tkTextIndex.c deleted file mode 100644 index 867d2ca..0000000 --- a/tk3.6/tkTextIndex.c +++ /dev/null @@ -1,651 +0,0 @@ -/* - * tkTextIndex.c -- - * - * This module provides procedures that manipulate indices for - * text widgets. - * - * 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. - */ - -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkTextIndex.c,v 1.4 93/08/18 16:26:01 ouster Exp $ SPRITE (Berkeley)"; -#endif - -#include "default.h" -#include "tkConfig.h" -#include "tkInt.h" -#include "tkText.h" - -/* - * Forward declarations for procedures defined later in this file: - */ - -static void BackwardChars _ANSI_ARGS_((TkText *textPtr, - TkTextLine *linePtr, int *lineIndexPtr, - int *chPtr, int count)); -static char * ForwBack _ANSI_ARGS_((TkText *textPtr, - char *string, int *lineIndexPtr, int *chPtr)); -static void ForwardChars _ANSI_ARGS_((TkText *textPtr, - TkTextLine *linePtr, int *lineIndexPtr, - int *chPtr, int count)); -static char * StartEnd _ANSI_ARGS_((TkText *textPtr, - char *string, int *lineIndexPtr, int *chPtr)); - -/* - *---------------------------------------------------------------------- - * - * TkTextGetIndex -- - * - * Given a string, return the line and character indices that - * it describes. - * - * Results: - * The return value is a standard Tcl return result. If - * TCL_OK is returned, then everything went well and information - * is stored at *lineIndexPtr and *chPtr; otherwise TCL_ERROR - * is returned and an error message is left in interp->result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TkTextGetIndex(interp, textPtr, string, lineIndexPtr, chPtr) - Tcl_Interp *interp; /* Use this for error reporting. */ - TkText *textPtr; /* Information about text widget. */ - char *string; /* Textual description of position. */ - int *lineIndexPtr; /* Store line number here. */ - int *chPtr; /* Store character position here. */ -{ - register char *p; - char *end, *endOfBase; - TkTextLine *linePtr; - Tcl_HashEntry *hPtr; - TkAnnotation *markPtr; - TkTextTag *tagPtr; - TkTextSearch search; - int first; - char c; - - /* - *------------------------------------------------ - * Stage 1: parse the base index. - *------------------------------------------------ - */ - - if (string[0] == '@') { - /* - * Find character at a given x,y location in the window. - */ - - int x, y; - - p = string+1; - x = strtol(p, &end, 0); - if ((end == p) || (*end != ',')) { - goto error; - } - p = end+1; - y = strtol(p, &end, 0); - if (end == p) { - goto error; - } - *lineIndexPtr = TkBTreeLineIndex(TkTextCharAtLoc(textPtr, x, - y, chPtr)); - endOfBase = end; - goto gotBase; - } else if (isdigit(UCHAR(string[0])) || (string[0] == '-')) { - /* - * Base is identified with line and character indices. - */ - - *lineIndexPtr = strtol(string, &end, 0) - 1; - if ((end == string) || (*end != '.')) { - goto error; - } - p = end+1; - if ((*p == 'e') && (strncmp(p, "end", 3) == 0)) { - linePtr = TkBTreeFindLine(textPtr->tree, *lineIndexPtr); - if (linePtr == NULL) { - Tcl_AppendResult(interp, "bad text index \"", string, - "\": no such line in text", (char *) NULL); - return TCL_ERROR; - } - *chPtr = linePtr->numBytes - 1; - endOfBase = p+3; - goto gotBase; - } else { - *chPtr = strtol(p, &end, 0); - if (end == p) { - goto error; - } - endOfBase = end; - goto gotBase; - } - } - - for (p = string; *p != 0; p++) { - if (isspace(UCHAR(*p)) || (*p == '+') || (*p == '-')) { - break; - } - } - endOfBase = p; - if ((string[0] == 'e') - && (strncmp(string, "end", endOfBase-string) == 0)) { - /* - * Base position is end of text. - */ - - *lineIndexPtr = TkBTreeNumLines(textPtr->tree) - 1; - linePtr = TkBTreeFindLine(textPtr->tree, *lineIndexPtr); - *chPtr = linePtr->numBytes - 1; - goto gotBase; - } else { - /* - * See if the base position is the name of a mark. - */ - - c = *endOfBase; - *endOfBase = 0; - hPtr = Tcl_FindHashEntry(&textPtr->markTable, string); - *endOfBase = c; - if (hPtr != NULL) { - markPtr = (TkAnnotation *) Tcl_GetHashValue(hPtr); - *lineIndexPtr = TkBTreeLineIndex(markPtr->linePtr); - *chPtr = markPtr->ch; - goto gotBase; - } - } - - /* - * Nothing has worked so far. See if the base has the form - * "tag.first" or "tag.last" where "tag" is the name of a valid - * tag. - */ - - p = strchr(string, '.'); - if (p == NULL) { - goto error; - } - if ((p[1] == 'f') && (endOfBase == (p+6)) - && (strncmp(p+1, "first", endOfBase - (p+1)) == 0)) { - first = 1; - } else if ((p[1] == 'l') && (endOfBase == (p+5)) - && (strncmp(p+1, "last", endOfBase - (p+1)) == 0)) { - first = 0; - } else { - goto error; - } - *p = 0; - hPtr = Tcl_FindHashEntry(&textPtr->tagTable, string); - *p = '.'; - if (hPtr == NULL) { - goto error; - } - tagPtr = (TkTextTag *) Tcl_GetHashValue(hPtr); - TkBTreeStartSearch(textPtr->tree, 0, 0, TkBTreeNumLines(textPtr->tree), - 0, tagPtr, &search); - if (!TkBTreeNextTag(&search)) { - Tcl_AppendResult(interp, - "text doesn't contain any characters tagged with \"", - Tcl_GetHashKey(&textPtr->tagTable, hPtr), "\"", (char *) NULL); - return TCL_ERROR; - } - if (first) { - *lineIndexPtr = search.line1; - *chPtr = search.ch1; - } else { - while (TkBTreeNextTag(&search)) { - *lineIndexPtr = search.line1; - *chPtr = search.ch1; - } - } - - /* - *------------------------------------------------------------------- - * Stage 2: process zero or more modifiers. Each modifier is either - * a keyword like "wordend" or "linestart", or it has the form - * "op count units" where op is + or -, count is a number, and units - * is "chars" or "lines". - *------------------------------------------------------------------- - */ - - gotBase: - p = endOfBase; - while (1) { - while (isspace(UCHAR(*p))) { - p++; - } - if (*p == 0) { - return TCL_OK; - } - - if ((*p == '+') || (*p == '-')) { - p = ForwBack(textPtr, p, lineIndexPtr, chPtr); - } else { - p = StartEnd(textPtr, p, lineIndexPtr, chPtr); - } - if (p == NULL) { - goto error; - } - } - - error: - Tcl_AppendResult(interp, "bad text index \"", string, "\"", - (char *) NULL); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * TkTextPrintIndex -- - * - * Given a line number and a character index, this procedure - * generates a string description of the position, which is - * suitable for reading in again later. - * - * Results: - * The characters pointed to by string are modified. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -TkTextPrintIndex(line, ch, string) - int line; /* Line number. */ - int ch; /* Character position within line. */ - char *string; /* Place to store the position. Must have - * at least POS_CHARS characters. */ -{ - sprintf(string, "%d.%d", line+1, ch); -} - -/* - *---------------------------------------------------------------------- - * - * TkTextRoundIndex -- - * - * Given a line index and a character index, this procedure - * adjusts those positions if necessary to correspond to the - * nearest actual character within the text. - * - * Results: - * The return value is a pointer to the line structure for - * the line of the text's B-tree that contains the indicated - * character. In addition, *lineIndexPtr and *chPtr are - * modified if necessary to refer to an existing character - * in the file. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - - -TkTextLine * -TkTextRoundIndex(textPtr, lineIndexPtr, chPtr) - TkText *textPtr; /* Information about text widget. */ - int *lineIndexPtr; /* Points to initial line index, - * which is overwritten with actual - * line index. */ - int *chPtr; /* Points to initial character index, - * which is overwritten with actual - * character index. */ -{ - int line, ch, lastLine; - TkTextLine *linePtr; - - line = *lineIndexPtr; - ch = *chPtr; - if (line < 0) { - line = 0; - ch = 0; - } - lastLine = TkBTreeNumLines(textPtr->tree) - 1; - if (line > lastLine) { - line = lastLine; - linePtr = TkBTreeFindLine(textPtr->tree, line); - ch = linePtr->numBytes - 1; - } else { - linePtr = TkBTreeFindLine(textPtr->tree, line); - if (ch < 0) { - ch = 0; - } - if (ch >= linePtr->numBytes) { - if (line == lastLine) { - ch = linePtr->numBytes - 1; - } else { - line++; - linePtr = TkBTreeNextLine(linePtr); - ch = 0; - } - } - } - *lineIndexPtr = line; - *chPtr = ch; - return linePtr; -} - -/* - *---------------------------------------------------------------------- - * - * ForwBack -- - * - * This procedure handles +/- modifiers for indices to adjust - * the index forwards or backwards. - * - * Results: - * If the modifier is successfully parsed then the return value - * is the address of the first character after the modifier, and - * *lineIndexPtr and *chPtr are updated to reflect the modifier. - * If there is a syntax error in the modifier then NULL is returned. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static char * -ForwBack(textPtr, string, lineIndexPtr, chPtr) - TkText *textPtr; /* Information about widget that index - * refers to. */ - char *string; /* String to parse for additional info - * about modifier (count and units). - * Points to "+" or "-" that starts - * modifier. */ - int *lineIndexPtr; /* Points to current line index, which will - * be updated to reflect modifier. */ - int *chPtr; /* Points to current character index, which - * will be updated to reflect modifier. */ -{ - register char *p; - char *end, *units; - int count, length, lastLine; - TkTextLine *linePtr; - - /* - * Get the count (how many units forward or backward). - */ - - p = string+1; - while (isspace(UCHAR(*p))) { - p++; - } - count = strtoul(p, &end, 0); - if (end == p) { - return NULL; - } - p = end; - while (isspace(UCHAR(*p))) { - p++; - } - - /* - * Find the end of this modifier (next space or + or - character), - * then parse the unit specifier and update the position - * accordingly. - */ - - units = p; - while ((*p != 0) && !isspace(UCHAR(*p)) && (*p != '+') && (*p != '-')) { - p++; - } - length = p - units; - if ((*units == 'c') && (strncmp(units, "chars", length) == 0)) { - linePtr = TkTextRoundIndex(textPtr, lineIndexPtr, chPtr); - if (*string == '+') { - ForwardChars(textPtr, linePtr, lineIndexPtr, chPtr, count); - } else { - BackwardChars(textPtr, linePtr, lineIndexPtr, chPtr, count); - } - } else if ((*units == 'l') && (strncmp(units, "lines", length) == 0)) { - if (*string == '+') { - *lineIndexPtr += count; - lastLine = TkBTreeNumLines(textPtr->tree) - 1; - if (*lineIndexPtr > lastLine) { - *lineIndexPtr = lastLine; - } - } else { - *lineIndexPtr -= count; - if (*lineIndexPtr < 0) { - *lineIndexPtr = 0; - } - } - linePtr = TkBTreeFindLine(textPtr->tree, *lineIndexPtr); - if (*chPtr >= linePtr->numBytes) { - *chPtr = linePtr->numBytes - 1; - } - if (*chPtr < 0) { - *chPtr = 0; - } - } else { - return NULL; - } - return p; -} - -/* - *---------------------------------------------------------------------- - * - * ForwardChars -- - * - * Given a position in a text widget, this procedure computes - * a new position that is "count" characters ahead of the given - * position. - * - * Results: - * *LineIndexPtr and *chPtr are overwritten with new values - * corresponding to the new position. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static void -ForwardChars(textPtr, linePtr, lineIndexPtr, chPtr, count) - TkText *textPtr; /* Information about text widget. */ - register TkTextLine *linePtr; /* Text line corresponding to - * *lineIndexPtr. */ - int *lineIndexPtr; /* Points to initial line index, - * which is overwritten with final - * line index. */ - int *chPtr; /* Points to initial character index, - * which is overwritten with final - * character index. */ - int count; /* How many characters forward to - * move. Must not be negative. */ -{ - TkTextLine *nextPtr; - int bytesInLine; - - while (count > 0) { - bytesInLine = linePtr->numBytes - *chPtr; - if (bytesInLine > count) { - *chPtr += count; - return; - } - nextPtr = TkBTreeNextLine(linePtr); - if (nextPtr == NULL) { - *chPtr = linePtr->numBytes - 1; - return; - } - *chPtr = 0; - *lineIndexPtr += 1; - linePtr = nextPtr; - count -= bytesInLine; - } -} - -/* - *---------------------------------------------------------------------- - * - * BackwardChars -- - * - * Given a position in a text widget, this procedure computes - * a new position that is "count" characters earlier than the given - * position. - * - * Results: - * *LineIndexPtr and *chPtr are overwritten with new values - * corresponding to the new position. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -BackwardChars(textPtr, linePtr, lineIndexPtr, chPtr, count) - TkText *textPtr; /* Information about text widget. */ - register TkTextLine *linePtr; /* Text line corresponding to - * *lineIndexPtr. */ - int *lineIndexPtr; /* Points to initial line index, - * which is overwritten with final - * line index. */ - int *chPtr; /* Points to initial character index, - * which is overwritten with final - * character index. */ - int count; /* How many characters backward to - * move. Must not be negative. */ -{ - int bytesInLine; - - while (count > 0) { - bytesInLine = *chPtr; - if (bytesInLine >= count) { - *chPtr -= count; - return; - } - if (*lineIndexPtr <= 0) { - *chPtr = 0; - return; - } - *lineIndexPtr -= 1; - linePtr = TkBTreeFindLine(textPtr->tree, *lineIndexPtr); - count -= bytesInLine; - *chPtr = linePtr->numBytes; - } -} - -/* - *---------------------------------------------------------------------- - * - * StartEnd -- - * - * This procedure handles modifiers like "wordstart" and "lineend" - * to adjust indices forwards or backwards. - * - * Results: - * If the modifier is successfully parsed then the return value - * is the address of the first character after the modifier, and - * *lineIndexPtr and *chPtr are updated to reflect the modifier. - * If there is a syntax error in the modifier then NULL is returned. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static char * -StartEnd(textPtr, string, lineIndexPtr, chPtr) - TkText *textPtr; /* Information about widget that index - * refers to. */ - char *string; /* String to parse for additional info - * about modifier (count and units). - * Points to first character of modifer - * word. */ - int *lineIndexPtr; /* Points to current line index, which will - * be updated to reflect modifier. */ - int *chPtr; /* Points to current character index, which - * will be updated to reflect modifier. */ -{ - char *p, c; - int length; - register TkTextLine *linePtr; - - /* - * Find the end of the modifier word. - */ - - for (p = string; isalnum(UCHAR(*p)); p++) { - /* Empty loop body. */ - } - length = p-string; - linePtr = TkTextRoundIndex(textPtr, lineIndexPtr, chPtr); - if ((*string == 'l') && (strncmp(string, "lineend", length) == 0) - && (length >= 5)) { - *chPtr = linePtr->numBytes - 1; - } else if ((*string == 'l') && (strncmp(string, "linestart", length) == 0) - && (length >= 5)) { - *chPtr = 0; - } else if ((*string == 'w') && (strncmp(string, "wordend", length) == 0) - && (length >= 5)) { - c = linePtr->bytes[*chPtr]; - if (!isalnum(UCHAR(c)) && (c != '_')) { - if (*chPtr >= (linePtr->numBytes - 1)) { - /* - * End of line: go to start of next line unless this is the - * last line in the text. - */ - - if (TkBTreeNextLine(linePtr) != NULL) { - *lineIndexPtr += 1; - *chPtr = 0; - } - } else { - *chPtr += 1; - } - } else { - do { - *chPtr += 1; - c = linePtr->bytes[*chPtr]; - } while (isalnum(UCHAR(c)) || (c == '_')); - } - } else if ((*string == 'w') && (strncmp(string, "wordstart", length) == 0) - && (length >= 5)) { - c = linePtr->bytes[*chPtr]; - if (isalnum(UCHAR(c)) || (c == '_')) { - while (*chPtr > 0) { - c = linePtr->bytes[(*chPtr) - 1]; - if (!isalnum(UCHAR(c)) && (c != '_')) { - break; - } - *chPtr -= 1; - } - } - } else { - return NULL; - } - return p; -} diff --git a/tk4.2/README b/tk4.2/README new file mode 100644 index 0000000..bce3a16 --- /dev/null +++ b/tk4.2/README @@ -0,0 +1,260 @@ +The Tk Toolkit + +SCCS: @(#) README 1.36 96/10/07 10:21:13 + +1. Introduction +--------------- + +This directory and its descendants contain the sources and documentation +for Tk, an X11 toolkit implemented with the Tcl scripting language. The +information here corresponds to Tk 4.2. This release is designed to work +with Tcl 7.6 and may not work with any other version of Tcl. + +This is a minor release. The main changes are a revision of the +gridder, a new set of standard dialog boxes, and a new virtual event +mechanism. See below for details. There should be no backward +incompatibilities in Tk 4.2 except for two small changes related to +the gridder. + +2. Documentation +---------------- + +The best way to get started with Tk is to read one of the introductory +books on Tcl and Tk: + + Tcl and the Tk Toolkit, by John Ousterhout, + Addison-Wesley, 1994, ISBN 0-201-63337-X + + Practical Programming in Tcl and Tk, by Brent Welch, + Prentice-Hall, 1995, ISBN 0-13-182007-9 + + Exploring Expect, by Don Libes, + O'Reilly and Associates, 1995, ISBN 1-56592-090-2 + +The "doc" subdirectory in this release contains a complete set of +reference manual entries for Tk. Files with extension ".1" are for +programs such as wish; files with extension ".3" are for C library +procedures; and files with extension ".n" describe Tcl commands. To +print any of the manual entries, cd to the "doc" directory and invoke +your favorite variant of troff using the normal -man macros, for example + + ditroff -man wish.1 + +to print wish.1. If Tk 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 wish + +If you are porting Tk 3.6 scripts to Tk 4.0 or later releases, you may +find the Postscript file doc/tk4.0.ps useful. It is a porting guide +that summarizes the new features and discusses how to deal with the +changes in Tk 4.0 that are not backwards compatible. + +There is also an official home for Tcl and Tk on the Web: + http://www.smli.com/research/tcl +These Web pages include release updates, reports on bug fixes and porting +issues, HTML versions of the manual pages, and pointers to many other +Tcl/Tk Web pages at other sites. Check them out! + +3. Compiling and installing Tk +------------------------------ + +This release contains everything you should need to compile and run +Tk under UNIX, Macintoshes, and PCs (either Windows NT, Windows 95, +or Win 3.1 with Win32s). + +Before trying to compile Tk you should do the following things: + + (a) Check for a binary release. Pre-compiled binary releases are + available now for PCs and Macintoshes, and several flavors of + UNIX. Binary releases are much easier to install than source + releases. To find out whether a binary release is available for + your platform, check the home page for the Sun Tcl/Tk project + (http://www.sunlabs.com/research/tcl) and also check in the FTP + directory from which you retrieved the base distribution. + + (b) Make sure you have the most recent patch release. Look in the + FTP directory from which you retrieved this distribution to see + if it has been updated with patches. Patch releases fix bugs + without changing any features, so you should normally use the + latest patch release for the version of Tk that you want. + Patch releases are available in two forms. A file like + tk4.2p1.tar.Z is a complete release for patch level 1 of Tk + version 4.2. If there is a file with a higher patch level than + this release, just fetch the file with the highest patch level + and use it. + + Patches are also available in the form of patch files that just + contain the changes from one patch level to another. These + files have names like tk4.2p1.patch, tk4.2p2.patch, etc. They + may also have .gz or .Z extensions to indicate compression. To + use one of these files, you apply it to an existing release with + the "patch" program. Patches must be applied in order: + tk4.2p1.patch must be applied to an unpatched Tk 4.2 release + to produce a Tk 4.2p1 release; tk4.2p2.patch can then be + applied to Tk 4.2p1 to produce Tk 4.2p2, and so on. To apply an + uncompressed patch file such as tk4.2p1.patch, invoke a shell + command like the following from the directory containing this + file: + patch -p < tk4.2p1.patch + If the patch file has a .gz extension, it was compressed with + gzip. To apply it, invoke a command like the following: + gunzip -c tk4.2p1.patch.gz | patch -p + If the patch file has a .Z extension, it was compressed with + compress. To apply it, invoke a command like the following: + zcat tk4.2p1.patch.Z | patch -p + If you're applying a patch to a release that has already been + compiled, then before applying the patch you should cd to the + "unix" subdirectory and type "make distclean" to restore the + directory to a pristine state. + +Once you've done this, change to the "unix" subdirectory if you're +compiling under UNIX, "win" if you're compiling under Windows, or +"mac" if you're compiling on a Macintosh. Then follow the instructions +in the README file in that directory for compiling Tk, installing it, +and running the test suite. + +4. Getting started +------------------ + +The best way to get started with Tk is by reading one of the introductory +books. + +The subdirectory library/demos contains a number of pre-canned scripts +that demonstrate various features of Tk. See the README file in the +directory for a description of what's available. The file +library/demos/widget is a script that you can use to invoke many individual +demonstrations of Tk's facilities, see the code that produced the demos, +and modify the code to try out alternatives. + +5. Summary of changes in Tk 4.2 +------------------------------- + +Here are the new features in Tk 4.2. The release also includes several +bug fixes. See the "changes" file for a complete list of all changes. + + 1. The grid geometry manager has been completely rewritten: + - The layout algorithm produces much better layouts than before, + particularly where rows or columns were stretchable. + - There is a new -pad option for rows and columns. + - The command "grid forget" has been renamed "grid remove", + and "grid forget" now has semantics like "pack forget". + - The "grid" command no longer accepts floating-point values + for row or column weights: integers must be used. + + 2. There are new commands for creating common dialog boxes: + tk_chooseColor, tk_getOpenFile, tk_getSaveFile and tk_messageBox. + These use native dialog boxes if they are available. Examples of + the dialogs are available in the widget demo. + + 3. There is a new virtual event mechanism for handling events in a + more portable way. See the new command "event". It also allows + events (both physical and virtual) to be generated dynamically. + The Macintosh now generates <>, <>, <>, and <> + events from the edit menu. + +The only incompatible changes in this release are the last two for the +gridder ("grid forget" and integer row/column weights). Most scripts +that ran under Tk 4.1 should also work under Tk 4.2 with no changes. + +6. Tcl/Tk 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 +this newsgroup both for general information questions and for bug reports. +We read the newsgroup and will attempt to fix bugs and problems reported +to it. + +When using comp.lang.tcl, please be sure that your e-mail return address +is correctly set in your postings. This allows people to respond directly +to you, rather than the entire newsgroup, for answers that are not of +general interest. A bad e-mail return address may prevent you from +getting answers to your questions. You may have to reconfigure your news +reading software to ensure that it is supplying valid e-mail addresses. + +7. Tcl/Tk contributed archive +-------------------------- + +Many people have created exciting packages and applications based on Tcl +and/or Tk and made them freely available to the Tcl community. An archive +of these contributions is kept on the machine ftp.neosoft.com. You +can access the archive using anonymous FTP; the Tcl contributed archive is +in the directory "/pub/tcl". The archive also contains several FAQ +("frequently asked questions") documents that provide solutions to problems +that are commonly encountered by TCL newcomers. + +8. Support and bug fixes +------------------------ + +We're very interested in receiving bug reports and suggestions for +improvements. We prefer that you send this information to the +comp.lang.tcl newsgroup rather than to any of us at Sun. We'll see +anything on comp.lang.tcl, and in addition someone else who reads +comp.lang.tcl may be able to offer a solution. The normal turn-around +time for bugs is 3-6 weeks. Enhancements may take longer and may not +happen at all unless there is widespread support for them (we're +trying to slow the rate at which Tk turns into a kitchen sink). It's +very difficult to make incompatible changes to Tcl at this point, due +to the size of the installed base. + +When reporting bugs, please provide a short wish script that we can +use to reproduce the bug. Make sure that the script runs with a +bare-bones wish and doesn't depend on any extensions or other +programs, particularly those that exist only at your site. Also, +please include three additional pieces of information with the +script: + (a) how do we use the script to make the problem happen (e.g. + what things do we click on, in what order)? + (b) what happens when you do these things (presumably this is + undesirable)? + (c) what did you expect to happen instead? + +The Tcl/Tk community is too large for us to provide much individual +support for users. If you need help we suggest that you post questions +to comp.lang.tcl. We read the newsgroup and will attempt to answer +esoteric questions for which no-one else is likely to know the answer. +In addition, Tcl/Tk support and training are available commercially from +NeoSoft (info@neosoft.com), Computerized Processes Unlimited +(gwl@cpu.com), and Data Kinetics (education@dkl.com). + +9. Release organization +------------------------ + +Each Tk release is identified by two numbers separated by a dot, e.g. +3.2 or 3.3. 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: 3.0, 4.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. 3.1, 3.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. + +Alpha and beta releases have an additional suffix of the form a2 or b1. +For example, Tk 3.3b1 is the first beta release of Tk version 3.3, +Tk 3.3b2 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. An alpha release is like a beta +release, except it's likely to need even more work before it's "ready +for prime time". New releases are normally preceded by one or more +alpha and beta releases. We hope that lots of people will try out +the alpha and beta releases and report problems. We'll make new alpha/ +beta releases to fix the problems, until eventually there is a beta +release that appears to be stable. Once this occurs we'll make the +final release. + +We can't promise to maintain compatibility among alpha and beta releases. +For example, release 4.1b2 may not be backward compatible with 4.1b1, even +though the final 4.1 release will be backward compatible with 4.0. This +allows us to change new features as we find problems during beta testing. +We'll try to minimize incompatibilities between beta releases, but if a +major problem turns up then we'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. + +Patch releases have a suffix such as p1 or p2. These releases contain +bug fixes only. A patch release (e.g Tk 4.1p2) should be completely +compatible with the base release from which it is derived (e.g. Tk +4.1), and you should normally use the highest available patch release. diff --git a/tk4.2/ToDo b/tk4.2/ToDo new file mode 100644 index 0000000..683dc80 --- /dev/null +++ b/tk4.2/ToDo @@ -0,0 +1,90 @@ +This file contains a list of bugs to fix and minor feature changes +needed in the Tk toolkit. The list is ordered by the time when the +idea for the change first arose; no priority should be inferred from +the order. + +sccsid = SCCS: @(#) ToDo 1.8 96/02/16 10:55:14 + +106. Add feature to buttons for automatic defaulting, where button +allocates extra space for default ring. + +136. Implement mechanism for using existing window as main window for +application, support with command-line argument in wish. + +139. Change canvas Postscript generation to be smarter about font names +that have been abbreviated: use X to look up the full name. + +147. Add "window" entry to menus. + +148. Add an "initProc" and a "freeProc" to TK_CONFIG_CUSTOM config types. + +150. In SYNONYM options, specify a command-line switch for the other +option, not a database name. + +153. Some fonts (e.g. Times) have underline characters that extend +*below* the official descent of the font. Right now the underline +is invisible for these fonts in text widgets. Find a way to make +this work in text? + +150. Change the bindings for menubuttons to watch mouse motion events +and map them to menu or menubutton windows "by hand", so as to eliminate +the need for a menu to be a descendant of the menubutton. + +151. Create an I/O event handler so that Tk can continue after a server +connection is lost. + +153. Allow Tk applications to be embedded inside other Tk applications: + - Allow the window for a widget to be specified explicitly, rather + than being created automatically by Tk. This would allow the + main window for one application to use an internal window that + already exists in another application. + - Modify wish's main.c to allow a window id for the main window to + be specified as a command-line argument. + - Build a special widget for embedding other applications, which will + implement the window-manager side of the ICCCM protocols, e.g., + feeding requested size information up from the embedded application + into the enclosing widget hierarchy. + +154. Improvements to canvases: + - Allow items to be rotated? + - Allow polygons to be outlined. + - Make "raise" of window items work correctly. + - In the "find" widget option, make it possible to restrict search + to a particular tag. + - Allow items to become visible/invisible. + +156. Add a "wm anchor" option to make it easier to center windows. + +157. Various improvements to option database: + - Allow patterns to be read from database or deleted from database. + - Allow database to be cleared without automatically reloading from + .Xdefaults files. + - Allow additional info to be read from various window properties. + - Support new wildcards from X11R5. + - Allow mechanism to extend to cover cases where there isn't even + a window, or even an application by the name used in the option + get command. + - Allow options in database to override those specified on Tcl + command lines? + - Revert to X conflict-resolution scheme? + +158. Make it possible for wish to run without a display. + +159. Change option tables to be arrays of pointers, rather than arrays of +entries? Makes it easier to keep separate named structures for particular +options, e.g. so that you can tell when an option has changed. + +160. Change text scrolling so that the top of the window can fall in +the middle of a text line. + +161. Allow text tabs to be specified in units of characters, rather +than just inches. + +162. Fix tk_strictMotif to make it easier to turn on and off (e.g. +conditionalize the binding scripts, rather than the creation of +the bindings). + +163. Change text bindings so that Enter and Leave events occur when +the mouse moves between disjoint ranges with the same tag. + +164. Provide block insertion cursor in text widgets. diff --git a/tk3.6/bitmaps/error b/tk4.2/bitmaps/error.bmp similarity index 90% rename from tk3.6/bitmaps/error rename to tk4.2/bitmaps/error.bmp index 08521e0..5a1331f 100644 --- a/tk3.6/bitmaps/error +++ b/tk4.2/bitmaps/error.bmp @@ -1,6 +1,6 @@ #define error_width 17 #define error_height 17 -static char error_bits[] = { +static unsigned char error_bits[] = { 0xf0, 0x0f, 0x00, 0x58, 0x15, 0x00, 0xac, 0x2a, 0x00, 0x16, 0x50, 0x00, 0x2b, 0xa0, 0x00, 0x55, 0x40, 0x01, 0xa3, 0xc0, 0x00, 0x45, 0x41, 0x01, 0x83, 0xc2, 0x00, 0x05, 0x45, 0x01, 0x03, 0xca, 0x00, 0x05, 0x74, 0x01, diff --git a/tk4.2/bitmaps/gray12.bmp b/tk4.2/bitmaps/gray12.bmp new file mode 100644 index 0000000..a0eafa1 --- /dev/null +++ b/tk4.2/bitmaps/gray12.bmp @@ -0,0 +1,6 @@ +#define gray12_width 16 +#define gray12_height 16 +static unsigned char gray12_bits[] = { + 0x00, 0x00, 0x22, 0x22, 0x00, 0x00, 0x88, 0x88, 0x00, 0x00, 0x22, 0x22, + 0x00, 0x00, 0x88, 0x88, 0x00, 0x00, 0x22, 0x22, 0x00, 0x00, 0x88, 0x88, + 0x00, 0x00, 0x22, 0x22, 0x00, 0x00, 0x88, 0x88}; diff --git a/tk3.6/bitmaps/gray25 b/tk4.2/bitmaps/gray25.bmp similarity index 86% rename from tk3.6/bitmaps/gray25 rename to tk4.2/bitmaps/gray25.bmp index bce4c8a..ae2000d 100644 --- a/tk3.6/bitmaps/gray25 +++ b/tk4.2/bitmaps/gray25.bmp @@ -1,6 +1,6 @@ #define gray25_width 16 #define gray25_height 16 -static char gray25_bits[] = { +static unsigned char gray25_bits[] = { 0x00, 0x00, 0x22, 0x22, 0x00, 0x00, 0x88, 0x88, 0x00, 0x00, 0x22, 0x22, 0x00, 0x00, 0x88, 0x88, 0x00, 0x00, 0x22, 0x22, 0x00, 0x00, 0x88, 0x88, 0x00, 0x00, 0x22, 0x22, 0x00, 0x00, 0x88, 0x88}; diff --git a/tk3.6/bitmaps/gray50 b/tk4.2/bitmaps/gray50.bmp similarity index 86% rename from tk3.6/bitmaps/gray50 rename to tk4.2/bitmaps/gray50.bmp index 93fe5a8..1f9fbc0 100644 --- a/tk3.6/bitmaps/gray50 +++ b/tk4.2/bitmaps/gray50.bmp @@ -1,6 +1,6 @@ #define gray50_width 16 #define gray50_height 16 -static char gray50_bits[] = { +static unsigned char gray50_bits[] = { 0x55, 0x55, 0xaa, 0xaa, 0x55, 0x55, 0xaa, 0xaa, 0x55, 0x55, 0xaa, 0xaa, 0x55, 0x55, 0xaa, 0xaa, 0x55, 0x55, 0xaa, 0xaa, 0x55, 0x55, 0xaa, 0xaa, 0x55, 0x55, 0xaa, 0xaa, 0x55, 0x55, 0xaa, 0xaa}; diff --git a/tk3.6/bitmaps/hourglass b/tk4.2/bitmaps/hourglass.bmp similarity index 91% rename from tk3.6/bitmaps/hourglass rename to tk4.2/bitmaps/hourglass.bmp index 322ab98..bb1d8ad 100644 --- a/tk3.6/bitmaps/hourglass +++ b/tk4.2/bitmaps/hourglass.bmp @@ -1,6 +1,6 @@ #define hourglass_width 19 #define hourglass_height 21 -static char hourglass_bits[] = { +static unsigned char hourglass_bits[] = { 0xff, 0xff, 0x07, 0x55, 0x55, 0x05, 0xa2, 0x2a, 0x03, 0x66, 0x15, 0x01, 0xa2, 0x2a, 0x03, 0x66, 0x15, 0x01, 0xc2, 0x0a, 0x03, 0x46, 0x05, 0x01, 0x82, 0x0a, 0x03, 0x06, 0x05, 0x01, 0x02, 0x03, 0x03, 0x86, 0x05, 0x01, diff --git a/tk3.6/bitmaps/info b/tk4.2/bitmaps/info.bmp similarity index 82% rename from tk3.6/bitmaps/info rename to tk4.2/bitmaps/info.bmp index 2f6cf9c..801476e 100644 --- a/tk3.6/bitmaps/info +++ b/tk4.2/bitmaps/info.bmp @@ -1,5 +1,5 @@ #define info_width 8 #define info_height 21 -static char info_bits[] = { +static unsigned char info_bits[] = { 0x3c, 0x2a, 0x16, 0x2a, 0x14, 0x00, 0x00, 0x3f, 0x15, 0x2e, 0x14, 0x2c, 0x14, 0x2c, 0x14, 0x2c, 0x14, 0x2c, 0xd7, 0xab, 0x55}; diff --git a/tk3.6/bitmaps/questhead b/tk4.2/bitmaps/questhead.bmp similarity index 91% rename from tk3.6/bitmaps/questhead rename to tk4.2/bitmaps/questhead.bmp index 2ba303f..17b2929 100644 --- a/tk3.6/bitmaps/questhead +++ b/tk4.2/bitmaps/questhead.bmp @@ -1,6 +1,6 @@ #define questhead_width 20 #define questhead_height 22 -static char questhead_bits[] = { +static unsigned char questhead_bits[] = { 0xf8, 0x1f, 0x00, 0xac, 0x2a, 0x00, 0x56, 0x55, 0x00, 0xeb, 0xaf, 0x00, 0xf5, 0x5f, 0x01, 0xfb, 0xbf, 0x00, 0x75, 0x5d, 0x01, 0xfb, 0xbe, 0x02, 0x75, 0x5d, 0x05, 0xab, 0xbe, 0x0a, 0x55, 0x5f, 0x07, 0xab, 0xaf, 0x00, diff --git a/tk3.6/bitmaps/question b/tk4.2/bitmaps/question.bmp similarity index 93% rename from tk3.6/bitmaps/question rename to tk4.2/bitmaps/question.bmp index abfe83e..ceba2ab 100644 --- a/tk3.6/bitmaps/question +++ b/tk4.2/bitmaps/question.bmp @@ -1,6 +1,6 @@ #define question_width 17 #define question_height 27 -static char question_bits[] = { +static unsigned char question_bits[] = { 0xf0, 0x0f, 0x00, 0x58, 0x15, 0x00, 0xac, 0x2a, 0x00, 0x56, 0x55, 0x00, 0x2b, 0xa8, 0x00, 0x15, 0x50, 0x01, 0x0b, 0xa0, 0x00, 0x05, 0x60, 0x01, 0x0b, 0xa0, 0x00, 0x05, 0x60, 0x01, 0x0b, 0xb0, 0x00, 0x00, 0x58, 0x01, diff --git a/tk3.6/bitmaps/warning b/tk4.2/bitmaps/warning.bmp similarity index 81% rename from tk3.6/bitmaps/warning rename to tk4.2/bitmaps/warning.bmp index 652af7d..7925440 100644 --- a/tk3.6/bitmaps/warning +++ b/tk4.2/bitmaps/warning.bmp @@ -1,5 +1,5 @@ #define warning_width 6 #define warning_height 19 -static char warning_bits[] = { +static unsigned char warning_bits[] = { 0x0c, 0x16, 0x2b, 0x15, 0x2b, 0x15, 0x2b, 0x16, 0x0a, 0x16, 0x0a, 0x16, 0x0a, 0x00, 0x00, 0x1e, 0x0a, 0x16, 0x0a}; diff --git a/tk4.2/changes b/tk4.2/changes new file mode 100644 index 0000000..ae297cb --- /dev/null +++ b/tk4.2/changes @@ -0,0 +1,3350 @@ +This file summarizes all changes made to Tk since version 1.0 was +released on March 13, 1991. Changes that aren't backward compatible +are marked specially. + +SCCS: @(#) changes 1.134 96/10/17 17:34:05 + +3/16/91 (bug fix) Modified tkWindow.c to remove Tk's Tcl commands from +the interpreter when the main window is deleted (otherwise there will +be dangling pointers to the non-existent window). + +3/16/91 (bug fix) Modified tkColor.c not to free black or white colors: +some X servers get upset at this. + +3/18/91 (bug fix) Modified tkShare.c to fix bug causing "DeleteGroup +couldn't find group on shareList" panic. + +3/18/91 (bug fix) Several changes to tkListbox.c and tkScrollbar.c to +handle listboxes (and scrollbars) with zero total entries in them. + +3/22/91 (bug fix) Fixed a few ='s in tkListbox.c that should be ==. + +3/22/91 (bug fix) Fixed error in main.c that caused BadWindow errors +in some cases where wish scripts invoke "destroy .". + +3/23/91 (new feature) Added Tk_CancelIdleCall to remove Tk_DoWhenIdle +handler. + +3/23/91 (bug fix and new feature) Added -name option to main.c, made +it more clever about choosing name (was always using the name "wish" +on most Unix systems). + +3/23/91 (new feature) Added TK_CONFIG_STRING option to Tk_ConfigureWidget, +used it to malloc strings for various widget options that used to be +Tk_Uid's (e.g. button text, message strings, etc.). Eliminates core +leaks when values change in continuous non-repeating fashion. + +3/29/91 (new feature) Added Tk_Preserve, Tk_Release, and +Tk_EventuallyFree procedures to help manage widget records and avoid +premature memory free-ing. + +4/4/91 (bug fix) Fixed problem in tkWm.c where top-level window geometry +wasn't tracking correctly when wm-induced size change also changed window +position (e.g. menus wouldn't be displayed at the right places). + +4/5/91 (new feature) Added "invoke" option to widget command for buttons, +check buttons, and radio buttons. + +4/5/91 (new feature) Added "unpack" option to "pack" command. + +4/5/91 (bug fix) Changed tkPack.c to use new Tk_Preserve code and be +more careful about window deletions that occur while repacking is in +progress. + +4/6/91 (bug fix) Major overhaul of deletion code in all widgets to use +Tk_Preserve and Tk_Release. Should fix many problems. + +4/6/91 (bug fix) Changed "winfo children" to generate correct lists +when child names have embedded spaces. + +4/6/91 (new feature) Added "screenheight" and "screenwidth" options to +"winfo". + +4/18/91 (bug fix) Binding mechanism didn't correctly handle very long +%-substitutions in commands (e.g. long path names) and caused memory +to be overwritten. Modified tkBind.c to fix. + +---------------------- Release 1.1, 4/18/91 ------------------------- + +4/19/91 (bug fix) Inconsistent ICCCM handling of coordinates of reparented +windows causes windows to gradually walk south when moved or resized. +Fixed tkWm.c to patch around the problem. + +---------------------- Release 1.2, 4/24/91 ------------------------- + +4/26/91 (new feature) Added -geometry and -display switches to wish. +Also wrote wish manual entry. + +5/3/91 (bug fix) Fixed bug in tkListbox.c that caused garbage to appear +at right edge of window when strings were to large to fit in window. + +5/3/91 (bug fix) Fixed bug in tkListbox.c where topIndex wasn't getting +updated when elements were deleted: tended to cause errors in +communication with scrollbars. + +5/16/91 (bug fix) Fixed bug in tk3d.c, which caused core dumps when +consecutive points in a polygon were the same (happened with some +configurations of radio buttons, for example). + +5/16/91 (bug fix) Fixed main.c to allow stdin to be redirected. + +6/1/91 (bug fix) Make sure that pointers are never used after being +freed. + +6/15/91 (bug fix) Fixed bug in tkBind.c that caused current binding +values to not always be printed correctly. + +6/15/91 (bug fix) Make sure that interpreters are always unregistered +when their main windows are deleted, and make wish delete the main +window before exiting. + +8/21/91 (misfeature correction) Automatically set source of window +position to "user" in "wm geometry" command, unless it has been +explicitly set to "program". + +9/5/91 (bug fix) Modified option code to accept '#' as a comment +character in .Xdefaults files, in addition to '!'. + +9/10/91 (misfeature correction) Changed binding mechanism so that +numeric %-sequences are output in decimal instead of hex. + +9/19/91 (bug fix) Fixed bug in Tk_DoOneEvent(1) where it wasn't +checking files and X connections properly so it missed events. + +10/6/91 (new feature) Reorganized tkBind.c to provide generic "binding +table" structure, which can be used to create bindings on items in +canvases as well as windows. + +10/6/91 (new feature) Upgraded buttons and menus to use new tracing +code in Tcl 6.0. Allows radio buttons and check buttons to both set +and clear themselves when associated variable changes. + +10/17/91 (bug fix) Fixed 2 bugs in listboxes: accidentally advanced the +selection when new entries were inserted in the listbox after the location +of the selected item(s), and goofed up on redisplay if selected item +was deleted and then selection was immediately lost. + +10/27/91 (bug fix) "pack unpack" wasn't telling Tk that it no longer +manages window; this led to core dumps in some situations. + +10/31/91 (reorganization) Renamed manual entries so that they are no +more than 14 characters in length. + +10/31/91 (reorganization) Changed tk.h and tkInt.h so that tkInt.h +doesn't needed to be included by tk.h. + +11/3/91 (portability improvement) Eliminated use of "class" as a variable +name, since it's a reserved word in C++. + +11/7/91 (reorganization) Many changes to upgrade for Tcl 6.1 including +use of Tcl hash tables instead of separate "Hash_" module. The "lib" +subdirectory is no longer needed in Tk. + +---------------------- Release 1.3, 11/7/91 ------------------------- + +11/24/91 (bug fix) Fixed bug causing occasional errors if existing bindings +are modified (FindSequence in tkBind.c forget to set *maskPtr). + +11/24/91 (bug fix) Used wrong hash table in Tk_GetColorByValue. Could +cause new entries to get created unnecessarily. + +12/2/91 (bug fix) Changed "bind" code to put backslashes in front of +special characters (e.g. [ or \) that appear in %-replacements, so that +they can be parsed cleanly. + +12/10/91 (bug fix) Manual entries had first lines that caused "man" program +to try weird preprocessor. Added blank comment lines to fix problem. + +1/2/92 (documentation cleanup) Changed manual entries for Tk_GetBitmap +and the like to make it more clear that the argument must be a Tk_Uid +and not a string. + +1/2/92 (bug fix) Fixed problem where scrollbars that were very short or +very narrow (too small to hold both arrows) could cause negative values +in calls to XClearArea, which crashed some servers. + +1/2/92 (bug fix) Fixed bug in TkMeasureChars occurring when maxChars +is 0. Occasionally affected things like message window geometry. + +1/3/92 (new feature) Added procedures Tk_GetJustify, Tk_GetAnchor, +Tk_GetCapStyle, and Tk_GetJoinStyle, plus support for these things +in Tk_ConfigureWidget. + +---------------------- Release 1.4, 1/10/92 ------------------------- + +1/12/92 (bug fix) TkMenubutton.c wasn't cleaning up mbPtr->varName +properly during menubutton cleanup if an error occurred during +menubutton creation. + +1/19/92 (bug fix) Fixed off-by-one bug in tkListbox.c that caused +scrollbars to display a slider that was too large. + +2/10/92 (bug fix) Tk_CreateFileHandler didn't correctly handle case +where new mask was specified for existing handler. + +2/13/92 (bug fix) Tk_DeleteAllBindings wasn't correctly removing +bindings from the pattern table: only did the removal for the +first pattern in a pattern list. + +2/15/92 (new feature) Added procedures Tk_DefineBitmap and +Tk_SizeOfBitmap. Tk_GetBitmapFromData is now considered obsolete +and probably shouldn't be used anymore. Tk_GetBitmapFromData +is now implemented by calling Tk_DefineBitmap and Tk_GetBitmap. + +2/15/92 (new feature) Added "curselection" and "select clear" options +to widget command for listboxes. + +2/15/92 (new feature) Added Tk_3DBorderColor procedure. + +2/17/92 (relaxed limitations) Changed scrollbars so they no longer limit +the slider position to lie within the object's range: can scroll off the +end of an object, if the object permits it. Changed listboxes and +entries to explicitly prevent viewing off the ends. Also relaxed +listbox index checks so that out-of-range indices are automatically +adjust to fit within the listbox range. + +2/19/92 (bug fix) tkWindow.c tended to leave half-created windows around +if a new window's name was found to be in use already. Fixed to clean +them up. + +2/22/92 (new feature) Added -anchor, -bitmap, -height, -textvariable, +-width options to labels, buttons, check buttons, menu buttons, and radio +buttons. This means that (a) size can be controlled better, (b) bitmaps +can be displayed in any buttons, (c) the position of the text within the +button can be controlled, and (d) a button can be made to display the value +of a variable, continuously updating itself. Also changed -selector option +so that if it's specified as an empty string then no selector is drawn +for the button. + +2/22/92 (new feature) Changed menus to support bitmaps in menu entries: +added new -bitmap option for entries. + +2/26/92 (bug fix) "after" command, when invoked with just one argument, +called Tk_Sleep rather than registering a timer handler and looping on +Tk_DoOneEvent. As a result, it caused the application to become non- +responsive to X events during the sleep. Changed to use a Tk_DoOneEvent +loop so that it is responsive. + +2/26/92 (bug fix) Tk's main program didn't map the main window until +after the startup script returned. Changed to map the window as a +do-when-idle handler, so that scripts can cause the window to be +mapped immediately with a call to "update" or "after". + +2/28/92 (bug fix) "wm withdraw" wasn't working if invoked before window +was originally mapped: window got mapped anyway. Fixed so that the +window doesn't get mapped as long as it's withdrawn. + +2/29/92 (new feature) Can use "focus none" to clear input focus. + +2/29/92 (bug fix) Fixed tkEvent.c to generate SubstructureNotify events +properly. These weren't being generated previously. + +2/29/92 (bug fix) Fixed entries so that newline characters can be properly +displayed (as `\x0a'). Had to change interface to TkDisplayChars in order +to do this (added flags argument). + +2/29/92 (bug fix) Change Tk not to update size and position of top-level +windows directly during calls like Tk_ResizeWindow. Instead, wait until +actual event is received. This makes updates happen at same time as +callbacks. + +3/6/92 (bug fix) TkMenubutton.c was dumping core when a menubutton was +pressed at a time when there was no associated menu for the button. + +3/6/92 (new feature) Added Tk script library directory with official +Tk initialization file "tk.tcl". Other procedures used by Tk are in +other files. Tk procedures and variables all have names starting +with "tk_". Also added Wish startup script "wish.tcl", which sources +both the Tk and Tcl startup scripts. This means that things like +auto-loading and abbreviation expansion are now available in wish. +Added new variables tk_library, tk_priv, and tk_version. + +3/6/92 (new feature) It's now possible to set bindings for whole +classes by using the class name in the bind command. For example, +"bind Button {puts stdout Hi!}" will cause a message to be +printed whenever any mouse button is entered. Can also use "all" +to set bindings for all widgets. Widget-specific bindings override +class bindings which override "all" bindings. + +3/6/92 (reorganization) Changed buttons (all flavors) and listboxes to +eliminate all hard-wired behavior. Instead, default behavior is set +by class bindings in tk.tcl. Also set up class bindings for menus, +menubuttons, and entries, which previously had no default behavior at +all. Scrollbars and scales still have hard-wired behavior that can't +be overridden. + +3/7/92 (look-and-feel change) Changed listboxes and entries and menus +to use button 2 for scanning instead of button 3. This is more consistent +with the official Motif use of button 2 for dragging. + +3/10/92 (new features) Added more options to "winfo" command: screencells, +screendepth, screenmmheight, screenmmwidth, and screenvisual. + +3/13/92 (bug fix) Event sharing mechanism (tkShare.c) wasn't checking +to see whether window was mapped before sharing events with it. + +3/16/92 (bug fix) Tk_SetInternalBorderWidth was passing wrong window to +geometry-management procedures, causing core-dumps when menu buttons +had their border widths changed. + +3/16/92 (bug fix) Menus were setting their geometry directory rather +than using Tk_GeometryRequest mechanism. + +3/17/92 (new feature) Added -cursor option to all widgets to set the +active cursor for the widget. Also added TK_CONFIG_ACTIVE_CURSOR +configure type. + +3/18/92 (new feature) Implemented generalized screen coordinates to +allow resolution-independent specification in many cases (but pixel- +based coordinates are still OK). Added Tk_GetScreenMM(), +Tk_GetPixels(), new configure types TK_CONFIG_SCREEN_MM and +TK_CONFIG_PIXELS. Changed widgets to use this new configure types +wherever possible (a few of the more complex cases still haven't +been taken care of yet). Added "pixels" and "fpixels" options to +"winfo" command. + +3/18/92 (new feature) First cut at canvas widgets is done and part of +the official Tk now. Canvases display text and structured graphics, +and allow you to bind commands to events related to the text and +graphics. + +3/21/92 (new feature) Added new "place" command. It implements a +new geometry manager that provides fixed placement, rubber-sheet +placement, and combinations of the two. Eliminated the commands +"move", "resize", and "map" that were provided by main.c but never +officially supported; the placer provides all of this functionality. + +3/23/92 (bug fix) Fixed bug in tkWm.c where top-level windows were +occasionally not being given the right size. The problem occurred +when a string of resizes happened all in a row (such as deleting all +the windows in an application and then recreating them). + +3/23/92 (new feature) Added Tk_CoordsToWindow procedure and +"winfo containing" command. These may be used to locate the window +containing a given point. + +3/28/92 (new feature) Added "-exportselection" option to listboxes, +so that listbox selection need not necessarily be the X selection. + +4/12/92 (bug fix) Changed menu buttons to store name of menubutton +in the associated variable, rather than the name of the menu. This +is necessary in order to allow several menu buttons to share the +same menu. +*** POTENTIAL INCOMPATIBILITY *** + +4/12/92 (bug fix) Fixed core dump that occurred in tkError.c when +removing the first error record from the error list. + +4/15/92 (bug fix) Fixed bug in tkBind.c that prevented +event specifications from being processed correctly: the "1" was +treated as a button name rather than a keysym. + +4/18/92 (new feature) Added Tk_DefineCursor and Tk_UndefineCursor +procedures. + +4/18/92 (new feature) Major revision to listboxes. Can now scroll and +scan in both x and y, plus -exportselection option allows selection not +to be exported. The "view" widget command has been replaced by "xview" +and "yview", and the "scan" widget command has a new syntax. +*** POTENTIAL INCOMPATIBILITY *** + +4/18/92 (new feature) Added -exportselection option to entries, so you +can select whether you want the entry selection to be the X selection +or not. + +4/24/92 (new features) Added TK_CONFIG_CUSTOM type to Tk_ConfigureWidget, +plus added new flags TK_CONFIG_NULL_OK, TK_CONFIG_DONT_SET_DEFAULT, +and TK_CONFIG_OPTION_SPECIFIED. Several other new types, such as +TK_CONFIG_CAP_STYLE, were also added as part of implementing canvases. + +4/29/92 (bug fix) Changed "-selector" default for menus to have separate +values for mono and color. + +4/30/92 (bug fix) Fixed bug in tkListbox.c where it occasionally generated +bogus scroll commands (last index less than first). + +4/30/92 (reorganization) Moved demos directory to "library/demos". + +---------------------- Release 2.0, 5/1/92 ------------------------- + +5/2/92 (bug fix) Fixed problem in tkListbox.c where it was doing too many +redisplays after repeated insertions. Also reduced number of invocations +of scrollbar commands. + +5/7/92 (portability improvement) Changed main.c not to use TK_EXCEPTION +flag; it isn't needed and it causes problems on some systems. + +5/9/92 (bug fix) Plugged core leaks in tkListbox.c and tkBind.c + +5/9/92 (bug fix) TkBind.c was accidentally deleting bindings during +attempts to print non-existent bindings. + +5/11/92 (bug fix) Maximum name length for applications (name used in +"send" commands) was too short (only 20); increased to 1000. Also +fixed bug related to over-long names that caused core dumps. + +5/13/92 (bug fix) tkShare.c was using a dangling pointer if a share +group was deleted as a side-effect of a shared event. + +5/13/92 (bug fix) Various initialization and core leak problems in +tkGC.c, tkSend.c, tkMenu.c, tkEvent.c, tkCanvas.c, tkCanvPoly.c, +tkCanvLine.c, tkListbox.c, tkEntry.c. + +5/13/92 (bug fix) Empty entries could be scanned off the left edge, +displaying a garbage character. + +5/13/92 (bug fix) Fixed a few problems with window manager interactions, +such as tendency for windows to spontaneously shrink in size. By no +means are all of the problems fixed, though. + +5/13/92 (performance optimization) Changed Tk_GeometryRequest not to +invoke geometry manager unless requested size has changed. + +---------------------- Release 2.1, 5/14/92 ------------------------- + +5/1/92 (new features) Added flags like TK_IDLE_EVENTS to Tk_DoWhenIdle, +plus added "idletasks" option to "update" command. Tk_DoWhenIdle arguments +look different now, but the change should be upward-compatible. + +5/17/92 (new feature/bug fix) Added support for VisibilityNotify events +to the "bind" command. For some reason they weren't supported previously. + +5/17/92 (new feature) Added "tkwait" command. + +5/17/92 (new feature) Added "grab" command. + +5/17/92 (new feature) Added "-width" option to messages. Also changed +messages to use the computed (i.e. desired) line length when displaying, +not the actual width of the window. + +5/17/92 (bug fixes) Did some more fiddling with tkWm.c in the hopes +of improving window manager interactions. Now there won't be more than +one configure request outstanding to the wm at a time. + +5/17/92 (bug fix) Arrowheads on canvas lines weren't being translated +or scaled correctly. + +5/20/92 (bug fix) Page-mode scrolling didn't work correctly for canvases +(wrong windowUnits was passed to scrollbars). + +5/20/92 (bug fix) Changed scrollbars not to lose highlight when pointer +leaves window with button down. Also changed redisplay to double-buffer +for smoother redraws. + +5/21/92 (new feature) Added "gray50" and "gray25" as predefined bitmaps. + +5/22/92 (new feature) Buttons can now be disabled using the "-state" and +"-disabledforeground configuration options. The "activate" and "deactivate" +widget commands for buttons are now obsolete and will go away soon. +Please change Tcl scripts not to use them. + +5/23/92 (new feature) Entries can now be disabled using the "-state" +config option. Also improved class bindings for entries to keep the +cursor visible in the window when operations occur. Also made slight +improvements in the way redisplay is done. + +5/23/92 (new feature) Added "-textvariable" option to entries so that +the text in an entry can be tied to the value of a global variable in +a fashion similar to buttons. + +5/27/92 (new feature) Added "-textvariable" and "-anchor" options to +messages. + +5/28/92 (new feature) Added "-padx" and "-pady" and "-underline" options +to menubuttons. + +5/28/92 (feature change) Changed "-width" and "-height" options on +all flavors of buttons and menubuttons so that they are orthogonal +to "-padx" and "-pady". It used to be that -width overrode -padx +(no padding). Now they accumulate. + +5/29/92 (new feature) Added "-disabledforeground" option to menus and +all flavors of buttons (can specify color for disabled things rather +than just using stipple to gray out). + +5/29/92 (new features) Added many new options to menu entries: +-activebackground, -background, -font, -state, -underline. The +"disable" and "enable" widget commands for menus are now obsolete +and will go away soon. Please change Tcl scripts not to use them. + +5/29/92 (new features) Added "atom" and "atomname" options to "winfo" +command. + +5/29/92 (new feature) Wrote tk_listboxSingleSelect procedure, which +can be used to change listbox behavior so that only a single item is +selected at once. + +6/1/92 (new feature) Added new modifier names "Meta" and "Alt" for +"bind" command. + +6/3/92 (new feature) Added "winfo toplevel" command. + +6/3/92 (new feature) Made several changes for greater Motif compliance, +including: + - menu retention if you click and release in the menu button, + - keyboard traversal of menus (see traversal.man) + - no widget flashing if you set $tk_strictMotif to 1 + +6/15/92 (bug fix) Fixed problem in tkBind.c where command string for a +binding could get reallocated while the command was being executed (e.g. +bindings that delete or change themselves). + +6/15/92 (bug fix) Don't allow "tabWidth" field to become zero in tkFont.c: +can cause core dumps for fonts that don't enough information to compute +tab widths. + +6/19/92 (bug fix) Fixed bug in binding mechanism that caused structure- +related events to be reported both to the correct window and its parent. + +7/14/92 (bug fix) Changed tkColor.c not to free colors for visual types +StaticGray or StaticColor. + +7/15/92 (new feature) Text widgets now exist. They display any number of +lines of text with a variety of display formats, and include hypertext +facilities. See the manual page for details. + +7/20/92 (bug fix) If a top-level window was put in the iconic state to +begin with, it could be deiconified with "wm deiconify .foo" until it had +first been deiconified by hand from the window manager. Tk was getting +confused and thought the window was mapped when it wasn't. + +7/29/92 (bug fix) Don't permit rectangles or ovals to have zero-sized +dimensions. Round up to at least one pixel. + +7/29/92 (new features) Major upgrade to canvases: + - new item types: arc, window, bitmap + - added Bezier spline support for lines and polygons + - rectangles and ovals now center their outlines on the shape, + rather than drawing them entirely inside the shape + - new "coords" and "bbox" widget commands + - new "-tags" option for all item types. + - new "-confine" option to prevent scrolling off edge of canvas. + +8/6/92 (new feature) Added "-width" and "-height" options to frames. +The "-geometry" option is now obsolete and should be removed from Tcl +scripts: it may go away in the future. + +8/7/92 (bug fix) Error messages in Tk_ParseArgv were sometimes including +the option name where they should have included its value. + +---------------------- Release 2.2, 8/7/92 ------------------------- + +8/7/92 (bug fix) Changed tkCanvas.c to be more conservative in the area +it passes to XCopyArea. + +8/8/92 (bug fix) Fixed bug in tkTextDisp.c that sometimes caused core +dumps when text views changed (e.g. typing return on last line of screen). + +8/8/92 (bug fix) Fixed bug in menu.tcl that caused errors when using +keyboard to traverse over separator menu entries. + +8/10/92 (bug fix) Changed to use OPEN_MAX instead of MAX_FD to compute +maximum # of open files. + +8/10/92 (bug fix) Canvases weren't updating scrollbars on window size +changes. They also weren't recentering canvases on window size changes. + +8/10/92 (bug fix) There were still a few places where commands were being +invoked at local level instead of global level (e.g. commands associated +with buttons and menu entries). + +8/10/92 (bug fix) TkBind.c used to ignore explicit shift modifiers for +all keys (i.e. was treated the same as ). Modified to +allow explicit request for shift modifier, like . + +8/13/92 (feature change) Changed default fonts to request "Adobe" fonts +explicitly. + +8/16/92 (bug fixes) Modified tkCanvArc.c and tkTrig.c to increase slightly +the bounding boxes for arcs, in order to make sure that proper redisplay +occurs when arcs are moved (little turds were getting left behind). + +8/16/92 (bug fix) Modified tkCanvas.c not to redraw at all if the redisplay +area is off the screen. Also, only do a background clear for the portion +of the redraw area that is on-screen. Also, reduced size of off-screen +pixmaps used for redisplaying, which speeds up redisplay in some cases. + +8/19/92 (bug fix) Canvases that were taller than wide were not being +redisplayed properly. + +8/20/92 (new feature) Added Tk_CreateGenericHandler procedure for trapping +all X events (useful for tracing, watching non-Tk windows, etc.). + +8/21/92 (bug fix) Widgets weren't always being notified when they got +the focus back again (the problem had to do with grabs and menus in +particular). + +8/21/92 (new feature) Added "-state" option to scale widgets. + +8/22/92 (new feature) Changed tkBitmap.c to allow tilde-substitution +to occur in bitmap file names. + +---------------------- Release 2.3, 8/24/92 ------------------------- + +8/27/92 (bug fix) Changes to -activebackground and -activeforeground options +for menubuttons were being lost. + +8/27/92 (bug fix) Entries were selecting last character when a B1-drag +occurred past the right edge of the text. + +8/28/92 (bug fix) Fixed bug in canvases where a grab during a button +press caused the canvas state to lock up so that it didn't select a +new current item. + +9/7/92 (bug fix) Changed tkMenu.c to accept numerical menu indices that +are out of range; now it just rounds them off to the nearest existing +entry. + +9/7/92 (bug fix) Fixed bug in tkTextDisp.c that caused core dumps when +invoking "yview -pickplace" widget command on texts that are too small +to hold any lines at all. + +9/11/92 (bug fix) Fixed bug in tkTextDisp.c that caused core dumps +when adding tags to non-existent lines. + +9/11/92 (bug fix) Line items in canvases didn't permit an empty fill +color (i.e. couldn't make them transparent). + +9/14/92 (reorganization) Changed manual entries to use .1, .3, and .n +extensions. Added "install" target to Makefile to suggest how Tk should +be installed. + +9/16/92 (bug fix) Changed tkSend.c to always specify the root window of +screen 0 rather than using DefaultRootWindow. DefaultRootWindow doesn't +always go to screen 0 on displays with multiple screens, which can result +in send's not being possible between the screens. + +9/18/92 (new feature) Added three new options to "wm" command: "protocol", +"client", and "command". These provide support for window manager protocols +such as WM_DELETE_WINDOW and WM_TAKE_FOCUS, plus support for the +WM_CLIENT_MACHINE and WM_COMMAND properties. + +9/30/92 (new feature) Implemented color model support, including +"tk colormodel" command and Tk_GetColorModel and Tk_SetColorModel +procedures. These allow you to force mono operation even on a color +display. Also changed color allocation not to give errors when colors +run out, but just to switch to a mono color model. + +10/1/92 (bug fixes) Fixed two bugs in tkTextBTree.c that caused core dumps +during text deletion. + +10/5/92 (bug work-around) Changed tkColor.c to ignore errors when freeing +colors. This is needed to work around improper reference count management +for colormap entries under X11/NeWS. + +10/7/92 (new feature) Added support for different visual types, including +procedures Tk_SetWindowVisual and Tk_SetWindowColormap, plus macros +Tk_Visual, Tk_Depth, and Tk_Colormap. The code for this was contributed +by Paul Mackerras. + +10/7/92 (new feature) Added Tk_IsTopLevel macro. + +10/12/92 (bug fix) Fixed bug in tk.tcl that caused torn-off menus with +cascaded children not to track mouse motion correctly (the cascade +switched in response to mouse motions within the cascaded child). + +10/12/92 (new feature) Major changes to focus handling: +(a) Tk watches FocusIn and FocusOut events for focus changes, not Enter + and Leave, so it will work better with explicit-focus-model window + managers (e.g. mwm in default mode). +(b) Tk generates FocusIn and FocusOut events for the focus window now. + The old procedural interface (via Tk_CreateFocusHandler) is obsolete + and is no longer used inside Tk. It is still supported for + compatibility, but won't be for long. You should change your code + to use FocusIn and FocusOut events instead. +(c) The model for FocusIn and FocusOut events is different than the + one described in Xlib documentation. See the "focus" manual entry + for details. +(d) If there is no input focus then keyboard events are discarded. They + used to be directed to the mouse pointer window, although this wasn't + documented. The focus now defaults to the root window. +*** POTENTIAL INCOMPATIBILITY *** + +10/15/92 (bug fix) Fixed text items in canvases where they didn't +display the insertion cursor if the item had no characters in it. + +10/26/92 (bug fix) Fixed bug in tkSelect.c that occasionally caused +BadWindow X protocol errors when retrieving the selection. Tk wasn't +making sure that a window existed before using it to retrieve the +selection. + +10/30/92 (feature change) Changed canvases so that if the scroll region +is smaller than the window and -confine is on, the scroll region isn't +forced to be centered in the window; it can be anywhere that meets the +confinement restrictions. + +11/2/92 (new feature) Added "winfo exists" command. + +11/5/92 (new feature) Changed DoWhenIdle handlers so that if a new +when-idle handler is created as a side-effect of another when-idle +handler, the new handler isn't invoked until Tk has first checked +for other events to process. + +11/6/92 (bug fixes, new features) Major overhaul of window manager +interface: +(a) Tk should now work with virtual-root window managers; +(b) windows will now place more accurately on the screen and stay where + they're supposed to; +(c) size changes handled more reliably; +(d) code now works robustly in the face of withdrawals followed + immediately by deiconifications. +(e) Added new procedure Tk_GetVRootInfo and new options to "winfo" command: + vrootx, vrooty, vrootwidth, vrootheight. +(f) Added "overrideredirect" option to "wm". +(g) Fixed bug where change in width-only via "wm geom" didn't always work + (min and max window sizes weren't being set properly for the wm). + +11/6/92 (bug fixes) Modified menus so that they work correctly with +virtual root window managers. Also fixed bug where menus didn't move +along with their associated windows, so that the menu popped up at +the old location of the window rather than its new location. + +11/9/92 (new constraint) Made it illegal to give windows names that +start with upper-case letters, since such names will goof up the +option database by appearing to be classes rather than names. +*** POTENTIAL INCOMPATIBILITY *** + +11/10/92 (new feature) Added Postscript output to canvases. + +11/13/92 (bug fix) Changed default for maximum size passed to window +manager from 1000000 (which causes some wm's to make windows too large +when "maximized") to the size of the display. + +11/14/92 (feature change) Major overhaul of menubuttons and pull-down +menus. Removed event-sharing code, including Tk_ShareEvents and +Tk_UnshareEvents. The -variable option for menubuttons has been +removed,and the "post" and "unpost" widget commands for menubuttons +no longer exist. The "post" widget command for menus no longer +allows a group option. The procedure tk_menus has been replaced +with a new procedure, tk_menuBar, which has a slightly different +interface. +*** POTENTIAL INCOMPATIBILITY *** + +11/20/92 (new features, feature changes) Major overhaul of grab +mechanism to produce more correct event streams. Also changed Tcl +commands to require explicit window for grab releases (makes it +possible for grabs to work on multiple displays simultaneously). +The old "grab none" command no longer exists, but new options +have been added: "current", "release", "set", and "status". +*** POTENTIAL INCOMPATIBILITY *** + +11/20/92 (new feature) Use TK_LIBRARY environment variable to set library +directory location, if it is defined. Otherwise fall back on usual +compiled-in value. + +11/25/92 (bug fix) "wm grid" command was using wrong window. + +11/29/92 (bug fix) Fixed core dump that occurred when trying to use +placer on top-level windows: return error instead. + +11/29/92 (bug fix) Selection retrieval wasn't making sure that the window +on whose behalf selection is being retrieved actually exists. + +12/3/92 (new feature) Added support for Mode_switch key to support the +full ISO character set. Also added event handlers for MappingNotify +events so that Tk updates itself in response to keycode and modifier +changes. + +12/6/92 (bug fix) Ignore recursive attempts to destroy window. + +12/9/92 (new demos) Added "tcolor" and "rmt" demos. + +12/10/92 (new features) Added "yposition" widget command for menus, +changed "delete" widget command to take an optional second index, +and changed -command option for cascade entries so that it is +invoked when the entry is activated rather than when it is invoked. +*** POTENTIAL INCOMPATIBILITY *** + +12/12/92 (implementation change) Changed the procedures Tk_FreeBitmap, +Tk_NameOfBitmap, Tk_SizeOfBitmap, Tk_FreeCursor, Tk_NameOfCursor, and +Tk_FreeGC to require an addition Display argument. This is needed for +Tk to function correctly when an application has windows on multiple +displays. +*** POTENTIAL INCOMPATIBILITY *** + +12/12/92 (new feature) Started creating a test suite. Right now it +only has a few tests. + +12/12/92 (new feature) Modified the packer so that a window can be +packed in descendants of its parent (used to be restricted to the +parent alone). This makes it possible to hide extra windows used +for geometry management. Also, can use generalized screen distances +in the "pack" command. + +12/16/92 (feature change) Boolean options such as -exportselection now +print as 0/1 rather than true/false (both the default and current values +print this way). This makes it easier to use these values in expressions. +*** POTENTIAL INCOMPATIBILITY *** + +12/16/92 (name change) The classes "RadioButton" and "CheckButton" have +been renamed "Radiobutton" and "Checkbutton" for consistency. From now +on widget class names will have exactly one capital letter. +*** POTENTIAL INCOMPATIBILITY *** + +12/16/92 (new feature) Added -setgrid option to listboxes. + +12/16/92 (new feature) The "destroy" command, and the "delete" widget +command for canvases, now accept any number of arguments, including +zero. + +12/16/92 (new feature) Changed internal TkBindError procedure to +Tk_BackgroundError and exported it to Tk clients. + +12/16/92 (option name change) Changed the place command's "dependents" +option to "slaves" for better consistency with documentation. +*** POTENTIAL INCOMPATIBILITY *** + +12/16/92 (name changes) Renamed the "cursor*" options in entries and +canvases to "insert*". Also renamed the "cursor" index to "insert" and +the "cursor" widget command to "icursor". This was done to avoid +confusion between the mouse cursor and the insertion cursor. +*** POTENTIAL INCOMPATIBILITY *** + +---------------------- Release 3.0, 12/17/92 ------------------------- + +12/17/92 (bug fix) Fixed dangling-pointer bug in canvases that occurred +if a binding deleted the current item. + +12/18/92 (bug fix) Core dump occurred if "wm" invoked with no arguments. +Also, tkWm.c wasn't properly setting WM_CLASS property on application +startup. + +12/18/92 (incorrect documentation) Updated manual entries for Tk_FreeGC, +Tk_FreeCursor, and Tk_FreeBitmap to reflect new interface that requires +"display" argument. + +12/18/92 (missing documentation) Added documentation for the canvas +"postscript" command, which was missing in the 3.0 release. + +12/21/92 (bug fixes) There were lots of problems with the new installation +targets in the Makefiles, such as using "cp -f" and not installing +prolog.ps. Made several other miscellaneous improvements to Makefile. + +12/21/92 (bug fix) Arrowheads on canvas line items weren't moving properly +after coordinate changes made with the "coords" widget command. + +12/21/92 (bug fix) If top-level window was initially withdrawn, couldn't +ever deiconify it again. + +12/21/92 (bug fix) Double-button event sequences didn't always trigger +properly when grabs were in effect. + +12/22/92 (bug fix) The packer didn't display any top or bottom windows +after a left or right expanded window, and vice versa. Also made the +distribution of space among expanded windows more even. + +12/28/92 (new features) Several improvements to selection: +(a) Added procedures Tk_ClearSelection and Tk_DeleteSelHandler. +(b) Added "clear" and "own" options to "selection" command, extended + "handle" option to delete handlers. +(c) Error returns from "selection handle" scripts are now turned into + selection retrieval errors ("no such selection") rather than an + empty selection. +(d) Tk responds automatically for targets APPLICATION (name of application, + so you can "send" to it) and WINDOW_NAME (name of window within + application. +(e) Added test file "select.test" to test suite. + +12/28/92 (bug fix) Fixed problem with flashing menus that occurred +because menu.tcl was willing to unpost and then immediately repost +the same menu. + +1/6/93 (bug fix) Test for UnmapNotify events in tkPack.c used = instead +of ==. + +1/21/93 (bug fix) Changed many widgets to eliminate use of +DefaultVisualofScreen, DefaultColormap, etc. and use the visuals +and colormaps for the actual windows instead. Also changed to +inherit colormaps and windows from parent by default. + +1/21/93 (new features) Added new winfo options "cells", "depth", and +"visual". + +1/23/93 (bug fix) Fixed problem with text display that could result +in negative XCopyArea heights being sent to X server. This causes some +servers (e.g. some versions of OpenWindows) to crash. + +1/25/93 (new feature) Added -postcommand option to menus, so that menus +can be reconfigured before each posting. + +1/29/93 (feature change) Changed %X and %Y in bindings so that they +refer to the virtual root rather than the true root. Although +potentially incompatible, this change should almost always "do the +right thing". +*** POTENTIAL INCOMPATIBILITY *** + +1/31/93 (bug fix) Changed "send" code to grab server while updating +the registry property (before this fix, two programs could allocate +the same interpreter name if they started up simultaneously). In +order to make this fix I had to change the code for reclaiming +names of dead interpreters in a way that sometimes allows dead +interpreters to persist in the registry. + +2/1/93 (feature change) Changed entries to allow leftmost "visible" +character to be the end of the text (i.e. no characters actually visible). +This is needed so that the cursor can be displayed even if the last +actual character is too wide to fit in the window. + +2/3/93 (bug fix) Fixed two bugs in tkFocus.c: (a) FocusIn events +were getting lost in some cases because the focus window hadn't been +created yet (e.g. new top-level window pops up underneath the mouse); +(b) Tk was accidentally triggering FocusOut events when the mouse +moved from a top-level window to one of its children. + +2/4/93 (new feature) Added "visibility" option to "tkwait" command to make +it easier to wait for a new window to appear on the screen. + +---------------------- Release 3.1, 2/5/93 ------------------------- + +2/10/93 (installation improvements) Makefile improvements: added RANLIB +variable for easier Sys-V installation, changed to use INCLUDE_DIR +properly, and added SHELL variable for SGI systems. + +---------------------- Release 3.2, 2/11/93 ------------------------- + +2/11/93 (new feature) Added "wm state" command, and improved wm so that +the right thing will happen if you invoke "wm iconify" when a window is +withdrawn. + +2/14/93 (bug fix) When -colormap option was used in generating Postscript +for canvases, Tk didn't add an extra space after the color command. + +2/14/93 (new feature) Changed "extern" declarations in tk.h to "EXTERN", +which will use the definition of EXTERN from tcl.h and work correctly +in C++ programs. + +2/18/93 (bug fix) Item-specific bindings weren't getting deleted from +canvas items when the items were deleted. As a result, they could +suddenly re-appear for new items if the new items were allocated a +record at the same addresses as the old ones. + +2/18/93 (feature reversal) Changed "after" back again, so that it sleeps +*without* responding to events when it is invoked with just one argument; +can always use tkwait plus after with additional arguments to achieve +the effect of responding to events. +*** POTENTIAL INCOMPATIBILITY *** + +2/20/93 (bug fix) Fixed bug in tkWindow.c where colormaps weren't being +set correctly for new top-level windows on different screens than their +parents (the bug results in X protocol errors: "invalid Colormap +parameter"). + +2/22/93 (bug fix) Changed "#!/usr/local/wish" in demo scripts to +"#!/usr/local/bin/wish" to reflect new location of binary. + +2/22/93 (new feature) Added new reliefs "groove" and "ridge". + +2/25/93 (new feature) Added new built-in bitmaps: "error", "hourglass", +"info", "question", "questhead", and "warning". Also added new demo in +"widget" to display all of these (under the Miscellaneous menu). + +2/25/93 (improved implementation) Changed DrawText procedure in +prolog for outputting Postscript from canvases to use stringwidth +instead of charpath+pathbbox: avoids limitcheck problems with long +strings, and also properly includes space characters in calculation. + +2/25/93 (bug fix) Fixed several bugs in library/menu.tcl that caused +menu traversal to mis-behave when menu had no entries. + +2/26/93 (new feature) Added "wm frame" command. + +3/6/93 (bug fix) Mwm in click-to-focus mode was goofing up grabs so that +pull-down menus were sometimes unresponsive. Modified tk.tcl to ignore +the spurious B1-Enter events generated by mwm, plus modified tkGrab.c to +release simulated button grabs correctly. + +3/8/93 (bug fix) Tk had wrong interpretation of "lbearing" font metric, +which caused text to be displayed at the wrong horizontal position in +several places (labels/buttons, listboxes, canvas text, scales). This +change will cause slight changes in the way certain widgets are +displayed. + +3/12/93 (bug fix) Fixed core dumps that occurred in tkEntry.c because of +zero values in entryPtr->avgWidth. + +3/12/93 (bug fix) Tk_CoordsToWindow was using root coordinates always. +Changed to use virtual-root coordinates when a virtual-root window +manager is being used. Before this fix, "winfo containing" didn't +return the correct window under virtual-root window managers. + +3/18/93 (bug fix) Modified tkWm.c so that Tk doesn't fight with window +manager over position of window; it just takes what the window manager +gives it. + +3/21/93 (new feature) Changed menus to display cascade entries with +standard Motif arrows at right side.a + +3/22/93 (bug fix) Fixed bug in tkPack.c that was causing memory to +get trashed with the integer value 1. + +3/22/93 (bug fix) Canvas text didn't print correctly if it contained +an open paren (or other special character) immediately followed by +an octal digit. + +3/22/93 (bug fix) Text widgets didn't redisplay properly in cases +where two or more groups of lines both got taller at the same time +(e.g. from tag changes), causing two separate bit copies where the +first bit copy's target area overlapped the source area for +the second bit copy. + +4/1/93 (bug fix) Changed canvases to use ISO Latin-1 font encoding +if that's supported by the Postscript interpreter. Also added workaround +for bug in NeWSprint related to stipple fills. + +4/1/93 (bug fixes) Made various changes to focusing and grabs to +eliminate extraneous focus events and generally improve behavior. + +4/2/93 (bug fix) Modified tkWm.c not to wait indefinitely for the window +manager to map or reconfigure a window: this led to deadlock in some +situations, such as creating a new top-level window with a grab held. + +4/19/93 (bug fix) Fixed another bug in tkWm.c that caused windows to walk +across the screen in some situations. Also fixed problem where rapid +posting and unposting of cascaded submenus (or menus?) could cause Tk +to become confused about whether or not a window is mapped (added +TkWmUnmapWindow procedure to make top-level unmaps synchronous). + +4/24/93 (feature change) Changed the "after" command to allow times +less than or equal to 0, and to use 0 whenever they occur. + +4/26/93 (new feature) Implemented security check for "send" as proposed +by Bennett Todd: incoming sends are now rejected unless (a) xhost-style +access control is enabled and (b) the list of authorized hosts is +empty. In other words, you have to use xauth to use send. This feature +can be disabled by setting the TK_NO_SECURITY flag at compile-time. + +5/15/93 (improvement) Switched to use Tcl_PrintDouble whenever returning +real values as Tcl results. This potentially allows higher precision. +Switched to use %.15g whenever printing reals in Postscript files. +However, the change Tcl_PrintDouble causes incompatibilities. For +now, it's disabled with a macro in tclInt.h that redefines Tcl_PrintDouble. +Tk 4.0 will delete the macro, and you can also delete it now if you +want the better (but incompatible) behavior. + +5/19/93 (bug fix) Fixed divide-by-zero problem that could occur in +closeness calculations for canvas oval items. + +5/30/93 (bug fix) PROP and CONFIG were accidentally #defined to the same +value in tkBind.c, which could cause incorrect %-substitutions in event +bindings in a few exotic cases. + +6/4/93 (improvement) Changed to use GNU autoconfig for configuration. +Makefile format changed, and Tcl is no longer automatically included +in Tk releases. + +6/7/93 (bug fix) Fixed off-by-one error in rounding negative coordinates +during redisplay of canvases. + +6/9/93 (feature improvement) Modified default bindings for entries to +keep one character visible to the left of the cursor during backspaces. + +6/18/93 (feature improvement) Added patchlevel.h, for use in coordinating +future patch releases, and also added tk_patchLevel variable to make the +patch level available in scripts. + +6/26/93 (bug fix) Fixed numeric problems in scales that occurred with +very large scale values. + +6/26/93 (bug fix) Polygon items in canvases could cause core dumps if +the "coords" widget command was used to add one new coordinate. + +6/26/93 (bug fix) Changed canvases to handle large stipple patterns +gracefully (stipples used to jump around during redisplay and lose +coherency). + +7/1/93 (syntax change, new feature) Implemented the new packer syntax +as described in the book. For now the old syntax will continue to be +supported too. Converting over is straightforward except (a) use +"-anchor" instead of "frame", and (b) padding is different (separate +internal and external padding, plus pad amounts are *on each side* +instead of total). Also added "pack propagate" command for keeping +the packer from setting the master's requested size. + +7/1/93 Changed copyright notices. The effect is the same as with the +old notices, but the new notices more clearly disclaim liability. + +7/7/93 (new feature) Added support for window stacking order. Windows +will now stack in the order created (most recent on top), plus "raise" +and "lower" commands may be used to restack (Tk_RestackWindow procedure +is available from C level). + +7/7/93 (reorganization) Moved main.c to tkMain.c, reorganized it to +call Tcl_AppInit just like tclsh does, and added argv0 variable to contain +application name, and added default Tcl_AppInit procedure for wish. +Also added tkTest.c to hold C code for testing. + +7/7/93 (new feature) Added new Tk-specific "exit" command, which cleans +up properly before exiting. It replaces the Tcl "exit" command, and +can be used in place of "destroy .". + +7/9/93 (new features) Added tk_dialog library procedure that creates +dialogs with a bitmap, message, and any number of buttons. Also changed +default tkerror procedure to use tk_dialog plus offer the user a chance +to see a Tcl stack trace. + +-------------------- Release 3.3 Beta 1, 7/9/93 ------------------------- + +7/12/93 (configuration changes) Eliminated leading blank line in +configure script; provided separate targets in Makefile for installing +binary and non-binary information; fixed -lnsl and -lsocket handling +in configure; added autoconf support for fd_set type; check for various +typedefs like mode_t and size_t, and provide substitutes if they +don't exist; don't include tkAppInit.o in libtk.a; try to locate the +X includes and library in all of the standard places for various systems. + +7/14/93 (new feature) Modified tkMain.c so that it stores the value +of the -display command-line option into the DISPLAY environment +variable, if it is specified. + +7/15/93 (feature removal) Removed auto-initialization feature from +Tk_ConfigureWidget, so that you must once again initialize all fields +of a widget record before calling Tk_ConfigureWidget. This restores +the behavior back to what it was in Tk 3.2. + +7/16/93 (bug fix) Modified tkBind.c to ignore the Caps Lock modifier +unless it is explicitly requested in a binding. Without this fix, +buttons and menus and other things didn't work if the Caps Lock key +was active. + +-------------------- Release 3.3 Beta 2, 7/21/93 ------------------------- + +7/21/93 (new feature) Change "make install" so that it will modify the +#! lines on demo scripts to reflect the place where the wish binary +is installed. + +7/23/93 (new feature) Added Tk_MainWindow procedure that returns the +main window associated with a Tcl interpreter. This is intended for +use by Tcl_AppInit and other initialization procedures. + +7/24/93 (configuration improvements) Changed configure script not to +omplain about "fd_set" missing if it's defined in . + +7/28/93 (bug fix) "Bad Match - parameter mismatch" errors were +sometimes occurring when several top-level windows got created +at the same time, due to wrong choice of sibling when stacking +windows. + +8/14/93 (new feature) Added support for tcl_prompt1 and tcl_prompt2 +to wish main program: makes prompts user-settable. + +8/19/93 (bug fix) Bindings to event sequences like "aD" never matched +because the Shift key has to be pressed before D. Modified Tk to +ignore extraneous keypresses if they are for modifier keys. + +8/26/93 (configuration changes) Added Tk_Init, modified Tcl_AppInit +procedures to use it and Tcl_Init. Added support for .wishrc file. + +8/28/93 (new feature) The main window is now a legitimate toplevel +widget. + +-------------------- Release 3.3 Beta 3, 8/30/93 ------------------------- + +9/2/93 (bug fix) The packer wasn't always relaying out a master after +changes to some of the configuration options of its slaves. + +9/2/93 (bug fix) The binding mechanism made it impossible for patterns +like to ever match. + +9/2/93 (bug fix) Fixed core dump that occurred for bitmap canvas items +if Postscript is generated but no -bitmap option has been specified. + +9/4/93 (enhancement) Slight improvements to menu traversal: set menu +traversal bindings for menubar window in tk_menuBar, plus trigger +traversal on instead of . + +9/9/93 (bug fix) Changed tkBind.c so that the Num_Lock key doesn't +prevent events from triggering bindings. + +9/9/93 (bug fix) Changed tkOption.c to always fetch RESOURCE_MANAGER +property from root window of screen 0, rather than using default +screen. + +9/9/93 (bug fix) Entry widgets weren't allocating quite enough width +for themselves. Fixed this and changed the size computation to match +what's done for buttons and texts. + +9/16/93 (bug fix) Changed tkMain.c not to call exit C procedure directly; +instead always invoke "exit" Tcl command so that application can redefine +the command to do additional cleanup. + +-------------------- Release 3.3, 9/29/93 ------------------------- + +9/30/93 (bug fix) Packer wasn't unmapping slaves when master got deleted. + +9/30/93 (bug fix) Binding event sequences such as were being +misprinted as ASCII characters such as "S". + +10/6/93 (bug fix) Canvases weren't unmapping window items when the canvas +got unmapped, which caused problems for window items whose windows weren't +descendants of the canvas (they got left on the screen). + +10/7/93 (feature change) NULL proc arguments to Tk_CreateFileHandler used +to have a special undocumented meaning (fd was display); eliminated this +special interpretation. + +10/7/93 (configuration change) Eliminated dependency of tkMain.c on +tkInt.h and tkConfig.h, so that it's easier for people to copy the file +out of the source directory to make modified versions. + +10/8/93 (bug fix) 3.0 introduced a bug where the class of the application +wasn't being set properly, so options based on the application class +weren't triggering. Fixed by adding new argument to Tk_CreateMainWindow. + +10/11/93 (bug fix) Fixed bug in tkTextBTree.c where some deletions would +cause core dumps due to halfwayLinePtr not getting set correctly. + +10/18/93 (bug fix) Fixed a couple of bugs that made it hard to actually +display N characters in an entry with "-width N" (tended to scroll the +entry so that only N-1 characters were visible at once). + +10/22/93 (bug fix) During configuration, XINCLUDE_DIR and XLIBRARY_DIR +weren't overriding xmkmf like they were supposed to. + +10/23/93 (new feature) Allow negative scale factors in canvas "scale" +widget command. + +10/23/93 (bug fix) Grabs weren't being cleaned up right if the grab +window was deleted, causing core-dumps in some cases. + +10/23/93 (bug fix) tk_TextSelectTo wasn't checking to be sure that +the "anchor" mark exists. + +10/27/93 (bug fix) Fixed core dump that could occur in a text widget if +the scroll command modifies the text. + +11/1/93 (bug fix) Change texts so that the -yscrollcommand option is +invoked at display time, not when the window is re-layed out. This +eliminated various core dumps that could occur if -yscrollcommand modified +the text. + +-------------------- Release 3.4, 11/04/93 ------------------------- + +Note: there is no 3.5 release. It was flawed and was thus withdrawn +shortly after it was released. + +11/12/93 (bug fix) TkMain.c didn't compile on some systems because of +R_OK in call to "access". Changed to eliminate call to "access". + +-------------------- Release 3.6, 11/26/93 ------------------------- + +11/10/93 (bug fix) Packer and placer didn't always reposition a window +correctly if it was managed inside a neice or lower descendant (using +"-in" option) and the neice's parent moved. + +11/24/93 (bug fix) Fixed time problem in selection (retrievals could +fail if retriever hasn't received any X events since selection was +made, so that time of retrieval appears to be older than time of +selection). Selection code is now much less picky about times, both +on retrieving and supplying sides. + +12/2/93 (new feature) Changed arrow-head drawing code for canvas +lines to draw a 0-width outline in addition to filling the area: +this produces much nicer, more symmetrical displays. + +12/2/93 (bug fix) When colors ran out, Tk was invoking "tkerror" +when its state was internally inconsistent, which could cause +core dumps in some situations (e.g. if tkerror used the same color +that caused colors to run out). Changed notification to occur +as a when-idle handler. + +12/3/93 (bug fix) During a global grab, Tk wasn't including PointerMotion +in the list of grabbed events, so pointer motion couldn't be tracked +outside the grabbing application. + +12/3/93 (bug fix) Canvases didn't handle smoothed lines correctly +when they only contained two points. + +12/3/93 (bug fix) Fixed bug in tkWindow.c where certain kinds of +errors during window creation could cause Destroy events to be generated +for a window that was never completely initialized. + +12/13/93 (bug fix) Fixed bug in tkTextDisp.c that resulted in core +dumps at line 1467 under exmh. The exact situation is that a text +widget was being redisplayed at a time when it had a -yscrollcommand +option but hadn't yet been mapped onto the screen. + +12/17/93 (bug fix) Fixed bug in tkWindow.c whereby new top-level windows +with non-default visuals still inherited border pixmap from parent (root), +which could cause visual clash and X error. + +12/17/93 (bug fix) Fixed bug in tkTextDisp.c that caused round-off +error in the information passed to scroll commands. + +12/18/93 (bug fix) Fixed bug in tkPack.c that caused core dumps in +some situations if a master with siblings packed "-in" it was deleted. + +12/18/93 (bug fix) Added "compat" directory to distribution, since it's +referenced by tkConfig.h on some systems. + +12/18/93 (performance improvement) Improved performance of appending to +a listbox, so that inserting N items doesn't take N**2 time. + +12/20/93 (bug fix) Fixed bug in canvas ovals that caused the fill color +for the oval to stick out past the outline. + +1/2/94 (fixed Xlib bug) Added code to reuse X resource identifiers so +that they won't run out in long running applications. There are three +new library procedures: Tk_FreeXId, Tk_GetPixmap, and Tk_FreePixmap. +Modified all Tk code to use these procedures, so wish applications should +now be able to run forever without running out of identifiers. + +1/10/94 (bug fix) tkCursor wasn't freeing pixmaps used to create +cursors, which caused memory leaks in programs that changed cursors +frequently. + +1/21/94 (bug fix) Fixed bug in scales that caused them to loop +infinitely drawing tick-marks when -from and -to were the same. + +2/2/94 (bug fix) Fixed problem where messages that contained tabs +didn't always compute the correct size, so that text spilled off +the right edge. The fix adds an extra "tabOrigin" parameter to +the internal procedures TkMeasureChars, TkDisplayChars, and +TkUnderlineChars. + +2/4/94 (bug fix) Fixed off-by-one problem in tkBind.c that caused +it to read past the initialized part of dispPtr->modKeyCodes. + +2/7/94 (bug fix) Text widgets didn't handle grabs correctly, such +that the "current" character got stuck if a grab occurred while a +mouse button was down. It would get unstuck until after the +next button press and release. + +2/19/94 (bug fix) Fixed prolog.ps (prolog for Postscript printing from +canvases) so that it correctly prints all of the characters in the +ISO Latin-1 character set. + +2/19/94 (bug fix) Modified tkBind.c to save and restore the interpreter's +result across the execution of binding scripts. Otherwise if an event +triggers in the middle of some other script (e.g. a destroy event during +window creation, because there was an error in the creation command), +the intepreter's result gets lost. + +2/19/94 (bug fix) Fixed bug in dealing with results of sent command +that could cause them to get lost in some situations. + +2/21/94 (bug fix) Don't let user close a dialog window created by +tk_dialog, since this would cause tk_dialog to hang: force the user +to select one of the dialog's buttons. + +2/21/94 (bug fix) Fixed bug in canvas polygons whereby they didn't +correctly handle changes in the number of points (via "coords" +widget command). + +2/23/94 (bug fix) Large bitmaps in canvases didn't print correctly +because they overflowed the 64-KB limit on strings in Postscript. +Changed canvas printing to split up large bitmaps into mutliple +smaller ones for printing. + +2/25/94 (bug fix) The "." window was being set up with -width +and -height options, which interfered with geometry management (any +configuration change on "." causes the window to change size to +200x200, then change back again). + +2/26/94 (bug fix) Fixed several bugs that occurred when a Destroy +event handler for a window deleted the window's parent. + +3/3/94 (new features) Changes to binding mechanism: + - The modifiers for "Alt", "Meta", and "M" are now computed by + examining the modifier map, rather than being hardwired to + M2, M1, and M1. + - When processing events, one script is invoked for each object + in the list passed to Tk_BindEvent, rather than stopping as + soon as a script is invoked for some object. The "break" and + "continue" commands can be used within a script to abort all + scripts for the event or the current one. + *** POTENTIAL INCOMPATIBILITY *** + - Added "bindtags" command so that new binding groups can be + defined for widgets and the evaluation order can be changed. + - When matching events to bindings, extra modifiers are now ignored, + as if "Any" were specified for every event. The "Any" modifier + is still recognized, but it is ignored and is deprecated. + *** POTENTIAL INCOMPATIBILITY *** + - In % sequences that print window identifiers (e.g. %a and %S), print + in hexadecimal rather than decimal, for consistence with "winfo id". + *** POTENTIAL INCOMPATIBILITY *** + - The "bind" command no longer supports the event types CirculateRequest, + ConfigureRequest, MapRequest, or ResizeRequest. These event types + are somewhat dangerous, and they never worked anyway. + +3/13/94 (bug fix) Fixed numerous problems with the "wm iconwindow" command. +It appears that this command never really worked at all, but it should +work OK now. + +3/14/94 (feature changes) Removed several obsolete features: + - Eliminated "enable" and "disable" widget commands for menus. + *** POTENTIAL INCOMPATIBILITY *** + - Eliminated "activate" and "deactivate" widget commands for buttons, + checkbuttons, radiobuttons, and menubuttons. + *** POTENTIAL INCOMPATIBILITY *** + - Removed -geometry option for frames and toplevels: it causes + problems when .Xdefaults files contain entries like + "*geometry: +0+0". Must use -width and -height instead. + *** POTENTIAL INCOMPATIBILITY *** + - Desupported "tkVersion" variable: use "tk_version" instead. + *** POTENTIAL INCOMPATIBILITY *** + +3/16/94 (feature changes) Changes to listboxes: + - Eliminated -geometry option (it causes problems when .Xdefaults + files contain entries like "*geometry: +0+0"). Added -width + and -height options to use instead. + *** POTENTIAL INCOMPATIBILITY *** + +3/21/94 (bug fix) Fixed bug in tkOption.c where the option cache wasn't +properly cleaned up after window deletion; this could cause the wrong +value from the option database to be used under some conditions. + +3/25/94 (new features) Changes to geometry management: + - Added Tk_MaintainGeometry and Tk_UnmaintainGeometry procedures + to solve problems with -in windows. Modified the packer, the + placer, and canvases to use them. + - Changed 2nd argument to Tk_ManageGeometry from Tk_GeometryProc * + to a pointer to a structure with additional information about + the geometry manager, such as name and procedure to call when + slaves are stolen. + *** POTENTIAL INCOMPATIBILITY *** + +3/28/94 (new feature) Overhauled event management: + - Added "cancel" option to the "after" command so that you can + cancel previously-scheduled commands. + - Separated X-specific stuff from generic event management. The + file tkEvent.c can now be used stand-alone without the rest of Tk. + See the manual entry for Tk_EventInit for information on which + procedures are available this way. + - Added Tk_CreateFileHandler2 procedure, which provides a lower-level + and more powerful form of file event handler. + - Fixed bug in Tk_DoOneEvent where an infinite loop could occur if + the TK_FILE_EVENT and TK_DONT_WAIT flags were set simultaneously + (there were bugs with several other combinations too; all should + be fixed now). + +3/28/94 (new feature) Added "fileevent" command, which allows event- +driven I/O in the style of Mark Diekhans' "addinput" command. + +4/11/94 (new feature) Better support for colormaps and visuals: + - Added new -colormap and -visual options to toplevels and frames. + - Added "winfo visualsavailable" command. + - Added "wm colormapwindows" command, plus support for WM_COLORMAP_WINDOWS + to Tk_SetWindowColormap. + - Added new library procedures Tk_GetVisual, Tk_GetColormap, + and Tk_FreeColormap. + +4/11/94 (bug fix) Fixed core dump that used to occur when specifying +an iconwindow ("wm iconwindow") for a toplevel on a different screen +than the main window. + +4/23/94 (new feature) Added support for images, including the following: + - New "image" command for creating images. + - Built-in image type: bitmap. + - New "image" item type in canvases. + - Labels, buttons, checkbuttons, radiobuttons, menubuttons, and + menu entries now support a -image option for displaying images. + - Tk_CreateImageType and Tk_ImageChanged procedures, for defining + new types of images in C. + - Tk_GetImage, Tk_FreeImage, Tk_RedrawImage, and Tk_SizeOfImage + procedures, for using images in widgets. + +5/1/94 (new features) Added new procedures Tk_3DVerticalBevel and +Tk_3DHorizontalBevel. + +5/11/94 (new features) Major overhaul of text widgets: + - Implemented embedded windows and "window" widget command. + - Added new configuration options for tags: -justify, -lmargin1, + -lmargin2, -rmargin, -offset, -spacing1, -spacing2, and -spacing3. + See the "Display styles" widget demo for examples. + - Added new configuration options for texts: -spacing1, -spacing2, + and -spacing3. + - Added "tagList" option to "insert" widget command to control + tags on new text. Made tagged regions so they aren't sticky on + either side: new characters get a tag only if the old chars. on + both sides had it. + *** POTENTIAL INCOMPATIBILITY *** + - Added gravity for marks, and "mark gravity" widget command. + - Added horizontal scrolling, "xview" widget command, -xscrollcommand + option. Changed "scan" widget commands to support horizontal + scrolling. + *** POTENTIAL INCOMPATIBILITY *** + - Added "search" widget command for searching (either exact matches + or regular expressions). + - New widget commands: bbox, dlineinfo, and see. + - Changed implementation of bindings so that Enter and Leave + events are not generated unless the tag has just become present + (or just ceased to be present) on the current character. Also + changed bindings to process separately for each tag, rather than + having high-priority tags override low-priority ones. + - The "end" index now refers to the character after the last newline + rather than the newline itself. You can now tag the final newline + and set a mark after the final newline. + - Deletions of the "sel" tag and the "insert" and "current" marks + are now ignored silently, rather than generating errors. This means + you can do things like "eval .t tag delete [.t tag names]". + +5/19/94 (bug fix) Canvases didn't generate proper Postscript for stippled +text. + +5/20/94 (new feature) Added "bell" command to ring the display's bell. + +5/20/94 (new feature) Incorporated "square" demonstration widget into +tktest application. + +5/20/94 (new features) Changed wish application (tkMain.c): + - wish no longer processes the -help option. + *** POTENTIAL INCOMPATIBILITY *** + - The wish main program is now called Tk_Main; tkAppInit.c has a + "main" procedure that calls Tk_Main. This makes it easier to use + Tk with C++ programs, which need their own main programs, and it + also allows an application to prefilter the argument list before + calling Tk_Main. + *** POTENTIAL INCOMPATIBILITY *** + - The application's class is now the same as its name (except the + first letter is capitalized), instead of "Tk". + *** POTENTIAL INCOMPATIBILITY *** + - The -file keyword is no longer required: the script file name can + be provided as the first argument without being preceded by "-file", + as in tclsh. For backward compatibility the "-file" keyword is + ignored if it is the first argument, but it is deprecated. + +5/26/94 (feature removed) Removed support for "fill" justify mode from +Tk_GetJustify and from the TK_CONFIG_JUSTIFY configuration option. None +of the built-in widgets ever supported this mode anyway. +*** POTENTIAL INCOMPATIBILITY *** + +5/27/94 (feature change) Changed Tk to use Tk_PrintDouble everywhere +that it converts reals to strings. This means that floating-point +values will be generated in some cases where integer-like values were +generated before. +*** POTENTIAL INCOMPATIBILITY *** + +6/1/94 (feature change) Renamed "pack newinfo" command to "pack info". +The old "pack info" command is no longer available. +*** POTENTIAL INCOMPATIBILITY *** + +6/20/94 (feature changes) Overhaul of entry widgets: + - Added "-justify" option. + - Added "-show" option to make entries easier to use for passwords. + - Added "cget" widget command. + - Added "selection range" and "selection present" widget commands. + - Added "anchor" symbolic index. + - Changed "-scrollcommand" option to "-xscrollcommand", "view" + widget command to "xview", for compatibility with other widgets. + *** POTENTIAL INCOMPATIBILITY *** + - Changed sel.last to refer to character just *after* last one + selected, again for compatibility with other widgets. + *** POTENTIAL INCOMPATIBILITY *** + - For "delete" widget command, second index now refers to character + just *after* last one to delete. + *** POTENTIAL INCOMPATIBILITY *** + - Overhauled bindings to be more Motif-compatible and to include + common Emacs bindings for editing. + - Changed -width option: if specified as 0, widget sizes to fit + its current text. + +6/11/94 (new features) Improved Motif compatibility: + - Added "-highlightwidth" and "-highlightcolor" options to all widgets. + +6/27/94 (bug fix) Postscript generation for text items in canvases was +not justifying the text properly when a -width was specified that was +longer than the longest line. + +6/27/94 (bug fix) "winfo exists" used to report a window as existing +if it was in the process of being destroyed (i.e., a destroy handler +is in the middle of execution). Changed to report it as non-existent +under these conditions. +*** POTENTIAL INCOMPATIBILITY *** + +7/11/94 (bug fix) Selections claimed via "selection own" weren't always +being cleared properly when the selection was claimed away. Also fixed +bug where Tk wasn't properly claiming the selection, if there haven't +been any recent X events at the time of the claim. + +7/13/94 (feature changes) Overhaul of scrollbar widgets: + - New widget commands: "activate", "cget", "fraction", and "identify". + - New options: -activebackground, -activerelief, -highlightcolor, + -jump, -highlightthickness, and -troughcolor. What used to be + -background is now -troughcolor, -foreground is now -background, + and -activeforeground is now -activebackground. + *** POTENTIAL INCOMPATIBILITY *** + - Added new syntax for "set" command, "get" result, and generated + commands. Changed other widgets to use the new syntax. + - Moved the bindings out of C and into Tcl scripts, using the new + options and widget commands. Added support for all Motif + bindings, plus jump scrolling and cancelling of slider drags. + +7/16/94 (bug fix) Canvases assumed that the Leave event for one item +didn't modify or delete the next current item; this could cause core +dumps under some conditions. + +7/23/94 (feature change) Modified Tk_BackgroundError so that tkerror +is invoked as an idle handler. If tkerror generates a break exception +then all other queued reports are aborted. + +8/14/94 (bug fix) "cursorOffTime" and "cursorOnTime" were confused in +canvases, resulting in the same time being used for both. + +8/16/94 (bug fix) "tkwait variable" command didn't detect errors in +variable name, such as trying to wait for an entire array. + +9/2/94 (new features) Overhaul of scale widgets: + - Floating-point values are supported now, following Paul Mackerras' + "fscale" widget. Added "-resolution" and "-digits" options. + - Added "-variable" option to link scale to variable, following + Henning Schulzrinne's implementation. + - Added focus highlight (-highlightthickness and -highlightcolor + options). + - Added new widget commands "cget", "coords", "identify", plus + improved "get"; removed wired-in bindings, added complete set + of Motif bindings via Tcl scripts. + - Changed -sliderforeground option to -background, -background to + -troughColor, -activeforeground to -activebackground. + *** POTENTIAL INCOMPATIBILITY *** + - Moved value label from below horizontal scales to above the scale, + for Motif compliance. + +9/9/94 (bug fix) Fixed bug in tkWm.c that caused long delays in "raise" +command under some conditions (window already at the top of the stack). + +9/10/94 (new features) Overhaul of label/button/checkbutton/radiobutton +widgets: + - Added focus highlight (-highlightthickness and -highlightcolor + options). + - Added new widget command "cget". + - Changed -selector option to -selectcolor, and changed its meaning + too: empty no longer means don't draw the indicator; it means + don't use a special color when selected. + *** POTENTIAL INCOMPATIBILITY *** + - Added -indicatoron (controls whether indicator is displayed) and + -selectimage (gives special image to display when selected) options. + - Modified bindings to be more Motif-like, added binding for space + key. + - Changed padding defaults to give widgets correct Motif appearance + by default. Also, changed to ignore padding options when displaying + an image or bitmap. + *** POTENTIAL INCOMPATIBILITY *** + - Can now display text on multiple lines: newlines cause line breaks, + and word wrapping can be requested with -wraplength option. Also + added -justify and -underline options. + - The -value option for radiobuttons can now have an empty string as + its value; it no longer defaults to the name of the widget. + *** POTENTIAL INCOMPATIBILITY *** + +9/13/94 (new features) Modified both canvases and messages to support +-highlightthickness and -highlightcolor options plus "cget" widget +command. + +9/19/94 (new features) Added Tk_UnsetGrid procedure, modified widgets +to use it. Also changed Tk_SetGrid so that at most one window per +toplevel can have gridding enabled. + +9/23/94 (new features) Major overhaul of listbox widgets: + - Added focus highlight (-highlightthickness and -highlightcolor + options). + - Added new widget command "cget". + - Revised selection commands to support single selections as well + as multiple disjoint selections; syntax of "selection" widget + command has changed to support this. Added new option -selectmode + for specifying which mode to use. Default is single selection; + tk_listboxSingleSelect procedure no longer exists. Selections + now return as items separated by newlines instead of a list whose + elements are the items. + *** POTENTIAL INCOMPATIBILITY *** + - Extended "get" widget command to allow many items to be retrieved + at once. + - Added "bbox" widget command for finding position of an element on + screen. + - Added "activate" command to mark element with traversal focus. + - Extended index mechanism to support new types of indices: + "active", "anchor", "@x,y". + - Added "see" widget command. + - Revised bindings to include all Motif features except for AddMode. + - If -width or -height option is <= 0, the widget requests a size just + large enough to hold all of its text. + +10/6/94 (new features) Overhaul of menubuttons: + - Added focus highlight (-highlightthickness and -highlightcolor + options). + - Added new widget command "cget". + - Added -indicatoron option to display option menu indicator. + - The -menu option must be a child of the menubutton. + *** POTENTIAL INCOMPATIBILITY *** + +10/6/94 (new features) Overhaul of menu widgets: + - Added new widget commands "cget" and "entrycget". + - Changed the implementation of tear-off menus to be more + Motif-like; added -tearoff option for specifying whether + tearoff entry is displayed. + - Changed interpretation of "@y" index: it now returns the + closest entry, rather than "none" if y is outside the menu's + range. + *** POTENTIAL INCOMPATIBILITY *** + - The -menu option for a cascade entry must now be a child of + the menu. + *** POTENTIAL INCOMPATIBILITY *** + - Added "type" widget command, so that you can query the type of + an entry. + - Added -foreground, -activeforeground, -selectcolor, -indicatoron, + -image, and -selectimage options to menu entries. + - Changed "selector" menu option to "selectColor" for Motif compliance. + *** POTENTIAL INCOMPATIBILITY *** + - Added -relief option for menus, just for consistency with other + widgets (it was implicitly "raised" before). + +10/6/94 (feature change) Completely overhauled the bindings for menus +and menubuttons. They now fit better with other Tk 4.0 facilities, +such as the new binding mechanism, and they provide better Motif +compliance (e.g. keyboard traversal of submenus). Also, the bindings +now support option menus, popup menus, and proper Motif tear-off +menus. + +10/6/94 (obsolete features) The procedures tk_menuBar and +tk_bindForTraversal are no longer needed in Tk 4.0. They still exist +for compability, but they do nothing. + +10/6/94 (new procedures) Added "tk_popup" procedure for posting a +popup menu, and "tk_optionMenu" for creating an option menubutton +and its associated menu. + +10/6/94 (change in name) The variable "tk_priv" has been renamed +to "tkPriv" to reflect that fact that it is private to Tk now. +This shouldn't cause any problems, since no-one except Tk should +have been using it before anyway (right?). + +10/6/94 (bug fix) Fixed bug in texts where sometimes the text would +stop tracking mouse motion (the "current" item wouldn't get updated) +because the text widget missed a ButtonRelease event. + +10/20/94 (new features) Overhauled selection code to support multiple +selections (primary, secondary, etc.) and multiple displays: + - Changed "selection" command to support new options such as + "-displayof" and "-selection". Old command formats are still + supported for compatibility, but they are no longer documented + and are deprecated. + - Changed procedures Tk_GetSelection, Tk_CreateSelHandler, and + Tk_ClearSelection to take additional "selection" argument. + *** POTENTIAL INCOMPATIBILITY *** + - Selection targets APPLICATION and WINDOW_NAME have been replaced + by TK_APPLICATION and TK_WINDOW. + *** POTENTIAL INCOMPATIBILITY *** + +10/20/94 (new features) Added support for clipboard: + - New "clipboard" command. + - C procedures Tk_ClipboardClear and Tk_ClipboardAppend. + - Bindings for "cut", "paste", and "copy" for text and entry widgets, + plus "copy" binding for listboxes. + +10/24/94 (bug fix) Button widgets weren't checking for errors when +setting the values of associated variables. + +11/3/94 (bug fix) Fixed bug whereby Tk would hang if "exit" was invoked +from inside a binding. + +11/15/94 (new features) Overhaul of focus mechanism: + - Added support for multiple displays: separate focus windows are + kept for each display. + - Added support for keyboard traversal. + - Changed focus model so Tk keeps track of a focus window for each + top-level window and automatically sets the focus on Enter to the + top-level. Tk no longer synthesizes FocusIn and FocusOut events, + but just uses the standard X mechanisms. There is no "default" + focus window anymore; the focus reverts to top-levels by default. + *** POTENTIAL INCOMPATIBILITY *** + - Changed focus command: eliminated "focus default" and "focus none", + added "-displayof" and "-lastfor" options. An empty string is now + used to signify "no focus" instead of "none". + *** POTENTIAL INCOMPATIBILITY *** + - Added library procedures tk_focusNext, tk_focusPrev, and + tk_focusFollowsMouse. + - Removed obsolete Tk_CreateFocusHandler: must use FocusIn and + FocusOut events now. + *** POTENTIAL INCOMPATIBILITY *** + +11/23/94 (new features) Overhaul of "send" command: + - Added support for multiple displays: -displayof option to "send". + - Added asynchronous sends: -async option to "send". + - Eliminated fixed timeouts on sends: as long as the target + application appears to exist, the send will wait for it. + - Stale entries get removed from the application registry now, + so "winfo interps" should never return non-existent applications. + - Can change the name of an application with "tk appname" command. + This is also the preferred way of querying the application name + now. + - The errorCode and errorInfo variables are now propagated back to + the sender now, so a full stack trace is available. + - Tk checks display security on each send now, instead of just during + initialization, so changes in the security status are seen immediately + by all applications. + - The above changes required changes to the data formats used for + communication between source and target applications, so Tk 4.0 + applications cannot send to, or be sent from, Tk 3.6 applications. + *** POTENTIAL INCOMPATIBILITY *** + - The procedure Tk_RegisterInterp has been replaced with Tk_SetAppName. + *** POTENTIAL INCOMPATIBILITY *** + +12/6/94 (cleanup) Eliminated "interp" argument to Tk_GetColorByValue, +since it is no longer needed. +*** POTENTIAL INCOMPATIBILITY *** + +12/7/94 (feature change) Changed the "wm" command so that top-level +windows are now resizable by default. You can no longer specify +empty arguments to "wm maxsize" and "wm minsize". +*** POTENTIAL INCOMPATIBILITY *** + +12/8/94 (new feature) Added new "photo" image type using code provided +by Paul Mackerras: currently supports only PPM "P6" format images. + +12/14/94 (new features) Canvas modifications: + - Modified the interfaces between generic canvas code and the item + types so that it's easy for people to write new item types outside + of Tk. + - Added support for transparent bitmap items: just specify an + empty string as the background color. + - Changed the "xview" and "yview" commands for canvases to use the + new scrolling syntax. + - Eliminated -scrollincrement option. + *** POTENTIAL INCOMPATIBILITY *** + +12/14/94 (bug fix) Fixed bug where the dimensions of canvas arrowheads +scaled during a "scale" widget command, but the scaling was only +temporary and got lost on the next re-configure of the item. The +correct behavior is for the arrowheads not to scale. + +-------------------- Release 4.0b1, 12/23/94 ------------------------- + +12/26/94 (bug fix) Removed obsolete demos from Makefile (color, dialog, +size), fixed "install" target. + +1/3/95 (bug fix) Fixed all procedure calls to explicitly cast arguments: +implicit conversions from prototypes don't work when compiling under +non-ANSI compilers. Tk is now clean under gcc -Wconversion. + +1/4/95 (bug fix) Used "screenX" without ever setting it in DisplayText +in tkCanvText.c: caused tabs in canvas text items to get messed up. + +1/4/95 (bug fix) Canvases forgot to register the built-in types if +Tk_CreateItemType was called before a canvas widget was created. + +1/4/95 (bug fixes) Fixed glitches in various text bindings: + - Up used to do nothing if the cursor was at 2.0. + - Right used to make the cursor invisible if it was just before + the final newline of the text. + - Control-t didn't conform to Emacs; made it conform to GNU Emacs. + - Deleted Control-x binding, since it doesn't conform to anything and + is confusing for Emacs users. + +1/4/95 (bug fixes) Changed Control-t for entries just as for texts (see +above) an deleted Control-x for entries (see above). + +1/4/95 (bug fix) The packer didn't map slaves unless the master was mapped; +this could cause slaves to get "lost" so that they weren't mapped until the +master resized. + +1/5/95 (bug fix) Scrollbars weren't executing the proper code the first time +the mouse entered the widget; this caused problems if tk_strictMotif was +set. + +1/6/95 (bug fix) Fixed label/button/checkbutton/radiobutton/menubutton +widgets to allow arbitrary screen distances when specifying -width and +-height for an image or bitmap (the manual pages already documented this +but the code didn't implement it). + +1/6/95 (new feature) Added very primitive support for input methods, +as suggested by Martin Forssen. This should be enough for European +character sets (Compose key) but it isn't near enough for Asian +character sets. + +1/8/95 (bug fix) Fixed problem in canvas "xview" and "yview" commands +where divide-by-zero errors could sometimes occur. + +1/8/95 (bug fix) New event handler didn't properly handle files for +which both TK_READABLE and TK_WRITABLE were specified. + +1/11/95 (bug fix) Fixed bug with text selections: was returning count +too high for data, causing bogus garbage to appear when selection was +copied. + +-------------------- Release 4.0b2, 1/12/95 ------------------------- + +1/27/95 (feature removal) Removed %D substitution from binding scripts: +wasn't portable, shouldn't be used anyway. +*** POTENTIAL INCOMPATIBILITY *** + +1/27/95 (new features) Added -displayof options to the commands +"winfo atom", "winfo atomname", "winfo containing", "winfo interps", +and "winfo pathname". + +1/27/95 (new feature) Added "idle" option to "after" command to run +scripts as idle handlers. + +1/28/95 (new feature) Modified placer to make -x and -relx additive +if you specify both. Same for -y and -rely, -width and -relwidth, +and -height and -relheight. This makes it easy to make request such +as "make .a 2 pixels larger than .b". +*** POTENTIAL INCOMPATIBILITY *** + +1/28/95 (new feature) Improved auto-grab mechanism in canvases (which +prevents current item from changing while a button is down): changed +to report Enter and Leave events for the current item while a button +is down. However, as before, no Enter events are reported for other +items until the button goes up. + +1/28/95 (new feature) Bitmap images are now transparent if the -background +is specified as an empty string (-maskdata and -maskfile are ignored in +this case). This is also the default. + +1/28/95 (bug fix) Tk didn't support manufacturer- or site-specific keysyms +such as SunAudioMute. Modified tkBind.c so that it uses XStringToKeysym +in addition to its own hash table, so that all keysyms are now available. + +1/30/95 (feature change) Modified "clipboard append" so that it reclaims +the clipboard selection if it had been previously lost, rather than just +generating an error. This handles certain race conditions more cleanly, +and also allows the use of programs like "xclipboard". + +1/30/95 (new feature) Added -xscrollincrement and -yscrollincrement +options to canvases. + +1/31/95 (bug fix) Geometry management was broken if a particular geometry +manager claimed a slave away from itself. + +1/31/95 (bug fix) Fixed bug in tkVisual.c where a visual with fewer bits +than requested was being selected in preference to one with just the right +number of bits. + +1/31/95 (bug fix) Texts weren't redisplaying the padding region properly +after changes in -padx or -pady. + +1/31/95 (new features) More text improvements: + - Extended "insert" widget command for texts to allow multiple + text-tagList pairs in the same command. + - Added -nocase option to "search" widget command. + - Added -overstrike option to tags. + - Added tab stops, via -tabs option for widget and for tags. + +2/10/95 (bug fix) Modified all widgets to allow renaming of widget +commands. Deleting a widget command will delete the widget. + +2/11/95 (new feature) Added -highlightbackground option to all widgets. + +2/14/95 (new feature) Added "insert" widget command for menus. + +2/15/95 (new feature) Modified text display code (for all widgets) to +display well-known control characters like newline and backspace as +\n or \b instead of \xa. + +2/15/95 (bug fix) Modified bitmap and photo image managers to delete +the image command when the image is deleted. Also modified them to +allow renaming of the image command, and to delete the image if the +image command is deleted. + +2/15/95 (bug fix) Fixed text widgets to allow horizontal scrolling +even if wrapping was enabled, if a line isn't entirely visible due to +a large character or embedded window. + +2/16/95 (feature change) Added "postcascade" widget command to menus, +changed "invoke" and "activate" not to post or unpost submenus. Also +fixed bug in redisplay that tended to leave bits of garbage on menu +when submenu unposted. +*** POTENTIAL INCOMPATIBILITY *** + +2/16/95 (feature removal) Removed "snap back" behavior (slider +snaps back to old position if you move the mouse outside the widet +before releasing the button) from scrollbars and scales. + +2/16/95 (bug fix) The last line of a listbox wasn't being displayed if +it was only partially visible. + +2/16/95 (new features) Added support for "-resolution 0" (no rounding +of values) to scale widgets, plus smarter computation of how many digits +to display. + +2/17/95 (bug fix) Fixed bug in text bindings for things like Shift-Left: +didn't properly set the anchor position. + +2/20/95 (bug fix) Changed management of COLORMAP_WINDOWS property to +add the toplevel implicitly to the end of the list if it wasn't already +on the list somewhere. Without this, some window managers implicitly +put it at the front of the list, so that colormaps in internal windows +are never used. + +2/20/95 (bug fix) Changed to use separate command procedures for +button, checkbutton, label, and radiobutton commands. This allows the +class commands to be renamed without breaking their behavior. + +2/20/95 (removed feature) The "bind" command no longer supports +"Keymap" events; they never worked anyway. + +2/20/95 (bug fix) The text "search" widget command looped infinitely +when searching an empty text. + +2/20/95 (bug fix) Canvases weren't redrawing their borders after +configuration changes. + +2/20/95 (upgrade) Changed to use autoconf version 2.2. + +2/21/95 (bug fix) Fixed several bug fixes in menu bindings that occur +when menus have no entries. + +2/21/95 (bug fix) Fixed bug in geometry management that caused windows +packed -in siblings to not always be mapped and unmapped properly +(particularly when the toplevel got unmapped and mapped). + +2/22/95 (bug fix) Fixed resource leak problem in tkTextDisp.c that +caused embedded windows not to be unmapped when off-screen. + +2/23/95 (bug fix) "After cancel" dumped core when the script for an +after event cancelled itself. + +2/24/95 (bug fix) Text and entry widgets weren't properly ignoring +Alt-, Control-, and Meta- keystrokes, so a widget-specific binding +for one of these resulted in the character also being inserted. + +2/24/95 (bug fix) Several widgets accidentally performed unsigned +division on negative numbers, thereby losing the sign bit. This +mostly affected the display of images and bitmaps in buttons, +menubuttons, and messages. + +2/24/95 (feature reversal) Restored old behavior of %A so that it +returns non-printing characters as well as printing ones now. +*** POTENTIAL INCOMPATIBILITY with Tk 4.0b2, but not with Tk 3.6 *** + +2/24/95 (bug fix) Duplicate "leave" events could occur for canvas +items under some conditions, due to recursive calls to PickCurrentItem. +Added code to detect and skip the nested calls. + +2/24/95 (bug fix) Fixed bug where an error could occur during the first +keystroke in an application if its binding invoked "break". + +2/25/95 (new feature) Modified syntax of "search" widget command for +texts. The -nowrap switch and the "variable" final argument are no +longer supported. Instead, there is a -count switch to replace +the final argument; if the final argument is specified, it is now +a stopping index for the search. The features of -nowrap can be +achieved now with the stopping index. +*** POTENTIAL INCOMPATIBILITY with Tk 4.0b2, but not with Tk 3.6 *** + +2/27/95 (bug fix) Fixed problem that appears to prevent keyboard +input for working under IRIX: tkBind.c was ignoring XmbLookupString +calls that returned a status of XLookupBoth. + +2/27/95 (new feature) Added Tk_GetItemTypes procedure to return +information about available canvas item types. + +2/27/95 (feature change) Changed Makefile to always use install-sh +for installations: there's just too much variation among "install" +system programs, which makes installation flakey. + +2/27/95 (bug fix) Fixed bug in tkSend.c that caused core dumps if +the app's main window was destroyed by a destroy handler on a +child. + +3/5/95 (feature change) Change separator character used in "bind +..." +bindings from semi-colon to newline (permits bindings that are +comments, for what that's worth). + +3/7/95 (bug fix/feature change) Overhauled focus code, both in C +and in Tcl: + - Tk won't move the X focus in response to the "focus" command + unless either the application already has the focus or the + -force switch is specified. + - Tk no longer sets the X focus to anything other than top-levels; + it synthesizes events for FocusIn and FocusOut to children. + - A window no longer has to be viewable when focussed to; Tk will + set the X focus later, when the window becomes viewable. + - Added -takefocus option to all widgets. + - Rewrote tk_focusPrev and tk_focusNext to use the -takefocus option. + These procedures no longer set the focus; they just return the + next window in focus order. + *** POTENTIAL INCOMPATIBILITY with Tk 4.0b2, but not with Tk 3.6 *** + - Eliminated tk_focusContinue. + *** POTENTIAL INCOMPATIBILITY with Tk 4.0b2, but not with Tk 3.6 *** + +3/8/95 (new feature, bug fix) Added support for tk_strictMotif variable +in C: Tk_StrictMotif library procedure. Modified buttons, menubuttons, +menus to use it. This fixes the problem with menus not supporting +tk_strictMotif properly in Tk4.0b1 and b2. + +3/16/95 (feature overhaul) Overhauled color management: + - Changed Tk so it never denies a color request because a colormap + filled up. Instead, it allocates the closest available color. + - Eliminated "color model" mechanism. The "tk colormodel" command + is gone, as are the procedures Tk_GetColorModel and Tk_SetColorModel. + *** POTENTIAL INCOMPATIBILITY *** + - Changed 3D border implementation to allocate colors for shadows + lazily, so they're never allocated if they're never used. Also + added new feature whereby stippling is used for borders when + the colormap has run out of entries. Changed arguments to many + of Tk_3D C procedures to take a Tk_Window as argument instead of + a (Display *). This is needed to do lazy color allocation. + *** POTENTIAL INCOMPATIBILITY *** + - Eliminated colormap argument to Tk_GetColor, Tk_GetColorByValue, + and Tk_Get3DBorder. + *** POTENTIAL INCOMPATIBILITY *** + +3/16/95 (feature change) Event bindings created from Tcl will now ignore +Enter, Leave, FocusIn, and FocusOut events with detail NotifyInferior. +This is done in anticipation of mega-widgets, so that the user of a +mega-widget can create Enter/Leave bindings on the mega-widget without +seeing spurious events as the mouse moves among the windows in the +mega-widget. +*** POTENTIAL INCOMPATIBILITY *** + +3/17/95 (feature change) Changed C interfaces throughout Tk to use ints +instead of unsigneds: the unsigneds turn out to cause subtle problems +with arithmetic in some places, and using ints everywhere is just +simpler. +*** POTENTIAL INCOMPATIBILITY *** + +3/23/95 (bug fix) Selections longer than 4000 bytes were being +truncated to 4000 bytes. + +-------------------- Release 4.0b3, 3/24/95 ------------------------- + +3/25/95 (bug fix) Changed "install" to "./install" in Makefile so that +"make install" will work even when "." isn't in the search path. + +3/25/95 (bug fix) Modified Tk's selection mechanism to prevent core +dumps in other applications during retrievals of large selections +(this is actually a bug in the other apps, but I've patched Tk to +keep it from getting triggered). + +3/25/95 (bug fix) Fixed bug where X window for "." wasn't being +deleted. + +3/27/95 (bug fix) Fixed many bugs associated with having more than +one application in a single process. + +3/28/95 (bug fix) The "search" widget command for texts didn't +return the correct index and count if there were embedded widgets +on the same line as the returned range but before the end of +the range. + +3/28/95 (bug fix) Changed pasting via button 2 in text and entries +so that it inserts at the pointer location, not the location of +the insertion cursor. + +3/28/95 (bug fix) Fixed several bugs related to bindings +that delete ancestors in the window hierarchy. Also eliminated +extraneous calls to XDestroyWindow, which speeds up window deletion +by about 3x. + +3/28/95 (bug fix) Several widgets (buttons, menubuttons, menus) didn't +properly handle image deletions that occurred while the widget was +being deleted (caused core dumps). + +3/29/95 (bug fix) When retrieving long selections from text widgets, +parts of lines were getting duplicated in the selection information. + +4/1/95 (bug fix) Fixed bug that caused infinite loop in horizontal +scales with 0 range. + +4/1/95 (bug fix) Fixed problem with -command option for scrollbars and +-takefocus option that caused commands to be evaluated in the wrong +context. + +4/1/95 (bug fix) Fixed problem with option database that caused it to +sometimes use the wrong option (wasn't flushing the database properly +after a change in a window's class). + +4/1/95 (bug fix) If a line in a text widget just barely fit in the window, +Tk was allocating a second screen line just for the newline character. + +4/1/95 (new feature) When backspacing in an entry widget, when you reach +the left edge of the widget, the insertion cursor gets recentered. + +4/1/95 (new features) Added "winfo pointerx" and "winfo pointery" commands +to fetch the current pointer position. + +4/6/95 (bug fix) If the last line of a text widget was only partially +visible, it was counted as visible for purposes of the scrollbar. Now +it is treated as if it were off-screen for scrolling purposes. + +4/6/95 (new feature) Modified "bell" command to reset screen saver as well. + +4/6/95 (feature change) Modified menu scanning (where menus pull down +as you drag across their menubuttons) so it only works among menus +in the same toplevel; it used to work for any menubuttons in the +application. + +4/6/95 (bug fix) Canvas text items weren't allowing real numbers in +"@x,y" notation for specifying indices. + +4/7/95 (bug fix) Menus didn't display correctly when -activeborderwidth +was large. + +4/7/95 (bug fix) Changed "clipboard append" command to support -- option +and to always treat the last argument as data, even if it starts with +"-". + +4/17/95 (new feature) Added -wrap option to text tags. + +4/18/95 (bug fix) Listboxes and texts weren't updating their grid information +when -width or -height changed. + +4/18/95 (bug fix) "Down" didn't work right in text widgets if the last +line was only partially visible in the window. + +4/19/95 (bug fix) Listboxes didn't handle partially visible last lines +right: couldn't scroll it into full visibility, for example. + +4/20/95 (bug fix) If a toplevel was positioned with a command like +"wm geometry . -0-0", the window didn't reposition itself to maintain +that geometry after a size change. + +4/21/95 (feature change) Changed order of binding tags so widget bindings +fire before class bindings. New order is: widget, class, toplevel, all. +*** POTENTIAL INCOMPATIBILITY with Tk 4.0b3, but not with Tk 3.6 *** + +4/23/95 (new feature) Added "winfo colormapfull" command. + +4/23/95 (new feature) Buttons and radiobuttons and checkbuttons now +treat Return the same as Space, unless tk_strictMotif is set. + +4/23/95 (bug fix) Modified menu tear-off procedure to duplicate the +binding tags and bindings of the original in the copy. + +4/25/95 (bug fix and feature change) Modified mechanism for choosing +"best" visual to fix a bug where depth wasn't really getting highest +priority in all situations. + +4/28/95 (bug fix) Failed text searches starting at "end" could result +in an infinite loop in Tk. + +4/30/95 (new feature) Added "wm resizable" command to enable and +disable interactive resizing. + +4/30/95 (new feature) Added "window names" widget command to texts: +returns a list of all embedded windows. + +5/2/95 (feature change) Changed text searches so that forward searches +start at the given index, rather than the character just after the +given index. +*** POTENTIAL INCOMPATIBILITY with Tk 4.0b3, but not with Tk 3.6 *** + +5/4/95 (bug fix) Default bit gravity for windows was wrong (it was +ForgetGravity) causing unnecessary flashing when windows were resized. + +5/4/95 (feature change) Modified Tk_DoOneEvent so that it doesn't +sleep if there's nothing that will wake it up again (e.g. no file +or timer handlers). Returns 0 immediately. + +5/5/95 (configuration change) Changed to use BSDgettimeofday instead +of gettimeofday on systems like IRIX where BSDgettimeofday is +available. This avoids compilation problems due to the different +interface to gettimeofday provided by IRIX. + +5/5/95 (feature change) Changed binding mechanism so that all bindings +are created immediately at initialization time, rather than waiting +until the first FocusIn or Enter event for a class. + +5/6/95 (feature change) Changed default text for labels, buttons, +checkbuttons, radiobuttons, menubuttons, and messages from " " to +"". + +5/6/95 (bug fix) If the application was destroyed in the middle of +an "update" command, Tk would dump core. + +5/6/95 (bug fix) Changed manual entries to use the standard .TH +macro instead of a custom .HS macro; the .HS macro confuses index +generators like makewhatis. + +5/6/95 (bug fix) Change "wm iconwindow" command to disable button +presses for the icon window. This is needed so that the window +manager can get those events (X only allows button presses to go +to one client for a given window). + +5/9/95 (new feature) When specifying visuals, can now use "best" +with a depth, e.g. "-visual {best 8}" to get the best 8-bit visual. + +5/18/95 (bug fix) Fixed bug with -spacing* options for text widget: +screen distances weren't allowed, only integers. + +5/20/95 (bug fix) Eliminated memory leaks in tkTextDisp.c and elsewhere. + +5/22/95 (color change) Changed the Tk color palette to a gray scheme. +Also added a library procedure tk_setPalette that makes it easy to +change colors on the fly, and a procedure tk_bisque that restores the +previous light brown scheme. + +5/28/95 (bug fix) Modified canvases so that the -width and -height +options refer to the space inside the borders, not the total widget +space. Also changed "xview" and "yview" commands and scroll-increment +rounding to use the pixel just inside the borders, rather than (0,0). + +5/28/95 (bug fix) Several widgets (e.g. entries, buttons, and menus) +didn't properly handle unsets of variables they were tracing, if the +variables were reference through upvars in procedures. + +6/4/95 (bug fix) The placer wasn't rounding window widths right when +both -relx and -relwidth were specified (or -rely and -relheight) so +that rounding errors accumulated. + +6/4/95 (feature improvement) Change parsing of text indices to handle +weird mark and tag names better (e.g. any string ending with ".first" +will now be parsed as a tag name, even if it contains embedded spaces, +etc.). + +6/4/95 (feature change) If a font defines glyphs for control characters, +they are now displayed, instead of translating the character to a +backslash sequence (however, tabs and newlines are still treated +specially; glyphs are not displayed for these characters). + +6/4/95 (bug fix) Modify the implementation of "raise" and "lower" for +toplevels so that it now works under olwm and olvwm. It didn't use to +work, and the problem is really in the window manager, but Tk now +patches around it. However, only "total" raises and lowers work: +raising and lowering relative to a sibling still don't work under +olvwm and olwm. + +6/4/95 (feature change) Modified tab code in texts so that a tab always +occupies at least as much space as a space character. + +6/4/95 (bug fix) The "%t" substitution wasn't being made properly in +Enter and Leave event bindings. + +6/7/95 (new feature) Added support for GIF images. Unfortunately it's +a bit fragile: certain kinds of badly formed images can cause core +dumps; I don't know enough about the GIF reader (taken from giftoppm) +to figure this out. + +6/7/95 (bug fix and feature change) Fixed PPM image reader to be more +flexible about header formats, and added support for PGM images. + +6/7/95 (feature change) Added -outlinestipple option to canvas arc +items, changed "-style arc" to use -outline as the color instead of +-fill (the old approach was pretty quirky). +*** POTENTIAL INCOMPATIBILITY *** + +6/8/95 (feature change) Modified interface to Tk_Main to pass in the +address of the application-specific initialization procedure. +Tcl_AppInit is no longer hardwired into Tk_Main. This is needed +in order to make Tcl a shared library. + +6/8/95 (feature change) Modified Makefile so that the installed versions +of wish and libtk.a have version number in them (e.g. wish4.0 and +libtk4.0.a) and the library directory name also has an embedded version +number (e.g., /usr/local/lib/tk4.0). This should make it easier for +Tk 4.0 to coexist with earlier versions. + +6/9/95 (new feature) Added -outline and -width options to canvas polygon +items. + +6/9/95 (feature changed) Renamed -decimate in photo widget to -subsample +(decimate wasn't technically correct). +*** POTENTIAL INCOMPATIBILITY with Tk 4.0b3, but not with Tk 3.6 *** + +-------------------- Release 4.0b4, 6/16/95 ------------------------- + +6/19/95 (bug fix) Colors weren't being rounded correctly in canvas +Postscript generation: caused "white" to appear slightly gray when +the display of the canvas used only 8 bits per color. + +6/20/95 (bug fix) "bbox" widget command for texts didn't return +proper width for tabs. + +6/20/95 (bug fix) Scrollbars didn't always work right for texts: +couldn't scroll all the way to the bottom of the text in a single +drag of the slider. + +6/20/95 (new feature) Added "delta" widget command for scrollbars +(needed for above bug fix). + +6/23/95 (bug fix) Listboxes weren't properly redisplaying their +borders when the were configured to a smaller size. + +6/23/95 (new feature) Added "winfo server" command. + +6/23/95 (bug fix) If a menu was posted, couldn't switch to another +menu with an Alt- key. + +6/24/95 (new feature) Added "winfo pointerxy" command. + +6/25/95 (bug fix) Tk_ParseArgv referenced beyond the end of 0-length +option names. + +6/25/95 (bug fix) Fixed problem in tkOption.c where "cachedWindow" +could get garbage in it if the main window's class was changed by +calling Tk_SetClass. + +6/25/95 (bug fix) Fixed two bugs in menus, one where errors in +variable traces weren't propagated correctly and one where "invoke" +was invoked at the wrong stack level, with the result that variable +traces didn't have access to the right variables. + +6/27/95 (bug fix) tk3d.c wasn't using all the right information +when deciding whether or not to stipple borders, so it stippled +borders even on 16-bit true-color displays. + +6/28/95 (bug fix) Page up and down operations in texts could cause +insertion cursor to drift to the right. Changed tkTextScrollPages +to use upper-left corner of current character, rather than center +of character. + +6/28/95 (bug fix) Changed text widget so that you can't put the +insertion cursor after the last newline in the text. + +6/28/95 (bug fix) Bitmap images didn't allow ~'s in file names. + +6/28/95 (bug fix) Fixed problem that could cause core dumps in the +text widget when dealing with embedded windows (there were problems +if the act of redisplaying caused the window layout to change, which +can happen with embedded windows). + +6/28/95 (bug fix) Texts didn't handle indices with double negatives, +such as ".t mark set insert {insert + -20 chars}". + +6/28/95 (bug fix) Fixed problem where focus didn't always revert to +its prior window after a dialog box was dismissed. + +6/28/95 (bug fix) Fixed problem with "search" widget command returning +incorrect length on some backwards regexp searches. + +6/28/95 (bug fix) Successive "wm iconbitmap . {}" commands could cause +a core dump. + +6/29/95 (new feature) Added -elementborderwidth option for scrollbars +so the -borderwidth can be set to 0 without flattening the arrows and +slider. + +-------------------- Release 4.0, 7/1/95 ------------------------- + +7/18/95 (bug fix) %t in event bindings didn't work properly for some +events (e.g. PropertyNotify). + +7/18/95 (bug fix) Changed "exec wish" lines in demo scripts to +"exec wish4.0" to avoid version conflicts. + +7/18/95 (bug fix) Fixed round-off errors in scrolling for texts, +canvases, listboxes, and entries. The error could cause the view +to shift up in a command like "$w yview moveto [lindex [$w yview] 0]". + +7/19/95 (bug fix) Canvases weren't always redrawing borders correctly +when they became unobscured. There were also some problems with +improper refresh after size changes. + +7/19/95 (bug fix) Fixed bug in text index processing that causes +tests textIndex-11.1 and textIndex12.1 to fail on some platforms. + +7/19/95 (bug fix) Fixed bug where 2-second delays were ocurring during +"raise" and "lower" commands for toplevel windows under some window +managers (such as fvwm). + +7/20/95 (bug fix) Text searches were misbehaving when there were embedded +windows on the starting line of the search. The most common symptom is +that Tk would fail to find a match at the starting position for the +search. + +7/22/95 (bug fix) Fixed core dump that could occur in menus if a checkbutton +entry's -variable option referred to an array (or couldn't be read +by the menu C code for some other reason). + +7/22/95 (bug fix) Text widgets didn't update their scrollbars when +changes were made to information that was off-screen. + +7/25/95 (bug fix) Fixed core-dump in tkListbox.c that used to happen +in the command ".l bbox end" if the listbox was empty. + +7/25/95 (bug fix) Page-up and page-down bindings for listboxes didn't +move active element to remain on the screen. + +7/25/95 (bug fix) Patched around H-P compiler problem that results in +core-dumps in tkImgPhoto.c during image handling. + +7/25/95 (bug fix) Fixed bug in tkImgPhoto.c that caused core dumps +(during Tk self-tests and other image uses) on AIX and other machines +where "schar" in tkImgPhoto.c was being defined as "short" instead of +"char". + +7/26/95 (bug fix) The PPM image reader couldn't handle maximum intensity +values other than 255. + +7/26/95 (bug fix) Canvases didn't redraw their borders when the relief +changed from raised to flat. + +7/27/95 (bug fix) Canvases didn't set the scrolling values correctly +when no scroll region was specified. + +7/28/95 (bug fix) Modified menu and tk_dialog scripts to restore any +old grab that might have been in effect before a menu or dialog was +posted. + +----------------- Released patch 4.0p1, 7/29/95 ---------------------- + +8/4/95 (bug fix) Calls to toupper and tolower weren't using the UCHAR +macro, so they didn't always work in non-U.S. locales. (JO) + +8/14/95 (new feature) Added -tearoffcommand option for menus. + +8/16/95 (bug fix) Canvases didn't generate proper Enter and Leave +events if the Leave handler for an item reconfigured the canvas in +a way that made the old current item the new current item again. (JO) + +8/21/95 (bug fix/feature change) When -takefocus was a script, Tk +was allowing window viewability to override it. Changed so that +viewability is now ignored when -takefocus is a script. (JO) + +8/21/95 (bug fixes) Fixed memory leaks in tkSend.c, tkSelect.c, and +tkUnixWm.c (JO). + +8/21/95 (bug fix) Text widgets didn't handle commands like +".t search -backwards foo end 1.0" properly: never found foo. (JO) + +8/23/95 (new feature) Added Makefile and configure.in support for +dynamic loading. (JO) + +8/25/95 (bug fix) The "frame" and "toplevel" commands couldn't safely +be renamed, due to a kludgy way that they shared a single command +procedure. Split into separate procedures. (JO) + +8/25/95 (bug fix) Fixed bug in libary/menu.tcl that caused "grab +window not visible" errors for popup menus (and perhaps elsewhere?). (JO) + +8/25/95 (bug fix / new feature) The "gray25" bitmap was really only +12.5% on, not 25%. Added new "gray12" bitmap that is the same as the +old "gray25". "Gray25" is still supported for compatibility, but its +use is deprecated. (JO) + +8/25/95 (bug fix) Scrollbar bindings didn't properly handle case where +B2 is clicked while B1 is already down. (JO) + +8/26/95 (bug fix) Menus were ignoring -activebackground if tk_strictMotif +was set, but not -activeforeground. Changed to ignore both. (JO) + +8/26/95 (bug fix) Scales and scrollbars didn't properly handle a +-repeatdelay value of 0 (they shouldn't auto-repeat in this case). (JO) + +8/28/95 (bug fix) Tcl errors were occurring for tkPriv(oldGrab) when +clicking on a disabled option menu. (JO) + +8/28/95 (bug fix) Changed event-handling code to use FD_SETSIZE instead +of OPEN_MAX, since OPEN_MAX is incorrect on some systems (e.g., IRIX). (JO) + +8/28/95 (bug fix) Fixed bug in photo images that caused garbling of +image data in the "put" and "copy" commands if the source data had +only one scan line but had a width less than the width of the target +image. (JO) + +8/29/95 (bug fix) Tk used to refuse to post menus if they had no +entries. This made it impossible for a menu to fill itself the first +time it is posted. Changed to allow menus with no entries to be +posted. (JO) + +8/30/95 (bug fix) If there was extra space at the bottom of a menu, +it wasn't being redisplayed properly. + +8/30/95 (new feature) Added -transient option to menus. + +8/30/95 (new features) Added proper button 2 support to both scrollbars +and scales (it sets the slider position from the mouse position). (JO) + +8/30/95 (bug fix) Fixed potential core dump that could occur in +photo images (ReadPPMFileHeader could overflow buffer under some bad +inputs, such as certain GIF images). (JO) + +8/30/95 (bug fix) Errors of the form `syntax error in expression "!"' +could occasionally happen in tkScaleDrag. (JO) + +8/31/95 (new feature) Changed man page installation (with "mkLinks" +script) to create additional links for manual pages corresponding to +each of the procedure and command names described in the pages. (JO) + +9/1/95 (new feature) Added "after info" command. Also added checks +so that one interpreter can't cancel another's "after" events. (JO) + +9/8/95 (bug fix) Fixed bug that could cause memory corruption and core +dumps if a "fileevent" handler was deleted while the handler was +active. (JO) + +9/11/95 Reorganized Tk sources for Windows and Mac ports. All sources +are now in subdirectories: "generic" contains sources that work on all +platforms, "windows", "mac", and "unix" directories contain platform- +specific sources. (SS) + +9/11/95 (new feature) Added new "notifier" mechanism to allow multiple +implementations of the mechanisms for finding out about events. This +change was necessary to support Mac and PC platforms, but it may also +allow other goodies such as combining Xt and Tk widgets in a single +application. See the new manual entry Notifier.3 for details. (SS) + +9/11/95 (feature change) Changed interface to Tk_RestrictProc so that +(a) it takes a clientData argument instead of display and arg, and +(b) it returns a value that can ask for the event to be discarded as well +as deferred or processed. (SS) +*** POTENTIAL INCOMPATIBILITY *** + +9/11/95 (new feature) Added TK_WINDOW_EVENTS #define, which is equivalent +to TK_X_EVENTS but is now preferred, since it applies to all platforms. (SS) + +9/11/95 (feature change) Can't export variables anymore because this doesn't +work under Windows DLLs. Eliminated tk_NumMainWindows variable and replaced +with procedure Tk_GetNumMainWindows. (SS) +*** POTENTIAL INCOMPATIBILITY *** + +9/11/95 (new feature) Added procedure Tk_PreserveColormap to increment +the reference count on colormaps. Used in photo widgets. (SS) + +----------------- Released patch 4.0p2, 9/15/95 ---------------------- + +----------------- Released 4.1a1, 9/15/95 ---------------------- + +9/22/95 (renamed files) Changed the names of the bitmap images in the +$tk_library/demos/images directory to use the .bmap file extension. (RJ) + +9/22/95 (bug fix) Fixed bug where text widgets could occasionally +display the insertion cursor both at the end of one line and the +beginning of the next. (JO) + +9/25/95 (bug fix) Fixed bug that could cause core dumps when an +application uses multiple screens and a binding destroys the main +window (bind code was using MainInfo structure after it had been +freed). (JO) + +9/25/95 (bug fix) Text widgets sometimes scrolled backwards on +occasion if you dragged down past the bottom of the scrollbar. (JO) + +9/25/95 (bug fix) Fixed bug in menus where a cascaded submenu posted +from a torn-off menu could be left posted if mouse was pulled off the +end of the cascade and released. (JO) + +9/25/95 (new feature) Added "--" switch to wish, so that you can +pass arguments like -n through to a script without having wish +interpret them. (JO) + +9/25/95 (bug fix) Fixed core dump that could occur for radiobuttons +and selectbuttons if -selectcolor was an empty string. (JO) + +9/26/95 (bug fix) Entries didn't used to notice if a trace procedure +on the -textvariable overrode a new value set by the entry. This +could cause the variable to get out of sync with the contents of the +entry. (JO) + +9/26/95 (new feature) Added -sliderrelief option to scales, changed +default bindings to change the slider's relief to sunken while it's +being dragged with the mouse. (JO) + +9/26/95 (bug fix) TkColor.c wasn't computing colormap size correctly; +could result in X Protocol error for QueryColors when colormaps run +out of colors. (JO) + +9/26/95 (bug fix) Wish couldn't handle script files with spaces in +their names. (JO) + +9/27/95 (cosmetic clean-up) Removed extraneous spaces to make error +messages consistent: ": should be" is now ": should be". (JO) + +9/27/95 (feature change) Modified tk_dialog so that it uses the +option database for the -wraplength option on the message. This +allows the option to be overridden by the caller. (JO) + +9/28/95 (bug fix) Wish incorrectly parsed the command line under +Windows, causing backslashes to be substituted. (SS) + +9/28/95 (bug fix) Wish now sources wishrc.tcl instead of .wishrc. (SS) + +9/28/95 (bug fix) Tk_DoOneEvent returned 0 under some circumstances +when it was possible to find more work to do. For example, if a +signal interrupted select(), but no event handlers were triggered, it +would return 0 even though it could still detect events by reentering +select(). (SS) + +9/29/95 (bug fix) "winfo interps" caused a crash under Windows. (SS) + +10/1/95 (feature change) Eliminated Tk_NotifyIdle interface in favor of +Tk_IdlePending. (SS) + +10/1/95 (bug fix) Turned motion event collapsing into an idle handler +so it will be easier to move the event loop into Tcl. (SS) + +10/1/95 (bug fix) Fixed several problems with negative coordinates +in canvases. One example: dragging a canvas rectangle with a wide +border and fractional coordinates could leave junk on the screen +if the rectangle was in negative coordinate space. (JO) + +10/2/95 (bug fix) Tk was improperly handling Enter/Leave events +during a button grab. (SS) + +10/2/95 (new feature) Added support for the Macintosh do script +('dosc') event. Available only on the Macintosh. (RJ) + +10/4/95 (new feature) Added support for compiling with VC++. +Resulting binaries work under Win32s through NT. + +----------------- Released 4.1a2, 10/6/95 ---------------------- + +10/10/95 (new feature) Macintosh Tk now supports the complete set +of X cursors that Unix Tk supports. (RJ) + +10/11/95 (bug fix) Tk now supports all of the X11 cursors under +Windows. (SS) + +10/11/95 (bug fix) The "wm resizable" command was missing from the +Windows version of Tk. (SS) + +10/12/95 (bug fix) Macintosh Tk had problems with clipping toplevel +windows that children of any frame other than another toplevel. (RJ) + +10/13/95 (bug fix) Eliminated dependency on MKS toolkit for generating +the tk.def file from Borland object files. (SS) + +10/16/95 (bug fix) Fixed clipping and update problems relating to +the raising and lowering of overlapping windows on Mac. (RJ) + +10/30/95 (bug fix) When focus-follows-mode (invoked via tk_focusFollowsMouse), +was focussing on windows even in situations where keyboard traversal would +skip the window. Changed to use the tkFocusOK procedure so that the +criteria for focussing are the same in both modes. (JO) + +11/2/95 (bug fix) Changed listbox bindings to ignore double-clicks. +This avoids errors that used to occur if a user defined a binding +for double-click that deleted the listbox. (JO) + +11/3/95 (feature change) Moved most of the Tk event loop to Tcl. Many +Tk_ names have become Tcl names now: + +TK_READABLE => TCL_READABLE +TK_WRITABLE => TCL_WRITABLE +TK_EXCEPTION => TCL_EXCEPTION +TK_DONT_WAIT => TCL_DONT_WAIT +TK_WINDOW_EVENTS => TCL_WINDOW_EVENTS +TK_FILE_EVENTS => TCL_FILE_EVENTS +TK_TIMER_EVENTS => TCL_TIMER_EVENTS +TK_IDLE_EVENTS => TCL_IDLE_EVENTS +TK_ALL_EVENTS => TCL_ALL_EVENTS +Tk_IdleProc => Tcl_IdleProc +Tk_FileProc => Tcl_FileProc +Tk_TimerProc => Tcl_TimerProc +Tk_TimerToken => Tcl_TimerToken +Tk_BackgroundError => Tcl_BackgroundError +Tk_CancelIdleCall => Tcl_CancelIdleCall +Tk_CreateFileHandler => Tcl_CreateFileHandler +Tk_CreateTimerHandler =>Tcl_CreateTimerHandler +Tk_DeleteFileHandler => Tcl_DeleteFileHandler +Tk_DeleteTimerHandler =>Tk_DeleteTimerHandler +Tk_DoOneEvent => Tcl_DoOneEvent +Tk_DoWhenIdle => Tcl_DoWhenIdle +Tk_Sleep => Tcl_Sleep +tkerror => bgerror + +Other than the name changes, the functions are the same. In addition, +there are #defines in tk.h so that the old Tk names will still work. +tkerror and bgerror are specially hacked as synonyms, so it should be +safe to use either one. You should switch to the new Tcl names ASAP, +though, since the old Tk names will eventually be desupported. (JO) + +11/7/95 (features removed) As part of moving the event loop to Tcl, +the following procedures were deleted: + - Tk_EventInit (the presence of the event loop in Tcl should + make this unneccessary). + - Tk_CreatFileHandler2 (you can get the same effect by using event + sources in Tcl, but you have to modify your code to use the new + Tcl APIs). + - All of the stuff in the manual entries Notifer.3 and QueueEvent.3; + this has changed because the notifier got reworked when it was + moved to Tcl. +*** POTENTIAL INCOMPATIBILITY *** + +11/7/95 (feature change) Changed to use exit handler to cleanup windows +in Tk, so Tk no longer needs to have a private copy of the "exit" command. +(JO) + +11/7/95 (bug fix) If wish was invoked with a command-line geometry and +a script file (e.g. "wish foo.tcl -geometry 30x20"), and if one of +the windows created by the script used the -setgrid option, then the +width and height from the command line were lost. (JO) + +11/8/95 (bug fix) The "see" command didn't work quite right for texts: +if the window was small and you try to "see" a line just offscreen, +Tk centered the line (actually, mis-centered it) when it should have +aligned it at the top or bottom. (JO) + +11/9/95 (bug fix) The "send" command crashed if you tried to send to +a different display with "-displayof". (JO) + +11/9/95 (bug fix) The Symbol font didn't print right in Postscript +output, because of changes made to re-encode fonts to get proper +ISO Latin1 behavior. Changed the code not to re-encode the Symbol +font. (JO) + +11/13/95 (bug fix) Fixed Makefile.in and configure.in for UNIX so that +configure can be run from a clean directory separate from the Tcl source +tree, and compilations can be performed there. (JO) + +11/17/95 (bug fix) If a window was gridded, Tk still computed the +default maximum dimensions in pixel units, which resulted in windows +that could grow much larger than the screen. (JO) + +11/17/95 (bug fix) If a menus entries were all disabled, posting +the menu and typing Up or Down caused an infinite loop, locking +up the screen (JO). + +11/19/95 (bug fix) The focus wasn't being restored properly after a +menu selection in a cascaded menu. (JO) + +11/19/95 (bug fix) Menubutton's didn't stipple display their images +differently when disabled. Change to have the same behavior as buttons: +the image is stippled over in the background color when the menubutton +is disabled. (JO) + +11/21/95 (bug fix) Changes in display attributes such as font could +cause core dumps in the text widget under some circumstances involving +line wrapping. (JO) + +11/22/95 (bug fix/new feature) Changed both the placer and the packer +to ensure that slaves are unmapped whenever the master is unmapped. +This saves time that slaves might otherwise spend trying to redisplay +themselves when they're unmapped. (JO) + +11/22/95 (bug fix) Space and return keys didn't work for menus if +they were posted via Alt-x keystrokes. (JO) + +11/24/95 (bug fix) tk_dialog procedure had binding for that +always activated default binding, even if input focus was in some +other binding. Removed this feature, since existing focus support +will already "do the right thing". (JO) + +11/24/95 (bug fix) Both canvases and texts could dump core if a binding +(such as ButtonRelease on an internal item) deleted the widget. (JO) + +11/24/95 (feature change) Replaced "configInfo" file with tkConfig.sh, +which is more complete and uses slightly different names. Also +arranged for tkConfig.sh to be installed in the platform-specific +library directory. (JO) + +11/24/95 (bug fix) It was possible for a slave to be placed or packed +-in itself, with unpleasant consequences. It is now an error for the +slave to be its own master for geometry management. (JO) + +11/25/95 (bug fix) The -command option of scales was sometimes being +invoked spuriously (e.g. when the mouse moved in the scale without a +button down). This was because the scale wasn't rounding properly +when setting the scale value from its associated variable. (JO) + +----------------- Released patch 4.0p3, 11/28/95 ---------------------- + +12/18/95 (feature change) Moved Tk_Preserve, Tk_Release, and +Tk_EventuallyFree to Tcl, renamed to Tcl_Preserve etc. Added #defines +to tk.h so that the old names still work. (JO) + +12/23/95 (bug fix) If a single process had > 1 Tk application, Tk +didn't guarantee that the application names were unique, which could +cause all sorts of confusion with "send". (JO) + +12/23/95 (feature change) Eliminated Tk_CreateMainWindow and moved +all of its functionality to Tk_Init. All that you need to do now +to get Tk in an application is to call Tk_Init. Improved Tk_Init +so that -colormap and -visual command-line arguments are now passed +through to TkCreateFrame. Tk_Main is much simpler now, since a lot +of its functionality has moved to Tk_Init. (JO) +*** POTENTIAL INCOMPATIBILITY *** + +12/23/95 (new feature) Added support for Tcl_StaticPackage so +that Tk can now be loaded into slave interpreters with the "load" +command to create new applications. (JO) + +12/23/95 (new features) Added support for -colormap and -visual command- +line options for wish. (JO) + +1/4/95 (bug fix) Fixed keyboard code to properly handle alt-key +sequences for international keyboards and menu-accelerators. (SS) + +1/5/96 (bug fix) Scrollbar code sometimes generated errors on accesses +to tkPriv(relief) during control-clicks. (JO) + +1/9/96 (new feature) added the "grid" command to provide a table based +geometry manager. (SU) + +1/12/96 (performance optimization) Changed the way tag information is kept +in the text's Btree so the cost of adding and removing tag ranges is no longer +proportional to the number of unique tags in the text. In the old system +the cost of adding N unique tags was O(N-squared). The new implementation is +optimized for tags that only cover a small amount of text, measuring from +their earliest tag range to the end of their last range. In the best case the +cost of adding a tag range is unrelated to the number of unique tags, so the +cost of adding N tags is only O(N). In the worst case, where all tags +cover all the text, the cost is still O(N-squared) to add N such tags. +Deleting tags still has an O(N) cost (so deleting N tags is O(N-squared), +but it is now a factor of 2 faster than the old system. (BW) + +1/12/96 (new feature) added the text "dump" operation that returns information +about all elements in a text widget: text, tags, marks, and windows. (BW) + +1/12/96 (new feature) added the text "mark next" and "mark previous" operations +to search forward and backwards for the next (previous) mark in the text. (BW) + +1/12/96 (new feature) added the text "tag prevrange" operation to search +backwards for the current or previous range of a tag. (BW) + +1/16/96 (new feature) Added support for relative widget placement on +the "grid" command. (SU) + +1/17/96 (new feature) Modified the Makefile/configure setup to support +compiling Tk as a shared library. Use the --enable-shared option to +the "configure" script. (JO) + +----------------- Released 4.1b1, 1/26/96 ----------------------- + +2/2/96 (bug fix) Frames were getting a default size of 200x200, whereas +there should be no default. (JO) + +2/2/96 (bug fix) Argc wasn't getting reset properly after Tk removed +the arguments it understood from those on the command line. (JO) + +2/6/96 (bug fix) Fixed off by one error in argument parsing code under +Windows. (SS) + +2/6/96 (bug fix) "wm transient" now works under Windows. The resulting +toplevel is created with a modal dialog box frame and will not appear +in the taskbar under Windows '95. (SS) + +2/9/96 (bug fix) Changed Makefile.in to use -L and -l for Tcl and Tk +libraries so that shared libraries are more likely to be found correctly +on more platforms. (JO) + +2/14/96 (feature change) Eliminated tk_CanvasTagsOption variable because +it can't be exported safely across DLL boundaries. Instead, exported +Tk_CanvasTagsParseProc and Tk_CanvasTagsPrintProc procedures for +use by canvas type managers in creating their own custom options. (JO) +*** POTENTIAL INCOMPATIBILITY *** + +2/14/96 (bug fix) "winfo pointerxy" when applied to a non-toplevel window +crashed wish. (SS) + +2/14/96 (bug fix) "tkwait visibility" would hang under Windows. (SS) + +2/14/96 (bug fix) Cursors were not being updated until an enter event. +In cases where the cursor left the toplevel and reentered before Tk +noticed, the cursor would get "stuck" until the next enter event. +Similarly, if the cursor attribute of a window was updated while the +mouse was in the window, the cursor would not change until the next +time the mouse entered the window. (SS) + +2/15/96 (bug fix) If a top-level was resizable in one direction +(e.g. "wm resizable . 0 1"), once the user resized it any changes +in the internally requested size (by the widgets) were ignored, +even for the non-resizable dimension. Fixed to handle the two +dimensions totally independently, so the widget's requests are +honored as long as that dimension hasn't been set by the user. (JO) + +2/17/96 (bug fix) If a text widget had very long lines (e.g. more than +32K pixels), integer overflow could occur, resulting in parts of the +line not being visible. (JO) + +2/20/96 (feature change) Changed the -minsize option of grid to take +screen units instead of pixels. (SU) + +2/20/96 (bug fix) grid row and column weights are compared against +MINWEIGHT (0.001) instead of 0.0 to guard against divide by zero errors +during weight normalization. (SU) + +2/20/96 (bug fix) Menu commands were not being invoked sometimes. +There was a race condition that caused events to be processed while a +menu was being unposted. (SS) + +----------------- Released 4.1b2, 2/23/96 ----------------------- + +2/23/96 (bug fix) Alt-keys invoked in torn-off and popped up menus +caused menus to be posted in the parent toplevel. (JO) + +2/23/96 (bug fix) Canvases weren't always updating their scrollbars +when they should. (JO) + +2/23/96 (bug fix) Fixed core dump that could occur if a WM_DELETE_PROTOCOL +handler generated an error. (JO) + +2/24/96 (bug fix) Removed dependencies on Makefile in the UNIX Makefile: +this caused problems on some platforms (like Linux?). (JO) + +2/24/96 (feature change) Changed text and entry widgets so that they +set the insertion cursor before inserting during a button-2 click. +Also made optional bindings check for tk_strictMotif at the time of +the event, rather than at the time the bindings are created. (JO) + +2/24/96 (bug fix) Tk tended to crash with an X error when unsetting +an icon window (e.g. "wm iconwindow . {}"). (JO) + +2/25/96 (bug fix) Wasn't removing windows from the WM_COLORMAP_WINDOWS +property when they were deleted. (JO) + +3/1/96 (new feature) Added new "bbox" widget command for entries. +Also modified mouse bindings for entries and texts so that the +mouse position rounds to the nearest inter-character gap, rather +than the left edge of the character under the mouse. This provides +more natural selection behavior. (JO) + +3/1/96 (bug fix) Fixed core dump that could occur in image code if an +image was deleted while in use in a widet, then re-used in another +widget while "deleted". (JO) + +3/1/96 (bug fix) Calling wish with a single argument caused a crash +under Windows due to an off-by-one error in the argument parsing code. (SS) + +3/1/96 (bug fix) Palette management was broken and resulted in +incorrect palette realization and refresh behavior. Also, images were +being drawn incorrectly if they were attached to widgets that had a +private colormap. (SS) + +3/2/96 (bug fix) It was possible to press the mouse button over an +option menu, drag to a pulldown menu, and have the pulldown menu +popup in place of the option menu. Fixed this so that option menus +are isolated from each other and from pulldowns. (JO) + +3/2/96 (bug fix) Fixed yet another bug that caused long delays when +raising toplevel windows. (JO) + +3/2/96 (bug fix) Fixed bug in canvases where zero-sized rectangles +and ovals didn't always redisplay right (could leave trailing +garbage on screen when moved). (JO) + +3/2/96 (bug fix) Entry widgets reset their insertion cursor, selection, +and view whenever the text variable changed, plus whenever a "configure" +widget command was invoked and there was a text variable for the +widget. Fixed to preserve this information as much as possible. (JO) + +3/5/96 (new feature) Added version suffix to shared library names so that +Tk will compile under NetBSD and FreeBSD (I hope). (JO) + +3/6/96 (bug fix) Changed the way certain configure & motion events are +reported. This fixes several bugs in menus & "winfo rootx". (RJ) + +3/7/96 (bug fix) Fixed tag remove bug that showed up when draging out a +selection. If you had dragged left, then tried to drag back right, the +left edge of the selection wasn't being updated because the tag remove +wasn't doing anything. (BW) + +3/7/96 (bug fix) Fixed the boundary conditions of tag prevrange. The second +index argument wasn't effecting in stopping the search if it fell within +a range. The second index has to come at or before the start of a range +for the range to be found by tag prevrange. (BW) + +3/7/96 (bug fix) "puts" to stdout or stderr when running from a script +caused wish41.exe to exit silently. Now the output is silently +discarded without generating an error. (SS) + +3/7/96 (bug fix) Fixed bug where wish was treating empty lines in the input +as end of input, if the input came from stdin. This would cause it to +complain about missing closing braces etc. (JL) + +----------------- Released 4.1b3, 3/8/96 ----------------------- + +3/9/96 (bug fix) Fixed bug in text.tcl that could cause errors in text +widgets of the form 'can't use non-numeric string as operand of "-"'. (JO) + +3/12/96 (feature improvement) Modified startup script to look in several +different places for the Tcl library directory. This should allow tk +to find the libraries under all but the weirdest conditions, even without +the TK_LIBRARY environment variable being set. (JO) + +3/14/96 (bug fix) "wish bogus_file_name" didn't print an error message. (JO) + +3/14/96 (bug fix) Button-2 wasn't claiming the focus during paste +operations. (JO) + +3/14/96 (bug fix) "tkwait visibility" use to hang forever if its window +was deleted. Now it detects this condition and returns an error. (JO) + +3/16/96 (bug fix) Changed configuration stuff to get dynamic loading and +shared libraries working under AIX. (JO) + +3/16/96 (bug fix) Fixed core dumps that could occur when a slave interpreter +was deleted in the middle of executin bindings. (JO) + +3/18/96 (new feature) Added support for Activate/Deactivate events. +Currently, these new X events will generated only on the Macintosh. (RJ/CS) + +3/21/96 (bug fix) The "tag prevrange" command would fail to return the current +range if it began at 1.0 and the starting point of the search was within +the range. (BW) + +3/21/96 (configuration improvement) Changed configure script so it +doesn't use version numbers (as in -ltk4.1 and libtk4.1.so) under +SunOS 4.1, where they don't work anyway. (JO) + +3/22/96 (bug fix) Made Tk more robust against interpreter deletion. Now it +should be safe to delete an interpreter with a Tk application inside it, +without first deleting the Tk application. (JL) + +3/26/96 (bug fix) Tk now returns results from a "send" to an interpreter +in which the Tk application is destroyed, if the interpreter continues +computing after the Tk application is destroyed. Previously any results +computed after '.' was destroyed in the target interpreter were discarded +by the "send". (JL) + +3/26/96 (new feature) Tk now provides a static Tktest package which is +present only in test versions of Tk; this allows the testing commands to +be loaded into new interpreters besides the main one. (JL) + +3/28/96 (bug fix) Changed the tk_dialog procedure *not* to make the +dialog a transient for its parent. The old behavior meant that the +dialog did not get posted if the parent was iconified. (JO) + +4/5/96 (bug fix) Tk would occasionally crash when destroying toplevels +under Windows. (SS) + +4/5/96 (bug fix) Fonts were not being properly deallocated, causing +GDI resources to be consumed and never released under Windows. (SS) + +4/11/96 (bug fix) Toplevel windows with no specified geometry were +always appearing in the upper left corner of the screen under +Windows. (SS) + +4/11/96 (bug fix) "wm minsize" did not properly report the minimum +size imposed by the Windows window manager. (SS) + +4/13/96 (bug fix) Text widgets could dump core in some cases where +text was inserted on the top visible line. (JO) + +4/16/96 (bug fix) Changed menu code to ignore errors that occur when +restoring a grab: the old grab window might not be visible anymore. (JO) + +----------------- Released 4.1, 4/21/96 ----------------------- + +5/1/96 (buf fix) "option readfile" did not handle files with CRLF +line termination. (SS) + +5/1/96 (bug fix) Changed to install tkConfig.sh under "make install-binaries", +not "make install-libraries". (JO) + +5/7/96 (bug fix) Moved initScript in tkUnixInit.c to writable memory to +avoid potential core dumps. (JO) + +5/7/96 (bug fix) Changed tk_dialog back so that the dialog box is a +transient window again. This is needed to make sure that the dialog +box doesn't get obscured. Also changed it to return -1 if the dialog +window is deleted before the user presses a button. (JO) + +5/16/96 (bug fix) Fixed bug that caused core-dumps if a text widget +with -setgrid 1 was deleted by removing its command. (JO) + +5/22/96 (bug fix) Listboxes weren't properly ignoring double clicks on +button 1. (JO) + +6/12/96 (bug fix) Focus was automatically placed on new toplevels. +This caused the titlebar to flash during menubar traversal. (SS) + +6/12/96 (bug fix) Iconification of a window with a specified geometry +by using the minimize button would leave the window in an inconsistent +state. When the window was deiconified using "wm deiconify", the +window would continue to display as an icon with the deiconified +geometry. (SS) + +6/12/96 (bug fix) Fixed a resource leak where the text widget was not +freeing all of the TkRegions it created. This fix affects all +platforms, but is particularly important for Win32s. (SS) + +6/21/96 (configuration change) Added --enable-gcc switch to configure +script to make Tk just like Tcl. Now Tk will not use gcc unless you +request it explicitly. (JO) + +7/18/96 (bug fix) Changed "configure" script to add an extra -R switch +(or whatever is appropriate to the platform) if the X library is in a +nonstandard place. This guarantees that the shared library can be +found at runtime without having to set the LD_LIBRARY_PATH variable. (JO) + +7/19/96 (bug fix) Fixed bug in tkImgGIF.c that cause core dumps if a +GIF file contained multiple images. (JO) + +7/20/96 (bug fix) Deadlock could occur if a recursive series of send +operations involved multiple displays. (JO) + +7/23/96 (bug fix) Fixed a resource leak where deallocated XIDs were +taking up memory on Windows and Macintosh platforms. (SS) + +7/30/96 (bug fix) A core dump could occur if a handler for +a window tried to create a child in the half-dead window. Fixed by +making the window's name disappear from the name table once it starts +to be deleted. (JO) + +----------------- Released patch 4.1p1, 8/2/96 ----------------------- + +4/30/96 (new feature) Added support for named virtual events. New "event" +command to define/destroy named virtual events and to programmatically +send both real and virtual events to Tk. (CS) + +8/6/96 (bug fix) Entry widgets were invoking scrollbar update functions +too often. (JO) + +8/9/96 (bug fix) 7/30 change above for handlers broke many +things by making window available during Destroy handler. Reworked +fix for core dump to simply disallow creating children of half-dead +parents. (JO) + +8/12/96 (bug fix) Fixed bug where using the Copy menu item on the +Macintosh would append a NULL character at the end of the text. (RJ) + +8/15/96 (bug fix) Fixed Mac code so garbage wouldn't be printed in +text and entry widgets when function & other non-printing keys were +pressed. (RJ) + +8/15/96 (configuration improvement) Changed the file patchlevel.h +to be tkPatch.h. This avoids conflict with the Tcl file and is now +in 8.3 format on the Windows platform. (RJ) + +8/19/96 (bug fix) Fixed a bug under Windows where the initial window +position for a toplevel window was reported as +0+0, regardless of the +actual position. (SS) + +8/21/96 (bug fix) If the last character on a line in a text widget was +a space character that didn't completely fit, the text widget would +sometimes add an extra wrap line. (JO) + +8/22/96 (feature change) Complete rewrite of the grid geometry manager. +There is a new layout algorithm that produces better (but different) +layouts in many common cases. (SU) + +8/22/96 (new feature) There are two new options for the grid geometry +manager, "grid update" which forces an immediate layout calculation, +and a "-pad" option to rowconfigure and columnconfigure that allows for +extra space around widgets. (SU) + +8/22/96 (feature change) The order in which the grid geometry manager +reports slaves is now last-managed first. (SU) + +8/22/96 (feature change) The column and row weights in the grid +geometry manager are kept internally as integers, instead of floating +point values. Floating point values are still accepted on the command line, +but are truncated to integers. (SU) + +8/22/96 (new feature) There are four new commands for opening common +dialog boxes: tk_chooseColor, tk_getOpenFile, tk_getSaveFile and +tk_messageBox. Native dialog boxes are used wherever available. (IL) + +8/22/96 (new demos) Added "fsbox", "msgbox" and "clrpick" demos. (IL) + +8/23/96 (feature change) Invoking the edit menu on the Macintosh now +generates the following virtual events <>, <>, <>, +and <> instead of faking key events. (RJ) +*** POTENTIAL INCOMPATIBILITY *** + +8/25/96 (bug fix) Fixed a bug that would cause "grid x" to dump core. (SU) + +8/26/96 (new feature) Added the "unsupported1" command to the +Macintosh version of Tk. This command will allow you to set the style +of a new toplevel Window (much like overrideredirect). You can use +this to get access to all of the Native Mac window styles. This is to +hold you over until we get a more general solution added to the +toplevel command. (RJ) + +8/26/96 (new feature) Added support to handle the zoom box on a +Macintosh window. (Currently, you can only get a Tk window with a +zoom box by using the "unsupported1" command. (RJ) + +8/27/96 (documentation change) Removed old change bars (for changes in +Tk 4.1 and earlier releases) from manual entries. (JO) + +----------------- Released 4.2b1, 8/30/96 ----------------------- + +9/5/96 (bug fixes) Fixed several bugs in file dialogs: individual files +could be listed twice, if a long list of files were shown, and the view +scrolled to the right, and then a different file file was shown, the +scrollregion on the canvas wasn't being reset, so the file dialog was +broken from then on, added an update idletasks so that the watch +cursor was shown when the dialog was thinking. For the motif file +dialog, fixed the weights for resizing. On the clrpicker, fixed the +finalColor variable which caused problems when the OK button was +"clicked" before the dialog was mapped (in the test suite). Added Ioi's +last changes from before he left. For message boxes, if a single button +message box is shown (currently only 'ok'), it is set to be the default +even if not specified. (KC) + +9/5/96 (bug fix) Fixed bug on Macintosh where menus would appear in a +seemingly random location. (RJ) + +9/5/96 (bug fix) Text widgets had rounding problems with the "yview" +command that caused them sometimes to round to the line before the +correct one. (JO) + +9/5/96 (bug fix) Changed grab code to retry grabs after errors where +another application already has the grab. This is needed to get +around race conditions with some window managers and will hopefully +solve the grab errors that people see occasionally. (JO) + +9/6/96 (bug fix) Fixed x-y coordinate confusion problem with scaling +of window items in canvases. (JO) + +9/11/96 (bug fix) The open and save file dialogs would change the +current working directory under Windows. (SS) + +9/12/96 (bug fix) The Tk event system was delivering events to dead +windows, if the event handler got reentered during a Destroy event +handler. This could cause core dumps and other problems. (JO) + +9/20/96 (bug fix) In XFillRectangles under Windows, a brush was not +being deallocated. (SS) + +9/20/96 (bug fix) The Mac window manager used to generate a mouseUp +event for a top level that was recently raised to the front/active +window which often caused a tk(priv) error. The up event is no +longer generated with solves several problems. (RJ) + +9/25/96 (bug fix) The font code under Windows was leaking memory +whenever a new font was referenced using the three part font names. (SS) + +9/26/96 (bug fix) The tests for the common dialogs still used the 'testevent' +function. I updated these calls in clrpick.test, msgbox.test, filebox.test +to use the new event gereating mechanism. + +9/18/96 (bug fix) Long-standing bug in bind where was +reported as , but was reported as "aa". (CS) + +9/27/96 (bug fix) Bindings didn't work on 64-bit machines due to changes +made for virtual events. (CS) + +9/30/96 (feature change) Binding for new virtual events included both +lower and upper-case, e.g., <> was defined as and +. Previously, widgets were directly bound to only lower-case +bindings. The upper-case binding caused incompatibility with some existing +Tcl programs, so the upper case bindings for <>, <>, and <> +were removed. (CS) + +9/30/96 (bug fix) The postscript code in the canvas widget now uses +channels to get and write .ps files which fixed a bug on the Mac where +an output file would have mixed EOL characters. In addition, I added +the ability for the prolog to come from the Tk shared library on the +Mac which makes it possible to have a standalone application. (RJ) + +10/1/96 (feature change) "grid forget" was renamed "grid remove". A new +command "grid forget" was added whose semantics are the same as "pack forget" +(SAU) +*** POTENTIAL INCOMPATIBILITY *** + +10/1/96 (feature change) grid no longer accepts floating point values for +row or column weights, integers must be used. (SAU) +*** POTENTIAL INCOMPATIBILITY *** + +10/1/96 (feature change) "grid {column,row}configure " +returns a list of option value pairs for all of the row or column +constraints. It used to return an error. (SAU) + +10/1/96 (bug fix) "The way grid handles '^' short-cuts was re-written +to eliminate core dumps. (SAU) + +10/3/96 (feature change) A virtual event binding associated with a +given physical event is now considered less specific than a binding for +that same physical event, all other things being equal. (CS). + +10/3/96 (bug fix) Under Windows text placed on the clipboard did not +undergo CRLF translation when delivered to other applications. (SS) + +10/3/96 (bug fix) Copying an image onto itself with a zoom factor that +caused the image to grow was accessing freed memory. (SS) + +10/3/96 (bug fix) Under Windows, the image blank subcommand did not +work. (SS) + +10/10/96 (bug fix) Under Windows & Macintosh, XSetFont and XChangeGC +were not implemented, and XSetLineAttributes did not correctly update +the GC. (SS) + +10/10/96 (bug fix) Under Windows, 8-bit non-palette displays were not +handled properly. (SS) + +10/10/96 (bug fix) Under Windows, images of depth other than 8 or 24 +bits were not being rendered properly. (SS) + +10/10/96 (bug fix) Under Windows, bitmap subimages were not correctly +displayed. (SS) + +10/14/96 (bug fix) Under Window, wm resizable would constrain both +programatic resizes as well as user resizes. (SS) + +----------------- Released 4.2, 10/16/96 ----------------------- + +10/17/96 (bug fix) XCopyPlane was broken under Windows and would cause +a crash when used with a clipping bitmap. (SS) diff --git a/tk4.2/compat/license.terms b/tk4.2/compat/license.terms new file mode 100644 index 0000000..03ca6fc --- /dev/null +++ b/tk4.2/compat/license.terms @@ -0,0 +1,39 @@ +This software is copyrighted by the Regents of the University of +California, Sun Microsystems, Inc., and other parties. The following +terms apply to all files associated with the software unless explicitly +disclaimed in individual files. + +The authors hereby grant permission to use, copy, modify, distribute, +and license this software and its documentation for any purpose, provided +that existing copyright notices are retained in all copies and that this +notice is included verbatim in any distributions. No written agreement, +license, or royalty fee is required for any of the authorized uses. +Modifications to this software may be copyrighted by their authors +and need not follow the licensing terms described here, provided that +the new terms are clearly indicated on the first page of each file where +they apply. + +IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY +FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES +ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY +DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + +THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE +IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE +NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR +MODIFICATIONS. + +GOVERNMENT USE: If you are acquiring this software on behalf of the +U.S. government, the Government shall have only "Restricted Rights" +in the software and related documentation as defined in the Federal +Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you +are acquiring the software on behalf of the Department of Defense, the +software shall be classified as "Commercial Computer Software" and the +Government shall have only "Restricted Rights" as defined in Clause +252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the +authors grant the U.S. Government and others acting in its behalf +permission to use and distribute the software in accordance with the +terms specified in this license. diff --git a/tk4.2/compat/limits.h b/tk4.2/compat/limits.h new file mode 100644 index 0000000..66eb542 --- /dev/null +++ b/tk4.2/compat/limits.h @@ -0,0 +1,22 @@ +/* + * 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 tclPort.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. + * Copyright (c) 1994 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) limits.h 1.7 96/02/15 14:43:55 + */ + +#define LONG_MIN 0x80000000 +#define LONG_MAX 0x7fffffff +#define INT_MIN 0x80000000 +#define INT_MAX 0x7fffffff diff --git a/tk4.2/compat/stdlib.h b/tk4.2/compat/stdlib.h new file mode 100644 index 0000000..059ea29 --- /dev/null +++ b/tk4.2/compat/stdlib.h @@ -0,0 +1,45 @@ +/* + * 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. + * Copyright (c) 1994 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) stdlib.h 1.10 96/02/15 14:43:54 + */ + +#ifndef _STDLIB +#define _STDLIB + +#include + +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/tk4.2/compat/unistd.h b/tk4.2/compat/unistd.h new file mode 100644 index 0000000..3af430c --- /dev/null +++ b/tk4.2/compat/unistd.h @@ -0,0 +1,84 @@ +/* + * 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. + * + * SCCS: @(#) unistd.h 1.7 96/02/15 14:43:57 + */ + +#ifndef _UNISTD +#define _UNISTD + +#include +#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 long lseek _ANSI_ARGS_((int fd, long 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 ioctl _ANSI_ARGS_((int fd, int request, ...)); +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/tk3.6/doc/3DBorder.3 b/tk4.2/doc/3DBorder.3 similarity index 55% rename from tk3.6/doc/3DBorder.3 rename to tk4.2/doc/3DBorder.3 index 35d5f57..3f12025 100644 --- a/tk3.6/doc/3DBorder.3 +++ b/tk4.2/doc/3DBorder.3 @@ -1,48 +1,41 @@ '\" '\" Copyright (c) 1990-1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/wish/man/RCS/3DBorder.3,v 1.12 93/04/01 09:40:48 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) 3DBorder.3 1.22 96/08/27 13:21:14 '\" .so man.macros -.HS Tk_Get3DBorder tkc +.TH Tk_Get3DBorder 3 4.0 Tk "Tk Library Procedures" .BS .SH NAME -Tk_Get3DBorder, Tk_Draw3DRectangle, Tk_Fill3DRectangle, Tk_Draw3DPolygon, Tk_Fill3DPolygon, Tk_SetBackgroundFromBorder, Tk_NameOf3DBorder, Tk_Free3DBorder \- draw borders with three-dimensional appearance +Tk_Get3DBorder, Tk_Draw3DRectangle, Tk_Fill3DRectangle, Tk_Draw3DPolygon, Tk_Fill3DPolygon, Tk_3DVerticalBevel, Tk_3DHorizontalBevel, Tk_SetBackgroundFromBorder, Tk_NameOf3DBorder, Tk_3DBorderColor, Tk_3DBorderGC, Tk_Free3DBorder \- draw borders with three-dimensional appearance .SH SYNOPSIS .nf \fB#include \fR .sp Tk_3DBorder -\fBTk_Get3DBorder(\fIinterp, tkwin, colorMap, colorName\fB)\fR +\fBTk_Get3DBorder(\fIinterp, tkwin, colorName\fB)\fR .sp void -\fBTk_Draw3DRectangle(\fIdisplay, drawable, border, x, y, width, height, borderWidth, relief\fB)\fR +\fBTk_Draw3DRectangle(\fItkwin, drawable, border, x, y, width, height, borderWidth, relief\fB)\fR .sp void -\fBTk_Fill3DRectangle(\fIdisplay, drawable, border, x, y, width, height, borderWidth, relief\fB)\fR +\fBTk_Fill3DRectangle(\fItkwin, drawable, border, x, y, width, height, borderWidth, relief\fB)\fR .sp void -\fBTk_Draw3DPolygon(\fIdisplay, drawable, border, pointPtr, numPoints, polyBorderWidth, leftRelief\fB)\fR +\fBTk_Draw3DPolygon(\fItkwin, drawable, border, pointPtr, numPoints, polyBorderWidth, leftRelief\fB)\fR .sp void -\fBTk_Fill3DPolygon(\fIdisplay, drawable, border, pointPtr, numPoints, polyBorderWidth, leftRelief\fB)\fR +\fBTk_Fill3DPolygon(\fItkwin, drawable, border, pointPtr, numPoints, polyBorderWidth, leftRelief\fB)\fR +.sp +void +\fBTk_3DVerticalBevel\fR(\fItkwin, drawable, border, x, y, width, height, leftBevel, relief\fB)\fR +.sp +void +\fBTk_3DHorizontalBevel\fR(\fItkwin, drawable, border, x, y, width, height, leftIn, rightIn, topBevel, relief\fB)\fR .sp void \fBTk_SetBackgroundFromBorder(\fItkwin, border\fB)\fR @@ -50,10 +43,11 @@ void char * \fBTk_NameOf3DBorder(\fIborder\fB)\fR .sp -.VS XColor * \fBTk_3DBorderColor(\fIborder\fB)\fR -.VE +.sp +GC * +\fBTk_3DBorderGC(\fItkwin, border, which\fB)\fR .sp \fBTk_Free3DBorder(\fIborder\fB)\fR .SH ARGUMENTS @@ -61,38 +55,36 @@ XColor * .AP Tcl_Interp *interp in Interpreter to use for error reporting. .AP Tk_Window tkwin in -Token for window in which border will be drawn. -.AP Colormap colormap in -Colormap from which to allocate colors. If None, then the default -colormap for \fItkwin\fR's screen is used. +Token for window (for all procedures except \fBTk_Get3DBorder\fR, +must be the window for which the border was allocated). .AP Tk_Uid colorName in Textual description of color corresponding to background (flat areas). -Illuminated edges will be brighter than this, and shadowed edges will +Illuminated edges will be brighter than this and shadowed edges will be darker than this. -.AP Display *display in -Xlib pointer indicating display with which drawable is associated. .AP Drawable drawable in -X token for window or pixmap; indicates where border is to be drawn. +X token for window or pixmap; indicates where graphics are to be drawn. +Must either be the X window for \fItkwin\fR or a pixmap with the +same screen and depth as \fItkwin\fR. .AP Tk_3DBorder border in Token for border previously allocated in call to \fBTk_Get3DBorder\fR. .AP int x in -X-coordinate of upper-left corner of rectangle describing border. +X-coordinate of upper-left corner of rectangle describing border +or bevel, in pixels. .AP int y in -Y-coordinate of upper-left corner of rectangle describing border. +Y-coordinate of upper-left corner of rectangle describing border or +bevel, in pixels. .AP int width in -Width of rectangle describing border, in pixels. +Width of rectangle describing border or bevel, in pixels. .AP int height in -Height of rectangle describing border, in pixels. +Height of rectangle describing border or bevel, in pixels. .AP int borderWidth in Width of border in pixels. Positive means border is inside rectangle given by \fIx\fR, \fIy\fR, \fIwidth\fR, \fIheight\fR, negative means border is outside rectangle. .AP int relief in -Indicates 3-D position of interior of rectangle relative to exterior; +Indicates 3-D position of interior of object relative to exterior; should be TK_RELIEF_RAISED, TK_RELIEF_SUNKEN, TK_RELIEF_GROOVE, -.VS or TK_RELIEF_RIDGE (may also be TK_RELIEF_FLAT -.VE for \fBTk_Fill3DRectangle\fR). .AP XPoint *pointPtr in Pointer to array of points describing the set of vertices in a polygon. @@ -109,11 +101,29 @@ TK_RELIEF_RIDGE then the border is centered on the trajectory. Height of left side of polygon's path relative to right. TK_RELIEF_RAISED means left side should appear higher and TK_RELIEF_SUNKEN means right side should appear higher; -.VS TK_RELIEF_GROOVE and TK_RELIEF_RIDGE mean the obvious things. -.VE For \fBTk_Fill3DPolygon\fR, TK_RELIEF_FLAT may also be specified to indicate no difference in height. +.AP int leftBevel in +Non-zero means this bevel forms the left side of the object; zero means +it forms the right side. +.AP int leftIn in +Non-zero means that the left edge of the horizontal bevel angles in, +so that the bottom of the edge is farther to the right than +the top. +Zero means the edge angles out, so that the bottom is farther to the +left than the top. +.AP int rightIn in +Non-zero means that the right edge of the horizontal bevel angles in, +so that the bottom of the edge is farther to the left than the top. +Zero means the edge angles out, so that the bottom is farther to the +right than the top. +.AP int topBevel in +Non-zero means this bevel forms the top side of the object; zero means +it forms the bottom side. +.AP int which in +Specifies which of the border's graphics contexts is desired. +Must be TK_3D_FLAT_GC, TK_3D_LIGHT_GC, or TK_3D_DARK_GC. .BE .SH DESCRIPTION @@ -121,12 +131,12 @@ indicate no difference in height. These procedures provide facilities for drawing window borders in a way that produces a three-dimensional appearance. \fBTk_Get3DBorder\fR allocates colors and Pixmaps needed to draw a border in the window -given by the \fItkwin\fR argument. The \fIcolormap\fR argument -specifies a Colormap to use for allocating colors, and the \fIcolorName\fR -argument indicates what colors should be used in the border. \fIColorName\fR -may be any value acceptable to \fBTk_GetColor\fR. The color indicated -by \fIcolorName\fR will not actually be used in the border; it indicates -the background color for the window (i.e. a color for flat surfaces). +given by the \fItkwin\fR argument. The \fIcolorName\fR +argument indicates what colors should be used in the border. +\fIColorName\fR may be any value acceptable to \fBTk_GetColor\fR. +The color indicated by \fIcolorName\fR will not actually be used in +the border; it indicates the background color for the window +(i.e. a color for flat surfaces). The illuminated portions of the border will appear brighter than indicated by \fIcolorName\fR, and the shadowed portions of the border will appear darker than \fIcolorName\fR. @@ -137,12 +147,14 @@ for the border (e.g. \fIcolorName\fR isn't a legal color specifier), then NULL is returned and an error message is left in \fIinterp->result\fR. .PP Once a border structure has been created, \fBTk_Draw3DRectangle\fR may be -invoked to draw the border. The \fIdisplay\fR and \fIdrawable\fR -arguments specify a window or pixmap in which the border is to be -drawn. \fIDrawable\fR need not refer to the same window as the -\fItkwin\fR used to create the border, but it must refer to a compatible -pixmap or window: one associated with the same display and with the -same depth as the \fItkwin\fR used to create the border. +invoked to draw the border. +The \fItkwin\fR argument specifies the +window for which the border was allocated, and \fIdrawable\fR +specifies a window or pixmap in which the border is to be drawn. +\fIDrawable\fR need not refer to the same window as \fItkwin\fR, but it +must refer to a compatible +pixmap or window: one associated with the same screen and with the +same depth as \fItkwin\fR. The \fIx\fR, \fIy\fR, \fIwidth\fR, and \fIheight\fR arguments define the bounding box of the border region within \fIdrawable\fR (usually \fIx\fR and \fIy\fR are zero and @@ -153,10 +165,8 @@ which of several three-dimensional effects is desired: TK_RELIEF_RAISED means that the interior of the rectangle should appear raised relative to the exterior of the rectangle, and TK_RELIEF_SUNKEN means that the interior should appear depressed. -.VS TK_RELIEF_GROOVE and TK_RELIEF_RIDGE mean that there should appear to be a groove or ridge around the exterior of the rectangle. -.VE .PP \fBTk_Fill3DRectangle\fR is somewhat like \fBTk_Draw3DRectangle\fR except that it first fills the rectangular area with the background color @@ -186,6 +196,35 @@ then calls \fBTk_Draw3DPolygon\fR to draw a border around the area (unless \fIleftRelief\fR is TK_RELIEF_FLAT; in this case no border is drawn). .PP +The procedures \fBTk_3DVerticalBevel\fR and \fBTk_3DHorizontalBevel\fR +provide lower-level drawing primitives that are used by +procedures such as \fBTk_Draw3DRectangle\fR. +These procedures are also useful in their own right for drawing +rectilinear border shapes. +\fBTk_3DVerticalBevel\fR draws a vertical beveled edge, such as the +left or right side of a rectangle, and \fBTk_3DHorizontalBevel\fR +draws a horizontal beveled edge, such as the top or bottom of a +rectangle. +Each procedure takes \fIx\fR, \fIy\fR, \fIwidth\fR, and \fIheight\fR +arguments that describe the rectangular area of the beveled edge +(e.g., \fIwidth\fR is the border width for \fBTk_3DVerticalBevel\fR). +The \fIleftBorder\fR and \fItopBorder\fR arguments indicate the +position of the border relative to the ``inside'' of the object, and +\fIrelief\fR indicates the relief of the inside of the object relative +to the outside. +\fBTk_3DVerticalBevel\fR just draws a rectangular region. +\fBTk_3DHorizontalBevel\fR draws a trapezoidal region to generate +mitered corners; it should be called after \fBTk_3DVerticalBevel\fR +(otherwise \fBTk_3DVerticalBevel\fR will overwrite the mitering in +the corner). +The \fIleftIn\fR and \fIrightIn\fR arguments to \fBTk_3DHorizontalBevel\fR +describe the mitering at the corners; a value of 1 means that the bottom +edge of the trapezoid will be shorter than the top, 0 means it will +be longer. +For example, to draw a rectangular border the top bevel should be +drawn with 1 for both \fIleftIn\fR and \fIrightIn\fR, and the +bottom bevel should be drawn with 0 for both arguments. +.PP The procedure \fBTk_SetBackgroundFromBorder\fR will modify the background pixel and/or pixmap of \fItkwin\fR to produce a result compatible with \fIborder\fR. For color displays, the resulting background will @@ -199,7 +238,6 @@ Given a token for a border, the procedure \fBTk_NameOf3DBorder\fR will return the \fIcolorName\fR string that was passed to \fBTk_Get3DBorder\fR to create the border. .PP -.VS The procedure \fBTk_3DBorderColor\fR returns the XColor structure that will be used for flat surfaces drawn for its \fIborder\fR argument by procedures like \fBTk_Fill3DRectangle\fR. @@ -207,7 +245,13 @@ The return value corresponds to the \fIcolorName\fR passed to \fBTk_Get3DBorder\fR. The XColor, and its associated pixel value, will remain allocated as long as \fIborder\fR exists. -.VE +.PP +The procedure \fBTk_3DBorderGC\fR returns one of the X graphics contexts +that are used to draw the border. +The argument \fIwhich\fR selects which one of the three possible GC's: +TK_3D_FLAT_GC returns the context used for flat surfaces, +TK_3D_LIGHT_GC returns the context for light shadows, +and TK_3D_DARK_GC returns the context for dark shadows. .PP When a border is no longer needed, \fBTk_Free3DBorder\fR should be called to release the resources associated with the border. diff --git a/tk4.2/doc/BindTable.3 b/tk4.2/doc/BindTable.3 new file mode 100644 index 0000000..bbcb64d --- /dev/null +++ b/tk4.2/doc/BindTable.3 @@ -0,0 +1,157 @@ +'\" +'\" Copyright (c) 1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) BindTable.3 1.5 96/03/26 18:03:09 +'\" +.so man.macros +.TH Tk_CreateBindingTable 3 4.0 Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_CreateBindingTable, Tk_DeleteBindingTable, Tk_CreateBinding, Tk_DeleteBinding, Tk_GetBinding, Tk_GetAllBindings, Tk_DeleteAllBindings, Tk_BindEvent \- invoke scripts in response to X events +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +Tk_BindingTable +\fBTk_CreateBindingTable(\fIinterp\fB)\fR +.sp +\fBTk_DeleteBindingTable(\fIbindingTable\fB)\fR +.sp +unsigned long +\fBTk_CreateBinding(\fIinterp, bindingTable, object, eventString, script, append\fB)\fR +.sp +int +\fBTk_DeleteBinding(\fIinterp, bindingTable, object, eventString\fB)\fR +.sp +char * +\fBTk_GetBinding(\fIinterp, bindingTable, object, eventString\fB)\fR +.sp +\fBTk_GetAllBindings(\fIinterp, bindingTable, object\fB)\fR +.sp +\fBTk_DeleteAllBindings(\fIbindingTable, object\fB)\fR +.sp +\fBTk_BindEvent(\fIbindingTable, eventPtr, tkwin, numObjects, objectPtr\fB)\fR +.SH ARGUMENTS +.AS Tk_BindingTable bindingTable +.AP Tcl_Interp *interp in +Interpreter to use when invoking bindings in binding table. Also +used for returning results and errors from binding procedures. +.AP Tk_BindingTable bindingTable in +Token for binding table; must have been returned by some previous +call to \fBTk_CreateBindingTable\fR. +.AP ClientData object in +Identifies object with which binding is associated. +.AP char *eventString in +String describing event sequence. +.AP char *script in +Tcl script to invoke when binding triggers. +.AP int append in +Non-zero means append \fIscript\fR to existing script for binding, +if any; zero means replace existing script with new one. +.AP XEvent *eventPtr in +X event to match against bindings in \fIbindingTable\fR. +.AP Tk_Window tkwin in +Identifier for any window on the display where the event occurred. +Used to find display-related information such as key maps. +.AP int numObjects in +Number of object identifiers pointed to by \fIobjectPtr\fR. +.AP ClientData *objectPtr in +Points to an array of object identifiers: bindings will be considered +for each of these objects in order from first to last. +.BE + +.SH DESCRIPTION +.PP +These procedures provide a general-purpose mechanism for creating +and invoking bindings. +Bindings are organized in terms of \fIbinding tables\fR. +A binding table consists of a collection of bindings plus a history +of recent events. +Within a binding table, bindings are associated with \fIobjects\fR. +The meaning of an object is defined by clients of the binding package. +For example, Tk keeps uses one binding table to hold all of the bindings +created by the \fBbind\fR command. +For this table, objects are pointers to strings such as window names, class +names, or other binding tags such as \fBall\fR. +Tk also keeps a separate binding table for each canvas widget, which manages +bindings created by the canvas's \fBbind\fR widget command; within +this table, an object is either a pointer to the internal structure for a +canvas item or a Tk_Uid identifying a tag. +.PP +The procedure \fBTk_CreateBindingTable\fR creates a new binding +table and associates \fIinterp\fR with it (when bindings in the +table are invoked, the scripts will be evaluated in \fIinterp\fR). +\fBTk_CreateBindingTable\fR returns a token for the table, which +must be used in calls to other procedures such as \fBTk_CreateBinding\fR +or \fBTk_BindEvent\fR. +.PP +\fBTk_DeleteBindingTable\fR frees all of the state associated +with a binding table. +Once it returns the caller should not use the \fIbindingTable\fR +token again. +.PP +\fBTk_CreateBinding\fR adds a new binding to an existing table. +The \fIobject\fR argument identifies the object with which the +binding is to be associated, and it may be any one-word value. +Typically it is a pointer to a string or data structure. +The \fIeventString\fR argument identifies the event or sequence +of events for the binding; see the documentation for the +\fBbind\fR command for a description of its format. +\fIscript\fR is the Tcl script to be evaluated when the binding +triggers. +\fIappend\fR indicates what to do if there already +exists a binding for \fIobject\fR and \fIeventString\fR: if \fIappend\fR +is zero then \fIscript\fR replaces the old script; if \fIappend\fR +is non-zero then the new script is appended to the old one. +\fBTk_CreateBinding\fR returns an X event mask for all the events +associated with the bindings. +This information may be useful to invoke \fBXSelectInput\fR to +select relevant events, or to disallow the use of certain events +in bindings. +If an error occurred while creating the binding (e.g., \fIeventString\fR +refers to a non-existent event), then 0 is returned and an error +message is left in \fIinterp->result\fR. +.PP +\fBTk_DeleteBinding\fR removes from \fIbindingTable\fR the +binding given by \fIobject\fR and \fIeventString\fR, if +such a binding exists. +\fBTk_DeleteBinding\fR always returns TCL_OK. +In some cases it may reset \fIinterp->result\fR to the default +empty value. +.PP +\fBTk_GetBinding\fR returns a pointer to the script associated +with \fIeventString\fR and \fIobject\fR in \fIbindingTable\fR. +If no such binding exists then NULL is returned and an error +message is left in \fIinterp->result\fR. +.PP +\fBTk_GetAllBindings\fR returns in \fIinterp->result\fR a list +of all the event strings for which there are bindings in +\fIbindingTable\fR associated with \fIobject\fR. +If there are no bindings for \fIobject\fR then an empty +string is returned in \fIinterp->result\fR. +.PP +\fBTk_DeleteAllBindings\fR deletes all of the bindings in +\fIbindingTable\fR that are associated with \fIobject\fR. +.PP +\fBTk_BindEvent\fR is called to process an event. +It makes a copy of the event in an internal history list associated +with the binding table, then it checks for bindings that match +the event. +\fBTk_BindEvent\fR processes each of the objects pointed to +by \fIobjectPtr\fR in turn. +For each object, it finds all the bindings that match the current +event history, selects the most specific binding using the priority +mechanism described in the documentation for \fBbind\fR, +and invokes the script for that binding. +If there are no matching bindings for a particular object, then +the object is skipped. +\fBTk_BindEvent\fR continues through all of the objects, handling +exceptions such as errors, \fBbreak\fR, and \fBcontinue\fR as +described in the documentation for \fBbind\fR. + +.SH KEYWORDS +binding, event, object, script diff --git a/tk4.2/doc/CanvPsY.3 b/tk4.2/doc/CanvPsY.3 new file mode 100644 index 0000000..017b762 --- /dev/null +++ b/tk4.2/doc/CanvPsY.3 @@ -0,0 +1,122 @@ +'\" +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) CanvPsY.3 1.6 96/03/26 18:03:26 +'\" +.so man.macros +.TH Tk_CanvasPsY 3 4.0 Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_CanvasPsY, Tk_CanvasPsBitmap, Tk_CanvasPsColor, Tk_CanvasPsFont, Tk_CanvasPsPath, Tk_CanvasPsStipple \- utility procedures for generating Postscript for canvases +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +double +\fBTk_CanvasPsY\fR(\fIcanvas, canvasY\fR) +.sp +int +\fBTk_CanvasPsBitmap\fR(\fIinterp, canvas, bitmap, x, y, width, height\fR) +.sp +int +\fBTk_CanvasPsColor\fR(\fIinterp, canvas, colorPtr\fR) +.sp +int +\fBTk_CanvasPsFont\fR(\fIinterp, canvas, fontStructPtr\fR) +.sp +\fBTk_CanvasPsPath\fR(\fIinterp, canvas, coordPtr, numPoints\fR) +.sp +int +\fBTk_CanvasPsStipple\fR(\fIinterp, canvas, bitmap\fR) +.SH ARGUMENTS +.AS "unsigned int" *fontStructPtr +.AP Tk_Canvas canvas in +A token that identifies a canvas widget for which Postscript is +being generated. +.AP double canvasY in +Y-coordinate in the space of the canvas. +.AP Tcl_Interp *interp in/out +A Tcl interpreter; Postscript is appended to its result, or the +result may be replaced with an error message. +.AP Pixmap bitmap in +Bitmap to use for generating Postscript. +.AP int x in +X-coordinate within \fIbitmap\fR of left edge of region to output. +.AP int y in +Y-coordinate within \fIbitmap\fR of top edge of region to output. +.AP "int" width in +Width of region of bitmap to output, in pixels. +.AP "int" height in +Height of region of bitmap to output, in pixels. +.AP XColor *colorPtr in +Information about color value to set in Postscript. +.AP XFontStruct *fontStructPtr in +Font for which Postscript is to be generated. +.AP double *coordPtr in +Pointer to an array of coordinates for one or more +points specified in canvas coordinates. +The order of values in \fIcoordPtr\fR is x1, y1, x2, y2, x3, y3, +and so on. +.AP int numPoints in +Number of points at \fIcoordPtr\fR. +.BE + +.SH DESCRIPTION +.PP +These procedures are called by canvas type managers to carry out +common functions related to generating Postscript. +Most of the procedures take a \fIcanvas\fR argument, which +refers to a canvas widget for which Postscript is being +generated. +.PP +\fBTk_CanvasY\fR takes as argument a y-coordinate in the space of +a canvas and returns the value that should be used for that point +in the Postscript currently being generated for \fIcanvas\fR. +Y coordinates require transformation because Postscript uses an +origin at the lower-left corner whereas X uses an origin at the +upper-left corner. +Canvas x coordinates can be used directly in Postscript without +transformation. +.PP +\fBTk_CanvasPsBitmap\fR generates Postscript to describe a region +of a bitmap. +The Postscript is generated in proper image data format for Postscript, +i.e., as data between angle brackets, one bit per pixel. +The Postscript is appended to \fIinterp->result\fR and TCL_OK is returned +unless an error occurs, in which case TCL_ERROR is returned and +\fIinterp->result\fR is overwritten with an error message. +.PP +\fBTk_CanvasPsColor\fR generates Postscript to set the current color +to correspond to its \fIcolorPtr\fR argument, taking into account any +color map specified in the \fBpostscript\fR command. +It appends the Postscript to \fIinterp->result\fR and returns +TCL_OK unless an error occurs, in which case TCL_ERROR is returned and +\fIinterp->result\fR is overwritten with an error message. +.PP +\fBTk_CanvasPsFont\fR generates Postscript that sets the current font +to match \fIfontStructPtr\fR as closely as possible. +\fBTk_CanvasPsFont\fR takes into account any font map specified +in the \fBpostscript\fR command, and it does +the best it can at mapping X fonts to Postscript fonts. +It appends the Postscript to \fIinterp->result\fR and returns TCL_OK +unless an error occurs, in which case TCL_ERROR is returned and +\fIinterp->result\fR is overwritten with an error message. +.PP +\fBTk_CanvasPsPath\fR generates Postscript to set the current path +to the set of points given by \fIcoordPtr\fR and \fInumPoints\fR. +It appends the resulting Postscript to \fIinterp->result\fR. +.PP +\fBTk_CanvasPsStipple\fR generates Postscript that will fill the +current path in stippled fashion. +It uses \fIbitmap\fR as the stipple pattern and the current Postscript +color; ones in the stipple bitmap are drawn in the current color, and +zeroes are not drawn at all. +The Postscript is appended to \fIinterp->result\fR and TCL_OK is +returned, unless an error occurs, in which case TCL_ERROR is returned and +\fIinterp->result\fR is overwritten with an error message. + +.SH KEYWORDS +bitmap, canvas, color, font, path, Postscript, stipple diff --git a/tk4.2/doc/CanvTkwin.3 b/tk4.2/doc/CanvTkwin.3 new file mode 100644 index 0000000..b421b5e --- /dev/null +++ b/tk4.2/doc/CanvTkwin.3 @@ -0,0 +1,161 @@ +'\" +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) CanvTkwin.3 1.8 96/08/27 13:21:54 +'\" +.so man.macros +.TH Tk_CanvasTkwin 3 4.1 Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_CanvasTkwin, Tk_CanvasGetCoord, Tk_CanvasDrawableCoords, Tk_CanvasSetStippleOrigin, Tk_CanvasWindowCoords, Tk_CanvasEventuallyRedraw, Tk_CanvasTagsOption \- utility procedures for canvas type managers +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +Tk_Window +\fBTk_CanvasTkwin\fR(\fIcanvas\fR) +.sp +int +\fBTk_CanvasGetCoord\fR(\fIinterp, canvas, string, doublePtr\fR) +.sp +\fBTk_CanvasDrawableCoords\fR(\fIcanvas, x, y, drawableXPtr, drawableYPtr\fR) +.sp +\fBTk_CanvasSetStippleOrigin\fR(\fIcanvas, gc\fR) +.sp +\fBTk_CanvasWindowCoords\fR(\fIcanvas, x, y, screenXPtr, screenYPtr\fR) +.sp +\fBTk_CanvasEventuallyRedraw\fR(\fIcanvas, x1, y1, x2, y2\fR) +.sp +Tk_OptionParseProc *\fBTk_CanvasTagsParseProc\fR; +.sp +Tk_OptionPrintProc *\fBTk_CanvasTagsPrintProc\fR; +.SH ARGUMENTS +.AS Tk_ItemType *drawableXPtr +.AP Tk_Canvas canvas in +A token that identifies a canvas widget. +.AP Tcl_Interp *interp in/out +Interpreter to use for error reporting. +.AP char *string in +Textual description of a canvas coordinate. +.AP double *doublePtr out +Points to place to store a converted coordinate. +.AP double x in +An x coordinate in the space of the canvas. +.AP double y in +A y coordinate in the space of the canvas. +.AP short *drawableXPtr out +Pointer to a location in which to store an x coordinate in the space +of the drawable currently being used to redisplay the canvas. +.AP short *drawableYPtr out +Pointer to a location in which to store a y coordinate in the space +of the drawable currently being used to redisplay the canvas. +.AP GC gc out +Graphics context to modify. +.AP short *screenXPtr out +Points to a location in which to store the screen coordinate in the +canvas window that corresponds to \fIx\fR. +.AP short *screenYPtr out +Points to a location in which to store the screen coordinate in the +canvas window that corresponds to \fIy\fR. +.AP int x1 in +Left edge of the region that needs redisplay. Only pixels at or to +the right of this coordinate need to be redisplayed. +.AP int y1 in +Top edge of the region that needs redisplay. Only pixels at or below +this coordinate need to be redisplayed. +.AP int x2 in +Right edge of the region that needs redisplay. Only pixels to +the left of this coordinate need to be redisplayed. +.AP int y2 in +Bottom edge of the region that needs redisplay. Only pixels above +this coordinate need to be redisplayed. +.BE + +.SH DESCRIPTION +.PP +These procedures are called by canvas type managers to perform various +utility functions. +.PP +\fBTk_CanvasTkwin\fR returns the Tk_Window associated with a particular +canvas. +.PP +\fBTk_CanvasGetCoord\fR translates a string specification of a +coordinate (such as \fB2p\fR or \fB1.6c\fR) into a double-precision +canvas coordinate. +If \fIstring\fR is a valid coordinate description then \fBTk_CanvasGetCoord\fR +stores the corresponding canvas coordinate at *\fIdoublePtr\fR +and returns TCL_OK. +Otherwise it stores an error message in \fIinterp->result\fR and +returns TCL_ERROR. +.PP +\fBTk_CanvasDrawableCoords\fR is called by type managers during +redisplay to compute where to draw things. +Given \fIx\fR and \fIy\fR coordinates in the space of the +canvas, \fBTk_CanvasDrawableCoords\fR computes the corresponding +pixel in the drawable that is currently being used for redisplay; +it returns those coordinates in *\fIdrawableXPtr\fR and *\fIdrawableYPtr\fR. +This procedure should not be invoked except during redisplay. +.PP +\fBTk_CanvasSetStippleOrigin\fR is also used during redisplay. +It sets the stipple origin in \fIgc\fR so that stipples drawn +with \fIgc\fR in the current offscreen pixmap will line up +with stipples drawn with origin (0,0) in the canvas's actual +window. +\fBTk_CanvasSetStippleOrigin\fR is needed in order to guarantee +that stipple patterns line up properly when the canvas is +redisplayed in small pieces. +Redisplays are carried out in double-buffered fashion where a +piece of the canvas is redrawn in an offscreen pixmap and then +copied back onto the screen. +In this approach the stipple origins in graphics contexts need to +be adjusted during each redisplay to compensate for the position +of the off-screen pixmap relative to the window. +If an item is being drawn with stipples, its type manager typically +calls \fBTk_CanvasSetStippleOrigin\fR just before using \fIgc\fR +to draw something; after it is finished drawing, the type manager +calls \fBXSetTSOrigin\fR to restore the origin in \fIgc\fR back to (0,0) +(the restore is needed because graphics contexts are shared, so +they cannot be modified permanently). +.PP +\fBTk_CanvasWindowCoords\fR is similar to \fBTk_CanvasDrawableCoords\fR +except that it returns coordinates in the canvas's window on the +screen, instead of coordinates in an off-screen pixmap. +.PP +\fBTk_CanvasEventuallyRedraw\fR may be invoked by a type manager +to inform Tk that a portion of a canvas needs to be redrawn. +The \fIx1\fR, \fIy1\fR, \fIx2\fR, and \fIy2\fR arguments +specify the region that needs to be redrawn, in canvas coordinates. +Type managers rarely need to invoke \fBTk_CanvasEventuallyRedraw\fR, +since Tk can normally figure out when an item has changed and make +the redisplay request on its behalf (this happens, for example +whenever Tk calls a \fIconfigureProc\fR or \fIscaleProc\fR). +The only time that a type manager needs to call +\fBTk_CanvasEventuallyRedraw\fR is if an item has changed on its own +without being invoked through one of the procedures in its Tk_ItemType; +this could happen, for example, in an image item if the image is +modified using image commands. +.PP +\fBTk_CanvasTagsParseProc\fR and \fBTk_CanvasTagsPrintProc\fR are +procedures that handle the \fB\-tags\fR option for canvas items. +The code of a canvas type manager won't call these procedures +directly, but will use their addresses to create a \fBTk_CustomOption\fR +structure for the \fB\-tags\fR option. The code typically looks +like this: +.CS +static Tk_CustomOption tagsOption = {Tk_CanvasTagsParseProc, + Tk_CanvasTagsPrintProc, (ClientData) NULL +}; + +static Tk_ConfigSpec configSpecs[] = { + ... + {TK_CONFIG_CUSTOM, "\-tags", (char *) NULL, (char *) NULL, + (char *) NULL, 0, TK_CONFIG_NULL_OK, &tagsOption}, + ... +}; +.CE + +.SH KEYWORDS +canvas, focus, item type, redisplay, selection, type manager diff --git a/tk4.2/doc/CanvTxtInfo.3 b/tk4.2/doc/CanvTxtInfo.3 new file mode 100644 index 0000000..47b37f7 --- /dev/null +++ b/tk4.2/doc/CanvTxtInfo.3 @@ -0,0 +1,104 @@ +'\" +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) CanvTxtInfo.3 1.8 96/03/26 18:03:51 +'\" +.so man.macros +.TH Tk_CanvasTextInfo 3 4.0 Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_CanvasTextInfo \- additional information for managing text items in canvases +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +Tk_CanvasTextInfo * +\fBTk_CanvasGetTextInfo\fR(\fIcanvas\fR) +.SH ARGUMENTS +.AS Tk_Canvas canvas +.AP Tk_Canvas canvas in +A token that identifies a particular canvas widget. +.BE + +.SH DESCRIPTION +.PP +Textual canvas items are somewhat more complicated to manage than +other items, due to things like the selection and the input focus. +\fBTk_CanvasGetTextInfo\fR may be invoked by a type manager +to obtain additional information needed for items that display text. +The return value from \fBTk_CanvasGetTextInfo\fR is a pointer to +a structure that is shared between Tk and all the items that display +text. +The structure has the following form: +.CS +typedef struct Tk_CanvasTextInfo { + Tk_3DBorder \fIselBorder\fR; + int \fIselBorderWidth\fR; + XColor *\fIselFgColorPtr\fR; + Tk_Item *\fIselItemPtr\fR; + int \fIselectFirst\fR; + int \fIselectLast\fR; + Tk_Item *\fIanchorItemPtr\fR; + int \fIselectAnchor\fR; + Tk_3DBorder \fIinsertBorder\fR; + int \fIinsertWidth\fR; + int \fIinsertBorderWidth\fR; + Tk_Item *\fIfocusItemPtr\fR; + int \fIgotFocus\fR; + int \fIcursorOn\fR; +} Tk_CanvasTextInfo; +.CE +The \fBselBorder\fR field identifies a Tk_3DBorder that should be +used for drawing the background under selected text. +\fIselBorderWidth\fR gives the width of the raised border around +selected text, in pixels. +\fIselFgColorPtr\fR points to an XColor that describes the foreground +color to be used when drawing selected text. +\fIselItemPtr\fR points to the item that is currently selected, or +NULL if there is no item selected or if the canvas doesn't have the +selection. +\fIselectFirst\fR and \fIselectLast\fR give the indices of the first +and last selected characters in \fIselItemPtr\fR, as returned by the +\fIindexProc\fR for that item. +\fIanchorItemPtr\fR points to the item that currently has the selection +anchor; this is not necessarily the same as \fIselItemPtr\fR. +\fIselectAnchor\fR is an index that identifies the anchor position +within \fIanchorItemPtr\fR. +\fIinsertBorder\fR contains a Tk_3DBorder to use when drawing the +insertion cursor; \fIinsertWidth\fR gives the total width of the +insertion cursor in pixels, and \fIinsertBorderWidth\fR gives the +width of the raised border around the insertion cursor. +\fIfocusItemPtr\fR identifies the item that currently has the input +focus, or NULL if there is no such item. +\fIgotFocus\fR is 1 if the canvas widget has the input focus and +0 otherwise. +\fIcursorOn\fR is 1 if the insertion cursor should be drawn in +\fIfocusItemPtr\fR and 0 if it should not be drawn; this field +is toggled on and off by Tk to make the cursor blink. +.PP +The structure returned by \fBTk_CanvasGetTextInfo\fR +is shared between Tk and the type managers; typically the type manager +calls \fBTk_CanvasGetTextInfo\fR once when an item is created and +then saves the pointer in the item's record. +Tk will update information in the Tk_CanvasTextInfo; for example, +a \fBconfigure\fR widget command might change the \fIselBorder\fR +field, or a \fBselect\fR widget command might change the \fIselectFirst\fR +field, or Tk might change \fIcursorOn\fR in order to make the insertion +cursor flash on and off during successive redisplays. +.PP +Type managers should treat all of the fields of the Tk_CanvasTextInfo +structure as read-only, except for \fIselItemPtr\fR, \fIselectFirst\fR, +\fIselectLast\fR, and \fIselectAnchor\fR. +Type managers may change \fIselectFirst\fR, \fIselectLast\fR, and +\fIselectAnchor\fR to adjust for insertions and deletions in the +item (but only if the item is the current owner of the selection or +anchor, as determined by \fIselItemPtr\fR or \fIanchorItemPtr\fR). +If all of the selected text in the item is deleted, the item should +set \fIselItemPtr\fR to NULL to indicate that there is no longer a +selection. + +.SH KEYWORDS +canvas, focus, insertion cursor, selection, selection anchor, text diff --git a/tk4.2/doc/Clipboard.3 b/tk4.2/doc/Clipboard.3 new file mode 100644 index 0000000..10de58f --- /dev/null +++ b/tk4.2/doc/Clipboard.3 @@ -0,0 +1,80 @@ +'\" +'\" Copyright (c) 1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) Clipboard.3 1.5 96/03/26 18:04:10 +'\" +.so man.macros +.TH Tk_ClipboardClear 3 4.0 Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_ClipboardClear, Tk_ClipboardAppend \- Manage the clipboard +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +int +\fBTk_ClipboardClear\fR(\fIinterp, tkwin\fR) +.sp +int +\fBTk_ClipboardAppend\fR(\fIinterp, tkwin, target, format, buffer\fR) +.SH ARGUMENTS +.AS Tk_ClipboardClear tkwin +.AP Tcl_Interp *interp in +Interpreter to use for reporting errors. +.AP Tk_Window tkwin in +Window that determines which display's clipboard to manipulate. +.AP Atom target in +Conversion type for this clipboard item; has same meaning as +\fItarget\fR argument to \fBTk_CreateSelHandler\fR. +.AP Atom format in +Representation to use when data is retrieved; has same meaning as +\fIformat\fR argument to \fBTk_CreateSelHandler\fR. +.AP char *buffer in +Null terminated string containing the data to be appended to the clipboard. +.BE + +.SH DESCRIPTION +.PP +These two procedures manage the clipboard for Tk. +The clipboard is typically managed by calling \fBTk_ClipboardClear\fR +once, then calling \fBTk_ClipboardAppend\fR to add data for any +number of targets. +.PP +\fBTk_ClipboardClear\fR claims the CLIPBOARD selection and frees any +data items previously stored on the clipboard in this application. +It normally returns TCL_OK, but if an error occurs it returns +TCL_ERROR and leaves an error message in \fIinterp->result\fR. +\fBTk_ClipboardClear\fR must be called before a sequence of +\fBTk_ClipboardAppend\fR calls can be issued. +.PP +\fBTk_ClipboardAppend\fR appends a buffer of data to the clipboard. +The first buffer for a given \fItarget\fR determines the \fIformat\fR +for that \fItarget\fR. +Any successive appends for that \fItarget\fR must have +the same format or an error will be returned. +\fBTk_ClipboardAppend\fR returns TCL_OK if the buffer is +successfully copied onto the clipboard. If the clipboard is not +currently owned by the application, either +because \fBTk_ClipboardClear\fR has not been called or because +ownership of the clipboard has changed since the last call to +\fBTk_ClipboardClear\fR, +\fBTk_ClipboardAppend\fR returns TCL_ERROR and leaves an error message in +\fIinterp->result\fR. +.PP +In order to guarantee atomicity, no event handling should occur +between \fBTk_ClipboardClear\fR and the following +\fBTk_ClipboardAppend\fR calls (otherwise someone could retrieve +a partially completed clipboard or claim ownership away from +this application). +.PP +\fBTk_ClipboardClear\fR may invoke callbacks, including arbitrary +Tcl scripts, as a result of losing the CLIPBOARD selection, so +any calling function should take care to be reentrant at the point +\fBTk_ClipboardClear\fR is invoked. + +.SH KEYWORDS +append, clipboard, clear, format, type diff --git a/tk4.2/doc/ClrSelect.3 b/tk4.2/doc/ClrSelect.3 new file mode 100644 index 0000000..6100973 --- /dev/null +++ b/tk4.2/doc/ClrSelect.3 @@ -0,0 +1,42 @@ +'\" +'\" Copyright (c) 1992-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) ClrSelect.3 1.10 96/08/27 13:21:16 +'\" +.so man.macros +.TH Tk_ClearSelection 3 4.0 Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_ClearSelection \- Deselect a selection +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +\fBTk_ClearSelection\fR(\fItkwin, selection\fR) +.SH ARGUMENTS +.AS Tk_Window tkwin +.AP Tk_Window tkwin in +The selection will be cleared from the display containing this +window. +.AP Atom selection in +The name of selection to be cleared. +.BE + +.SH DESCRIPTION +.PP +\fBTk_ClearSelection\fR cancels the selection specified by the atom +\fIselection\fR for the display containing \fItkwin\fR. +The selection need not be in \fItkwin\fR itself or even in +\fItkwin\fR's application. +If there is a window anywhere on \fItkwin\fR's display that +owns \fIselection\fR, the window will be notified and the +selection will be cleared. +If there is no owner for \fIselection\fR on the display, then the +procedure has no effect. + +.SH KEYWORDS +clear, selection diff --git a/tk3.6/doc/ConfigWidg.3 b/tk4.2/doc/ConfigWidg.3 similarity index 94% rename from tk3.6/doc/ConfigWidg.3 rename to tk4.2/doc/ConfigWidg.3 index 833dfad..3178580 100644 --- a/tk3.6/doc/ConfigWidg.3 +++ b/tk4.2/doc/ConfigWidg.3 @@ -1,30 +1,17 @@ '\" -'\" Copyright (c) 1990-1992 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1990-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/wish/man/RCS/ConfigWidg.3,v 1.18 93/04/30 08:51:56 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) ConfigWidg.3 1.30 96/08/27 13:21:18 '\" .so man.macros -.HS Tk_ConfigureWidget tkc 3.3 +.TH Tk_ConfigureWidget 3 4.1 Tk "Tk Library Procedures" .BS .SH NAME -Tk_ConfigureWidget, Tk_Offset, Tk_ConfigureInfo, Tk_FreeOptions \- process configuration options for widgets +Tk_ConfigureWidget, Tk_Offset, Tk_ConfigureInfo, Tk_ConfigureValue, Tk_FreeOptions \- process configuration options for widgets .SH SYNOPSIS .nf \fB#include \fR @@ -38,9 +25,9 @@ int int \fBTk_ConfigureInfo(\fIinterp, tkwin, specs, widgRec, argvName, flags\fB)\fR .sp -.VS +int +.sp \fBTk_FreeOptions(\fIspecs, widgRec, display, flags\fB)\fR -.VE .SH ARGUMENTS .AS Tk_ConfigSpec *widgRec .AP Tcl_Interp *interp in @@ -107,16 +94,13 @@ fashion. In the event of an error return, some of the fields of \fIwidgRec\fR could already have been set, if configuration information for them was successfully processed before the error occurred. -.VS The other fields will be set to reasonable initial values so that \fBTk_FreeOptions\fR can be called for cleanup. -.VE .PP The \fIspecs\fR array specifies the kinds of configuration options expected by the widget. Each of its entries specifies one configuration option and has the following structure: -.DS -.ta 1c 2c 3c +.CS typedef struct { int \fItype\fR; char *\fIargvName\fR; @@ -125,12 +109,9 @@ typedef struct { char *\fIdefValue\fR; int \fIoffset\fR; int \fIspecFlags\fR; -.VS Tk_CustomOption *\fIcustomPtr\fR; -.VE } Tk_ConfigSpec; -.DE -.LP +.CE The \fItype\fR field indicates what type of configuration option this is (e.g. TK_CONFIG_COLOR for a color value, or TK_CONFIG_INT for an integer value). The \fItype\fR field indicates how to use the @@ -188,10 +169,9 @@ legal values for \fItype\fR, and the corresponding actions, are: .TP \fBTK_CONFIG_ACTIVE_CURSOR\fR The value -.VS must be an ASCII string identifying a cursor in a form suitable for passing to \fBTk_GetCursor\fR. -The value is converted to a \fBCursor\fR by calling +The value is converted to a \fBTk_Cursor\fR by calling \fBTk_GetCursor\fR and the result is stored in the target. In addition, the resulting cursor is made the active cursor for \fItkwin\fR by calling \fBXDefineCursor\fR. @@ -206,17 +186,14 @@ The value must be an ASCII string identifying an anchor point in one of the ways accepted by \fBTk_GetAnchor\fR. The string is converted to a \fBTk_Anchor\fR by calling \fBTk_GetAnchor\fR and the result is stored in the target. -.VE .TP \fBTK_CONFIG_BITMAP\fR The value must be an ASCII string identifying a bitmap in a form suitable for passing to \fBTk_GetBitmap\fR. The value is converted to a \fBPixmap\fR by calling \fBTk_GetBitmap\fR and the result is stored in the target. -.VS If TK_CONFIG_NULL_OK is specified in \fIspecFlags\fR then the value may be an empty string, in which case the target is set to \fBNone\fR. -.VE If the previous value of the target wasn't \fBNone\fR, then it is freed by passing it to \fBTk_FreeBitmap\fR. .TP @@ -234,32 +211,26 @@ The value must be an ASCII string identifying a border color in a form suitable for passing to \fBTk_Get3DBorder\fR. The value is converted to a (\fBTk_3DBorder *\fR) by calling \fBTk_Get3DBorder\fR and the result is stored in the target. -.VS If TK_CONFIG_NULL_OK is specified in \fIspecFlags\fR then the value may be an empty string, in which case the target will be set to NULL. -.VE If the previous value of the target wasn't NULL, then it is freed by passing it to \fBTk_Free3DBorder\fR. .TP \fBTK_CONFIG_CAP_STYLE\fR The value must be -.VS an ASCII string identifying a cap style in one of the ways accepted by \fBTk_GetCapStyle\fR. The string is converted to an integer value corresponding to the cap style by calling \fBTk_GetCapStyle\fR and the result is stored in the target. -.VE .TP \fBTK_CONFIG_COLOR\fR The value must be an ASCII string identifying a color in a form suitable for passing to \fBTk_GetColor\fR. The value is converted to an (\fBXColor *\fR) by calling \fBTk_GetColor\fR and the result is stored in the target. -.VS If TK_CONFIG_NULL_OK is specified in \fIspecFlags\fR then the value may be an empty string, in which case the target will be set to \fBNone\fR. -.VE If the previous value of the target wasn't NULL, then it is freed by passing it to \fBTk_FreeColor\fR. .TP @@ -268,12 +239,10 @@ This option is identical to \fBTK_CONFIG_ACTIVE_CURSOR\fR except that the new cursor is not made the active one for \fItkwin\fR. .TP \fBTK_CONFIG_CUSTOM\fR -.VS This option allows applications to define new option types. The \fIcustomPtr\fR field of the entry points to a structure defining the new option type. See the section CUSTOM OPTION TYPES below for details. -.VE .TP \fBTK_CONFIG_DOUBLE\fR The value must be an ASCII floating-point number in @@ -291,10 +260,8 @@ The value must be an ASCII string identifying a font in a form suitable for passing to \fBTk_GetFontStruct\fR. The value is converted to an (\fBXFontStruct *\fR) by calling \fBTk_GetFontStruct\fR and the result is stored in the target. -.VS If TK_CONFIG_NULL_OK is specified in \fIspecFlags\fR then the value may be an empty string, in which case the target will be set to NULL. -.VE If the previous value of the target wasn't NULL, then it is freed by passing it to \fBTk_FreeFontStruct\fR. .TP @@ -307,7 +274,6 @@ value and the integer is stored in the target. .TP \fBTK_CONFIG_JOIN_STYLE\fR The value must be -.VS an ASCII string identifying a join style in one of the ways accepted by \fBTk_GetJoinStyle\fR. The string is converted to an integer value corresponding @@ -332,7 +298,6 @@ The value must specify screen units in one of the forms acceptable to \fBTk_GetPixels\fR. The string is converted to an integer distance in pixels and the value is stored in the target. -.VE .TP \fBTK_CONFIG_RELIEF\fR The value must be an ASCII string identifying a relief in a form @@ -342,7 +307,6 @@ is stored in the target. .TP \fBTK_CONFIG_STRING\fR A copy -.VS of the value is made by allocating memory space with \fBmalloc\fR and copying the value into the dynamically-allocated space. A pointer to the new string is stored in the target. @@ -350,7 +314,6 @@ If TK_CONFIG_NULL_OK is specified in \fIspecFlags\fR then the value may be an empty string, in which case the target will be set to NULL. If the previous value of the target wasn't NULL, then it is freed by passing it to \fBfree\fR. -.VE .TP \fBTK_CONFIG_SYNONYM\fR This \fItype\fR value identifies special entries in \fIspecs\fR that @@ -367,14 +330,12 @@ a single configuration option, such as ``\-background'' and ``\-bg''. The value is translated to a \fBTk_Uid\fR (by passing it to \fBTk_GetUid\fR). The resulting value is stored in the target. -.VS If TK_CONFIG_NULL_OK is specified in \fIspecFlags\fR and the value is an empty string then the target will be set to NULL. .TP \fBTK_CONFIG_WINDOW\fR The value must be a window path name. It is translated to a \fBTk_Window\fR token and the token is stored in the target. -.VE .SH "GROUPED ENTRIES" .PP @@ -413,7 +374,6 @@ leaving others in their current state, such as when a \fBconfigure\fR widget command is being processed. .PP Second, the \fIspecFlags\fR field of an entry in \fIspecs\fR may be used -.VS to control the processing of that entry. Each \fIspecFlags\fR field may consists of an OR-ed combination of the following values: .TP @@ -459,7 +419,6 @@ entries where a value was specified in \fIargv\fR. It will be zero in all other entries. This bit provides a way for clients to determine which values actually changed in a call to \fBTk_ConfigureWidget\fR. -.VE .PP The TK_CONFIG_MONO_ONLY and TK_CONFIG_COLOR_ONLY flags are typically used to specify different default values for @@ -537,9 +496,21 @@ if \fIargvName\fR had been NULL. The \fIflags\fR argument to \fBTk_ConfigureInfo\fR is used to restrict the \fIspecs\fR entries to consider, just as for \fBTk_ConfigureWidget\fR. +.SH TK_CONFIGUREVALUE +.PP +\fBTk_ConfigureValue\fR takes arguments similar to \fBTk_ConfigureInfo\fR; +instead of returning a list of values, it just returns the current value +of the option given by \fIargvName\fR (\fIargvName\fR must not be NULL). +The value is returned in \fIinterp->result\fR and TCL_OK is +normally returned as the procedure's result. +If an error occurs in \fBTk_ConfigureValue\fR (e.g., \fIargvName\fR is +not a valid option name), TCL_ERROR is returned and an error message +is left in \fIinterp->result\fR. +This procedure is typically called to implement \fBcget\fR widget +commands. + .SH TK_FREEOPTIONS .PP -.VS The \fBTk_FreeOptions\fR procedure may be invoked during widget cleanup to release all of the resources associated with configuration options. It scans through \fIspecs\fR and for each entry corresponding to a @@ -550,16 +521,13 @@ it contains a null pointer) then no resource is freed for that entry. After freeing a resource, \fBTk_FreeOptions\fR sets the corresponding field of the widget record to null. -.VE .SH "CUSTOM OPTION TYPES" .PP -.VS Applications can extend the built-in configuration types with additional configuration types by writing procedures to parse and print options of the a type and creating a structure pointing to those procedures: -.DS -.ta 1c 2c 3c +.CS typedef struct Tk_CustomOption { Tk_OptionParseProc *\fIparseProc\fR; Tk_OptionPrintProc *\fIprintProc\fR; @@ -580,14 +548,13 @@ typedef char *Tk_OptionPrintProc( char *\fIwidgRec\fR, int \fIoffset\fR, Tcl_FreeProc **\fIfreeProcPtr\fR); -.DE -.LP +.CE The Tk_CustomOption structure contains three fields, which are pointers to the two procedures and a \fIclientData\fR value to be passed to those procedures when they are invoked. The \fIclientData\fR value typically points to a structure containing information that is needed by the procedures when they are parsing and printing options. -.LP +.PP The \fIparseProc\fR procedure is invoked by \fBTk_ConfigureWidget\fR to parse a string and store the resulting value in the widget record. @@ -611,7 +578,7 @@ form is appropriate for the option and store the value in the widget record. It should normally return TCL_OK, but if an error occurs in translating the string to a value then it should return TCL_ERROR and store an error message in \fIinterp->result\fR. -.LP +.PP The \fIprintProc\fR procedure is called by \fBTk_ConfigureInfo\fR to produce a string value describing an existing option. @@ -627,13 +594,12 @@ a procedure to call to free the string's memory; \fBTk_ConfigureInfo\fR will call this procedure when it is finished with the string. If the result string is stored in static memory then \fIprintProc\fR need not do anything with the \fIfreeProcPtr\fR argument. -.LP +.PP Once \fIparseProc\fR and \fIprintProc\fR have been defined and a Tk_CustomOption structure has been created for them, options of this new type may be manipulated with Tk_ConfigSpec entries whose \fItype\fR fields are TK_CONFIG_CUSTOM and whose \fIcustomPtr\fR fields point to the Tk_CustomOption structure. -.VE .SH EXAMPLES .PP diff --git a/tk3.6/doc/ConfigWind.3 b/tk4.2/doc/ConfigWind.3 similarity index 75% rename from tk3.6/doc/ConfigWind.3 rename to tk4.2/doc/ConfigWind.3 index 78edafc..bbfd929 100644 --- a/tk3.6/doc/ConfigWind.3 +++ b/tk4.2/doc/ConfigWind.3 @@ -1,32 +1,17 @@ '\" '\" Copyright (c) 1990-1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/wish/man/RCS/ConfigWind.3,v 1.14 93/07/07 16:27:29 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) ConfigWind.3 1.27 96/08/27 13:21:19 '\" .so man.macros -.HS Tk_ConfigureWindow tkc 3.3 +.TH Tk_ConfigureWindow 3 4.0 Tk "Tk Library Procedures" .BS .SH NAME -.na -Tk_ConfigureWindow, Tk_MoveWindow, Tk_ResizeWindow, Tk_MoveResizeWindow, Tk_SetWindowBorderWidth Tk_ChangeWindowAttributes, Tk_SetWindowBackground, Tk_SetWindowBackgroundPixmap, Tk_SetWindowBorder, Tk_SetWindowBorderPixmap, Tk_SetWindowColormap, Tk_DefineCursor, Tk_UndefineCursor \- change window configuration or attributes -.ad +Tk_ConfigureWindow, Tk_MoveWindow, Tk_ResizeWindow, Tk_MoveResizeWindow, Tk_SetWindowBorderWidth, Tk_ChangeWindowAttributes, Tk_SetWindowBackground, Tk_SetWindowBackgroundPixmap, Tk_SetWindowBorder, Tk_SetWindowBorderPixmap, Tk_SetWindowColormap, Tk_DefineCursor, Tk_UndefineCursor \- change window configuration or attributes .SH SYNOPSIS .nf \fB#include \fR @@ -51,13 +36,11 @@ Tk_ConfigureWindow, Tk_MoveWindow, Tk_ResizeWindow, Tk_MoveResizeWindow, Tk_SetW .sp \fBTk_SetWindowBorderPixmap\fR(\fItkwin, pixmap\fR) .sp -.VS \fBTk_SetWindowColormap\fR(\fItkwin, colormap\fR) .sp \fBTk_DefineCursor\fR(\fItkwin, cursor\fR) .sp \fBTk_UndefineCursor\fR(\fItkwin\fR) -.VE .SH ARGUMENTS .AS XSetWindowAttributes borderWidth .AP Tk_Window tkwin in @@ -75,11 +58,11 @@ border, if any) within tkwin's parent. .AP int y in New y-coordinate for \fItkwin\fR's top left pixel (including border, if any) within tkwin's parent. -.AP "unsigned int" width in +.AP "int" width in New width for \fItkwin\fR (interior, not including border). -.AP "unsigned int" height in +.AP "int" height in New height for \fItkwin\fR (interior, not including border). -.AP "unsigned int" borderWidth in +.AP "int" borderWidth in New width for \fItkwin\fR's border. .AP XSetWindowAttributes *attsPtr in Points to a structure containing new values for the attributes @@ -92,13 +75,11 @@ New pixmap to use for background or border of \fItkwin\fR. WARNING: cannot necessarily be deleted immediately, as for Xlib calls. See note below. .AP Colormap colormap in -.VS New colormap to use for \fItkwin\fR. -.AP Cursor cursor in +.AP Tk_Cursor cursor in New cursor to use for \fItkwin\fR. If \fBNone\fR is specified, then \fItkwin\fR will not have its own cursor; it will use the cursor of its parent. -.VE .BE .SH DESCRIPTION @@ -125,7 +106,7 @@ In the procedures \fBTk_ConfigureWindow\fR, \fBTk_MoveWindow\fR, \fBTk_SetWindowBorderWidth\fR, if \fItkwin\fR is an internal window then event handlers interested in configure events are invoked immediately, before the procedure -returns. If \fItkwin\fR isn't a top-level window +returns. If \fItkwin\fR is a top-level window then the event handlers will be invoked later, after X has seen the request and returned an event for it. .PP @@ -133,19 +114,21 @@ Applications using Tk should never call procedures like \fBXConfigureWindow\fR directly; they should always use the corresponding Tk procedures. .PP -.VS The size and location of a window should only be modified by the appropriate geometry manager for that window and never by a window itself (but see \fBTk_MoveToplevelWindow\fR for moving a top-level window). -.VE .PP -.VS -It is not allowable to use \fBTk_ConfigureWindow\fR to change the +You may not use \fBTk_ConfigureWindow\fR to change the stacking order of a window (\fIvalueMask\fR may not contain the \fBCWSibling\fR or \fBCWStackMode\fR bits). To change the stacking order, use the procedure \fBTk_RestackWindow\fR. -.VE +.PP +The procedure \fBTk_SetWindowColormap\fR will automatically add +\fItkwin\fR to the \fBTK_COLORMAP_WINDOWS\fR property of its +nearest top-level ancestor if the new colormap is different from +that of \fItkwin\fR's parent and \fItkwin\fR isn't already in +the \fBTK_COLORMAP_WINDOWS\fR property. .SH BUGS .PP @@ -159,11 +142,9 @@ created. If you wish to delete \fIpixmap\fR, then call \fBTk_MakeWindowExist\fR first to be sure that \fItkwin\fR's window exists and \fIpixmap\fR has been passed to the X server. .PP -.VS A similar problem occurs for the \fIcursor\fR argument passed to \fBTk_DefineCursor\fR. The solution is the same as for pixmaps above: call \fBTk_MakeWindowExist\fR before freeing the cursor. -.VE .SH "SEE ALSO" Tk_MoveToplevelWindow, Tk_RestackWindow diff --git a/tk3.6/doc/CoordToWin.3 b/tk4.2/doc/CoordToWin.3 similarity index 55% rename from tk3.6/doc/CoordToWin.3 rename to tk4.2/doc/CoordToWin.3 index c11cea2..8773095 100644 --- a/tk3.6/doc/CoordToWin.3 +++ b/tk4.2/doc/CoordToWin.3 @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1990-1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/wish/man/RCS/CoordToWin.3,v 1.4 93/04/01 09:41:11 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) CoordToWin.3 1.9 96/03/26 18:05:14 '\" .so man.macros -.HS Tk_CoordsToWindow tkc +.TH Tk_CoordsToWindow 3 "" Tk "Tk Library Procedures" .BS .SH NAME Tk_CoordsToWindow \- Find window containing a point @@ -45,11 +32,9 @@ Token for window that identifies application. .PP \fBTk_CoordsToWindow\fR locates the window that contains a given point. The point is specified in root coordinates with \fIrootX\fR and -.VS \fIrootY\fR (if a virtual-root window manager is in use then \fIrootX\fR and \fIrootY\fR are in the coordinate system of the virtual root window). -.VE The return value from the procedure is a token for the window that contains the given point. If the point is not in any window, or if the containing window diff --git a/tk3.6/doc/CrtErrHdlr.3 b/tk4.2/doc/CrtErrHdlr.3 similarity index 81% rename from tk3.6/doc/CrtErrHdlr.3 rename to tk4.2/doc/CrtErrHdlr.3 index 70e2f69..a28a77b 100644 --- a/tk3.6/doc/CrtErrHdlr.3 +++ b/tk4.2/doc/CrtErrHdlr.3 @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1990 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/wish/man/RCS/CrtErrHdlr.3,v 1.6 93/04/01 09:41:13 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) CrtErrHdlr.3 1.12 96/03/26 18:05:30 '\" .so man.macros -.HS Tk_CreateErrorHandler tkc +.TH Tk_CreateErrorHandler 3 "" Tk "Tk Library Procedures" .BS .SH NAME Tk_CreateErrorHandler, Tk_DeleteErrorHandler \- handle X protocol errors @@ -85,18 +72,14 @@ the \fIminor_code\fR field from the error event. The protocol request to which the error pertains must have been made when the handler was active (see below for more information). .PP -\fIProc\fP should have arguments and result that match the +\fIProc\fR should have arguments and result that match the following type: -.nf -.RS +.CS typedef int Tk_ErrorProc( -.RS -ClientData \fIclientData\fR, -XErrorEvent *\fIerrEventPtr\fR); -.RE -.RE -.fi -The \fIclientData\fP parameter to \fIproc\fR is a copy of the \fIclientData\fP + ClientData \fIclientData\fR, + XErrorEvent *\fIerrEventPtr\fR); +.CE +The \fIclientData\fR parameter to \fIproc\fR is a copy of the \fIclientData\fR argument given to \fBTcl_CreateErrorHandler\fR when the callback was created. Typically, \fIclientData\fR points to a data structure containing application-specific information that is diff --git a/tk3.6/doc/CrtGenHdlr.3 b/tk4.2/doc/CrtGenHdlr.3 similarity index 66% rename from tk3.6/doc/CrtGenHdlr.3 rename to tk4.2/doc/CrtGenHdlr.3 index 9ffa83e..df3eca5 100644 --- a/tk3.6/doc/CrtGenHdlr.3 +++ b/tk4.2/doc/CrtGenHdlr.3 @@ -1,27 +1,14 @@ '\" -'\" Copyright (c) 19922 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1992-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/wish/man/RCS/CrtGenHdlr.3,v 1.3 93/04/01 09:41:14 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) CrtGenHdlr.3 1.9 96/03/26 18:06:21 '\" .so man.macros -.HS Tk_CreateGenericHandler tkc +.TH Tk_CreateGenericHandler 3 "" Tk "Tk Library Procedures" .BS .SH NAME Tk_CreateGenericHandler, Tk_DeleteGenericHandler \- associate procedure callback with all X events @@ -57,18 +44,14 @@ through \fBTk_HandleEvent\fR (or through other Tk procedures that call \fBTk_HandleEvent\fR, such as \fBTk_DoOneEvent\fR or \fBTk_MainLoop\fR). .PP -\fIProc\fP should have arguments and result that match the +\fIProc\fR should have arguments and result that match the type \fBTk_GenericProc\fR: -.nf -.RS +.CS typedef int Tk_GenericProc( -.RS -ClientData \fIclientData\fR, -XEvent *\fIeventPtr\fR); -.RE -.RE -.fi -The \fIclientData\fP parameter to \fIproc\fR is a copy of the \fIclientData\fP + ClientData \fIclientData\fR, + XEvent *\fIeventPtr\fR); +.CE +The \fIclientData\fR parameter to \fIproc\fR is a copy of the \fIclientData\fR argument given to \fBTk_CreateGenericHandler\fR when the callback was created. Typically, \fIclientData\fR points to a data structure containing application-specific information about diff --git a/tk4.2/doc/CrtImgType.3 b/tk4.2/doc/CrtImgType.3 new file mode 100644 index 0000000..596fc92 --- /dev/null +++ b/tk4.2/doc/CrtImgType.3 @@ -0,0 +1,225 @@ +'\" +'\" Copyright (c) 1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) CrtImgType.3 1.8 96/03/26 18:06:42 +'\" +.so man.macros +.TH Tk_CreateImageType 3 4.0 Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_CreateImageType \- define new kind of image +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +\fBTk_CreateImageType\fR(\fItypePtr\fR) +.SH ARGUMENTS +.AS Tk_ImageType *typePtr +.AP Tk_ImageType *typePtr in +Structure that defines the new type of image. +.BE + +.SH DESCRIPTION +.PP +\fBTk_CreateImageType\fR is invoked to define a new kind of image. +An image type corresponds to a particular value of the \fItype\fR +argument for the \fBimage create\fR command. There may exist +any number of different image types, and new types may be defined +dynamically by calling \fBTk_CreateImageType\fR. +For example, there might be one type for 2-color bitmaps, +another for multi-color images, another for dithered images, +another for video, and so on. +.PP +The code that implements a new image type is called an +\fIimage manager\fR. +It consists of a collection of procedures plus three different +kinds of data structures. +The first data structure is a Tk_ImageType structure, which contains +the name of the image type and pointers to five procedures provided +by the image manager to deal with images of this type: +.CS +typedef struct Tk_ImageType { + char *\fIname\fR; + Tk_ImageCreateProc *\fIcreateProc\fR; + Tk_ImageGetProc *\fIgetProc\fR; + Tk_ImageDisplayProc *\fIdisplayProc\fR; + Tk_ImageFreeProc *\fIfreeProc\fR; + Tk_ImageDeleteProc *\fIdeleteProc\fR; +} Tk_ImageType; +.CE +The fields of this structure will be described in later subsections +of this entry. +.PP +The second major data structure manipulated by an image manager +is called an \fIimage master\fR; it contains overall information +about a particular image, such as the values of the configuration +options specified in an \fBimage create\fR command. +There will usually be one of these structures for each +invocation of the \fBimage create\fR command. +.PP +The third data structure related to images is an \fIimage instance\fR. +There will usually be one of these structures for each usage of an +image in a particular widget. +It is possible for a single image to appear simultaneously +in multiple widgets, or even multiple times in the same widget. +Furthermore, different instances may be on different screens +or displays. +The image instance data structure describes things that may +vary from instance to instance, such as colors and graphics +contexts for redisplay. +There is usually one instance structure for each \fB\-image\fR +option specified for a widget or canvas item. +.PP +The following subsections describe the fields of a Tk_ImageType +in more detail. + +.SH NAME +.PP +\fItypePtr->name\fR provides a name for the image type. +Once \fBTk_CreateImageType\fR returns, this name may be used +in \fBimage create\fR commands to create images of the new +type. +If there already existed an image type by this name then +the new image type replaces the old one. + +.SH CREATEPROC +\fItypePtr->createProc\fR provides the address of a procedure for +Tk to call whenever \fBimage create\fR is invoked to create +an image of the new type. +\fItypePtr->createProc\fR must match the following prototype: +.CS +typedef int Tk_ImageCreateProc( + Tcl_Interp *\fIinterp\fR, + char *\fIname\fR, + int \fIargc\fR, + char **\fIargv\fR, + Tk_ImageType *\fItypePtr\fR, + Tk_ImageMaster \fImaster\fR, + ClientData *\fImasterDataPtr\fR); +.CE +The \fIinterp\fR argument is the interpreter in which the \fBimage\fR +command was invoked, and \fIname\fR is the name for the new image, +which was either specified explicitly in the \fBimage\fR command +or generated automatically by the \fBimage\fR command. +The \fIargc\fR and \fIargv\fR arguments describe all the configuration +options for the new image (everything after the name argument to +\fBimage\fR). +The \fImaster\fR argument is a token that refers to Tk's information +about this image; the image manager must return this token to +Tk when invoking the \fBTk_ImageChanged\fR procedure. +Typically \fIcreateProc\fR will parse \fIargc\fR and \fIargv\fR +and create an image master data structure for the new image. +\fIcreateProc\fR may store an arbitrary one-word value at +*\fImasterDataPtr\fR, which will be passed back to the +image manager when other callbacks are invoked. +Typically the value is a pointer to the master data +structure for the image. +.PP +If \fIcreateProc\fR encounters an error, it should leave an error +message in \fIinterp->result\fR and return \fBTCL_ERROR\fR; otherwise +it should return \fBTCL_OK\fR. +.PP +\fIcreateProc\fR should call \fBTk_ImageChanged\fR in order to set the +size of the image and request an initial redisplay. + +.SH GETPROC +.PP +\fItypePtr->getProc\fR is invoked by Tk whenever a widget +calls \fBTk_GetImage\fR to use a particular image. +This procedure must match the following prototype: +.CS +typedef ClientData Tk_ImageGetProc( + Tk_Window \fItkwin\fR, + ClientData \fImasterData\fR); +.CE +The \fItkwin\fR argument identifies the window in which the +image will be used and \fImasterData\fR is the value +returned by \fIcreateProc\fR when the image master was created. +\fIgetProc\fR will usually create a data structure for the new +instance, including such things as the resources needed to +display the image in the given window. +\fIgetProc\fR returns a one-word token for the instance, which +is typically the address of the instance data structure. +Tk will pass this value back to the image manager when invoking +its \fIdisplayProc\fR and \fIfreeProc\fR procedures. + +.SH DISPLAYPROC +.PP +\fItypePtr->displayProc\fR is invoked by Tk whenever an image needs +to be displayed (i.e., whenever a widget calls \fBTk_RedrawImage\fR). +\fIdisplayProc\fR must match the following prototype: +.CS +typedef void Tk_ImageDisplayProc( + ClientData \fIinstanceData\fR, + Display *\fIdisplay\fR, + Drawable \fIdrawable\fR, + int \fIimageX\fR, + int \fIimageY\fR, + int \fIwidth\fR, + int \fIheight\fR, + int \fIdrawableX\fR, + int \fIdrawableY\fR); +.CE +The \fIinstanceData\fR will be the same as the value returned by +\fIgetProc\fR when the instance was created. +\fIdisplay\fR and \fIdrawable\fR indicate where to display the +image; \fIdrawable\fR may be a pixmap rather than +the window specified to \fIgetProc\fR (this is usually the case, +since most widgets double-buffer their redisplay to get smoother +visual effects). +\fIimageX\fR, \fIimageY\fR, \fIwidth\fR, and \fIheight\fR +identify the region of the image that must be redisplayed. +This region will always be within the size of the image +as specified in the most recent call to \fBTk_ImageChanged\fR. +\fIdrawableX\fR and \fIdrawableY\fR indicate where in \fIdrawable\fR +the image should be displayed; \fIdisplayProc\fR should display +the given region of the image so that point (\fIimageX\fR, \fIimageY\fR) +in the image appears at (\fIdrawableX\fR, \fIdrawableY\fR) in \fIdrawable\fR. + +.SH FREEPROC +.PP +\fItypePtr->freeProc\fR contains the address of a procedure that +Tk will invoke when an image instance is released (i.e., when +\fBTk_FreeImage\fR is invoked). +This can happen, for example, when a widget is deleted or a image item +in a canvas is deleted, or when the image displayed in a widget or +canvas item is changed. +\fIfreeProc\fR must match the following prototype: +.CS +typedef void Tk_ImageFreeProc( + ClientData \fIinstanceData\fR, + Display *\fIdisplay\fR); +.CE +The \fIinstanceData\fR will be the same as the value returned by +\fIgetProc\fR when the instance was created, and \fIdisplay\fR +is the display containing the window for the instance. +\fIfreeProc\fR should release any resources associated with the +image instance, since the instance will never be used again. + +.SH DELETEPROC +.PP +\fItypePtr->deleteProc\fR is a procedure that Tk invokes when an +image is being deleted (i.e. when the \fBimage delete\fR command +is invoked). +Before invoking \fIdeleteProc\fR Tk will invoke \fIfreeProc\fR for +each of the image's instances. +\fIdeleteProc\fR must match the following prototype: +.CS +typedef void Tk_ImageDeleteProc( + ClientData \fImasterData\fR); +.CE +The \fImasterData\fR argument will be the same as the value +stored in \fI*masterDataPtr\fR by \fIcreateProc\fR when the +image was created. +\fIdeleteProc\fR should release any resources associated with +the image. + +.SH "SEE ALSO" +Tk_ImageChanged, Tk_GetImage, Tk_FreeImage, Tk_RedrawImage, Tk_SizeOfImage + +.SH KEYWORDS +image manager, image type, instance, master diff --git a/tk4.2/doc/CrtItemType.3 b/tk4.2/doc/CrtItemType.3 new file mode 100644 index 0000000..7f26dc5 --- /dev/null +++ b/tk4.2/doc/CrtItemType.3 @@ -0,0 +1,626 @@ +'\" +'\" Copyright (c) 1994-1995 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) CrtItemType.3 1.7 96/02/16 10:30:28 +'\" +.so man.macros +.TH Tk_CreateItemType 3 4.0 Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_CreateItemType, Tk_GetItemTypes \- define new kind of canvas item +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +\fBTk_CreateItemType\fR(\fItypePtr\fR) +.sp +Tk_ItemType * +\fBTk_GetItemTypes\fR() +.SH ARGUMENTS +.AS Tk_ItemType *typePtr +.AP Tk_ItemType *typePtr in +Structure that defines the new type of canvas item. +.BE + +.SH INTRODUCTION +.PP +\fBTk_CreateItemType\fR is invoked to define a new kind of canvas item +described by the \fItypePtr\fR argument. +An item type corresponds to a particular value of the \fItype\fR +argument to the \fBcreate\fR widget command for canvases, and +the code that implements a canvas item type is called a \fItype manager\fR. +Tk defines several built-in item types, such as \fBrectangle\fR +and \fBtext\fR and \fBimage\fR, but \fBTk_CreateItemType\fR +allows additional item types to be defined. +Once \fBTk_CreateItemType\fR returns, the new item type may be used +in new or existing canvas widgets just like the built-in item +types. +.PP +\fBTk_GetItemTypes\fR returns a pointer to the first in the list +of all item types currently defined for canvases. +The entries in the list are linked together through their +\fInextPtr\fR fields, with the end of the list marked by a +NULL \fInextPtr\fR. +.PP +You may find it easier to understand the rest of this manual entry +by looking at the code for an existing canvas item type such as +bitmap (file tkCanvBmap.c) or text (tkCanvText.c). +The easiest way to create a new type manager is to copy the code +for an existing type and modify it for the new type. +.PP +Tk provides a number of utility procedures for the use of canvas +type managers, such as \fBTk_CanvasCoords\fR and \fBTk_CanvasPsColor\fR; +these are described in separate manual entries. + +.SH "DATA STRUCTURES" +.PP +A type manager consists of a collection of procedures that provide a +standard set of operations on items of that type. +The type manager deals with three kinds of data +structures. +The first data structure is a Tk_ItemType; it contains +information such as the name of the type and pointers to +the standard procedures implemented by the type manager: +.CS +typedef struct Tk_ItemType { + char *\fIname\fR; + int \fIitemSize\fR; + Tk_ItemCreateProc *\fIcreateProc\fR; + Tk_ConfigSpec *\fIconfigSpecs\fR; + Tk_ItemConfigureProc *\fIconfigProc\fR; + Tk_ItemCoordProc *\fIcoordProc\fR; + Tk_ItemDeleteProc *\fIdeleteProc\fR; + Tk_ItemDisplayProc *\fIdisplayProc\fR; + int \fIalwaysRedraw\fR; + Tk_ItemPointProc *\fIpointProc\fR; + Tk_ItemAreaProc *\fIareaProc\fR; + Tk_ItemPostscriptProc *\fIpostscriptProc\fR; + Tk_ItemScaleProc *\fIscaleProc\fR; + Tk_ItemTranslateProc *\fItranslateProc\fR; + Tk_ItemIndexProc *\fIindexProc\fR; + Tk_ItemCursorProc *\fIicursorProc\fR; + Tk_ItemSelectionProc *\fIselectionProc\fR; + Tk_ItemInsertProc *\fIinsertProc\fR; + Tk_ItemDCharsProc *\fIdCharsProc\fR; + Tk_ItemType *\fInextPtr\fR; +} Tk_ItemType; +.CE +.PP +The fields of a Tk_ItemType structure are described in more detail +later in this manual entry. +When \fBTk_CreateItemType\fR is called, its \fItypePtr\fR +argument must point to a structure with all of the fields initialized +except \fInextPtr\fR, which Tk sets to link all the types together +into a list. +The structure must be in permanent memory (either statically +allocated or dynamically allocated but never freed); Tk retains +a pointer to this structure. +.PP +The second data structure manipulated by a type manager is an +\fIitem record\fR. +For each item in a canvas there exists one item record. +All of the items of a given type generally have item records with +the same structure, but different types usually have different +formats for their item records. +The first part of each item record is a header with a standard structure +defined by Tk via the type Tk_Item; the rest of the item +record is defined by the type manager. +A type manager must define its item records with a Tk_Item as +the first field. +For example, the item record for bitmap items is defined as follows: +.CS +typedef struct BitmapItem { + Tk_Item \fIheader\fR; + double \fIx\fR, \fIy\fR; + Tk_Anchor \fIanchor\fR; + Pixmap \fIbitmap\fR; + XColor *\fIfgColor\fR; + XColor *\fIbgColor\fR; + GC \fIgc\fR; +} BitmapItem; +.CE +The \fIheader\fR substructure contains information used by Tk +to manage the item, such as its identifier, its tags, its type, +and its bounding box. +The fields starting with \fIx\fR belong to the type manager: +Tk will never read or write them. +The type manager should not need to read or write any of the +fields in the header except for four fields +whose names are \fIx1\fR, \fIy1\fR, \fIx2\fR, and \fIy2\fR. +These fields give a bounding box for the items using integer +canvas coordinates: the item should not cover any pixels +with x-coordinate lower than \fIx1\fR or y-coordinate +lower than \fIy1\fR, nor should it cover any pixels with +x-coordinate greater than or equal to \fIx2\fR or y-coordinate +greater than or equal to \fIy2\fR. +It is up to the type manager to keep the bounding box up to +date as the item is moved and reconfigured. +.PP +Whenever Tk calls a procedure in a type manager it passes in a pointer +to an item record. +The argument is always passed as a pointer to a Tk_Item; the type +manager will typically cast this into a pointer to its own specific +type, such as BitmapItem. +.PP +The third data structure used by type managers has type +Tk_Canvas; it serves as an opaque handle for the canvas widget +as a whole. +Type managers need not know anything about the contents of this +structure. +A Tk_Canvas handle is typically passed in to the +procedures of a type manager, and the type manager can pass the +handle back to library procedures such as Tk_CanvasTkwin +to fetch information about the canvas. + +.SH NAME +.PP +This section and the ones that follow describe each of the fields +in a Tk_ItemType structure in detail. +The \fIname\fR field provides a string name for the item type. +Once \fBTk_CreateImageType\fR returns, this name may be used +in \fBcreate\fR widget commands to create items of the new +type. +If there already existed an item type by this name then +the new item type replaces the old one. + +.SH ITEMSIZE +\fItypePtr->itemSize\fR gives the size in bytes of item records +of this type, including the Tk_Item header. +Tk uses this size to allocate memory space for items of the type. +All of the item records for a given type must have the same size. +If variable length fields are needed for an item (such as a list +of points for a polygon), the type manager can allocate a separate +object of variable length and keep a pointer to it in the item record. + +.SH CREATEPROC +.PP +\fItypePtr->createProc\fR points to a procedure for +Tk to call whenever a new item of this type is created. +\fItypePtr->createProc\fR must match the following prototype: +.CS +typedef int Tk_ItemCreateProc( + Tcl_Interp *\fIinterp\fR, + Tk_Canvas \fIcanvas\fR, + Tk_Item *\fIitemPtr\fR, + int \fIargc\fR, + char **\fIargv\fR); +.CE +The \fIinterp\fR argument is the interpreter in which the canvas's +\fBcreate\fR widget command was invoked, and \fIcanvas\fR is a +handle for the canvas widget. +\fIitemPtr\fR is a pointer to a newly-allocated item of +size \fItypePtr->itemSize\fR. +Tk has already initialized the item's header (the first +\fBsizeof(Tk_ItemType)\fR bytes). +The \fIargc\fR and \fIargv\fR arguments describe all of the +arguments to the \fBcreate\fR command after the \fItype\fR +argument. +For example, in the widget command +.CS +\fB\&.c create rectangle 10 20 50 50 \-fill black\fR +.CE +\fIargc\fR will be \fB6\fR and \fIargv\fR[0] will contain the +string \fB10\fR. +.PP +\fIcreateProc\fR should use \fIargc\fR and \fIargv\fR to initialize +the type-specific parts of the item record and set an initial value +for the bounding box in the item's header. +It should return a standard Tcl completion code and leave an +error message in \fIinterp->result\fR if an error occurs. +If an error occurs Tk will free the item record, so \fIcreateProc\fR +must be sure to leave the item record in a clean state if it returns an error +(e.g., it must free any additional memory that it allocated for +the item). + +.SH CONFIGSPECS +.PP +Each type manager must provide a standard table describing its +configuration options, in a form suitable for use with +\fBTk_ConfigureWidget\fR. +This table will normally be used by \fItypePtr->createProc\fR +and \fItypePtr->configProc\fR, but Tk also uses it directly +to retrieve option information in the \fBitemcget\fR and +\fBitemconfigure\fR widget commands. +\fItypePtr->configSpecs\fR must point to the configuration table +for this type. +Note: Tk provides a custom option type \fBtk_CanvasTagsOption\fR +for implementing the \fB\-tags\fR option; see an existing type +manager for an example of how to use it in \fIconfigSpecs\fR. + +.SH CONFIGPROC +.PP +\fItypePtr->configProc\fR is called by Tk whenever the +\fBitemconfigure\fR widget command is invoked to change the +configuration options for a canvas item. +This procedure must match the following prototype: +.CS +typedef int Tk_ItemConfigureProc( + Tcl_Interp *\fIinterp\fR, + Tk_Canvas \fIcanvas\fR, + Tk_Item *\fIitemPtr\fR, + int \fIargc\fR, + char **\fIargv\fR, + int \fIflags\fR); +.CE +The \fIinterp\fR argument identifies the interpreter in which the +widget command was invoked, \fIcanvas\fR is a handle for the canvas +widget, and \fIitemPtr\fR is a pointer to the item being configured. +\fIargc\fR and \fIargv\fR contain the configuration options. For +example, if the following command is invoked: +.CS +\fB\&.c itemconfigure 2 \-fill red \-outline black\fR +.CE +\fIargc\fR is \fB4\fR and \fIargv\fR contains the strings \fB\-fill\fR +through \fBblack\fR. +\fIargc\fR will always be an even value. +The \fIflags\fR argument contains flags to pass to \fBTk_ConfigureWidget\fR; +currently this value is always TK_CONFIG_ARGV_ONLY when Tk +invokes \fItypePtr->configProc\fR, but the type manager's \fIcreateProc\fR +procedure will usually invoke \fIconfigProc\fR with different flag values. +.PP +\fItypePtr->configProc\fR returns a standard Tcl completion code and +leaves an error message in \fIinterp->result\fR if an error occurs. +It must update the item's bounding box to reflect the new configuration +options. + +.SH COORDPROC +.PP +\fItypePtr->coordProc\fR is invoked by Tk to implement the \fBcoords\fR +widget command for an item. +It must match the following prototype: +.CS +typedef int Tk_ItemCoordProc( + Tcl_Interp *\fIinterp\fR, + Tk_Canvas \fIcanvas\fR, + Tk_Item *\fIitemPtr\fR, + int \fIargc\fR, + char **\fIargv\fR); +.CE +The arguments \fIinterp\fR, \fIcanvas\fR, and \fIitemPtr\fR +all have the standard meanings, and \fIargc\fR and \fIargv\fR +describe the coordinate arguments. +For example, if the following widget command is invoked: +.CS +\fB\&.c coords 2 30 90\fR +.CE +\fIargc\fR will be \fB2\fR and \fBargv\fR will contain the string values +\fB30\fR and \fB90\fR. +.PP +The \fIcoordProc\fR procedure should process the new coordinates, +update the item appropriately (e.g., it must reset the bounding +box in the item's header), and return a standard Tcl completion +code. +If an error occurs, \fIcoordProc\fR must leave an error message in +\fIinterp->result\fR. + +.SH DELETEPROC +.PP +\fItypePtr->deleteProc\fR is invoked by Tk to delete an item +and free any resources allocated to it. +It must match the following prototype: +.CS +typedef void Tk_ItemDeleteProc( + Tk_Canvas \fIcanvas\fR, + Tk_Item *\fIitemPtr\fR, + Display *\fIdisplay\fR); +.CE +The \fIcanvas\fR and \fIitemPtr\fR arguments have the usual +interpretations, and \fIdisplay\fR identifies the X display containing +the canvas. +\fIdeleteProc\fR must free up any resources allocated for the item, +so that Tk can free the item record. +\fIdeleteProc\fR should not actually free the item record; this will +be done by Tk when \fIdeleteProc\fR returns. + +.SH "DISPLAYPROC AND ALWAYSREDRAW" +.PP +\fItypePtr->displayProc\fR is invoked by Tk to redraw an item +on the screen. +It must match the following prototype: +.CS +typedef void Tk_ItemDisplayProc( + Tk_Canvas \fIcanvas\fR, + Tk_Item *\fIitemPtr\fR, + Display *\fIdisplay\fR, + Drawable \fIdst\fR, + int \fIx\fR, + int \fIy\fR, + int \fIwidth\fR, + int \fIheight\fR); +.CE +The \fIcanvas\fR and \fIitemPtr\fR arguments have the usual meaning. +\fIdisplay\fR identifies the display containing the canvas, and +\fIdst\fR specifies a drawable in which the item should be rendered; +typically this is an off-screen pixmap, which Tk will copy into +the canvas's window once all relevant items have been drawn. +\fIx\fR, \fIy\fR, \fIwidth\fR, and \fIheight\fR specify a rectangular +region in canvas coordinates, which is the area to be redrawn; +only information that overlaps this area needs to be redrawn. +Tk will not call \fIdisplayProc\fR unless the item's bounding box +overlaps the redraw area, but the type manager may wish to use +the redraw area to optimize the redisplay of the item. +.PP +Because of scrolling and the use of off-screen pixmaps for +double-buffered redisplay, the item's coordinates in \fIdst\fR +will not necessarily be the same as those in the canvas. +\fIdisplayProc\fR should call \fBTk_CanvasDrawableCoords\fR +to transform coordinates from those of the canvas to those +of \fIdst\fR. +.PP +Normally an item's \fIdisplayProc\fR is only invoked if the item +overlaps the area being displayed. +However, if \fItypePtr->alwaysRedraw\fR has a non-zero value, then +\fIdisplayProc\fR is invoked during every redisplay operation, +even if the item doesn't overlap the area of redisplay. +\fIalwaysRedraw\fR should normally be set to 0; it is only +set to 1 in special cases such as window items that need to be +unmapped when they are off-screen. + +.SH POINTPROC +.PP +\fItypePtr->pointProc\fR is invoked by Tk to find out how close +a given point is to a canvas item. +Tk uses this procedure for purposes such as locating the item +under the mouse or finding the closest item to a given point. +The procedure must match the following prototype: +.CS +typedef double Tk_ItemPointProc( + Tk_Canvas \fIcanvas\fR, + Tk_Item *\fIitemPtr\fR, + double *\fIpointPtr\fR); +.CE +\fIcanvas\fR and \fIitemPtr\fR have the usual meaning. +\fIpointPtr\fR points to an array of two numbers giving +the x and y coordinates of a point. +\fIpointProc\fR must return a real value giving the distance +from the point to the item, or 0 if the point lies inside +the item. + +.SH AREAPROC +.PP +\fItypePtr->areaProc\fR is invoked by Tk to find out the relationship +between an item and a rectangular area. +It must match the following prototype: +.CS +typedef int Tk_ItemAreaProc( + Tk_Canvas \fIcanvas\fR, + Tk_Item *\fIitemPtr\fR, + double *\fIrectPtr\fR); +.CE +\fIcanvas\fR and \fIitemPtr\fR have the usual meaning. +\fIrectPtr\fR points to an array of four real numbers; +the first two give the x and y coordinates of the upper left +corner of a rectangle, and the second two give the x and y +coordinates of the lower right corner. +\fIareaProc\fR must return \-1 if the item lies entirely outside +the given area, 0 if it lies partially inside and partially +outside the area, and 1 if it lies entirely inside the area. + +.SH POSTSCRIPTPROC +.PP +\fItypePtr->postscriptProc\fR is invoked by Tk to generate +Postcript for an item during the \fBpostscript\fR widget command. +If the type manager is not capable of generating Postscript then +\fItypePtr->postscriptProc\fR should be NULL. +The procedure must match the following prototype: +.CS +typedef int Tk_ItemPostscriptProc( + Tcl_Interp *\fIinterp\fR, + Tk_Canvas \fIcanvas\fR, + Tk_Item *\fIitemPtr\fR, + int \fIprepass\fR); +.CE +The \fIinterp\fR, \fIcanvas\fR, and \fIitemPtr\fR arguments all have +standard meanings; \fIprepass\fR will be described below. +If \fIpostscriptProc\fR completes successfully, it should append +Postscript for the item to the information in \fIinterp->result\fR +(e.g. by calling \fBTcl_AppendResult\fR, not \fBTcl_SetResult\fR) +and return TCL_OK. +If an error occurs, \fIpostscriptProc\fR should clear the result +and replace its contents with an error message; then it should +return TCL_ERROR. +.PP +Tk provides a collection of utility procedures to simplify +\fIpostscriptProc\fR. +For example, \fBTk_CanvasPsColor\fR will generate Postscript to set +the current color to a given Tk color and \fBTk_CanvasPsFont\fR will +set up font information. +When generating Postscript, the type manager is free to change the +graphics state of the Postscript interpreter, since Tk places +\fBgsave\fR and \fBgrestore\fR commands around the Postscript for +the item. +The type manager can use canvas x coordinates directly in its Postscript, +but it must call \fBTk_CanvasPsY\fR to convert y coordinates from +the space of the canvas (where the origin is at the +upper left) to the space of Postscript (where the origin is at the +lower left). +.PP +In order to generate Postscript that complies with the Adobe Document +Structuring Conventions, Tk actually generates Postscript in two passes. +It calls each item's \fIpostscriptProc\fR in each pass. +The only purpose of the first pass is to collect font information +(which is done by \fBTk_CanvPsFont\fR); the actual Postscript is +discarded. +Tk sets the \fIprepass\fR argument to \fIpostscriptProc\fR to 1 +during the first pass; the type manager can use \fIprepass\fR to skip +all Postscript generation except for calls to \fBTk_CanvasPsFont\fR. +During the second pass \fIprepass\fR will be 0, so the type manager +must generate complete Postscript. + +.SH SCALEPROC +\fItypePtr->scaleProc\fR is invoked by Tk to rescale a canvas item +during the \fBscale\fR widget command. +The procedure must match the following prototype: +.CS +typedef void Tk_ItemScaleProc( + Tk_Canvas \fIcanvas\fR, + Tk_Item *\fIitemPtr\fR, + double \fIoriginX\fR, + double \fIoriginY\fR, + double \fIscaleX\fR, + double \fIscaleY\fR); +.CE +The \fIcanvas\fR and \fIitemPtr\fR arguments have the usual meaning. +\fIoriginX\fR and \fIoriginY\fR specify an origin relative to which +the item is to be scaled, and \fIscaleX\fR and \fIscaleY\fR give the +x and y scale factors. +The item should adjust its coordinates so that a point in the item +that used to have coordinates \fIx\fR and \fIy\fR will have new +coordinates \fIx'\fR and \fIy'\fR, where +.CS +\fIx' = originX + scaleX*(x-originX) +y' = originY + scaleY*(y-originY)\fR +.CE +\fIscaleProc\fR must also update the bounding box in the item's +header. + +.SH TRANSLATEPROC +\fItypePtr->translateProc\fR is invoked by Tk to translate a canvas item +during the \fBmove\fR widget command. +The procedure must match the following prototype: +.CS +typedef void Tk_ItemTranslateProc( + Tk_Canvas \fIcanvas\fR, + Tk_Item *\fIitemPtr\fR, + double \fIdeltaX\fR, + double \fIdeltaY\fR); +.CE +The \fIcanvas\fR and \fIitemPtr\fR arguments have the usual meaning, +and \fIdeltaX\fR and \fIdeltaY\fR give the amounts that should be +added to each x and y coordinate within the item. +The type manager should adjust the item's coordinates and +update the bounding box in the item's header. + +.SH INDEXPROC +\fItypePtr->indexProc\fR is invoked by Tk to translate a string +index specification into a numerical index, for example during the +\fBindex\fR widget command. +It is only relevant for item types that support indexable text; +\fItypePtr->indexProc\fR may be specified as NULL for non-textual +item types. +The procedure must match the following prototype: +.CS +typedef int Tk_ItemIndexProc( + Tcl_Interp *\fIinterp\fR, + Tk_Canvas \fIcanvas\fR, + Tk_Item *\fIitemPtr\fR, + char \fIindexString\fR, + int *\fIindexPtr\fR); +.CE +The \fIinterp\fR, \fIcanvas\fR, and \fIitemPtr\fR arguments all +have the usual meaning. +\fIindexString\fR contains a textual description of an index, +and \fIindexPtr\fR points to an integer value that should be +filled in with a numerical index. +It is up to the type manager to decide what forms of index +are supported (e.g., numbers, \fBinsert\fR, \fBsel.first\fR, +\fBend\fR, etc.). +\fIindexProc\fR should return a Tcl completion code and set +\fIinterp->result\fR in the event of an error. + +.SH ICURSORPROC +.PP +\fItypePtr->icursorProc\fR is invoked by Tk during +the \fBicursor\fR widget command to set the position of the +insertion cursor in a textual item. +It is only relevant for item types that support an insertion cursor; +\fItypePtr->icursorProc\fR may be specified as NULL for item types +that don't support an insertion cursor. +The procedure must match the following prototype: +.CS +typedef void Tk_ItemIndexProc( + Tk_Canvas \fIcanvas\fR, + Tk_Item *\fIitemPtr\fR, + int \fIindex\fR); +.CE +\fIcanvas\fR and \fIitemPtr\fR have the usual meanings, and +\fIindex\fR is an index into the item's text, as returned by a +previous call to \fItypePtr->insertProc\fR. +The type manager should position the insertion cursor in the +item just before the character given by \fIindex\fR. +Whether or not to actually display the insertion cursor is +determined by other information provided by \fBTk_CanvasGetTextInfo\fR. + +.SH SELECTIONPROC +.PP +\fItypePtr->selectionProc\fR is invoked by Tk during selection +retrievals; it must return part or all of the selected text in +the item (if any). +It is only relevant for item types that support text; +\fItypePtr->selectionProc\fR may be specified as NULL for non-textual +item types. +The procedure must match the following prototype: +.CS +typedef int Tk_ItemSelectionProc( + Tk_Canvas \fIcanvas\fR, + Tk_Item *\fIitemPtr\fR, + int \fIoffset\fR, + char *\fIbuffer\fR, + int \fImaxBytes\fR); +.CE +\fIcanvas\fR and \fIitemPtr\fR have the usual meanings. +\fIoffset\fR is an offset in bytes into the selection where 0 refers +to the first byte of the selection; it identifies +the first character that is to be returned in this call. +\fIbuffer\fR points to an area of memory in which to store the +requested bytes, and \fImaxBytes\fR specifies the maximum number +of bytes to return. +\fIselectionProc\fR should extract up to \fImaxBytes\fR characters +from the selection and copy them to \fImaxBytes\fR; it should +return a count of the number of bytes actually copied, which may +be less than \fImaxBytes\fR if there aren't \fIoffset+maxBytes\fR bytes +in the selection. + +.SH INSERTPROC +.PP +\fItypePtr->insertProc\fR is invoked by Tk during +the \fBinsert\fR widget command to insert new text into a +canvas item. +It is only relevant for item types that support text; +\fItypePtr->insertProc\fR may be specified as NULL for non-textual +item types. +The procedure must match the following prototype: +.CS +typedef void Tk_ItemInsertProc( + Tk_Canvas \fIcanvas\fR, + Tk_Item *\fIitemPtr\fR, + int \fIindex\fR, + char *\fIstring\fR); +.CE +\fIcanvas\fR and \fIitemPtr\fR have the usual meanings. +\fIindex\fR is an index into the item's text, as returned by a +previous call to \fItypePtr->insertProc\fR, and \fIstring\fR +contains new text to insert just before the character given +by \fIindex\fR. +The type manager should insert the text and recompute the bounding +box in the item's header. + +.SH DCHARSPROC +.PP +\fItypePtr->dCharsProc\fR is invoked by Tk during the \fBdchars\fR +widget command to delete a range of text from a canvas item. +It is only relevant for item types that support text; +\fItypePtr->dCharsProc\fR may be specified as NULL for non-textual +item types. +The procedure must match the following prototype: +.CS +typedef void Tk_ItemDCharsProc( + Tk_Canvas \fIcanvas\fR, + Tk_Item *\fIitemPtr\fR, + int \fIfirst\fR, + int \fIlast\fR); +.CE +\fIcanvas\fR and \fIitemPtr\fR have the usual meanings. +\fIfirst\fR and \fIlast\fR give the indices of the first and last bytes +to be deleted, as returned by previous calls to \fItypePtr->indexProc\fR. +The type manager should delete the specified characters and update +the bounding box in the item's header. + +.SH "SEE ALSO" +Tk_CanvasPsY, Tk_CanvasTextInfo, Tk_CanvasTkwin + +.SH KEYWORDS +canvas, focus, item type, selection, type manager diff --git a/tk4.2/doc/CrtPhImgFmt.3 b/tk4.2/doc/CrtPhImgFmt.3 new file mode 100644 index 0000000..93d517b --- /dev/null +++ b/tk4.2/doc/CrtPhImgFmt.3 @@ -0,0 +1,235 @@ +'\" +'\" Copyright (c) 1994 The Australian National University +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" Author: Paul Mackerras (paulus@cs.anu.edu.au), +'\" Department of Computer Science, +'\" Australian National University. +'\" +'\" SCCS: @(#) CrtPhImgFmt.3 1.8 96/03/18 14:25:30 +'\" +.so man.macros +.TH Tk_CreatePhotoImageFormat 3 4.0 Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_CreatePhotoImageFormat \- define new file format for photo images +.SH SYNOPSIS +.nf +\fB#include \fR +\fB#include \fR +.sp +\fBTk_CreatePhotoImageFormat\fR(\fIformatPtr\fR) +.SH ARGUMENTS +.AS Tk_PhotoImageFormat *formatPtr +.AP Tk_PhotoImageFormat *formatPtr in +Structure that defines the new file format. +.BE + +.SH DESCRIPTION +.PP +\fBTk_CreatePhotoImageFormat\fR is invoked to define a new file format +for image data for use with photo images. The code that implements an +image file format is called an image file format handler, or +handler for short. The photo image code +maintains a list of handlers that can be used to read and +write data to or from a file. Some handlers may also +support reading image data from a string or converting image data to a +string format. +The user can specify which handler to use with the \fB\-format\fR +image configuration option or the \fB\-format\fR option to the +\fBread\fR and \fBwrite\fR photo image subcommands. +.PP +An image file format handler consists of a collection of procedures +plus a Tk_PhotoImageFormat structure, which contains the name of the +image file format and pointers to six procedures provided by the +handler to deal with files and strings in this format. The +Tk_PhotoImageFormat structure contains the following fields: +.CS +typedef struct Tk_PhotoImageFormat { + char *\fIname\fR; + Tk_ImageFileMatchProc *\fIfileMatchProc\fR; + Tk_ImageStringMatchProc *\fIstringMatchProc\fR; + Tk_ImageFileReadProc *\fIfileReadProc\fR; + Tk_ImageStringReadProc *\fIstringReadProc\fR; + Tk_ImageFileWriteProc *\fIfileWriteProc\fR; + Tk_ImageStringWriteProc *\fIstringWriteProc\fR; +} Tk_PhotoImageFormat; +.CE +.PP +The handler need not provide implementations of all six procedures. +For example, the procedures that handle string data would not be +provided for a format in which the image data are stored in binary, +and could therefore contain null characters. If any procedure is not +implemented, the corresponding pointer in the Tk_PhotoImageFormat +structure should be set to NULL. The handler must provide the +\fIfileMatchProc\fR procedure if it provides the \fIfileReadProc\fR +procedure, and the \fIstringMatchProc\fR procedure if it provides the +\fIstringReadProc\fR procedure. + +.SH NAME +.PP +\fIformatPtr->name\fR provides a name for the image type. +Once \fBTk_CreatePhotoImageFormat\fR returns, this name may be used +in the \fB\-format\fR photo image configuration and subcommand option. +The manual page for the photo image (photo(n)) describes how image +file formats are chosen based on their names and the value given to +the \fB\-format\fR option. + +.SH FILEMATCHPROC +\fIformatPtr->fileMatchProc\fR provides the address of a procedure for +Tk to call when it is searching for an image file format handler +suitable for reading data in a given file. +\fIformatPtr->fileMatchProc\fR must match the following prototype: +.CS +typedef int Tk_ImageFileMatchProc( + FILE *\fIf\fR, + char *\fIfileName\fR, + char *\fIformatString\fR, + int *\fIwidthPtr\fR, + int *\fIheightPtr\fR); +.CE +The \fIfileName\fR argument is the name of the file containing the +image data, which is open for reading as \fIf\fR. The +\fIformatString\fR argument contains the value given for the +\fB\-format\fR option, or NULL if the option was not specified. +If the data in the file appears to be in the format supported by this +handler, the \fIformatPtr->fileMatchProc\fR procedure should store the +width and height of the image in *\fIwidthPtr\fR and *\fIheightPtr\fR +respectively, and return 1. Otherwise it should return 0. + +.SH STRINGMATCHPROC +\fIformatPtr->stringMatchProc\fR provides the address of a procedure for +Tk to call when it is searching for an image file format handler for +suitable for reading data from a given string. +\fIformatPtr->stringMatchProc\fR must match the following prototype: +.CS +typedef int Tk_ImageStringMatchProc( + char *\fIstring\fR, + char *\fIformatString\fR, + int *\fIwidthPtr\fR, + int *\fIheightPtr\fR); +.CE +The \fIstring\fR argument points to the string containing the image +data. The \fIformatString\fR argument contains the value given for +the \fB\-format\fR option, or NULL if the option was not specified. +If the data in the string appears to be in the format supported by +this handler, the \fIformatPtr->stringMatchProc\fR procedure should +store the width and height of the image in *\fIwidthPtr\fR and +*\fIheightPtr\fR respectively, and return 1. Otherwise it should +return 0. + +.SH FILEREADPROC +\fIformatPtr->fileReadProc\fR provides the address of a procedure for +Tk to call to read data from an image file into a photo image. +\fIformatPtr->fileReadProc\fR must match the following prototype: +.CS +typedef int Tk_ImageFileReadProc( + Tcl_Interp *\fIinterp\fR, + FILE *\fIf\fR, + char *\fIfileName\fR, + char *\fIformatString\fR, + PhotoHandle \fIimageHandle\fR, + int \fIdestX, int \fIdestY\fR, + int \fIwidth, int \fIheight\fR, + int \fIsrcX, int \fIsrcY\fR); +.CE +The \fIinterp\fR argument is the interpreter in which the command was +invoked to read the image; it should be used for reporting errors. +The image data is in the file named \fIfileName\fR, which is open for +reading as \fIf\fR. The \fIformatString\fR argument contains the +value given for the \fB\-format\fR option, or NULL if the option was +not specified. The image data in the file, or a subimage of it, is to +be read into the photo image identified by the handle +\fIimageHandle\fR. The subimage of the data in the file is of +dimensions \fIwidth\fR x \fIheight\fR and has its top-left corner at +coordinates (\fIsrcX\fR,\fIsrcY\fR). It is to be stored in the photo +image with its top-left corner at coordinates +(\fIdestX\fR,\fIdestY\fR) using the \fBTk_PhotoPutBlock\fR procedure. +The return value is a standard Tcl return value. + +.SH STRINGREADPROC +\fIformatPtr->stringReadProc\fR provides the address of a procedure for +Tk to call to read data from a string into a photo image. +\fIformatPtr->stringReadProc\fR must match the following prototype: +.CS +typedef int Tk_ImageStringReadProc( + Tcl_Interp *\fIinterp\fR, + char *\fIstring\fR, + char *\fIformatString\fR, + PhotoHandle \fIimageHandle\fR, + int \fIdestX, int \fIdestY\fR, + int \fIwidth, int \fIheight\fR, + int \fIsrcX, int \fIsrcY\fR); +.CE +The \fIinterp\fR argument is the interpreter in which the command was +invoked to read the image; it should be used for reporting errors. +The \fIstring\fR argument points to the image data in string form. +The \fIformatString\fR argument contains the +value given for the \fB\-format\fR option, or NULL if the option was +not specified. The image data in the string, or a subimage of it, is to +be read into the photo image identified by the handle +\fIimageHandle\fR. The subimage of the data in the string is of +dimensions \fIwidth\fR x \fIheight\fR and has its top-left corner at +coordinates (\fIsrcX\fR,\fIsrcY\fR). It is to be stored in the photo +image with its top-left corner at coordinates +(\fIdestX\fR,\fIdestY\fR) using the \fBTk_PhotoPutBlock\fR procedure. +The return value is a standard Tcl return value. + +.SH FILEWRITEPROC +\fIformatPtr->fileWriteProc\fR provides the address of a procedure for +Tk to call to write data from a photo image to a file. +\fIformatPtr->fileWriteProc\fR must match the following prototype: +.CS +typedef int Tk_ImageFileWriteProc( + Tcl_Interp *\fIinterp\fR, + char *\fIfileName\fR, + char *\fIformatString\fR, + Tk_PhotoImageBlock *\fIblockPtr\fR); +.CE +The \fIinterp\fR argument is the interpreter in which the command was +invoked to write the image; it should be used for reporting errors. +The image data to be written are in memory and are described by the +Tk_PhotoImageBlock structure pointed to by \fIblockPtr\fR; see the +manual page FindPhoto(3) for details. The \fIfileName\fR argument +points to the string giving the name of the file in which to write the +image data. The \fIformatString\fR argument contains the +value given for the \fB\-format\fR option, or NULL if the option was +not specified. The format string can contain extra characters +after the name of the format. If appropriate, the +\fIformatPtr->fileWriteProc\fR procedure may interpret these +characters to specify further details about the image file. +The return value is a standard Tcl return value. + +.SH STRINGWRITEPROC +\fIformatPtr->stringWriteProc\fR provides the address of a procedure for +Tk to call to translate image data from a photo image into a string. +\fIformatPtr->stringWriteProc\fR must match the following prototype: +.CS +typedef int Tk_ImageStringWriteProc( + Tcl_Interp *\fIinterp\fR, + Tcl_DString *\fIdataPtr\fR, + char *\fIformatString\fR, + Tk_PhotoImageBlock *\fIblockPtr\fR); +.CE +The \fIinterp\fR argument is the interpreter in which the command was +invoked to convert the image; it should be used for reporting errors. +The image data to be converted are in memory and are described by the +Tk_PhotoImageBlock structure pointed to by \fIblockPtr\fR; see the +manual page FindPhoto(3) for details. The data for the string +should be appended to the dynamic string given by \fIdataPtr\fR. +The \fIformatString\fR argument contains the +value given for the \fB\-format\fR option, or NULL if the option was +not specified. The format string can contain extra characters +after the name of the format. If appropriate, the +\fIformatPtr->stringWriteProc\fR procedure may interpret these +characters to specify further details about the image file. +The return value is a standard Tcl return value. + +.SH "SEE ALSO" +Tk_FindPhoto, Tk_PhotoPutBlock + +.SH KEYWORDS +photo image, image file diff --git a/tk3.6/doc/CrtSelHdlr.3 b/tk4.2/doc/CrtSelHdlr.3 similarity index 66% rename from tk3.6/doc/CrtSelHdlr.3 rename to tk4.2/doc/CrtSelHdlr.3 index f790e06..96cddca 100644 --- a/tk3.6/doc/CrtSelHdlr.3 +++ b/tk4.2/doc/CrtSelHdlr.3 @@ -1,41 +1,31 @@ '\" -'\" Copyright (c) 1990-1992 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1990-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/wish/man/RCS/CrtSelHdlr.3,v 1.7 93/04/01 09:41:16 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) CrtSelHdlr.3 1.18 96/08/27 13:21:21 '\" .so man.macros -.HS Tk_CreateSelHandler tkc +.TH Tk_CreateSelHandler 3 4.0 Tk "Tk Library Procedures" .BS .SH NAME -Tk_CreateSelHandler, Tk_DeleteSelHandler \- arrange to handle requests for the primary selection +Tk_CreateSelHandler, Tk_DeleteSelHandler \- arrange to handle requests for a selection .SH SYNOPSIS .nf \fB#include \fR .sp -\fBTk_CreateSelHandler\fR(\fItkwin, target, proc, clientData, format\fR) +\fBTk_CreateSelHandler\fR(\fItkwin, selection, target, proc, clientData, format\fR) .sp -\fBTk_DeleteSelHandler\fR(\fItkwin, target\fR) +\fBTk_DeleteSelHandler\fR(\fItkwin, selection, target\fR) .SH ARGUMENTS .AS Tk_SelectionProc clientData .AP Tk_Window tkwin in Window for which \fIproc\fR will provide selection information. +.AP Atom selection in +The name of the selection for which \fIproc\fR will provide +selection information. .AP Atom target in Form in which \fIproc\fR can provide the selection (e.g. STRING or FILE_NAME). Corresponds to \fItype\fR arguments in \fBselection\fR @@ -55,9 +45,10 @@ requestor. .SH DESCRIPTION .PP \fBTk_CreateSelHandler\fR arranges for a particular procedure -(\fIproc\fR) to be called whenever the selection is owned by +(\fIproc\fR) to be called whenever \fIselection\fR is owned by \fItkwin\fR and the selection contents are requested in the -form given by \fItarget\fR. \fITarget\fR should be one of +form given by \fItarget\fR. +\fITarget\fR should be one of the entries defined in the left column of Table 2 of the X Inter-Client Communication Conventions Manual (ICCCM) or any other form in which an application is willing to present @@ -65,19 +56,15 @@ the selection. The most common form is STRING. .PP \fIProc\fR should have arguments and result that match the type \fBTk_SelectionProc\fR: -.nf -.RS +.CS typedef int Tk_SelectionProc( -.RS -ClientData \fIclientData\fR, -int \fIoffset\fR, -char *\fIbuffer\fR, -int \fImaxBytes\fR); -.RE -.RE -.fi -The \fIclientData\fP parameter to \fIproc\fR is a copy of the -\fIclientData\fP argument given to \fBTk_CreateSelHandler\fR. + ClientData \fIclientData\fR, + int \fIoffset\fR, + char *\fIbuffer\fR, + int \fImaxBytes\fR); +.CE +The \fIclientData\fR parameter to \fIproc\fR is a copy of the +\fIclientData\fR argument given to \fBTk_CreateSelHandler\fR. Typically, \fIclientData\fR points to a data structure containing application-specific information that is needed to retrieve the selection. \fIOffset\fR specifies an @@ -94,7 +81,7 @@ it), then \fIproc\fR should return -1. .PP When transferring large selections, Tk will break them up into smaller pieces (typically a few thousand bytes each) for more -efficient transmision. It will do this by calling \fIproc\fR +efficient transmission. It will do this by calling \fIproc\fR one or more times, using successively higher values of \fIoffset\fR to retrieve successive portions of the selection. If \fIproc\fR returns a count less than \fImaxBytes\fR it means that the entire @@ -122,14 +109,12 @@ the \fIformat\fR atom is returned to the selection requestor along with the contents of the selection. .PP If \fBTk_CreateSelHandler\fR is called when there already exists a -handler for \fItarget\fR on \fItkwin\fR, then the existing handler -is replaced with a new one. +handler for \fIselection\fR and \fItarget\fR on \fItkwin\fR, then the +existing handler is replaced with a new one. .PP -\fBTk_DeleteSelHandler\fR removes the handler given by \fItkwin\fR -.VS -and \fItarget\fR, if such a handler exists. If there is no such -handler then it has no effect. -.VE +\fBTk_DeleteSelHandler\fR removes the handler given by \fItkwin\fR, +\fIselection\fR, and \fItarget\fR, if such a handler exists. +If there is no such handler then it has no effect. .SH KEYWORDS format, handler, selection, target diff --git a/tk4.2/doc/DeleteImg.3 b/tk4.2/doc/DeleteImg.3 new file mode 100644 index 0000000..88b2d23 --- /dev/null +++ b/tk4.2/doc/DeleteImg.3 @@ -0,0 +1,35 @@ +'\" +'\" Copyright (c) 1995-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) DeleteImg.3 1.4 96/03/26 18:07:21 +'\" +.so man.macros +.TH Tk_DeleteImage 3 4.0 Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_DeleteImage \- Destroy an image. +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +\fBTk_DeleteImage\fR(\fIinterp, name\fR) +.SH ARGUMENTS +.AS Tcl_Interp *interp +.AP Tcl_Interp *interp in +Interpreter for which the image was created. +.AP char *name in +Name of the image. +.BE + +.SH DESCRIPTION +.PP +\fBTk_DeleteImage\fR deletes the image given by \fIinterp\fR +and \fIname\fR, if there is one. All instances of that image +will redisplay as empty regions. If the given image does not +exist then the procedure has no effect. + +.SH KEYWORDS +delete image, image manager diff --git a/tk4.2/doc/DrawFocHlt.3 b/tk4.2/doc/DrawFocHlt.3 new file mode 100644 index 0000000..dfcc810 --- /dev/null +++ b/tk4.2/doc/DrawFocHlt.3 @@ -0,0 +1,40 @@ +'\" +'\" Copyright (c) 1995-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) DrawFocHlt.3 1.4 96/03/26 18:07:35 +'\" +.so man.macros +.TH Tk_DrawFocusHighlight 3 4.0 Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_DrawFocusHighlight \- draw the traversal highlight ring for a widget +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +\fBTk_GetPixels(\fItkwin, gc, width, drawable\fB)\fR +.SH ARGUMENTS +.AS "Tcl_Interp" *joinPtr +.AP Tk_Window tkwin in +Window for which the highlight is being drawn. Used to retrieve +the window's dimensions, among other things. +.AP GC gc in +Graphics context to use for drawing the highlight. +.AP int width in +Width of the highlight ring, in pixels. +.AP Drawable drawable in +Drawable in which to draw the highlight; usually an offscreen +pixmap for double buffering. +.BE + +.SH DESCRIPTION +.PP +\fBTk_DrawFocusHighlight\fR is a utility procedure that draws the +traversal highlight ring for a widget. +It is typically invoked by widgets during redisplay. + +.SH KEYWORDS +focus, traversal highlight diff --git a/tk3.6/doc/EventHndlr.3 b/tk4.2/doc/EventHndlr.3 similarity index 63% rename from tk3.6/doc/EventHndlr.3 rename to tk4.2/doc/EventHndlr.3 index bebde4e..c9222b4 100644 --- a/tk3.6/doc/EventHndlr.3 +++ b/tk4.2/doc/EventHndlr.3 @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1990 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/wish/man/RCS/EventHndlr.3,v 1.9 93/04/01 09:41:20 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) EventHndlr.3 1.15 96/03/14 10:55:08 '\" .so man.macros -.HS Tk_CreateEventHandler tkc +.TH Tk_CreateEventHandler 3 "" Tk "Tk Library Procedures" .BS .SH NAME Tk_CreateEventHandler, Tk_DeleteEventHandler \- associate procedure callback with an X event @@ -57,18 +44,14 @@ through \fBTk_HandleEvent\fR (or through other Tk procedures that call \fBTk_HandleEvent\fR, such as \fBTk_DoOneEvent\fR or \fBTk_MainLoop\fR). .PP -\fIProc\fP should have arguments and result that match the +\fIProc\fR should have arguments and result that match the type \fBTk_EventProc\fR: -.nf -.RS +.CS typedef void Tk_EventProc( -.RS -ClientData \fIclientData\fR, -XEvent *\fIeventPtr\fR); -.RE -.RE -.fi -The \fIclientData\fP parameter to \fIproc\fR is a copy of the \fIclientData\fP + ClientData \fIclientData\fR, + XEvent *\fIeventPtr\fR); +.CE +The \fIclientData\fR parameter to \fIproc\fR is a copy of the \fIclientData\fR argument given to \fBTk_CreateEventHandler\fR when the callback was created. Typically, \fIclientData\fR points to a data structure containing application-specific information about @@ -88,7 +71,7 @@ When a window is deleted all of its handlers will be deleted automatically; in this case there is no need to call \fBTk_DeleteEventHandler\fR. .PP -If mutliple handlers are declared for the same type of X event +If multiple handlers are declared for the same type of X event on the same window, then the handlers will be invoked in the order they were created. diff --git a/tk4.2/doc/FindPhoto.3 b/tk4.2/doc/FindPhoto.3 new file mode 100644 index 0000000..ed57750 --- /dev/null +++ b/tk4.2/doc/FindPhoto.3 @@ -0,0 +1,196 @@ +'\" +'\" Copyright (c) 1994 The Australian National University +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" Author: Paul Mackerras (paulus@cs.anu.edu.au), +'\" Department of Computer Science, +'\" Australian National University. +'\" +'\" "@(#) FindPhoto.3 1.9 96/03/18 14:25:42" +'\" +.so man.macros +.TH Tk_FindPhoto 3 4.0 Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_FindPhoto, Tk_PhotoPutBlock, Tk_PhotoPutZoomedBlock, Tk_PhotoGetImage, Tk_PhotoBlank, Tk_PhotoExpand, Tk_PhotoGetSize, Tk_PhotoSetSize \- manipulate the image data stored in a photo image. +.SH SYNOPSIS +.nf +\fB#include \fR +\fB#include \fR +.sp +Tk_PhotoHandle +\fBTk_FindPhoto\fR(\fIimageName\fR) +.sp +void +\fBTk_PhotoPutBlock\fR(\fIhandle, blockPtr, x, y, width, height\fR) +.sp +void +\fBTk_PhotoPutZoomedBlock\fR(\fIhandle, blockPtr, x, y, width, height,\ +zoomX, zoomY, subsampleX, subsampleY\fR) +.sp +int +\fBTk_PhotoGetImage\fR(\fIhandle, blockPtr\fR) +.sp +void +\fBTk_PhotoBlank\fR(\fIhandle\fR) +.sp +void +\fBTk_PhotoExpand\fR(\fIhandle, width, height\fR) +.sp +void +\fBTk_PhotoGetSize\fR(\fIhandle, widthPtr, heightPtr\fR) +.sp +void +\fBTk_PhotoSetSize\fR(\fIhandle, width, height\fR) +.SH ARGUMENTS +.AS Tk_PhotoImageBlock window_path +.AP char *imageName in +Name of the photo image. +.AP Tk_PhotoHandle handle in +Opaque handle identifying the photo image to be affected. +.AP Tk_PhotoImageBlock *blockPtr in +Specifies the address and storage layout of image data. +.AP int x in +Specifies the X coordinate where the top-left corner of the block is +to be placed within the image. +.AP int y in +Specifies the Y coordinate where the top-left corner of the block is +to be placed within the image. +.AP int width in +Specifies the width of the image area to be affected (for +\fBTk_PhotoPutBlock\fR) or the desired image width (for +\fBTk_PhotoExpand\fR and \fBTk_PhotoSetSize\fR). +.AP int height in +Specifies the height of the image area to be affected (for +\fBTk_PhotoPutBlock\fR) or the desired image height (for +\fBTk_PhotoExpand\fR and \fBTk_PhotoSetSize\fR). +.AP int *widthPtr out +Pointer to location in which to store the image width. +.AP int *heightPtr out +Pointer to location in which to store the image height. +.AP int subsampleX in +Specifies the subsampling factor in the X direction for input +image data. +.AP int subsampleY in +Specifies the subsampling factor in the Y direction for input +image data. +.AP int zoomX in +Specifies the zoom factor to be applied in the X direction to pixels +being written to the photo image. +.AP int zoomY in +Specifies the zoom factor to be applied in the Y direction to pixels +being written to the photo image. +.BE + +.SH DESCRIPTION +.PP +\fBTk_FindPhoto\fR returns an opaque handle that is used to identify a +particular photo image to the other procedures. The parameter is the +name of the image, that is, the name specified to the \fBimage create +photo\fR command, or assigned by that command if no name was specified. +.PP +\fBTk_PhotoPutBlock\fR is used to supply blocks of image data to be +displayed. The call affects an area of the image of size +\fIwidth\fR x \fIheight\fR pixels, with its top-left corner at +coordinates (\fIx\fR,\fIy\fR). All of \fIwidth\fR, \fIheight\fR, +\fIx\fR, and \fIy\fR must be non-negative. +If part of this area lies outside the +current bounds of the image, the image will be expanded to include the +area, unless the user has specified an explicit image size with the +\fB\-width\fR and/or \fB\-height\fR widget configuration options +(see photo(n)); in that +case the area is silently clipped to the image boundaries. +.PP +The \fIblock\fR parameter is a pointer to a +\fBTk_PhotoImageBlock\fR structure, defined as follows: +.CS +typedef struct { + unsigned char *\fIpixelPtr\fR; + int \fIwidth\fR; + int \fIheight\fR; + int \fIpitch\fR; + int \fIpixelSize\fR; + int \fIoffset[3]\fR; +} Tk_PhotoImageBlock; +.CE +The \fIpixelPtr\fR field points to the first pixel, that is, the +top-left pixel in the block. +The \fIwidth\fR and \fIheight\fR fields specify the dimensions of the +block of pixels. The \fIpixelSize\fR field specifies the address +difference between two horizontally adjacent pixels. Often it is 3 +or 4, but it can have any value. The \fIpitch\fR field specifies the +address difference between two vertically adjacent pixels. The +\fIoffset\fR array contains the offsets from the address of a pixel +to the addresses of the bytes containing the red, green and blue +components. These are normally 0, 1 and 2, but can have other values, +e.g., for images that are stored as separate red, green and blue +planes. +.PP +The value given for the \fIwidth\fR and \fIheight\fR parameters to +\fBTk_PhotoPutBlock\fR do not have to correspond to the values specified +in \fIblock\fR. If they are smaller, \fBTk_PhotoPutBlock\fR extracts a +sub-block from the image data supplied. If they are larger, the data +given are replicated (in a tiled fashion) to fill the specified area. +These rules operate independently in the horizontal and vertical +directions. +.PP +\fBTk_PhotoPutZoomedBlock\fR works like \fBTk_PhotoPutBlock\fR except that +the image can be reduced or enlarged for display. The +\fIsubsampleX\fR and \fIsubsampleY\fR parameters allow the size of the +image to be reduced by subsampling. +\fBTk_PhotoPutZoomedBlock\fR will use only pixels from the input image +whose X coordinates are multiples of \fIsubsampleX\fR, and whose Y +coordinates are multiples of \fIsubsampleY\fR. For example, an image +of 512x512 pixels can be reduced to 256x256 by setting +\fIsubsampleX\fR and \fIsubsampleY\fR to 2. +.PP +The \fIzoomX\fR and \fIzoomY\fR parameters allow the image to be +enlarged by pixel replication. Each pixel of the (possibly subsampled) +input image will be written to a block \fIzoomX\fR pixels wide and +\fIzoomY\fR pixels high of the displayed image. Subsampling and +zooming can be used together for special effects. +.PP +\fBTk_PhotoGetImage\fR can be used to retrieve image data from a photo +image. \fBTk_PhotoGetImage\fR fills +in the structure pointed to by the \fIblockPtr\fR parameter with values +that describe the address and layout of the image data that the +photo image has stored internally. The values are valid +until the image is destroyed or its size is changed. +\fBTk_PhotoGetImage\fR returns 1 for compatibility with the +corresponding procedure in the old photo widget. +.PP +\fBTk_PhotoBlank\fR blanks the entire area of the +photo image. Blank areas of a photo image are transparent. +.PP +\fBTk_PhotoExpand\fR requests that the widget's image be expanded to be +at least \fIwidth\fR x \fIheight\fR pixels in size. The width and/or +height are unchanged if the user has specified an explicit image width +or height with the \fB\-width\fR and/or \fB\-height\fR configuration +options, respectively. +If the image data +are being supplied in many small blocks, it is more efficient to use +\fBTk_PhotoExpand\fR or \fBTk_PhotoSetSize\fR at the beginning rather than +allowing the image to expand in many small increments as image blocks +are supplied. +.PP +\fBTk_PhotoSetSize\fR specifies the size of the image, as if the user +had specified the given \fIwidth\fR and \fIheight\fR values to the +\fB\-width\fR and \fB\-height\fR configuration options. A value of +zero for \fIwidth\fR or \fIheight\fR does not change the image's width +or height, but allows the width or height to be changed by subsequent +calls to \fBTk_PhotoPutBlock\fR, \fBTk_PhotoPutZoomedBlock\fR or +\fBTk_PhotoExpand\fR. +.PP +\fBTk_PhotoGetSize\fR returns the dimensions of the image in +*\fIwidthPtr\fR and *\fIheightPtr\fR. + +.SH CREDITS +.PP +The code for the photo image type was developed by Paul Mackerras, +based on his earlier photo widget code. + +.SH KEYWORDS +photo, image diff --git a/tk4.2/doc/FreeXId.3 b/tk4.2/doc/FreeXId.3 new file mode 100644 index 0000000..904523a --- /dev/null +++ b/tk4.2/doc/FreeXId.3 @@ -0,0 +1,52 @@ +'\" +'\" Copyright (c) 1990 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) FreeXId.3 1.5 96/03/26 18:07:59 +'\" +.so man.macros +.TH Tk_FreeXId 3 4.0 Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_FreeXId \- make X resource identifier available for reuse +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +\fBTk_FreeXId(\fIdisplay, id\fB)\fR +.SH ARGUMENTS +.AS Display *display out +.AP Display *display in +Display for which \fIid\fR was allocated. +.AP XID id in +Identifier of X resource (window, font, pixmap, cursor, graphics +context, or colormap) that is no longer in use. +.BE + +.SH DESCRIPTION +.PP +The default allocator for resource identifiers provided by Xlib is very +simple-minded and does not allow resource identifiers to be re-used. +If a long-running application reaches the end of the resource id +space, it will generate an X protocol error and crash. +Tk replaces the default id allocator with its own allocator, which +allows identifiers to be reused. +In order for this to work, \fBTk_FreeXId\fR must be called to +tell the allocator about resources that have been freed. +Tk automatically calls \fBTk_FreeXId\fR whenever it frees a +resource, so if you use procedures like \fBTk_GetFontStruct\fR, +\fBTk_GetGC\fR, and \fBTk_GetPixmap\fR then you need not call +\fBTk_FreeXId\fR. +However, if you allocate resources directly from Xlib, for example +by calling \fBXCreatePixmap\fR, then you should call \fBTk_FreeXId\fR +when you call the corresponding Xlib free procedure, such as +\fBXFreePixmap\fR. +If you don't call \fBTk_FreeXId\fR then the resource identifier will +be lost, which could cause problems if the application runs long enough +to lose all of the available identifiers. + +.SH KEYWORDS +resource identifier diff --git a/tk3.6/doc/GeomReq.3 b/tk4.2/doc/GeomReq.3 similarity index 67% rename from tk3.6/doc/GeomReq.3 rename to tk4.2/doc/GeomReq.3 index 243da1b..d06b0f8 100644 --- a/tk3.6/doc/GeomReq.3 +++ b/tk4.2/doc/GeomReq.3 @@ -1,28 +1,15 @@ '\" -'\" Copyright (c) 1990, 1991 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1990-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" -'\" $Header: /user6/ouster/wish/man/RCS/GeomReq.3,v 1.7 93/04/01 09:41:21 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) GeomReq.3 1.11 96/03/26 18:08:21 '\" .so man.macros -.HS Tk_GeometryRequest tkc +.TH Tk_GeometryRequest 3 "" Tk "Tk Library Procedures" .BS .SH NAME Tk_GeometryRequest, Tk_SetInternalBorder \- specify desired geometry or internal border for a window diff --git a/tk3.6/doc/GetAnchor.3 b/tk4.2/doc/GetAnchor.3 similarity index 63% rename from tk3.6/doc/GetAnchor.3 rename to tk4.2/doc/GetAnchor.3 index 0047eaa..4c5cdfb 100644 --- a/tk3.6/doc/GetAnchor.3 +++ b/tk4.2/doc/GetAnchor.3 @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1990 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/wish/man/RCS/GetAnchor.3,v 1.4 93/04/01 09:41:23 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) GetAnchor.3 1.9 96/03/26 18:08:45 '\" .so man.macros -.HS Tk_GetAnchor tkc +.TH Tk_GetAnchor 3 "" Tk "Tk Library Procedures" .BS .SH NAME Tk_GetAnchor, Tk_NameOfAnchor \- translate between strings and anchor positions @@ -29,7 +16,7 @@ Tk_GetAnchor, Tk_NameOfAnchor \- translate between strings and anchor positions .nf \fB#include \fR .sp -Tk_Anchor +int \fBTk_GetAnchor(\fIinterp, string, anchorPtr\fB)\fR .sp char * diff --git a/tk3.6/doc/GetBitmap.3 b/tk4.2/doc/GetBitmap.3 similarity index 79% rename from tk3.6/doc/GetBitmap.3 rename to tk4.2/doc/GetBitmap.3 index 4d088ed..a5bfd0b 100644 --- a/tk3.6/doc/GetBitmap.3 +++ b/tk4.2/doc/GetBitmap.3 @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1990 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/wish/man/RCS/GetBitmap.3,v 1.11 93/04/01 09:41:24 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) GetBitmap.3 1.24 96/08/27 13:21:25 '\" .so man.macros -.HS Tk_GetBitmap tkc +.TH Tk_GetBitmap 3 4.1 Tk "Tk Library Procedures" .BS .SH NAME Tk_GetBitmap, Tk_DefineBitmap, Tk_NameOfBitmap, Tk_SizeOfBitmap, Tk_FreeBitmap, Tk_GetBitmapFromData \- maintain database of single-plane pixmaps @@ -32,19 +19,15 @@ Tk_GetBitmap, Tk_DefineBitmap, Tk_NameOfBitmap, Tk_SizeOfBitmap, Tk_FreeBitmap, Pixmap \fBTk_GetBitmap(\fIinterp, tkwin, id\fB)\fR .sp -.VS int -\fBTk_DefineBitmap(\fIinterp, nameId, source, width, height\fR)\fR -.VE +\fBTk_DefineBitmap(\fIinterp, nameId, source, width, height\fB)\fR .sp Tk_Uid -.VS \fBTk_NameOfBitmap(\fIdisplay, bitmap\fB)\fR .sp \fBTk_SizeOfBitmap(\fIdisplay, bitmap, widthPtr, heightPtr\fB)\fR .sp \fBTk_FreeBitmap(\fIdisplay, bitmap\fB)\fR -.VE .SH ARGUMENTS .AS "unsigned long" *pixelPtr .AP Tcl_Interp *interp in @@ -53,23 +36,21 @@ Interpreter to use for error reporting. Token for window in which the bitmap will be used. .AP Tk_Uid id in Description of bitmap; see below for possible values. -.AP Tk_Uid *nameId in +.AP Tk_Uid nameId in Name for new bitmap to be defined. .AP char *source in Data for bitmap, in standard bitmap format. Must be stored in static memory whose value will never change. -.AP "unsigned int" width in +.AP "int" width in Width of bitmap. -.AP "unsigned int" height in +.AP "int" height in Height of bitmap. -.AP "unsigned int" *widthPtr out +.AP "int" *widthPtr out Pointer to word to fill in with \fIbitmap\fR's width. -.AP "unsigned int" *heightPtr out +.AP "int" *heightPtr out Pointer to word to fill in with \fIbitmap\fR's height. .AP Display *display in Display for which \fIbitmap\fR was allocated. -.VS -.VE .AP Pixmap bitmap in Identifier for a bitmap allocated by \fBTk_GetBitmap\fR. .BE @@ -98,20 +79,17 @@ by Tk: .RS .TP 12 \fBerror\fR -.VS The international "don't" symbol: a circle with a diagonal line across it. -.VE .TP 12 \fBgray50\fR 50% gray: a checkerboard pattern where every other bit is on. .TP 12 -\fBgray25\fR -25% gray: a pattern where 25% of the bits are on, consisting of all the -bit positions that can be reached by a chess knight starting at (0,0). +\fBgray12\fR +12.5% gray: a pattern where one-eighth of the bits are on, consisting of +every fourth pixel in every other row. .TP 12 \fBhourglass\fR -.VS An hourglass symbol. .TP 12 \fBinfo\fR @@ -125,8 +103,6 @@ A large question-mark. .TP 12 \fBwarning\fR A large exclamation point. -.VE -\fB .RE .LP Under normal conditions, \fBTk_GetBitmap\fR @@ -136,7 +112,6 @@ to a non-existent file, then \fBNone\fR is returned and an error message is left in \fIinterp->result\fR. .PP \fBTk_DefineBitmap\fR associates a name with -.VS in-memory bitmap data so that the name can be used in later calls to \fBTk_GetBitmap\fR. The \fInameId\fR argument gives a name for the bitmap; it must not previously @@ -151,7 +126,6 @@ Note: \fBTk_DefineBitmap\fR expects the memory pointed to by \fIsource\fR to be static: \fBTk_DefineBitmap\fR doesn't make a private copy of this memory, but uses the bytes pointed to by \fIsource\fR later in calls to \fBTk_GetBitmap\fR. -.VE .PP Typically \fBTk_DefineBitmap\fR is used by \fB#include\fR-ing a bitmap file directly into a C program and then referencing @@ -161,33 +135,29 @@ which was created by the \fBbitmap\fR program and contains a stipple pattern. The following code uses \fBTk_DefineBitmap\fR to define a new bitmap named \fBfoo\fR: -.nf -.RS -\fCPixmap bitmap; +.CS +Pixmap bitmap; #include "stip.bitmap" Tk_DefineBitmap(interp, Tk_GetUid("foo"), stip_bits, stip_width, stip_height); \&... -bitmap = Tk_GetBitmap(interp, tkwin, Tk_GetUid("foo"));\fR -.RE -.fi +bitmap = Tk_GetBitmap(interp, tkwin, Tk_GetUid("foo")); +.CE This code causes the bitmap file to be read at compile-time and incorporates the bitmap information into the program's executable image. The same bitmap file could be read at run-time using \fBTk_GetBitmap\fR: -.nf -.RS -\fCPixmap bitmap; -bitmap = Tk_GetBitmap(interp, tkwin, Tk_GetUid("@stip.bitmap"));\fR -.RE -.fi +.CS +Pixmap bitmap; +bitmap = Tk_GetBitmap(interp, tkwin, Tk_GetUid("@stip.bitmap")); +.CE The second form is a bit more flexible (the file could be modified after the program has been compiled, or a different string could be provided to read a different file), but it is a little slower and requires the bitmap file to exist separately from the program. .PP \fBTk_GetBitmap\fR maintains a -database of all the bitmaps that have been created. +database of all the bitmaps that are currently in use. Whenever possible, it will return an existing bitmap rather than creating a new one. This approach can substantially reduce server overhead, so @@ -204,17 +174,13 @@ The procedure \fBTk_NameOfBitmap\fR is roughly the inverse of \fBTk_GetBitmap\fR. Given an X Pixmap argument, it returns the \fIid\fR that was passed to \fBTk_GetBitmap\fR when the bitmap was created. -.VS \fIBitmap\fR must have been the return value from a previous call to \fBTk_GetBitmap\fR. -.VE .PP \fBTk_SizeOfBitmap\fR returns the dimensions of its \fIbitmap\fR -.VS argument in the words pointed to by the \fIwidthPtr\fR and \fIheightPtr\fR arguments. As with \fBTk_NameOfBitmap\fR, \fIbitmap\fR must have been created by \fBTk_GetBitmap\fR. -.VE .PP When a bitmap returned by \fBTk_GetBitmap\fR is no longer needed, \fBTk_FreeBitmap\fR should be called to release it. diff --git a/tk3.6/doc/GetCapStyl.3 b/tk4.2/doc/GetCapStyl.3 similarity index 60% rename from tk3.6/doc/GetCapStyl.3 rename to tk4.2/doc/GetCapStyl.3 index fd616f8..a9b8ec9 100644 --- a/tk3.6/doc/GetCapStyl.3 +++ b/tk4.2/doc/GetCapStyl.3 @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1990 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/wish/man/RCS/GetCapStyl.3,v 1.5 93/04/01 09:41:24 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) GetCapStyl.3 1.9 96/03/26 18:09:14 '\" .so man.macros -.HS Tk_GetCapStyle tkc +.TH Tk_GetCapStyle 3 "" Tk "Tk Library Procedures" .BS .SH NAME Tk_GetCapStyle, Tk_NameOfCapStyle \- translate between strings and cap styles diff --git a/tk4.2/doc/GetClrmap.3 b/tk4.2/doc/GetClrmap.3 new file mode 100644 index 0000000..4a4121f --- /dev/null +++ b/tk4.2/doc/GetClrmap.3 @@ -0,0 +1,73 @@ +'\" +'\" Copyright (c) 1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) GetClrmap.3 1.5 96/03/26 18:09:27 +'\" +.so man.macros +.TH Tk_GetColormap 3 4.0 Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_GetColormap, Tk_FreeColormap \- allocate and free colormaps +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +Colormap +\fBTk_GetColormap(\fIinterp, tkwin, string\fB)\fR +.sp +\fBTk_FreeColormap(\fIdisplay, colormap\fB)\fR +.SH ARGUMENTS +.AS "Colormap" colormap +.AP Tcl_Interp *interp in +Interpreter to use for error reporting. +.AP Tk_Window tkwin in +Token for window in which colormap will be used. +.AP char *string in +Selects a colormap: either \fBnew\fR or the name of a window +with the same screen and visual as \fItkwin\fR. +.AP Display *display in +Display for which \fIcolormap\fR was allocated. +.AP Colormap colormap in +Colormap to free; must have been returned by a previous +call to \fBTk_GetColormap\fR or \fBTk_GetVisual\fR. +.BE + +.SH DESCRIPTION +.PP +These procedures are used to manage colormaps. +\fBTk_GetColormap\fR returns a colormap suitable for use in \fItkwin\fR. +If its \fIstring\fR argument is \fBnew\fR then a new colormap is +created; otherwise \fIstring\fR must be the name of another window +with the same screen and visual as \fItkwin\fR, and the colormap from that +window is returned. +If \fIstring\fR doesn't make sense, or if it refers to a window on +a different screen from \fItkwin\fR or with +a different visual than \fItkwin\fR, then \fBTk_GetColormap\fR returns +\fBNone\fR and leaves an error message in \fIinterp->result\fR. +.PP +\fBTk_FreeColormap\fR should be called when a colormap returned by +\fBTk_GetColormap\fR is no longer needed. +Tk maintains a reference count for each colormap returned by +\fBTk_GetColormap\fR, so there should eventually be one call to +\fBTk_FreeColormap\fR for each call to \fBTk_GetColormap\fR. +When a colormap's reference count becomes zero, Tk releases the +X colormap. +.PP +\fBTk_GetVisual\fR and \fBTk_GetColormap\fR work together, in that +a new colormap created by \fBTk_GetVisual\fR may later be returned +by \fBTk_GetColormap\fR. +The reference counting mechanism for colormaps includes both procedures, +so callers of \fBTk_GetVisual\fR must also call \fBTk_FreeColormap\fR +to release the colormap. +If \fBTk_GetColormap\fR is called with a \fIstring\fR value of +\fBnew\fR then the resulting colormap will never +be returned by \fBTk_GetVisual\fR; however, it can be used in other +windows by calling \fBTk_GetColormap\fR with the original window's +name as \fIstring\fR. + +.SH KEYWORDS +colormap diff --git a/tk3.6/doc/GetColor.3 b/tk4.2/doc/GetColor.3 similarity index 70% rename from tk3.6/doc/GetColor.3 rename to tk4.2/doc/GetColor.3 index 3dc4db3..7f89446 100644 --- a/tk3.6/doc/GetColor.3 +++ b/tk4.2/doc/GetColor.3 @@ -1,43 +1,33 @@ '\" '\" Copyright (c) 1990, 1991 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/wish/man/RCS/GetColor.3,v 1.9 93/04/01 09:41:25 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) GetColor.3 1.22 96/08/27 13:21:26 '\" .so man.macros -.HS Tk_GetColor tkc +.TH Tk_GetColor 3 4.0 Tk "Tk Library Procedures" .BS .SH NAME -Tk_GetColor, Tk_GetColorByValue, Tk_NameOfColor Tk_FreeColor \- maintain database of colors +Tk_GetColor, Tk_GetColorByValue, Tk_NameOfColor, Tk_FreeColor \- maintain database of colors .SH SYNOPSIS .nf \fB#include \fR .sp XColor * -\fBTk_GetColor\fR(\fIinterp, tkwin, colorMap, nameId\fB)\fR +\fBTk_GetColor\fR(\fIinterp, tkwin, nameId\fB)\fR .sp XColor * -\fBTk_GetColorByValue\fR(\fIinterp, tkwin, colorMap, prefPtr\fB)\fR +\fBTk_GetColorByValue\fR(\fItkwin, prefPtr\fB)\fR .sp char * \fBTk_NameOfColor(\fIcolorPtr\fB)\fR .sp +GC +\fBTk_GCForColor\fR(\fIcolorPtr, drawable\fR) +.sp \fBTk_FreeColor(\fIcolorPtr\fB)\fR .SH ARGUMENTS .AS "Tcl_Interp" *colorPtr @@ -45,9 +35,6 @@ char * Interpreter to use for error reporting. .AP Tk_Window tkwin in Token for window in which color will be used. -.AP Colormap colormap in -Colormap from which to allocate color. If None, then the default -colormap for \fItkwin\fR's screen is used. .AP Tk_Uid nameId in Textual description of desired color. .AP XColor *prefPtr in @@ -57,14 +44,16 @@ color. Pointer to X color information. Must have been allocated by previous call to \fBTk_GetColor\fR or \fBTk_GetColorByValue\fR, except when passed to \fBTk_NameOfColor\fR. +.AP Drawable drawable in +Drawable in which the result graphics context will be used. Must have +same screen and depth as the window for which the color was allocated. .BE .SH DESCRIPTION .PP The \fBTk_GetColor\fR and \fBTk_GetColorByValue\fR procedures locate pixel values that may be used to render particular -colors in the window given by \fItkwin\fR using the colormap -given by \fIcolormap\fR. In \fBTk_GetColor\fR +colors in the window given by \fItkwin\fR. In \fBTk_GetColor\fR the desired color is specified with a Tk_Uid (\fInameId\fR), which may have any of the following forms: .TP 20 @@ -86,7 +75,7 @@ colors to be specified with 4-bit, 8-bit, 12-bit or 16-bit values. When fewer than 16 bits are provided for each color, they represent the most significant bits of the color. For example, #3a7 is the same as #3000a0007000. -.LP +.PP In \fBTk_GetColorByValue\fR, the desired color is indicated with the \fIred\fR, \fIgreen\fR, and \fIblue\fR fields of the structure pointed to by \fIcolorPtr\fR. @@ -96,9 +85,14 @@ in allocating the desired color, then it returns a pointer to an XColor structure; the structure indicates the exact intensities of the allocated color (which may differ slightly from those requested, depending on the limitations of the screen) and a pixel value -from \fIcolormap\fR that may be used to draw in the color. -If an error occurs in allocating a color then NULL is returned -and an error message will be stored in \fIinterp->result\fR. +that may be used to draw in the color. +If the colormap for \fItkwin\fR is full, \fBTk_GetColor\fR +and \fBTk_GetColorByValue\fR will use the closest existing color +in the colormap. +If \fBTk_GetColor\fR encounters an error while allocating +the color (such as an unknown color name) then NULL is returned and +an error message is stored in \fIinterp->result\fR; +\fBTk_GetColorByValue\fR never returns an error. .PP \fBTk_GetColor\fR and \fBTk_GetColorByValue\fR maintain a database of all the colors currently in use. @@ -130,6 +124,14 @@ that could be passed to \fBTk_GetColor\fR to return the same color. Note: the string returned by \fBTk_NameOfColor\fR is only guaranteed to persist until the next call to \fBTk_NameOfColor\fR. .PP +\fBTk_GCForColor\fR returns a graphics context whose \fBForeground\fR +field is the pixel allocated for \fIcolorPtr\fR and whose other fields +all have default values. +This provides an easy way to do basic drawing with a color. +The graphics context is cached with the color and will exist only as +long as \fIcolorPtr\fR exists; it is freed when the last reference +to \fIcolorPtr\fR is freed by calling \fBTk_FreeColor\fR. +.PP When a pixel value returned by \fBTk_GetColor\fR or \fBTk_GetColorByValue\fR is no longer needed, \fBTk_FreeColor\fR should be called to release the color. diff --git a/tk3.6/doc/GetCursor.3 b/tk4.2/doc/GetCursor.3 similarity index 77% rename from tk3.6/doc/GetCursor.3 rename to tk4.2/doc/GetCursor.3 index 560af50..5f940c9 100644 --- a/tk3.6/doc/GetCursor.3 +++ b/tk4.2/doc/GetCursor.3 @@ -1,26 +1,14 @@ +'\" '\" Copyright (c) 1990 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/wish/man/RCS/GetCursor.3,v 1.9 93/04/01 09:41:26 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) GetCursor.3 1.23 96/08/27 13:21:26 '\" .so man.macros -.HS Tk_GetCursor tkc +.TH Tk_GetCursor 3 4.1 Tk "Tk Library Procedures" .BS .SH NAME Tk_GetCursor, Tk_GetCursorFromData, Tk_NameOfCursor, Tk_FreeCursor \- maintain database of cursors @@ -28,18 +16,16 @@ Tk_GetCursor, Tk_GetCursorFromData, Tk_NameOfCursor, Tk_FreeCursor \- maintain d .nf \fB#include \fR .sp -Cursor +Tk_Cursor \fBTk_GetCursor(\fIinterp, tkwin, nameId\fB)\fR .sp -Cursor +Tk_Cursor \fBTk_GetCursorFromData(\fIinterp, tkwin, source, mask, width, height, xHot, yHot, fg, bg\fB)\fR .sp char * -.VS \fBTk_NameOfCursor(\fIdisplay, cursor\fB)\fR .sp \fBTk_FreeCursor(\fIdisplay, cursor\fB)\fR -.VE .SH ARGUMENTS .AS "unsigned long" *pixelPtr .AP Tcl_Interp *interp in @@ -52,13 +38,13 @@ Description of cursor; see below for possible values. Data for cursor bitmap, in standard bitmap format. .AP char *mask in Data for mask bitmap, in standard bitmap format. -.AP "unsigned int" width in +.AP "int" width in Width of \fIsource\fR and \fImask\fR. -.AP "unsigned int" height in +.AP "int" height in Height of \fIsource\fR and \fImask\fR. -.AP "unsigned int" xHot in +.AP "int" xHot in X-location of cursor hot-spot. -.AP "unsigned int" yHot in +.AP "int" yHot in Y-location of cursor hot-spot. .AP Tk_Uid fg in Textual description of foreground color for cursor. @@ -66,10 +52,8 @@ Textual description of foreground color for cursor. Textual description of background color for cursor. .AP Display *display in Display for which \fIcursor\fR was allocated. -.VS -.VE -.AP Cursor cursor in -X identifier for cursor. If passed to\fBTk_FreeCursor\fR, must +.AP Tk_Cursor cursor in +Opaque Tk identifier for cursor. If passed to\fBTk_FreeCursor\fR, must have been returned by some previous call to \fBTk_GetCursor\fR or \fBTk_GetCursorFromData\fR. .BE @@ -82,12 +66,13 @@ re-used efficiently, thereby avoiding server overhead, and also allow cursors to be named with character strings (actually Tk_Uids). .PP \fBTk_GetCursor\fR takes as argument a Tk_Uid describing a cursor, -and returns the X identifier for a cursor corresponding to the -description. It re-uses an existing cursor if possible and +and returns an opaque Tk identifier for a cursor corresponding to the +description. +It re-uses an existing cursor if possible and creates a new one otherwise. \fINameId\fR must be a standard Tcl list with one of the following forms: .TP -\fIname\fR\ \ [\fIfgColor\fR\ \ [\fIbgColor\fR]] +\fIname\fR\0[\fIfgColor\fR\0[\fIbgColor\fR]] \fIName\fR is the name of a cursor in the standard X cursor font, i.e., any of the names defined in \fBcursorfont.h\fR, without the \fBXC_\fR. Some example values are \fBX_cursor\fR, \fBhand2\fR, @@ -101,20 +86,31 @@ will be no background color: the background will be transparent. If no colors are specified, then the cursor will use black for its foreground color and white for its background color. + +The Macintosh version of Tk also supports all of the X cursors. +Tk on the Mac will also accept any of the standard Mac cursors +including \fBibeam\fR, \fBcrosshair\fR, \fBwatch\fR, \fBplus\fR, and +\fBarrow\fR. In addition, Tk will load Macintosh cursor resources of +the types \fBcrsr\fR (color) and \fBCURS\fR (black and white) by the +name of the of the resource. The application and all its open +dynamic library's resource files will be searched for the named +cursor. If there are conflicts color cursors will always be loaded +in preference to black and white cursors. .TP -\fB@\fIsourceName\ \ maskName\ \ fgColor\ \ bgColor\fR -.br +\fB@\fIsourceName\0maskName\0fgColor\0bgColor\fR In this form, \fIsourceName\fR and \fImaskName\fR are the names of files describing bitmaps for the cursor's source bits and mask. Each file must be in standard X11 or X10 bitmap format. \fIFgColor\fR and \fIbgColor\fR indicate the colors to use for the -cursor, in any of the forms acceptable to \fBTk_GetColor\fR. +cursor, in any of the forms acceptable to \fBTk_GetColor\fR. This +form of the command will not work on Macintosh or Windows computers. .TP -\fB@\fIsourceName\ \ fgColor\fR -.br +\fB@\fIsourceName\0fgColor\fR This form is similar to the one above, except that the source is -used as mask also. This means that the cursor's background is transparent. +used as mask also. This means that the cursor's background is +transparent. This form of the command will not work on Macintosh +or Windows computers. .PP \fBTk_GetCursorFromData\fR allows cursors to be created from in-memory descriptions of their source and mask bitmaps. \fISource\fR @@ -130,16 +126,14 @@ suitable for \fBTk_GetColor\fR may be used). Typically, the arguments to \fBTk_GetCursorFromData\fR are created by including a cursor file directly into the source code for a program, as in the following example: -.nf -.RS -\fCCursor cursor; +.CS +Tk_Cursor cursor; #include "source.cursor" #include "mask.cursor" cursor = Tk_GetCursorFromData(interp, tkwin, source_bits, mask_bits, source_width, source_height, source_x_hot, - source_y_hot, Tk_GetUid("red"), Tk_GetUid("blue"));\fR -.RE -.fi + source_y_hot, Tk_GetUid("red"), Tk_GetUid("blue")); +.CE .PP Under normal conditions, \fBTk_GetCursor\fR and \fBTk_GetCursorFromData\fR will return an identifier for the requested cursor. If an error @@ -164,7 +158,9 @@ cursor. If \fIcursor\fR was created by a call to \fBTk_GetCursorFromData\fR, or by any other mechanism, then the return value is a hexadecimal string giving the X identifier for the cursor. Note: the string returned by \fBTk_NameOfCursor\fR is -only guaranteed to persist until the next call to \fBTk_NameOfCursor\fR. +only guaranteed to persist until the next call to +\fBTk_NameOfCursor\fR. Also, this call is not portable except for +cursors returned by \fBTk_GetCursor\fR. .PP When a cursor returned by \fBTk_GetCursor\fR or \fBTk_GetCursorFromData\fR is no longer needed, \fBTk_FreeCursor\fR should be called to release it. diff --git a/tk3.6/doc/GetFontStr.3 b/tk4.2/doc/GetFontStr.3 similarity index 70% rename from tk3.6/doc/GetFontStr.3 rename to tk4.2/doc/GetFontStr.3 index 81cbc7a..3278353 100644 --- a/tk3.6/doc/GetFontStr.3 +++ b/tk4.2/doc/GetFontStr.3 @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1990-1992 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/wish/man/RCS/GetFontStr.3,v 1.6 93/04/01 09:41:27 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) GetFontStr.3 1.10 96/03/26 18:10:03 '\" .so man.macros -.HS Tk_GetFontStruct tkc +.TH Tk_GetFontStruct 3 "" Tk "Tk Library Procedures" .BS .SH NAME Tk_GetFontStruct, Tk_NameOfFontStruct, Tk_FreeFontStruct \- maintain database of fonts diff --git a/tk3.6/doc/GetGC.3 b/tk4.2/doc/GetGC.3 similarity index 69% rename from tk3.6/doc/GetGC.3 rename to tk4.2/doc/GetGC.3 index b44f35f..6908e9d 100644 --- a/tk3.6/doc/GetGC.3 +++ b/tk4.2/doc/GetGC.3 @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1990 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/wish/man/RCS/GetGC.3,v 1.6 93/04/30 11:41:39 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) GetGC.3 1.11 96/03/26 18:10:14 '\" .so man.macros -.HS Tk_GetGC tkc +.TH Tk_GetGC 3 "" Tk "Tk Library Procedures" .BS .SH NAME Tk_GetGC, Tk_FreeGC \- maintain database of read-only graphics contexts @@ -32,8 +19,6 @@ Tk_GetGC, Tk_FreeGC \- maintain database of read-only graphics contexts GC \fBTk_GetGC\fR(\fItkwin, valueMask, valuePtr\fR) .sp -.VS -.VE \fBTk_FreeGC(\fIdisplay, gc\fR) .SH ARGUMENTS .AS "unsigned long" valueMask @@ -47,8 +32,6 @@ Pointer to structure describing the desired values for the graphics context. .AP Display *display in Display for which \fIgc\fR was allocated. -.VS -.VE .AP GC gc in X identifier for graphics context that is no longer needed. Must have been allocated by \fBTk_GetGC\fR. diff --git a/tk4.2/doc/GetImage.3 b/tk4.2/doc/GetImage.3 new file mode 100644 index 0000000..4ac178a --- /dev/null +++ b/tk4.2/doc/GetImage.3 @@ -0,0 +1,135 @@ +'\" +'\" Copyright (c) 1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) GetImage.3 1.8 96/03/26 18:10:29 +'\" +.so man.macros +.TH Tk_GetImage 3 4.0 Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_GetImage, Tk_RedrawImage, Tk_SizeOfImage, Tk_FreeImage \- use an image in a widget +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +Tk_Image +\fBTk_GetImage\fR(\fIinterp, tkwin, name, changeProc, clientData\fR) +.sp +\fBTk_RedrawImage\fR(\fIimage, imageX, imageY, width, height, drawable, drawableX, drawableY\fR) +.sp +\fBTk_SizeOfImage\fR(\fIimage, widthPtr, heightPtr\fR) +.sp +\fBTk_FreeImage\fR(\fIimage\fR) +.SH ARGUMENTS +.AS Tk_ImageChangedProc *changeProc +.AP Tcl_Interp *interp in +Place to leave error message. +.AP Tk_Window tkwin in +Window in which image will be used. +.AP char *name in +Name of image. +.AP Tk_ImageChangedProc *changeProc in +Procedure for Tk to invoke whenever image content or size changes. +.AP ClientData clientData in +One-word value for Tk to pass to \fIchangeProc\fR. +.AP Tk_Image image in +Token for image instance; must have been returned by a previous +call to \fBTk_GetImage\fR. +.AP int imageX in +X-coordinate of upper-left corner of region of image to redisplay +(measured in pixels from the image's upper-left corner). +.AP int imageY in +Y-coordinate of upper-left corner of region of image to redisplay +(measured in pixels from the image's upper-left corner). +.AP "int" width (in) +Width of region of image to redisplay. +.AP "int" height (in) +Height of region of image to redisplay. +.AP Drawable drawable in +Where to display image. Must either be window specified to +\fBTk_GetImage\fR or a pixmap compatible with that window. +.AP int drawableX in +Where to display image in \fIdrawable\fR: this is the x-coordinate +in \fIdrawable\fR where x-coordinate \fIimageX\fR of the image +should be displayed. +.AP int drawableY in +Where to display image in \fIdrawable\fR: this is the y-coordinate +in \fIdrawable\fR where y-coordinate \fIimageY\fR of the image +should be displayed. +.AP "int" widthPtr out +Store width of \fIimage\fR (in pixels) here. +.AP "int" heightPtr out +Store height of \fIimage\fR (in pixels) here. +.BE + +.SH DESCRIPTION +.PP +These procedures are invoked by widgets that wish to display images. +\fBTk_GetImage\fR is invoked by a widget when it first decides to +display an image. +\fIname\fR gives the name of the desired image and \fItkwin\fR +identifies the window where the image will be displayed. +\fBTk_GetImage\fR looks up the image in the table of existing +images and returns a token for a new instance of the image. +If the image doesn't exist then \fBTk_GetImage\fR returns NULL +and leaves an error message in \fIinterp->result\fR. +.PP +When a widget wishes to actually display an image it must +call \fBTk_RedrawWidget\fR, identifying the image (\fIimage\fR), +a region within the image to redisplay (\fIimageX\fR, \fIimageY\fR, +\fIwidth\fR, and \fIheight\fR), and a place to display the +image (\fIdrawable\fR, \fIdrawableX\fR, and \fIdrawableY\fR). +Tk will then invoke the appropriate image manager, which will +display the requested portion of the image before returning. +.PP +A widget can find out the dimensions of an image by calling +\fBTk_SizeOfImage\fR: the width and height will be stored +in the locations given by \fIwidthPtr\fR and \fIheightPtr\fR, +respectively. +.PP +When a widget is finished with an image (e.g., the widget is +being deleted or it is going to use a different image instead +of the current one), it must call \fBTk_FreeImage\fR to +release the image instance. +The widget should never again use the image token after passing +it to \fBTk_FreeImage\fR. +There must be exactly one call to \fBTk_FreeImage\fR for each +call to \fBTk_GetImage\fR. +.PP +If the contents or size of an image changes, then any widgets +using the image will need to find out about the changes so that +they can redisplay themselves. +The \fIchangeProc\fR and \fIclientData\fR arguments to +\fBTk_GetImage\fR are used for this purpose. +\fIchangeProc\fR will be called by Tk whenever a change occurs +in the image; it must match the following prototype: +.CS +typedef void Tk_ImageChangedProc( + ClientData \fIclientData\fR, + int \fIx\fR, + int \fIy\fR, + int \fIwidth\fR, + int \fIheight\fR, + int \fIimageWidth\fR, + int \fIimageHeight\fR); +.CE +The \fIclientData\fR argument to \fIchangeProc\fR is the same as the +\fIclientData\fR argument to \fBTk_GetImage\fR. +It is usually a pointer to the widget record for the widget or +some other data structure managed by the widget. +The arguments \fIx\fR, \fIy\fR, \fIwidth\fR, and \fIheight\fR +identify a region within the image that must be redisplayed; +they are specified in pixels measured from the upper-left +corner of the image. +The arguments \fIimageWidth\fR and \fIimageHeight\fR give +the image's (new) size. + +.SH "SEE ALSO" +Tk_CreateImageType + +.SH KEYWORDS +images, redisplay diff --git a/tk3.6/doc/GetJoinStl.3 b/tk4.2/doc/GetJoinStl.3 similarity index 61% rename from tk3.6/doc/GetJoinStl.3 rename to tk4.2/doc/GetJoinStl.3 index 72725ed..8be41da 100644 --- a/tk3.6/doc/GetJoinStl.3 +++ b/tk4.2/doc/GetJoinStl.3 @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1990 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/wish/man/RCS/GetJoinStl.3,v 1.4 93/04/01 09:41:29 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) GetJoinStl.3 1.8 96/03/26 18:10:46 '\" .so man.macros -.HS Tk_GetJoinStyle tkc +.TH Tk_GetJoinStyle 3 "" Tk "Tk Library Procedures" .BS .SH NAME Tk_GetJoinStyle, Tk_NameOfJoinStyle \- translate between strings and join styles diff --git a/tk3.6/doc/GetJustify.3 b/tk4.2/doc/GetJustify.3 similarity index 57% rename from tk3.6/doc/GetJustify.3 rename to tk4.2/doc/GetJustify.3 index 19ef545..35ec0ae 100644 --- a/tk3.6/doc/GetJustify.3 +++ b/tk4.2/doc/GetJustify.3 @@ -1,27 +1,14 @@ '\" -'\" Copyright (c) 1990 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1990-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/wish/man/RCS/GetJustify.3,v 1.4 93/04/01 09:41:30 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) GetJustify.3 1.11 96/08/27 13:21:27 '\" .so man.macros -.HS Tk_GetJustify tkc +.TH Tk_GetJustify 3 4.0 Tk "Tk Library Procedures" .BS .SH NAME Tk_GetJustify, Tk_NameOfJustify \- translate between strings and justification styles @@ -39,8 +26,8 @@ char * .AP Tcl_Interp *interp in Interpreter to use for error reporting. .AP char *string in -String containing name of justification style (``left'', ``right'', -``center'', or ``fill''). +String containing name of justification style (``left'', ``right'', or +``center''). .AP int *justifyPtr out Pointer to location in which to store justify value corresponding to \fIstring\fR. @@ -64,11 +51,6 @@ the line; as a result, the left edges of lines may be ragged. \fBTK_JUSTIFY_CENTER\fR Means that the text on each line should be centered; as a result, both the left and right edges of lines may be ragged. -.TP -\fBTK_JUSTIFY_FILL\fR -Means that the text on each line should start at the left edge of -the line and end at the right edge, with the sizes of the spaces -in the line adjusted to make this work. .PP Under normal circumstances the return value is \fBTCL_OK\fR and \fIinterp\fR is unused. diff --git a/tk3.6/doc/GetOption.3 b/tk4.2/doc/GetOption.3 similarity index 50% rename from tk3.6/doc/GetOption.3 rename to tk4.2/doc/GetOption.3 index 3ff3d0a..d00fd9b 100644 --- a/tk3.6/doc/GetOption.3 +++ b/tk4.2/doc/GetOption.3 @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1990 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/wish/man/RCS/GetOption.3,v 1.5 93/04/01 09:41:30 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) GetOption.3 1.9 96/03/26 18:11:11 '\" .so man.macros -.HS Tk_GetOption tkc +.TH Tk_GetOption 3 "" Tk "Tk Library Procedures" .BS .SH NAME Tk_GetOption \- retrieve an option from the option database diff --git a/tk3.6/doc/GetPixels.3 b/tk4.2/doc/GetPixels.3 similarity index 66% rename from tk3.6/doc/GetPixels.3 rename to tk4.2/doc/GetPixels.3 index 31ae776..6b26eb3 100644 --- a/tk3.6/doc/GetPixels.3 +++ b/tk4.2/doc/GetPixels.3 @@ -1,30 +1,16 @@ '\" '\" Copyright (c) 1990 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/wish/man/RCS/GetPixels.3,v 1.3 93/04/01 09:41:36 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) GetPixels.3 1.8 96/03/26 18:11:30 '\" .so man.macros -.HS Tk_GetPixels tkc +.TH Tk_GetPixels 3 "" Tk "Tk Library Procedures" .BS .SH NAME -.VS Tk_GetPixels, Tk_GetScreenMM \- translate between strings and screen units .SH SYNOPSIS .nf @@ -88,4 +74,3 @@ in \fIinterp->result\fR. .SH KEYWORDS centimeters, convert, inches, millimeters, pixels, points, screen units -.VE diff --git a/tk4.2/doc/GetPixmap.3 b/tk4.2/doc/GetPixmap.3 new file mode 100644 index 0000000..f5d030e --- /dev/null +++ b/tk4.2/doc/GetPixmap.3 @@ -0,0 +1,56 @@ +'\" +'\" Copyright (c) 1990 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) GetPixmap.3 1.7 96/03/26 18:11:47 +'\" +.so man.macros +.TH Tk_GetPixmap 3 4.0 Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_GetPixmap, Tk_FreePixmap \- allocate and free pixmaps +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +Pixmap +\fBTk_GetPixmap(\fIdisplay, d, width, height, depth\fB)\fR +.sp +\fBTk_FreePixmap(\fIdisplay, pixmap\fB)\fR +.SH ARGUMENTS +.AS "Drawable" *pixelPtr +.AP Display *display in +X display for the pixmap. +.AP Drawable d in +Pixmap or window where the new pixmap will be used for drawing. +.AP "int" width in +Width of pixmap. +.AP "int" height in +Height of pixmap. +.AP "int" depth in +Number of bits per pixel in pixmap. +.AP Pixmap pixmap in +Pixmap to destroy. +.BE + +.SH DESCRIPTION +.PP +These procedures are identical to the Xlib procedures \fBXCreatePixmap\fR +and \fBXFreePixmap\fR, except that they have extra code to manage X +resource identifiers so that identifiers for deleted pixmaps can be +reused in the future. +It is important for Tk applications to use these procedures rather +than \fBXCreatePixmap\fR and \fBXFreePixmap\fR; otherwise long-running +applications may run out of resource identifiers. +.PP +\fBTk_GetPixmap\fR creates a pixmap suitable for drawing in \fId\fR, +with dimensions given by \fIwidth\fR, \fIheight\fR, and \fIdepth\fR, +and returns its identifier. +\fBTk_FreePixmap\fR destroys the pixmap given by \fIpixmap\fR and makes +its resource identifier available for reuse. + +.SH KEYWORDS +pixmap, resource identifier diff --git a/tk3.6/doc/GetRelief.3 b/tk4.2/doc/GetRelief.3 similarity index 58% rename from tk3.6/doc/GetRelief.3 rename to tk4.2/doc/GetRelief.3 index fbe7469..20a2b68 100644 --- a/tk3.6/doc/GetRelief.3 +++ b/tk4.2/doc/GetRelief.3 @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1990 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/wish/man/RCS/GetRelief.3,v 1.5 93/04/01 09:41:37 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) GetRelief.3 1.10 96/03/26 18:12:01 '\" .so man.macros -.HS Tk_GetRelief tkc +.TH Tk_GetRelief 3 "" Tk "Tk Library Procedures" .BS .SH NAME Tk_GetRelief, Tk_NameOfRelief \- translate between strings and relief values @@ -46,9 +33,7 @@ Pointer to location in which to store relief value corresponding to \fIname\fR. .AP int relief in Relief value (one of TK_RELIEF_FLAT, TK_RELIEF_RAISED, TK_RELIEF_SUNKEN, -.VS TK_RELIEF_GROOVE, or TK_RELIEF_RIDGE). -.VE .BE .SH DESCRIPTION @@ -56,9 +41,7 @@ TK_RELIEF_GROOVE, or TK_RELIEF_RIDGE). \fBTk_GetRelief\fR places in \fI*reliefPtr\fR the relief value corresponding to \fIname\fR. This value will be one of TK_RELIEF_FLAT, TK_RELIEF_RAISED, TK_RELIEF_SUNKEN, -.VS TK_RELIEF_GROOVE, or TK_RELIEF_RIDGE. -.VE Under normal circumstances the return value is TCL_OK and \fIinterp\fR is unused. If \fIname\fR doesn't contain one of the valid relief names @@ -68,9 +51,7 @@ TCL_ERROR is returned, and \fI*reliefPtr\fR is unmodified. .PP \fBTk_NameOfRelief\fR is the logical inverse of \fBTk_GetRelief\fR. Given a relief value it returns the corresponding string (``flat'', -.VS ``raised'', ``sunken'', ``groove'', or ``ridge''). -.VE If \fIrelief\fR isn't a legal relief value, then ``unknown relief'' is returned. diff --git a/tk4.2/doc/GetRootCrd.3 b/tk4.2/doc/GetRootCrd.3 new file mode 100644 index 0000000..c9dea3c --- /dev/null +++ b/tk4.2/doc/GetRootCrd.3 @@ -0,0 +1,43 @@ +'\" +'\" Copyright (c) 1990 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) GetRootCrd.3 1.9 96/03/26 18:12:16 +'\" +.so man.macros +.TH Tk_GetRootCoords 3 "" Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_GetRootCoords \- Compute root-window coordinates of window +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +\fBTk_GetRootCoords\fR(\fItkwin, xPtr, yPtr\fR) +.SH ARGUMENTS +.AS Tk_Window tkwin +.AP Tk_Window tkwin in +Token for window. +.AP int *xPtr out +Pointer to location in which to store root-window x-coordinate +corresponding to left edge of \fItkwin\fR's border. +.AP int *yPtr out +Pointer to location in which to store root-window y-coordinate +corresponding to top edge of \fItkwin\fR's border. +.BE + +.SH DESCRIPTION +.PP +This procedure scans through the structural information maintained +by Tk to compute the root-window coordinates corresponding to +the upper-left corner of \fItkwin\fR's border. If \fItkwin\fR has +no border, then \fBTk_GetRootCoords\fR returns the root-window +coordinates corresponding to location (0,0) in \fItkwin\fR. +\fBTk_GetRootCoords\fR is relatively efficient, since it doesn't have to +communicate with the X server. + +.SH KEYWORDS +coordinates, root window diff --git a/tk4.2/doc/GetScroll.3 b/tk4.2/doc/GetScroll.3 new file mode 100644 index 0000000..72b97f7 --- /dev/null +++ b/tk4.2/doc/GetScroll.3 @@ -0,0 +1,65 @@ +'\" +'\" Copyright (c) 1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) GetScroll.3 1.7 96/03/26 18:12:29 +'\" +.so man.macros +.TH Tk_GetScrollInfo 3 4.0 Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_GetScrollInfo \- parse arguments for scrolling commands +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +int +\fBTk_GetScrollInfo(\fIinterp, argc, argv, dblPtr, intPtr\fB)\fR +.SH ARGUMENTS +.AS "Tcl_Interp" *dblPtr +.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 +Argument strings. These represent the entire widget command, of +which the first word is typically the widget name and the second +word is typically \fBxview\fR or \fByview\fR. This procedure parses +arguments starting with \fIargv\fR[2]. +.AP double *dblPtr out +Filled in with fraction from \fBmoveto\fR option, if any. +.AP int *intPtr out +Filled in with line or page count from \fBscroll\fR option, if any. +The value may be negative. +.BE + +.SH DESCRIPTION +.PP +\fBTk_GetScrollInfo\fR parses the arguments expected by widget +scrolling commands such as \fBxview\fR and \fByview\fR. +It receives the entire list of words that make up a widget command +and parses the words starting with \fIargv\fR[2]. +The words starting with \fIargv\fR[2] must have one of the following forms: +.CS +\fBmoveto \fIfraction\fR +\fBscroll \fInumber\fB units\fR +\fBscroll \fInumber\fB pages\fR +.CE +.LP +Any of the \fBmoveto\fR, \fBscroll\fR, \fBunits\fR, and \fBpages\fR +keywords may be abbreviated. +If \fIargv\fR has the \fBmoveto\fR form, \fBTK_SCROLL_MOVETO\fR +is returned as result and \fI*dblPtr\fR is filled in with the +\fIfraction\fR argument to the command, which must be a proper real +value. +If \fIargv\fR has the \fBscroll\fR form, \fBTK_SCROLL_UNITS\fR +or \fBTK_SCROLL_PAGES\fR is returned and \fI*intPtr\fR is filled +in with the \fInumber\fR value, which must be a proper integer. +If an error occurs in parsing the arguments, \fBTK_SCROLL_ERROR\fR +is returned and an error message is left in \fIinterp->result\fR. + +.SH KEYWORDS +parse, scrollbar, scrolling command, xview, yview diff --git a/tk4.2/doc/GetSelect.3 b/tk4.2/doc/GetSelect.3 new file mode 100644 index 0000000..f0780cc --- /dev/null +++ b/tk4.2/doc/GetSelect.3 @@ -0,0 +1,79 @@ +'\" +'\" Copyright (c) 1990-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) GetSelect.3 1.16 96/08/27 13:21:28 +'\" +.so man.macros +.TH Tk_GetSelection 3 4.0 Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_GetSelection \- retrieve the contents of a selection +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +int +\fBTk_GetSelection\fR(\fIinterp, tkwin, selection, target, proc, clientData\fR) +.SH ARGUMENTS +.AS Tk_GetSelProc clientData +.AP Tcl_Interp *interp in +Interpreter to use for reporting errors. +.AP Tk_Window tkwin in +Window on whose behalf to retrieve the selection (determines +display from which to retrieve). +.AP Atom selection in +The name of the selection to be retrieved. +.AP Atom target in +Form in which to retrieve selection. +.AP Tk_GetSelProc *proc in +Procedure to invoke to process pieces of the selection as they +are retrieved. +.AP ClientData clientData in +Arbitrary one-word value to pass to \fIproc\fR. +.BE + +.SH DESCRIPTION +.PP +\fBTk_GetSelection\fR retrieves the selection specified by the atom +\fIselection\fR in the format specified by \fItarget\fR. The +selection may actually be retrieved in several pieces; as each piece +is retrieved, \fIproc\fR is called to process the piece. \fIProc\fR +should have arguments and result that match the type +\fBTk_GetSelProc\fR: +.CS +typedef int Tk_GetSelProc( + ClientData \fIclientData\fR, + Tcl_Interp *\fIinterp\fR, + char *\fIportion\fR); +.CE +The \fIclientData\fR and \fIinterp\fR parameters to \fIproc\fR +will be copies of the corresponding arguments to +\fBTk_GetSelection\fR. \fIPortion\fR will be a pointer to +a string containing part or all of the selection. For large +selections, \fIproc\fR will be called several times with successive +portions of the selection. The X Inter-Client Communication +Conventions Manual allows a selection to be returned in formats +other than strings, e.g. as an array of atoms or integers. If +this happens, Tk converts the selection back into a string +before calling \fIproc\fR. If a selection is returned as an +array of atoms, Tk converts it to a string containing the atom names +separated by white space. For any other format besides string, +Tk converts a selection to a string containing hexadecimal +values separated by white space. +.PP +\fBTk_GetSelection\fR returns to its caller when the selection has +been completely retrieved and processed by \fIproc\fR, or when a +fatal error has occurred (e.g. the selection owner didn't respond +promptly). \fBTk_GetSelection\fR normally returns TCL_OK; if +an error occurs, it returns TCL_ERROR and leaves an error message +in \fIinterp->result\fR. \fIProc\fR should also return either +TCL_OK or TCL_ERROR. If \fIproc\fR encounters an error in dealing with the +selection, it should leave an error message in \fIinterp->result\fR +and return TCL_ERROR; this will abort the selection retrieval. + +.SH KEYWORDS +format, get, selection retrieval diff --git a/tk3.6/doc/GetUid.3 b/tk4.2/doc/GetUid.3 similarity index 53% rename from tk3.6/doc/GetUid.3 rename to tk4.2/doc/GetUid.3 index a273fbe..7c6bb7c 100644 --- a/tk3.6/doc/GetUid.3 +++ b/tk4.2/doc/GetUid.3 @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1990 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/wish/man/RCS/GetUid.3,v 1.5 93/04/01 09:41:40 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) GetUid.3 1.10 96/03/26 18:12:55 '\" .so man.macros -.HS Tk_GetUid tkc +.TH Tk_GetUid 3 "" Tk "Tk Library Procedures" .BS .SH NAME Tk_GetUid, Tk_Uid \- convert from string to unique identifier @@ -35,7 +22,7 @@ Tk_Uid \fBTk_GetUid\fR(\fIstring\fR) .SH ARGUMENTS .AP char *string in -String for which the corresponding unique identifer is +String for which the corresponding unique identifier is desired. .BE diff --git a/tk3.6/doc/GetVRoot.3 b/tk4.2/doc/GetVRoot.3 similarity index 55% rename from tk3.6/doc/GetVRoot.3 rename to tk4.2/doc/GetVRoot.3 index 1c0bbcf..9895e42 100644 --- a/tk3.6/doc/GetVRoot.3 +++ b/tk4.2/doc/GetVRoot.3 @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1990 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/wish/man/RCS/GetVRoot.3,v 1.3 93/04/01 09:41:41 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) GetVRoot.3 1.10 96/08/27 13:21:28 '\" .so man.macros -.HS Tk_GetVRootGeometry tkc +.TH Tk_GetVRootGeometry 3 4.0 Tk "Tk Library Procedures" .BS .SH NAME Tk_GetVRootGeometry \- Get location and size of virtual root for window @@ -29,7 +16,7 @@ Tk_GetVRootGeometry \- Get location and size of virtual root for window .nf \fB#include \fR .sp -\fBTk_GetVRootGeometry(\fItkwin, xPtr, yPtr, widthPtr, heightPtr\fB) +\fBTk_GetVRootGeometry(\fItkwin, xPtr, yPtr, widthPtr, heightPtr\fB)\fR .SH ARGUMENTS .AS Tk_Window heightPtr .AP Tk_Window tkwin in @@ -38,9 +25,9 @@ Token for window whose virtual root is to be queried. Points to word in which to store x-offset of virtual root. .AP int yPtr out Points to word in which to store y-offset of virtual root. -.AP "unsigned int" widthPtr out +.AP "int" widthPtr out Points to word in which to store width of virtual root. -.AP "unsigned int" heightPtr out +.AP "int" heightPtr out Points to word in which to store height of virtual root. .BE diff --git a/tk4.2/doc/GetVisual.3 b/tk4.2/doc/GetVisual.3 new file mode 100644 index 0000000..cf54c2c --- /dev/null +++ b/tk4.2/doc/GetVisual.3 @@ -0,0 +1,98 @@ +'\" +'\" Copyright (c) 1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) GetVisual.3 1.9 96/03/26 18:13:20 +'\" +.so man.macros +.TH Tk_GetVisual 3 4.0 Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_GetVisual \- translate from string to visual +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +Visual * +\fBTk_GetVisual(\fIinterp, tkwin, string, depthPtr, colormapPtr\fB)\fR +.SH ARGUMENTS +.AS "Tcl_Interp" *colormapPtr +.AP Tcl_Interp *interp in +Interpreter to use for error reporting. +.AP Tk_Window tkwin in +Token for window in which the visual will be used. +.AP char *string in +String that identifies the desired visual. See below for +valid formats. +.AP int *depthPtr out +Depth of returned visual gets stored here. +.AP Colormap *colormapPtr out +If non-NULL then a suitable colormap for visual is found and its +identifier is stored here. +.BE + +.SH DESCRIPTION +.PP +\fBTk_GetVisual\fR takes a string description of a visual and +finds a suitable X Visual for use in \fItkwin\fR, if there is one. +It returns a pointer to the X Visual structure for the visual +and stores the number of bits per pixel for it at \fI*depthPtr\fR. +If \fIstring\fR is unrecognizable or if no suitable visual could +be found, then NULL is returned and \fBTk_GetVisual\fR leaves +an error message in \fIinterp->result\fR. +If \fIcolormap\fR is non-NULL then \fBTk_GetVisual\fR +also locates an appropriate colormap for use with the result visual +and stores its X identifier at \fI*colormapPtr\fR. +.PP +The \fIstring\fR argument specifies the desired visual in one +of the following ways: +.TP 15 +\fIclass depth\fR +The string consists of a class name followed by an integer depth, +with any amount of white space (including none) in between. +\fIclass\fR selects what sort of visual is desired and must be one of +\fBdirectcolor\fR, \fBgrayscale\fR, \fBgreyscale\fR, \fBpseudocolor\fR, +\fBstaticcolor\fR, \fBstaticgray\fR, \fBstaticgrey\fR, or +\fBtruecolor\fR, or a unique abbreviation. +\fIdepth\fR specifies how many bits per pixel are needed for the +visual. +If possible, \fBTk_GetVisual\fR will return a visual with this depth; +if there is no visual of the desired depth then \fBTk_GetVisual\fR +looks first for a visual with greater depth, then one with less +depth. +.TP 15 +\fBdefault\fR +Use the default visual for \fItkwin\fR's screen. +.TP 15 +\fIpathName\fR +Use the visual for the window given by \fIpathName\fR. +\fIpathName\fR must be the name of a window on the same screen +as \fItkwin\fR. +.TP 15 +\fInumber\fR +Use the visual whose X identifier is \fInumber\fR. +.TP 15 +\fBbest\fR ?\fIdepth\fR? +Choose the ``best possible'' visual, using the following rules, in +decreasing order of priority: +(a) a visual that has exactly the desired depth is best, followed +by a visual with greater depth than requested (but as little extra +as possible), followed by a visual with less depth than requested +(but as great a depth as possible); +(b) if no \fIdepth\fR is specified, then the deepest available visual +is chosen; +(c) \fBpseudocolor\fR is better than \fBtruecolor\fR or \fBdirectcolor\fR, +which are better than \fBstaticcolor\fR, which is better than +\fBstaticgray\fR or \fBgrayscale\fR; +(d) the default visual for the screen is better than any other visual. + +.SH CREDITS +.PP +The idea for \fBTk_GetVisual\fR, and the first implementation, came +from Paul Mackerras. + +.SH KEYWORDS +colormap, screen, visual diff --git a/tk4.2/doc/HandleEvent.3 b/tk4.2/doc/HandleEvent.3 new file mode 100644 index 0000000..4fb0a7f --- /dev/null +++ b/tk4.2/doc/HandleEvent.3 @@ -0,0 +1,49 @@ +'\" +'\" Copyright (c) 1990-1992 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) HandleEvent.3 1.6 96/03/26 18:13:34 +'\" +.so man.macros +.TH Tk_HandleEvent 3 "" Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_HandleEvent \- invoke event handlers for window system events +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +\fBTk_HandleEvent\fR(\fIeventPtr\fR) +.SH ARGUMENTS +.AS XEvent *eventPtr +.AP XEvent *eventPtr in +Pointer to X event to dispatch to relevant handler(s). +.BE + +.SH DESCRIPTION +.PP +\fBTk_HandleEvent\fR is a lower-level procedure that deals with window +events. It is called by \fBTk_ServiceEvent\fR (and indirectly by +\fBTk_DoOneEvent\fR), and in a few other cases within Tk. +It makes callbacks to any window event +handlers (created by calls to \fBTk_CreateEventHandler\fR) +that match \fIeventPtr\fR and then returns. In some cases +it may be useful for an application to bypass the Tk event +queue and call \fBTk_HandleEvent\fR directly instead of +calling \fBTk_QueueEvent\fR followed by +\fBTk_ServiceEvent\fR. +.PP +This procedure may be invoked recursively. For example, +it is possible to invoke \fBTk_HandleEvent\fR recursively +from a handler called by \fBTk_HandleEvent\fR. This sort +of operation is useful in some modal situations, such +as when a +notifier has been popped up and an application wishes to +wait for the user to click a button in the notifier before +doing anything else. + +.SH KEYWORDS +callback, event, handler, window diff --git a/tk4.2/doc/IdToWindow.3 b/tk4.2/doc/IdToWindow.3 new file mode 100644 index 0000000..fd7af7d --- /dev/null +++ b/tk4.2/doc/IdToWindow.3 @@ -0,0 +1,36 @@ +'\" +'\" Copyright (c) 1995-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) IdToWindow.3 1.4 96/03/26 18:14:08 +'\" +.so man.macros +.TH Tk_IdToWindow 3 4.0 Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_IdToWindow \- Find Tk's window information for an X window +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +Tk_Window +\fBTk_IdToWindow\fR(\fIdisplay, window\fR) +.SH ARGUMENTS +.AS Tk_Window display +.AP Display *display in +X display containing the window. +.AP Window window in +X id for window. +.BE + +.SH DESCRIPTION +.PP +Given an X window identifier and the X display it corresponds to, +this procedure returns the corresponding Tk_Window handle. +If there is no Tk_Window corresponding to \fIwindow\fR then +NULL is returned. + +.SH KEYWORDS +X window id diff --git a/tk4.2/doc/ImgChanged.3 b/tk4.2/doc/ImgChanged.3 new file mode 100644 index 0000000..5210e82 --- /dev/null +++ b/tk4.2/doc/ImgChanged.3 @@ -0,0 +1,69 @@ +'\" +'\" Copyright (c) 1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) ImgChanged.3 1.6 96/03/26 18:14:18 +'\" +.so man.macros +.TH Tk_ImageChanged 3 4.0 Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_ImageChanged \- notify widgets that image needs to be redrawn +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +\fBTk_ImageChanged\fR(\fIimageMaster, x, y, width, height, imageWidth, imageHeight\fR) +.SH ARGUMENTS +.AS Tk_ImageMaster imageHeight +.AP Tk_ImageMaster imageMaster in +Token for image, which was passed to image's \fIcreateProc\fR when +the image was created. +.AP int x in +X-coordinate of upper-left corner of region that needs redisplay (measured +from upper-left corner of image). +.AP int y in +Y-coordinate of upper-left corner of region that needs redisplay (measured +from upper-left corner of image). +.AP "int" width in +Width of region that needs to be redrawn, in pixels. +.AP "int" height in +Height of region that needs to be redrawn, in pixels. +.AP "int" imageWidth in +Current width of image, in pixels. +.AP "int" imageHeight in +Current height of image, in pixels. +.BE + +.SH DESCRIPTION +.PP +An image manager calls \fBTk_ImageChanged\fR for an image +whenever anything happens that requires the image to be redrawn. +As a result of calling \fBTk_ImageChanged\fR, any widgets using +the image are notified so that they can redisplay themselves +appropriately. +The \fIimageMaster\fR argument identifies the image, and +\fIx\fR, \fIy\fR, \fIwidth\fR, and \fIheight\fR +specify a rectangular region within the image that needs to +be redrawn. +\fIimageWidth\fR and \fIimageHeight\fR specify the image's (new) size. +.PP +An image manager should call \fBTk_ImageChanged\fR during +its \fIcreateProc\fR to specify the image's initial size and to +force redisplay if there are existing instances for the image. +If any of the pixel values in the image should change later on, +\fBTk_ImageChanged\fR should be called again with \fIx\fR, \fIy\fR, +\fIwidth\fR, and \fIheight\fR values that cover all the pixels +that changed. +If the size of the image should change, then \fBTk_ImageChanged\fR +must be called to indicate the new size, even if no pixels +need to be redisplayed. + +.SH "SEE ALSO" +Tk_CreateImageType + +.SH KEYWORDS +images, redisplay, image size changes diff --git a/tk3.6/doc/InternAtom.3 b/tk4.2/doc/InternAtom.3 similarity index 59% rename from tk3.6/doc/InternAtom.3 rename to tk4.2/doc/InternAtom.3 index 15357e9..e6eff2c 100644 --- a/tk3.6/doc/InternAtom.3 +++ b/tk4.2/doc/InternAtom.3 @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1990 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/wish/man/RCS/InternAtom.3,v 1.4 93/04/01 09:41:41 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) InternAtom.3 1.8 96/03/26 18:14:31 '\" .so man.macros -.HS Tk_InternAtom tkc +.TH Tk_InternAtom 3 "" Tk "Tk Library Procedures" .BS .SH NAME Tk_InternAtom, Tk_GetAtomName \- manage cache of X atoms diff --git a/tk4.2/doc/MainLoop.3 b/tk4.2/doc/MainLoop.3 new file mode 100644 index 0000000..339f7e1 --- /dev/null +++ b/tk4.2/doc/MainLoop.3 @@ -0,0 +1,32 @@ +'\" +'\" Copyright (c) 1990-1992 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) MainLoop.3 1.3 96/03/26 18:15:01 +'\" +.so man.macros +.TH Tk_MainLoop 3 "" Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_MainLoop \- loop for events until all windows are deleted +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +\fBTk_MainLoop\fR() +.BE + +.SH DESCRIPTION +.PP +\fBTk_MainLoop\fR is a procedure that loops repeatedly calling +\fBTcl_DoOneEvent\fR. It returns only when there are no applications +left in this process (i.e. no main windows exist anymore). Most +windowing applications will call \fBTk_MainLoop\fR after +initialization; the main execution of the application will consist +entirely of callbacks invoked via \fBTcl_DoOneEvent\fR. + +.SH KEYWORDS +application, event, main loop diff --git a/tk4.2/doc/MainWin.3 b/tk4.2/doc/MainWin.3 new file mode 100644 index 0000000..4144812 --- /dev/null +++ b/tk4.2/doc/MainWin.3 @@ -0,0 +1,36 @@ +'\" +'\" Copyright (c) 1990 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) MainWin.3 1.5 96/03/26 18:15:15 +'\" +.so man.macros +.TH Tk_MainWindow 3 7.0 Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_MainWindow \- find the main window for an application +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +Tk_Window +\fBTk_MainWindow\fR(\fIinterp\fR) +.SH ARGUMENTS +.AS Tcl_Interp *pathName +.AP Tcl_Interp *interp in/out +Interpreter associated with the application. +.BE + +.SH DESCRIPTION +.PP +If \fIinterp\fR is associated with a Tk application then \fBTk_MainWindow\fR +returns the application's main window. +If there is no Tk application associated with \fIinterp\fR then +\fBTk_MainWindow\fR returns NULL and leaves an error message +in \fIinterp->result\fR. + +.SH KEYWORDS +application, main window diff --git a/tk4.2/doc/MaintGeom.3 b/tk4.2/doc/MaintGeom.3 new file mode 100644 index 0000000..159b3b7 --- /dev/null +++ b/tk4.2/doc/MaintGeom.3 @@ -0,0 +1,102 @@ +'\" +'\" Copyright (c) 1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) MaintGeom.3 1.7 96/03/26 18:15:30 +'\" +.so man.macros +.TH Tk_MaintainGeometry 3 4.0 Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_MaintainGeometry, Tk_UnmaintainGeometry \- maintain geometry of one window relative to another +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +\fBTk_MaintainGeometry\fR(\fIslave, master, x, y, width, height\fR) +.sp +\fBTk_UnmaintainGeometry\fR(\fIslave, master\fR) +.SH ARGUMENTS +.AS Tk_Window master +.AP Tk_Window slave in +Window whose geometry is to be controlled. +.AP Tk_Window master in +Window relative to which \fIslave\fR's geometry will be controlled. +.AP int x in +Desired x-coordinate of \fIslave\fR in \fImaster\fR, measured in pixels +from the inside of \fImaster\fR's left border to the outside of +\fIslave\fR's left border. +.AP int y in +Desired y-coordinate of \fIslave\fR in \fImaster\fR, measured in pixels +from the inside of \fImaster\fR's top border to the outside of +\fIslave\fR's top border. +.AP int width in +Desired width for \fIslave\fR, in pixels. +.AP int height in +Desired height for \fIslave\fR, in pixels. +.BE + +.SH DESCRIPTION +.PP +\fBTk_MaintainGeometry\fR and \fBTk_UnmaintainGeometry\fR make it +easier for geometry managers to deal with slaves whose masters are not +their parents. +Three problems arise if the master for a slave is not its parent: +.IP [1] +The x- and y-position of the slave must be translated from the +coordinate system of the master to that of the parent before +positioning the slave. +.IP [2] +If the master window, or any of its ancestors up to the slave's +parent, is moved, then the slave must be repositioned within its +parent in order to maintain the correct position relative to the +master. +.IP [3] +If the master or one of its ancestors is mapped or unmapped, then +the slave must be mapped or unmapped to correspond. +.LP +None of these problems is an issue if the parent and master are +the same. For example, if the master or one of its ancestors +is unmapped, the slave is automatically removed by the screen +by X. +.PP +\fBTk_MaintainGeometry\fR deals with these problems for slaves +whose masters aren't their parents. +\fBTk_MaintainGeometry\fR is typically called by a window manager +once it has decided where a slave should be positioned relative +to its master. +\fBTk_MaintainGeometry\fR translates the coordinates to the +coordinate system of \fIslave\fR's parent and then moves and +resizes the slave appropriately. +Furthermore, it remembers the desired position and creates event +handlers to monitor the master and all of its ancestors up +to (but not including) the slave's parent. +If any of these windows is moved, mapped, or unmapped, +the slave will be adjusted so that it is mapped only when the +master is mapped and its geometry relative to the master +remains as specified by \fIx\fR, \fIy\fR, \fIwidth\fR, and +\fIheight\fR. +.PP +When a window manager relinquishes control over a window, or +if it decides that it does not want the window to appear on the +screen under any conditions, it calls \fBTk_UnmaintainGeometry\fR. +\fBTk_UnmaintainGeometry\fR unmaps the window and cancels any +previous calls to \fBTk_MaintainGeometry\fR for the +\fImaster\fR\-\fIslave\fR pair, so that the slave's +geometry and mapped state are no longer maintained +automatically. +\fBTk_UnmaintainGeometry\fR need not be called by a geometry +manager if the slave, the master, or any of the master's ancestors +is destroyed: Tk will call it automatically. +.PP +If \fBTk_MaintainGeometry\fR is called repeatedly for the same +\fImaster\fR\-\fIslave\fR pair, the information from the most +recent call supersedes any older information. +If \fBTk_UnmaintainGeometry\fR is called for a \fImaster\fR\-\fIslave\fR +pair that is isn't currently managed, the call has no effect. + +.SH KEYWORDS +geometry manager, map, master, parent, position, slave, unmap diff --git a/tk4.2/doc/ManageGeom.3 b/tk4.2/doc/ManageGeom.3 new file mode 100644 index 0000000..67ca5b4 --- /dev/null +++ b/tk4.2/doc/ManageGeom.3 @@ -0,0 +1,94 @@ +'\" +'\" Copyright (c) 1990-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) ManageGeom.3 1.18 96/08/27 13:21:30 +'\" +.so man.macros +.TH Tk_ManageGeometry 3 4.0 Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_ManageGeometry \- arrange to handle geometry requests for a window +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +\fBTk_ManageGeometry\fR(\fItkwin, mgrPtr, clientData\fR) +.SH ARGUMENTS +.AS Tk_GeometryProc clientData +.AP Tk_Window tkwin in +Token for window to be managed. +.AP Tk_GeomMgr *mgrPtr in +Pointer to data structure containing information about the +geometry manager, or NULL to indicate that \fItkwin\fR's geometry +shouldn't be managed anymore. +The data structure pointed to by \fImgrPtr\fR must be static: +Tk keeps a reference to it as long as the window is managed. +.AP ClientData clientData in +Arbitrary one-word value to pass to geometry manager callbacks. +.BE + +.SH DESCRIPTION +.PP +\fBTk_ManageGeometry\fR arranges for a particular geometry manager, +described by the \fImgrPtr\fR argument, to control the geometry +of a particular slave window, given by \fItkwin\fR. +If \fItkwin\fR was previously managed by some other geometry manager, +the previous manager loses control in favor of the new one. +If \fImgrPtr\fR is NULL, geometry management is cancelled for +\fItkwin\fR. +.PP +The structure pointed to by \fImgrPtr\fR contains information about +the geometry manager: +.CS +typedef struct { + char *\fIname\fR; + Tk_GeomRequestProc *\fIrequestProc\fR; + Tk_GeomLostSlaveProc *\fIlostSlaveProc\fR; +} Tk_GeomMgr; +.CE +The \fIname\fR field is the textual name for the geometry manager, +such as \fBpack\fR or \fBplace\fR; this value will be returned +by the command \fBwinfo manager\fR. +.PP +\fIrequestProc\fR is a procedure in the geometry manager that +will be invoked whenever \fBTk_GeometryRequest\fR is called by the +slave to change its desired geometry. +\fIrequestProc\fR should have arguments and results that match the +type \fBTk_GeomRequestProc\fR: +.CS +typedef void Tk_GeomRequestProc( + ClientData \fIclientData\fR, + Tk_Window \fItkwin\fR); +.CE +The parameters to \fIrequestProc\fR will be identical to the +corresponding parameters passed to \fBTk_ManageGeometry\fR. +\fIclientData\fR usually points to a data +structure containing application-specific information about +how to manage \fItkwin\fR's geometry. +.PP +The \fIlostSlaveProc\fR field of \fImgrPtr\fR points to another +procedure in the geometry manager. +Tk will invoke \fIlostSlaveProc\fR if some other manager +calls \fBTk_ManageGeometry\fR to claim +\fItkwin\fR away from the current geometry manager. +\fIlostSlaveProc\fR is not invoked if \fBTk_ManageGeometry\fR is +called with a NULL value for \fImgrPtr\fR (presumably the current +geometry manager has made this call, so it already knows that the +window is no longer managed), nor is it called if \fImgrPtr\fR +is the same as the window's current geometry manager. +\fIlostSlaveProc\fR should have +arguments and results that match the following prototype: +.CS +typedef void Tk_GeomLostSlaveProc( + ClientData \fIclientData\fR, + Tk_Window \fItkwin\fR); +.CE +The parameters to \fIlostSlaveProc\fR will be identical to the +corresponding parameters passed to \fBTk_ManageGeometry\fR. + +.SH KEYWORDS +callback, geometry, managed, request, unmanaged diff --git a/tk3.6/doc/MapWindow.3 b/tk4.2/doc/MapWindow.3 similarity index 55% rename from tk3.6/doc/MapWindow.3 rename to tk4.2/doc/MapWindow.3 index ce29052..77188ce 100644 --- a/tk3.6/doc/MapWindow.3 +++ b/tk4.2/doc/MapWindow.3 @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1990 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/wish/man/RCS/MapWindow.3,v 1.7 93/04/01 09:41:43 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) MapWindow.3 1.11 96/03/26 18:15:57 '\" .so man.macros -.HS Tk_MapWindow tkc +.TH Tk_MapWindow 3 "" Tk "Tk Library Procedures" .BS .SH NAME Tk_MapWindow, Tk_UnmapWindow \- map or unmap a window diff --git a/tk3.6/doc/MoveToplev.3 b/tk4.2/doc/MoveToplev.3 similarity index 61% rename from tk3.6/doc/MoveToplev.3 rename to tk4.2/doc/MoveToplev.3 index 12635ed..4aec2b7 100644 --- a/tk3.6/doc/MoveToplev.3 +++ b/tk4.2/doc/MoveToplev.3 @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1990-1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/wish/man/RCS/MoveToplev.3,v 1.3 93/04/01 09:41:44 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) MoveToplev.3 1.8 96/03/26 18:16:11 '\" .so man.macros -.HS Tk_MoveToplevelWindow tkc +.TH Tk_MoveToplevelWindow 3 "" Tk "Tk Library Procedures" .BS .SH NAME Tk_MoveToplevelWindow \- Adjust the position of a top-level window @@ -29,7 +16,7 @@ Tk_MoveToplevelWindow \- Adjust the position of a top-level window .nf \fB#include \fR .sp -\fBTk_MoveToplevelWindow(\fItkwin, x, y\fB) +\fBTk_MoveToplevelWindow(\fItkwin, x, y\fB)\fR .SH ARGUMENTS .AS Tk_Window tkwin .AP Tk_Window tkwin in diff --git a/tk3.6/doc/Name.3 b/tk4.2/doc/Name.3 similarity index 72% rename from tk3.6/doc/Name.3 rename to tk4.2/doc/Name.3 index 58181c4..3d7e5b3 100644 --- a/tk3.6/doc/Name.3 +++ b/tk4.2/doc/Name.3 @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1990 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/wish/man/RCS/Name.3,v 1.8 93/04/01 09:41:45 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) Name.3 1.13 96/03/26 18:16:25 '\" .so man.macros -.HS Tk_Name tkc +.TH Tk_Name 3 "" Tk "Tk Library Procedures" .BS .SH NAME Tk_Name, Tk_PathName, Tk_NameToWindow \- convert between names and window tokens @@ -62,7 +49,7 @@ passed to \fBTk_CreateMainWindow\fR or \fBTk_CreateTopLevelWindow\fR or \fBTk_CreateChildWindow\fR when the window was created. The value is returned as a Tk_Uid, which may be used just like a string pointer but also has -the properties of a unique identfier (see the manual entry for +the properties of a unique identifier (see the manual entry for \fBTk_GetUid\fR for details). .PP The \fBTk_PathName\fR macro returns a diff --git a/tk4.2/doc/NameOfImg.3 b/tk4.2/doc/NameOfImg.3 new file mode 100644 index 0000000..4fd814c --- /dev/null +++ b/tk4.2/doc/NameOfImg.3 @@ -0,0 +1,34 @@ +'\" +'\" Copyright (c) 1995-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) NameOfImg.3 1.4 96/03/26 18:16:37 +'\" +.so man.macros +.TH Tk_NameOfImage 3 4.0 Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_NameOfImage \- Return name of image. +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +char * +\fBTk_NameOfImage\fR(\fItypePtr\fR) +.SH ARGUMENTS +.AS Tk_ImageMaster *masterPtr +.AP Tk_ImageMaster *masterPtr in +Token for image, which was passed to image manager's \fIcreateProc\fR when +the image was created. +.BE + +.SH DESCRIPTION +.PP +This procedure is invoked by image managers to find out the name +of an image. Given the token for the image, it returns the +string name for the image. + +.SH KEYWORDS +image manager, image name diff --git a/tk4.2/doc/OwnSelect.3 b/tk4.2/doc/OwnSelect.3 new file mode 100644 index 0000000..9473c76 --- /dev/null +++ b/tk4.2/doc/OwnSelect.3 @@ -0,0 +1,52 @@ +'\" +'\" Copyright (c) 1990-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) OwnSelect.3 1.16 96/08/27 13:21:31 +'\" +.so man.macros +.TH Tk_OwnSelection 3 4.0 Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_OwnSelection \- make a window the owner of the primary selection +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +\fBTk_OwnSelection\fR(\fItkwin, selection, proc, clientData\fR) +.SH ARGUMENTS +.AS Tk_LostSelProc clientData +.AP Tk_Window tkwin in +Window that is to become new selection owner. +.AP Atom selection in +The name of the selection to be owned, such as XA_PRIMARY. +.AP Tk_LostSelProc *proc in +Procedure to invoke when \fItkwin\fR loses selection ownership later. +.AP ClientData clientData in +Arbitrary one-word value to pass to \fIproc\fR. +.BE + +.SH DESCRIPTION +.PP +\fBTk_OwnSelection\fR arranges for \fItkwin\fR to become the +new owner of the selection specified by the atom +\fIselection\fR. After this call completes, future requests +for the selection will be directed to handlers created for +\fItkwin\fR using \fBTk_CreateSelHandler\fR. When \fItkwin\fR +eventually loses the selection ownership, \fIproc\fR will be +invoked so that the window can clean itself up (e.g. by +unhighlighting the selection). \fIProc\fR should have arguments and +result that match the type \fBTk_LostSelProc\fR: +.CS +typedef void Tk_LostSelProc(ClientData \fIclientData\fR); +.CE +The \fIclientData\fR parameter to \fIproc\fR is a copy of the +\fIclientData\fR argument given to \fBTk_OwnSelection\fR, and is +usually a pointer to a data structure containing application-specific +information about \fItkwin\fR. + +.SH KEYWORDS +own, selection owner diff --git a/tk3.6/doc/ParseArgv.3 b/tk4.2/doc/ParseArgv.3 similarity index 86% rename from tk3.6/doc/ParseArgv.3 rename to tk4.2/doc/ParseArgv.3 index b2a01f4..790d748 100644 --- a/tk3.6/doc/ParseArgv.3 +++ b/tk4.2/doc/ParseArgv.3 @@ -1,35 +1,22 @@ '\" '\" Copyright (c) 1990-1992 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/wish/man/RCS/ParseArgv.3,v 1.8 93/08/27 17:11:49 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) ParseArgv.3 1.16 96/03/18 14:25:51 '\" .so man.macros -.HS Tk_ParseArgv tkc +.TH Tk_ParseArgv 3 "" Tk "Tk Library Procedures" .BS .SH NAME Tk_ParseArgv \- process command-line options .SH SYNOPSIS +.nf \fB#include \fR .sp int -.br \fBTk_ParseArgv\fR(\fIinterp, tkwin, argcPtr, argv, argTable, flags\fR) .SH ARGUMENTS .AS Tk_ArgvInfo *argTable @@ -50,10 +37,8 @@ type TK_ARGV_END. .AP int flags in If non-zero, then it specifies one or more flags that control the parsing of arguments. Different flags may be OR'ed together. -.na The flags currently defined are TK_ARGV_DONT_SKIP_FIRST_ARG, TK_ARGV_NO_ABBREV, TK_ARGV_NO_LEFTOVERS, and TK_ARGV_NO_DEFAULTS. -.ad .BE .SH DESCRIPTION .PP @@ -84,17 +69,15 @@ possible causes of errors are explained below. .PP The \fIargTable\fR array specifies the kinds of arguments that are expected; each of its entries has the following structure: -.DS -.ta 2c -\fBtypedef struct\fR { - \fBchar\fR *\fIkey\fR; - \fBint\fR \fItype\fR; - \fBchar\fR *\fIsrc\fR; - \fBchar\fR *\fIdst\fR; - \fBchar\fR *\fIhelp\fR; -\fB} Tk_ArgvInfo;\fR -.DE -.LP +.CS +typedef struct { + char *\fIkey\fR; + int \fItype\fR; + char *\fIsrc\fR; + char *\fIdst\fR; + char *\fIhelp\fR; +} Tk_ArgvInfo; +.CE The \fIkey\fR field is a string such as ``\-display'' or ``\-bg'' that is compared with the values in \fIargv\fR. \fIType\fR indicates how to process an argument that matches \fIkey\fR @@ -215,23 +198,22 @@ In addition, \fBTk_ParseArgv\fR treats \fIdst\fR as the address of an integer value, and stores at \fI*dst\fR the index of the first of the \fBTK_ARGV_REST\fR options in the returned \fIargv\fR. This allows the program to distinguish the \fBTK_ARGV_REST\fR options from other -unprocessed options that preceeded the \fBTK_ARGV_REST\fR. +unprocessed options that preceded the \fBTK_ARGV_REST\fR. .TP \fBTK_ARGV_FUNC\fR For this kind of argument, \fIsrc\fR is treated as the address of a procedure, which is invoked to process the following argument. The procedure should have the following structure: -.DS -.ta 1c 2c 3c 4c 5c 6c -\fBint\fI -func(dst, key, nextArg) - \fBchar\fR *\fIdst\fR; - \fBchar\fR *\fIkey\fR; - \fBchar\fR *\fInextArg\fR; +.RS +.CS +int +\fIfunc(dst, key, nextArg) + char *\fIdst\fR; + char *\fIkey\fR; + char *\fInextArg\fR; { } -.DE -.IP +.CE The \fIdst\fR and \fIkey\fR parameters will contain the corresponding fields from the \fIargTable\fR entry, and \fInextArg\fR will point to the following argument from \fIargv\fR @@ -241,25 +223,25 @@ If \fIfunc\fR uses \fInextArg\fR (so that should return 0 and \fBTkParseArgv\fR will process the following argument in the normal fashion. In either event the matching argument is discarded. +.RE .TP \fBTK_ARGV_GENFUNC\fR This form provides a more general procedural escape. It treats \fIsrc\fR as the address of a procedure, and passes that procedure all of the remaining arguments. The procedure should have the following form: -.DS -.ta 1c 2c 3c 4c 5c 6c -\fBint\fI -genfunc(dst, interp, key, argc, argv) - \fBchar\fR *\fIdst\fR; - \fBTcl_Interp\fR *\fIinterp\fR; - \fBchar\fR *\fIkey\fR; - \fBint\fR \fIargc\fR; - \fBchar\fR **\fIargv\fR; +.RS +.CS +int +\fIgenfunc\fR(dst, interp, key, argc, argv) + char *\fIdst\fR; + Tcl_Interp *\fIinterp\fR; + char *\fIkey\fR; + int \fIargc\fR; + char **\fIargv\fR; { } -.DE -.IP +.CE The \fIdst\fR and \fIkey\fR parameters will contain the corresponding fields from the \fIargTable\fR entry. \fIInterp\fR will be the same as the \fIinterp\fR argument to \fBTcl_ParseArgv\fR. @@ -273,25 +255,30 @@ should return a count of how many arguments are left in \fIargv\fR; an error then it should leave an error message in \fIinterp->result\fR, in the usual Tcl fashion, and return -1; when this happens \fBTk_ParseArgv\fR will abort its processing and return TCL_ERROR. +.RE .SH "FLAGS" -.IP \fBTK_ARGV_DONT_SKIP_FIRST_ARG\fR +.TP +\fBTK_ARGV_DONT_SKIP_FIRST_ARG\fR \fBTk_ParseArgv\fR normally treats \fIargv[0]\fR as a program or command name, and returns it to the caller just as if it hadn't matched \fIargTable\fR. If this flag is given, then \fIargv[0]\fR is not given special treatment. -.IP \fBTK_ARGV_NO_ABBREV\fR +.TP +\fBTK_ARGV_NO_ABBREV\fR Normally, \fBTk_ParseArgv\fR accepts unique abbreviations for \fIkey\fR values in \fIargTable\fR. If this flag is given then only exact matches will be acceptable. -.IP \fBTK_ARGV_NO_LEFTOVERS\fR +.TP +\fBTK_ARGV_NO_LEFTOVERS\fR Normally, \fBTk_ParseArgv\fR returns unrecognized arguments to the caller. If this bit is set in \fIflags\fR then \fBTk_ParseArgv\fR will return an error if it encounters any argument that doesn't match \fIargTable\fR. The only exception to this rule is \fIargv[0]\fR, which will be returned to the caller with no errors as long as TK_ARGV_DONT_SKIP_FIRST_ARG isn't specified. -.IP \fBTK_ARGV_NO_DEFAULTS\fR +.TP +\fBTK_ARGV_NO_DEFAULTS\fR Normally, \fBTk_ParseArgv\fR searches an internal table of standard argument specifiers in addition to \fIargTable\fR. If this bit is set in \fIflags\fR, then \fBTk_ParseArgv\fR will @@ -304,8 +291,8 @@ some sample command lines that use the options. Note the effect on \fIargc\fR and \fIargv\fR; arguments processed by \fBTk_ParseArgv\fR are eliminated from \fIargv\fR, and \fIargc\fR is updated to reflect reduced number of arguments. -.DS L -\fC/* +.CS +/* * Define and set default values for globals. */ int debugFlag = 0; @@ -344,18 +331,18 @@ main(argc, argv) /* * Remainder of the program. */ -}\fR -.DE +} +.CE .PP Note that default values can be assigned to variables named in \fIargTable\fR: the variables will only be overwritten if the particular arguments are present in \fIargv\fR. Here are some example command lines and their effects. -.DS -\fCprog -N 200 infile # just sets the numReps variable to 200 +.CS +prog -N 200 infile # just sets the numReps variable to 200 prog -of out200 infile # sets fileName to reference "out200" -prog -XN 10 infile # sets the debug flag, also sets numReps\fR -.DE +prog -XN 10 infile # sets the debug flag, also sets numReps +.CE In all of the above examples, \fIargc\fR will be set by \fBTk_ParseArgv\fR to 2, \fIargv\fR[0] will be ``prog'', \fIargv\fR[1] will be ``infile'', and \fIargv\fR[2] will be NULL. diff --git a/tk4.2/doc/QWinEvent.3 b/tk4.2/doc/QWinEvent.3 new file mode 100644 index 0000000..5bbb4f4 --- /dev/null +++ b/tk4.2/doc/QWinEvent.3 @@ -0,0 +1,42 @@ +'\" +'\" Copyright (c) 1995-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) QWinEvent.3 1.4 96/03/26 18:17:16 +'\" +.so man.macros +.TH Tk_QueueWindowEvent 3 7.5 Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_QueueWindowEvent \- Add a window event to the Tcl event queue +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +\fBTk_QueueWindowEvent\fR(\fIeventPtr, position\fR) +.SH ARGUMENTS +.AS Tcl_QueuePosition position +.AP XEvent *eventPtr in +An event to add to the event queue. +.AP Tcl_QueuePosition position in +Where to add the new event in the queue: \fBTCL_QUEUE_TAIL\fR, +\fBTCL_QUEUE_HEAD\fR, or \fBTCL_QUEUE_MARK\fR. +.BE + +.SH DESCRIPTION +.PP +This procedure places a window event on Tcl's +internal event queue for eventual servicing. It creates a +Tcl_Event structure, copies the event into that structure, +and calls \fBTcl_QueueEvent\fR to add the event to the queue. +When the event is eventually removed from the queue it is +processed just like all window events. +.PP +The \fIposition\fR argument to \fBTk_QueueWindowEvent\fR has +the same significance as for \fBTcl_QueueEvent\fR; see the +documentation for \fBTcl_QueueEvent\fR for details. + +.SH KEYWORDS +callback, clock, handler, modal timeout diff --git a/tk3.6/doc/Restack.3 b/tk4.2/doc/Restack.3 similarity index 54% rename from tk3.6/doc/Restack.3 rename to tk4.2/doc/Restack.3 index 16da199..6f86c8e 100644 --- a/tk3.6/doc/Restack.3 +++ b/tk4.2/doc/Restack.3 @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1990 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/wish/man/RCS/Restack.3,v 1.1 93/07/07 11:11:05 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) Restack.3 1.5 96/03/26 18:17:32 '\" .so man.macros -.HS Tk_RestackWindow tkc +.TH Tk_RestackWindow 3 "" Tk "Tk Library Procedures" .BS .SH NAME Tk_RestackWindow \- Change a window's position in the stacking order diff --git a/tk4.2/doc/RestrictEv.3 b/tk4.2/doc/RestrictEv.3 new file mode 100644 index 0000000..5daaac4 --- /dev/null +++ b/tk4.2/doc/RestrictEv.3 @@ -0,0 +1,81 @@ +'\" +'\" Copyright (c) 1990 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) RestrictEv.3 1.13 96/08/27 13:21:55 +'\" +.so man.macros +.TH Tk_RestrictEvents 3 "" Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_RestrictEvents \- filter and selectively delay X events +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +Tk_RestrictProc * +\fBTk_RestrictEvents\fR(\fIproc, clientData, prevClientDataPtr\fR) +.SH ARGUMENTS +.AS Tk_RestrictProc **prevClientDataPtr +.AP Tk_RestrictProc *proc in +Predicate procedure to call to filter incoming X events. +NULL means do not restrict events at all. +.AP ClientData clientData in +Arbitrary argument to pass to \fIproc\fR. +.AP ClientData *prevClientDataPtr out +Pointer to place to save argument to previous restrict procedure. +.BE + +.SH DESCRIPTION +.PP +This procedure is useful in certain situations where applications +are only prepared to receive certain X events. After +\fBTk_RestrictEvents\fR is called, \fBTk_DoOneEvent\fR (and +hence \fBTk_MainLoop\fR) will filter X input events through +\fIproc\fR. \fIProc\fR indicates whether a +given event is to be processed immediately, deferred until some +later time (e.g. when the event restriction is lifted), or discarded. +\fIProc\fR +is a procedure with arguments and result that match +the type \fBTk_RestrictProc\fR: +.CS +typedef Tk_RestrictAction Tk_RestrictProc( + ClientData \fIclientData\fR, + XEvent *\fIeventPtr\fR); +.CE +The \fIclientData\fR argument is a copy of the \fIclientData\fR passed +to \fBTk_RestrictEvents\fR; it may be used to provide \fIproc\fR with +information it needs to filter events. The \fIeventPtr\fR points to +an event under consideration. \fIProc\fR returns a restrict action +(enumerated type \fBTk_RestrictAction\fR) that indicates what +\fBTk_DoOneEvent\fR should do with the event. If the return value is +\fBTK_PROCESS_EVENT\fR, then the event will be handled immediately. +If the return value is \fBTK_DEFER_EVENT\fR, then the event will be +left on the event queue for later processing. If the return value is +\fBTK_DISCARD_EVENT\fR, then the event will be removed from the event +queue and discarded without being processed. +.PP +\fBTk_RestrictEvents\fR uses its return value and \fIprevClientDataPtr\fR +to return information about the current event restriction procedure +(a NULL return value means there are currently no restrictions). +These values may be used to restore the previous restriction state +when there is no longer any need for the current restriction. +.PP +There are very few places where \fBTk_RestrictEvents\fR is needed. +In most cases, the best way to restrict events is by changing the +bindings with the \fBbind\fR Tcl command or by calling +\fBTk_CreateEventHandler\fR and \fBTk_DeleteEventHandler\fR from C. +The main place where \fBTk_RestrictEvents\fR must be used is when +performing synchronous actions (for example, if you need to wait +for a particular event to occur on a particular window but you don't +want to invoke any handlers for any other events). The ``obvious'' +solution in these situations is to call \fBXNextEvent\fR or +\fBXWindowEvent\fR, but these procedures cannot be used because +Tk keeps its own event queue that is separate from the X event +queue. Instead, call \fBTk_RestrictEvents\fR to set up a filter, +then call \fBTk_DoOneEvent\fR to retrieve the desired event(s). +.SH KEYWORDS +delay, event, filter, restriction diff --git a/tk4.2/doc/SetAppName.3 b/tk4.2/doc/SetAppName.3 new file mode 100644 index 0000000..6f19e98 --- /dev/null +++ b/tk4.2/doc/SetAppName.3 @@ -0,0 +1,65 @@ +'\" +'\" Copyright (c) 1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) SetAppName.3 1.10 96/03/26 18:17:58 +'\" +.so man.macros +.TH Tk_SetAppName 3 4.0 Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_SetAppName \- Set the name of an application for ``send'' commands +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +char * +\fBTk_SetAppName\fR(\fItkwin, name\fR) +.SH ARGUMENTS +.AS Tk_Window parent +.AP Tk_Window tkwin in +Token for window in application. Used only to select a particular +application. +.AP char *name in +Name under which to register the application. +.BE + +.SH DESCRIPTION +.PP +\fBTk_SetAppName\fR associates a name with a given application and +records that association on the display containing with the application's +main window. +After this procedure has been invoked, other applications on the +display will be able to use the \fBsend\fR command to invoke operations +in the application. +If \fIname\fR is already in use by some other application on the +display, then a new name will be generated by appending +``\fB #2\fR'' to \fIname\fR; if this name is also in use, +the number will be incremented until an unused name is found. +The return value from the procedure is a pointer to the name actually +used. +.PP +If the application already has a name when \fBTk_SetAppName\fR is +called, then the new name replaces the old name. +.PP +\fBTk_SetAppName\fR also adds a \fBsend\fR command to the application's +interpreter, which can be used to send commands from this application +to others on any of the displays where the application has windows. +.PP +The application's name registration persists until the interpreter is +deleted or the \fBsend\fR command is deleted from \fIinterp\fR, at which +point the name is automatically unregistered and the application +becomes inaccessible via \fBsend\fR. +The application can be made accessible again by calling \fBTk_SetAppName\fR. +.PP +\fBTk_SetAppName\fR is called automatically by \fBTk_CreateMainWindow\fR, +so applications don't normally need to call it explicitly. +.PP +The command \fBtk appname\fR provides Tcl-level access to the +functionality of \fBTk_SetAppName\fR. + +.SH KEYWORDS +application, name, register, send command diff --git a/tk3.6/doc/SetClass.3 b/tk4.2/doc/SetClass.3 similarity index 59% rename from tk3.6/doc/SetClass.3 rename to tk4.2/doc/SetClass.3 index c0b1d7f..03127b7 100644 --- a/tk3.6/doc/SetClass.3 +++ b/tk4.2/doc/SetClass.3 @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1990 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/wish/man/RCS/SetClass.3,v 1.7 93/04/01 09:41:57 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) SetClass.3 1.12 96/03/26 18:18:10 '\" .so man.macros -.HS Tk_SetClass tkc +.TH Tk_SetClass 3 "" Tk "Tk Library Procedures" .BS .SH NAME Tk_SetClass, Tk_Class \- set or retrieve a window's class @@ -65,7 +52,7 @@ the window. \fBTk_Class\fR is a macro that returns the current value of \fItkwin\fR's class. The value is returned as a Tk_Uid, which may be used just like a string pointer but also has -the properties of a unique identfier (see the manual entry for +the properties of a unique identifier (see the manual entry for \fBTk_GetUid\fR for details). If \fItkwin\fR has not yet been given a class, then \fBTk_Class\fR will return NULL. diff --git a/tk4.2/doc/SetGrid.3 b/tk4.2/doc/SetGrid.3 new file mode 100644 index 0000000..b2a3b40 --- /dev/null +++ b/tk4.2/doc/SetGrid.3 @@ -0,0 +1,67 @@ +'\" +'\" Copyright (c) 1990-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) SetGrid.3 1.11 96/08/27 13:21:33 +'\" +.so man.macros +.TH Tk_SetGrid 3 4.0 Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_SetGrid, Tk_UnsetGrid \- control the grid for interactive resizing +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +\fBTk_SetGrid\fR(\fItkwin, reqWidth, reqHeight, widthInc, heightInc\fR) +.sp +\fBTk_UnsetGrid\fR(\fItkwin\fR) +.SH ARGUMENTS +.AS Tk_Window heightInc +.AP Tk_Window tkwin in +Token for window. +.AP int reqWidth in +Width in grid units that corresponds to the pixel dimension \fItkwin\fR +has requested via \fBTk_GeometryRequest\fR. +.AP int reqHeight in +Height in grid units that corresponds to the pixel dimension \fItkwin\fR +has requested via \fBTk_GeometryRequest\fR. +.AP int widthInc in +Width of one grid unit, in pixels. +.AP int heightInc in +Height of one grid unit, in pixels. +.BE + +.SH DESCRIPTION +.PP +\fBTk_SetGrid\fR turns on gridded geometry management for \fItkwin\fR's +toplevel window and specifies the geometry of the grid. +\fBTk_SetGrid\fR is typically invoked by a widget when its \fBsetGrid\fR +option is true. +It restricts interactive resizing of \fItkwin\fR's toplevel window so +that the space allocated to the toplevel is equal to its requested +size plus or minus even multiples of \fIwidthInc\fR and \fIheightInc\fR. +Furthermore, the \fIreqWidth\fR and \fIreqHeight\fR values are +passed to the window manager so that it can report the window's +size in grid units during interactive resizes. +If \fItkwin\fR's configuration changes (e.g., the size of a grid unit +changes) then the widget should invoke \fBTk_SetGrid\fR again with the new +information. +.PP +\fBTk_UnsetGrid\fR cancels gridded geometry management for +\fItkwin\fR's toplevel window. +.PP +For each toplevel window there can be at most one internal window +with gridding enabled. +If \fBTk_SetGrid\fR or \fBTk_UnsetGrid\fR is invoked when some +other window is already controlling gridding for \fItkwin\fR's +toplevel, the calls for the new window have no effect. +.PP +See the \fBwm\fR manual entry for additional information on gridded geometry +management. + +.SH KEYWORDS +grid, window, window manager diff --git a/tk3.6/doc/SetVisual.3 b/tk4.2/doc/SetVisual.3 similarity index 55% rename from tk3.6/doc/SetVisual.3 rename to tk4.2/doc/SetVisual.3 index 3fea1d3..f76c467 100644 --- a/tk3.6/doc/SetVisual.3 +++ b/tk4.2/doc/SetVisual.3 @@ -1,32 +1,17 @@ '\" '\" Copyright (c) 1992 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/wish/man/RCS/SetVisual.3,v 1.4 93/04/01 09:41:58 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) SetVisual.3 1.10 96/03/26 18:18:39 '\" .so man.macros -.HS Tk_SetWindowVisual tkc +.TH Tk_SetWindowVisual 3 4.0 Tk "Tk Library Procedures" .BS .SH NAME -.na Tk_SetWindowVisual \- change visual characteristics of window -.ad .SH SYNOPSIS .nf \fB#include \fR @@ -34,12 +19,12 @@ Tk_SetWindowVisual \- change visual characteristics of window int \fBTk_SetWindowVisual\fR(\fItkwin, visual, depth, colormap\fR) .SH ARGUMENTS -.AS "unsigned int" colormap +.AS "Tk_Window int" colormap .AP Tk_Window tkwin in Token for window. .AP Visual *visual in New visual type to use for \fItkwin\fR. -.AP "unsigned int" depth in +.AP "int" depth in Number of bits per pixel desired for \fItkwin\fR. .AP Colormap colormap in New colormap for \fItkwin\fR, which must be compatible with diff --git a/tk4.2/doc/StrictMotif.3 b/tk4.2/doc/StrictMotif.3 new file mode 100644 index 0000000..6ba5b60 --- /dev/null +++ b/tk4.2/doc/StrictMotif.3 @@ -0,0 +1,41 @@ +'\" +'\" Copyright (c) 1995-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) StrictMotif.3 1.4 96/03/26 18:18:52 +'\" +.so man.macros +.TH Tk_StrictMotif 3 4.0 Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_StrictMotif \- Return value of tk_strictMotif variable +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +int +\fBTk_StrictMotif\fR(\fItkwin\fR) +.SH ARGUMENTS +.AS Tk_Window tkwin +.AP Tk_Window tkwin in +Token for window. +.BE + +.SH DESCRIPTION +.PP +This procedure returns the current value of the \fBtk_strictMotif\fR +variable in the interpreter associated with \fItkwin\fR's application. +The value is returned as an integer that is either 0 or 1. +1 means that strict Motif compliance has been requested, so anything +that is not part of the Motif specification should be avoided. +0 means that ``Motif-like'' is good enough, and extra features +are welcome. +.PP +This procedure uses a link to the Tcl variable to provide much +faster access to the variable's value than could be had by calling +\fBTcl_GetVar\fR. + +.SH KEYWORDS +Motif compliance, tk_strictMotif variable diff --git a/tk4.2/doc/Tk_Init.3 b/tk4.2/doc/Tk_Init.3 new file mode 100644 index 0000000..20ed41d --- /dev/null +++ b/tk4.2/doc/Tk_Init.3 @@ -0,0 +1,47 @@ +'\" +'\" Copyright (c) 1995-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) Tk_Init.3 1.3 96/03/26 18:19:08 +'\" +.so man.macros +.TH Tk_Init 3 4.1 Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_Init \- add Tk to an interpreter and make a new Tk application. +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +int +\fBTk_Init\fR(\fIinterp\fR) +.SH ARGUMENTS +.AS Tcl_Interp *interp +.AP Tcl_Interp *interp in +Interpreter in which to load Tk. Tk should not already be loaded +in this interpreter. +.BE + +.SH DESCRIPTION +.PP +\fBTk_Init\fR is the package initialization procedure for Tk. +It is normally invoked by the \fBTcl_AppInit\fR procedure +for an application or by the \fBload\fR command. +\fBTk_Init\fR adds all of Tk's commands to \fIinterp\fR +and creates a new Tk application, including its main window. +If the initialization is successful \fBTk_Init\fR returns +\fBTCL_OK\fR; if there is an error it returns \fBTCL_ERROR\fR. +\fBTk_Init\fR also leaves a result or error message +in \fIinterp->result\fR. +.PP +If there is a variable \fBargv\fR in \fIinterp\fR, \fBTk_Init\fR +treats the contents of this variable as a list of options for the +new Tk application. +The options may have any of the forms documented for the +\fBwish\fR application (in fact, \fBwish\fR uses Tk_Init to process +its command-line arguments). + +.SH KEYWORDS +application, initialization, load, main window diff --git a/tk4.2/doc/Tk_Main.3 b/tk4.2/doc/Tk_Main.3 new file mode 100644 index 0000000..7565aae --- /dev/null +++ b/tk4.2/doc/Tk_Main.3 @@ -0,0 +1,61 @@ +'\" +'\" Copyright (c) 1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) Tk_Main.3 1.7 96/03/26 18:19:21 +'\" +.so man.macros +.TH Tk_Main 3 4.0 Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_Main \- main program for Tk-based applications +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +\fBTk_Main\fR(\fIargc, argv, appInitProc\fR) +.SH ARGUMENTS +.AS Tcl_AppInitProc *appInitProc +.AP int argc in +Number of elements in \fIargv\fR. +.AP char *argv[] in +Array of strings containing command-line arguments. +.AP Tcl_AppInitProc *appInitProc in +Address of an application-specific initialization procedure. +The value for this argument is usually \fBTcl_AppInit\fR. +.BE + +.SH DESCRIPTION +.PP +\fBTk_Main\fR acts as the main program for most Tk-based applications. +Starting with Tk 4.0 it is not called \fBmain\fR anymore because it +is part of the Tk library and having a function \fBmain\fR +in a library (particularly a shared library) causes problems on many +systems. +Having \fBmain\fR in the Tk library would also make it hard to use +Tk in C++ programs, since C++ programs must have special C++ +\fBmain\fR functions. +.PP +Normally each application contains a small \fBmain\fR function that does +nothing but invoke \fBTk_Main\fR. +\fBTk_Main\fR then does all the work of creating and running a +\fBwish\fR-like application. +.PP +When it is has finished its own initialization, but before +it processes commands, \fBTk_Main\fR calls the procedure given by +the \fIappInitProc\fR argument. This procedure provides a ``hook'' +for the application to perform its own initialization, such as defining +application-specific commands. The procedure must have an interface +that matches the type \fBTcl_AppInitProc\fR: +.CS +typedef int Tcl_AppInitProc(Tcl_Interp *\fIinterp\fR); +.CE +\fIAppInitProc\fR is almost always a pointer to \fBTcl_AppInit\fR; +for more details on this procedure, see the documentation +for \fBTcl_AppInit\fR. + +.SH KEYWORDS +application-specific initialization, command-line arguments, main program diff --git a/tk3.6/doc/WindowId.3 b/tk4.2/doc/WindowId.3 similarity index 80% rename from tk3.6/doc/WindowId.3 rename to tk4.2/doc/WindowId.3 index bcfb0f1..fa7a3d9 100644 --- a/tk3.6/doc/WindowId.3 +++ b/tk4.2/doc/WindowId.3 @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1990-1993 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/wish/man/RCS/WindowId.3,v 1.9 93/04/01 09:42:00 ouster Exp $ SPRITE (Berkeley) +'\" SCCS: @(#) WindowId.3 1.15 96/03/26 18:19:40 '\" .so man.macros -.HS Tk_WindowId tkc +.TH Tk_WindowId 3 "" Tk "Tk Library Procedures" .BS .SH NAME Tk_WindowId, Tk_Parent, Tk_Display, Tk_DisplayName, Tk_ScreenNumber, Tk_Screen, Tk_X, Tk_Y, Tk_Width, Tk_Height, Tk_Changes, Tk_Attributes, Tk_IsMapped, Tk_IsTopLevel, Tk_ReqWidth, Tk_ReqHeight, Tk_InternalBorderWidth, Tk_Visual, Tk_Depth, Tk_Colormap \- retrieve information from Tk's local data structure @@ -68,35 +55,26 @@ XSetWindowAttributes * int \fBTk_IsMapped\fR(\fItkwin\fR) .sp -.VS int \fBTk_IsTopLevel\fR(\fItkwin\fR) -.VE .sp int \fBTk_ReqWidth\fR(\fItkwin\fR) .sp int -.br \fBTk_ReqHeight\fR(\fItkwin\fR) .sp int -.br \fBTk_InternalBorderWidth\fR(\fItkwin\fR) .sp -.VS Visual * -.br \fBTk_Visual\fR(\fItkwin\fR) .sp int -.br \fBTk_Depth\fR(\fItkwin\fR) .sp Colormap -.br \fBTk_Colormap\fR(\fItkwin\fR) -.VE .SH ARGUMENTS .AS Tk_Window tkwin .AP Tk_Window tkwin in @@ -145,11 +123,9 @@ data structures up-to-date. \fBTk_IsMapped\fR returns a non-zero value if \fItkwin\fR is mapped and zero if \fItkwin\fR isn't mapped. .PP -.VS \fBTk_IsTopLevel\fR returns a non-zero value if \fItkwin\fR is a top-level window (its X parent is the root window of the screen) and zero if \fItkwin\fR isn't a top-level window. -.VE .PP \fBTk_ReqWidth\fR and \fBTk_ReqHeight\fR return information about the window's requested size. These values correspond to the last @@ -160,7 +136,6 @@ that has been requested for \fItkwin\fR, or 0 if no internal border was requested. The return value is simply the last value passed to \fBTk_SetInternalBorder\fR for \fItkwin\fR. .PP -.VS \fBTk_Visual\fR, \fBTk_Depth\fR, and \fBTk_Colormap\fR return information about the visual characteristics of a window. \fBTk_Visual\fR returns the visual type for @@ -169,7 +144,6 @@ and \fBTk_Colormap\fR returns the current colormap for the window. The visual characteristics are normally set from the defaults for the window's screen, but they may be overridden by calling \fBTk_SetWindowVisual\fR. -.VE .SH KEYWORDS attributes, colormap, depth, display, height, geometry manager, diff --git a/tk4.2/doc/bell.n b/tk4.2/doc/bell.n new file mode 100644 index 0000000..03c7452 --- /dev/null +++ b/tk4.2/doc/bell.n @@ -0,0 +1,34 @@ +'\" +'\" Copyright (c) 1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) bell.n 1.8 96/03/26 18:19:55 +'\" +.so man.macros +.TH bell n 4.0 Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +bell \- Ring a display's bell +.SH SYNOPSIS +\fBbell \fR?\fB\-displayof \fIwindow\fR? +.BE + +.SH DESCRIPTION +.PP +This command rings the bell on the display for \fIwindow\fR and +returns an empty string. +If the \fB\-displayof\fR option is omitted, the display of the +application's main window is used by default. +The command uses the current bell-related settings for the display, which +may be modified with programs such as \fBxset\fR. +.PP +This command also resets the screen saver for the screen. Some +screen savers will ignore this, but others will reset so that the +screen becomes visible again. + +.SH KEYWORDS +beep, bell, ring diff --git a/tk4.2/doc/bind.n b/tk4.2/doc/bind.n new file mode 100644 index 0000000..e621c94 --- /dev/null +++ b/tk4.2/doc/bind.n @@ -0,0 +1,474 @@ +'\" +'\" Copyright (c) 1990 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) bind.n 1.41 96/10/03 18:27:05 +'\" +.so man.macros +.TH bind n 4.1 Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +bind \- Arrange for X events to invoke Tcl scripts +.SH SYNOPSIS +\fBbind\fI tag\fR +.sp +\fBbind\fI tag sequence\fR +.sp +\fBbind\fI tag sequence script\fR +.sp +\fBbind\fI tag sequence \fB+\fIscript\fR +.BE + +.SH INTRODUCTION +.PP +The \fBbind\fR command associates Tcl scripts with X events. +If all three arguments are specified, \fBbind\fR will +arrange for \fIscript\fR (a Tcl script) to be evaluated whenever +the event(s) given by \fIsequence\fR occur in the window(s) +identified by \fItag\fR. +If \fIscript\fR is prefixed with a ``+'', then it is appended to +any existing binding for \fIsequence\fR; otherwise \fIscript\fR replaces +any existing binding. +If \fIscript\fR is an empty string then the current binding for +\fIsequence\fR is destroyed, leaving \fIsequence\fR unbound. +In all of the cases where a \fIscript\fR argument is provided, +\fBbind\fR returns an empty string. +.PP +If \fIsequence\fR is specified without a \fIscript\fR, then the +script currently bound to \fIsequence\fR is returned, or +an empty string is returned if there is no binding for \fIsequence\fR. +If neither \fIsequence\fR nor \fIscript\fR is specified, then the +return value is a list whose elements are all the sequences +for which there exist bindings for \fItag\fR. +.PP +The \fItag\fR argument determines which window(s) the binding applies to. +If \fItag\fR begins with a dot, as in \fB.a.b.c\fR, then it must +be the path name for a window; otherwise it may be an arbitrary +string. +Each window has an associated list of tags, and a binding applies +to a particular window if its tag is among those specified for +the window. +Although the \fBbindtags\fR command may be used to assign an +arbitrary set of binding tags to a window, the default binding +tags provide the following behavior: +.IP +If a tag is the name of an internal window the binding applies +to that window. +.IP +If the tag is the name of a toplevel window the binding applies +to the toplevel window and all its internal windows. +.IP +If the tag is the name of a class of widgets, such as \fBButton\fR, +the binding applies to all widgets in that class; +.IP +If \fItag\fR has the value \fBall\fR, +the binding applies to all windows in the application. + +.SH "EVENT PATTERNS" +.PP +The \fIsequence\fR argument specifies a sequence of one or more +event patterns, with optional white space between the patterns. Each +.VS +event pattern may +take one of three forms. In the simplest case it is a single +.VE +printing ASCII character, such as \fBa\fR or \fB[\fR. The character +may not be a space character or the character \fB<\fR. This form of +pattern matches a \fBKeyPress\fR event for the particular +character. The second form of pattern is longer but more general. +It has the following syntax: +.CS +\fB<\fImodifier-modifier-type-detail\fB>\fR +.CE +The entire event pattern is surrounded by angle brackets. +Inside the angle brackets are zero or more modifiers, an event +type, and an extra piece of information (\fIdetail\fR) identifying +a particular button or keysym. Any of the fields may be omitted, +as long as at least one of \fItype\fR and \fIdetail\fR is present. +The fields must be separated by white space or dashes. +.VS +.PP +The third form of pattern is used to specify a user-defined, named virtual +event. It has the following syntax: +.CS +\fB<<\fIname\fB>>\fR +.CE +The entire virtual event pattern is surrounded by double angle brackets. +Inside the angle brackets is the user-defined name of the virtual event. +Modifiers, such as \fBShift\fR or \fBControl\fR, may not be combined with a +virtual event to modify it. Bindings on a virtual event may be created +before the virtual event is defined, and if the definition of a virtual +event changes dynamically, all windows bound to that virtual event will +respond immediately to the new definition. +.VE +.SH "MODIFIERS" +.PP +Modifiers consist of any of the following values: +.DS +.ta 6c +\fBControl\fR \fBMod2, M2\fR +\fBShift\fR \fBMod3, M3\fR +\fBLock\fR \fBMod4, M4\fR +\fBButton1, B1\fR \fBMod5, M5\fR +\fBButton2, B2\fR \fBMeta, M\fR +\fBButton3, B3\fR \fBAlt\fR +\fBButton4, B4\fR \fBDouble\fR +\fBButton5, B5\fR \fBTriple\fR +\fBMod1, M1\fR +.DE +Where more than one value is listed, separated by commas, the values +are equivalent. +Most of the modifiers have the obvious X meanings. +For example, \fBButton1\fR requires that +button 1 be depressed when the event occurs. +For a binding to match a given event, the modifiers in the event +must include all of those specified in the event pattern. +An event may also contain additional modifiers not specified in +the binding. +For example, if button 1 is pressed while the shift and control keys +are down, the pattern \fB\fR will match +the event, but \fB\fR will not. +If no modifiers are specified, then any combination of modifiers may +be present in the event. +.PP +\fBMeta\fR and \fBM\fR refer to whichever of the +\fBM1\fR through \fBM5\fR modifiers is associated with the meta +key(s) on the keyboard (keysyms \fBMeta_R\fR and \fBMeta_L\fR). +If there are no meta keys, or if they are not associated with any +modifiers, then \fBMeta\fR and \fBM\fR will not match any events. +Similarly, the \fBAlt\fR modifier refers to whichever modifier +is associated with the alt key(s) on the keyboard (keysyms +\fBAlt_L\fR and \fBAlt_R\fR). +.PP +The \fBDouble\fR and \fBTriple\fR modifiers are a convenience +for specifying double mouse clicks and other repeated +events. They cause a particular event pattern to be +repeated 2 or 3 times, and also place a time and space requirement +on the sequence: for a sequence of events to match a \fBDouble\fR +or \fBTriple\fR pattern, all of the events must occur close together +in time and without substantial mouse motion in between. +For example, \fB\fR +is equivalent to \fB\fR with the extra +time and space requirement. + +.SH "EVENT TYPES" +.PP +The \fItype\fR field may be any of the standard X event types, with a +few extra abbreviations. Below is a list of all the valid types; +where two names appear together, they are synonyms. +.DS C +.ta 5c 10c +\fBButtonPress, Button Expose Map +ButtonRelease FocusIn Motion +Circulate FocusOut Property +Colormap Gravity Reparent +Configure KeyPress, Key Unmap +Destroy KeyRelease Visibility +Enter Leave Activate +Deactivate\fR +.DE +.PP +The last part of a long event specification is \fIdetail\fR. In the +case of a \fBButtonPress\fR or \fBButtonRelease\fR event, it is the +number of a button (1-5). If a button number is given, then only an +event on that particular button will match; if no button number is +given, then an event on any button will match. Note: giving a +specific button number is different than specifying a button modifier; +in the first case, it refers to a button being pressed or released, +while in the second it refers to some other button that is already +depressed when the matching event occurs. If a button +number is given then \fItype\fR may be omitted: if will default +to \fBButtonPress\fR. For example, the specifier \fB<1>\fR +is equivalent to \fB\fR. +.PP +If the event type is \fBKeyPress\fR or \fBKeyRelease\fR, then +\fIdetail\fR may be specified in the form of an X keysym. Keysyms +are textual specifications for particular keys on the keyboard; +they include all the alphanumeric ASCII characters (e.g. ``a'' is +the keysym for the ASCII character ``a''), plus descriptions for +non-alphanumeric characters (``comma'' is the keysym for the comma +character), plus descriptions for all the non-ASCII keys on the +keyboard (``Shift_L'' is the keysm for the left shift key, and +``F1'' is the keysym for the F1 function key, if it exists). The +complete list of keysyms is not presented here; it is +available in other X documentation and may vary from system to +system. +If necessary, you can use the \fB%K\fR notation described below +to print out the keysym name for a particular key. +If a keysym \fIdetail\fR is given, then the +\fItype\fR field may be omitted; it will default to \fBKeyPress\fR. +For example, \fB\fR is equivalent to +\fB\fR. + +.SH "BINDING SCRIPTS AND SUBSTITUTIONS" +.PP +The \fIscript\fR argument to \fBbind\fR is a Tcl script, +which will be executed whenever the given event sequence occurs. +\fICommand\fR will be executed in the same interpreter that the +\fBbind\fR command was executed in, and it will run at global +level (only global variables will be accessible). +If \fIscript\fR contains +any \fB%\fR characters, then the script will not be +executed directly. Instead, a new script will be +generated by replacing each \fB%\fR, and the character following +it, with information from the current event. The replacement +depends on the character following the \fB%\fR, as defined in the +list below. Unless otherwise indicated, the +replacement string is the decimal value of the given field from +the current event. +Some of the substitutions are only valid for +certain types of events; if they are used for other types of events +the value substituted is undefined. +.IP \fB%%\fR 5 +Replaced with a single percent. +.IP \fB%#\fR 5 +The number of the last client request processed by the server +(the \fIserial\fR field from the event). Valid for all event +types. +.IP \fB%a\fR 5 +The \fIabove\fR field from the event, +formatted as a hexadecimal number. +Valid only for \fBConfigure\fR events. +.IP \fB%b\fR 5 +The number of the button that was pressed or released. Valid only +for \fBButtonPress\fR and \fBButtonRelease\fR events. +.IP \fB%c\fR 5 +The \fIcount\fR field from the event. Valid only for \fBExpose\fR events. +.IP \fB%d\fR 5 +The \fIdetail\fR field from the event. The \fB%d\fR is replaced by +a string identifying the detail. For \fBEnter\fR, +\fBLeave\fR, \fBFocusIn\fR, and \fBFocusOut\fR events, +the string will be one of the following: +.RS +.DS +.ta 6c +\fBNotifyAncestor NotifyNonlinearVirtual +NotifyDetailNone NotifyPointer +NotifyInferior NotifyPointerRoot +NotifyNonlinear NotifyVirtual\fR +.DE +For events other than these, the substituted string is undefined. +.RE +.IP \fB%f\fR 5 +The \fIfocus\fR field from the event (\fB0\fR or \fB1\fR). Valid only +for \fBEnter\fR and \fBLeave\fR events. +.IP \fB%h\fR 5 +.VS +The \fIheight\fR field from the event. Valid only for \fBConfigure\fR and +\fBExpose\fR events. +.VE +.IP \fB%k\fR 5 +The \fIkeycode\fR field from the event. Valid only for \fBKeyPress\fR +and \fBKeyRelease\fR events. +.IP \fB%m\fR 5 +The \fImode\fR field from the event. The substituted string is one of +\fBNotifyNormal\fR, \fBNotifyGrab\fR, \fBNotifyUngrab\fR, or +.VS +\fBNotifyWhileGrabbed\fR. Valid only for \fBEnter\fR, +\fBFocusIn\fR, \fBFocusOut\fR, and \fBLeave\fR events. +.VE +.IP \fB%o\fR 5 +The \fIoverride_redirect\fR field from the event. Valid only for +\fBMap\fR, \fBReparent\fR, and \fBConfigure\fR events. +.IP \fB%p\fR 5 +The \fIplace\fR field from the event, substituted as one of the +strings \fBPlaceOnTop\fR or \fBPlaceOnBottom\fR. Valid only +for \fBCirculate\fR events. +.IP \fB%s\fR 5 +The \fIstate\fR field from the event. For \fBButtonPress\fR, +\fBButtonRelease\fR, \fBEnter\fR, \fBKeyPress\fR, \fBKeyRelease\fR, +\fBLeave\fR, and \fBMotion\fR events, a decimal string +is substituted. For \fBVisibility\fR, one of the strings +\fBVisibilityUnobscured\fR, \fBVisibilityPartiallyObscured\fR, +and \fBVisibilityFullyObscured\fR is substituted. +.IP \fB%t\fR 5 +The \fItime\fR field from the event. Valid only for events that +contain a \fItime\fR field. +.IP \fB%w\fR 5 +The \fIwidth\fR field from the event. Valid only for +.VS +\fBConfigure\fR and \fBExpose\fR events. +.VE +.IP \fB%x\fR 5 +The \fIx\fR field from the event. Valid only for events containing +an \fIx\fR field. +.IP \fB%y\fR 5 +The \fIy\fR field from the event. Valid only for events containing +a \fIy\fR field. +.IP \fB%A\fR 5 +Substitutes the ASCII character corresponding to the event, or +the empty string if the event doesn't correspond to an ASCII character +(e.g. the shift key was pressed). \fBXLookupString\fR does all the +work of translating from the event to an ASCII character. +Valid only for \fBKeyPress\fR and \fBKeyRelease\fR events. +.IP \fB%B\fR 5 +The \fIborder_width\fR field from the event. Valid only for +\fBConfigure\fR events. +.IP \fB%E\fR 5 +The \fIsend_event\fR field from the event. Valid for all event types. +.IP \fB%K\fR 5 +The keysym corresponding to the event, substituted as a textual +string. Valid only for \fBKeyPress\fR and \fBKeyRelease\fR events. +.IP \fB%N\fR 5 +The keysym corresponding to the event, substituted as a decimal +number. Valid only for \fBKeyPress\fR and \fBKeyRelease\fR events. +.IP \fB%R\fR 5 +The \fIroot\fR window identifier from the event. Valid only for +events containing a \fIroot\fR field. +.IP \fB%S\fR 5 +The \fIsubwindow\fR window identifier from the event, +formatted as a hexadecimal number. +Valid only for events containing a \fIsubwindow\fR field. +.IP \fB%T\fR 5 +The \fItype\fR field from the event. Valid for all event types. +.IP \fB%W\fR 5 +The path name of the window to which the event was reported (the +\fIwindow\fR field from the event). Valid for all event types. +.IP \fB%X\fR 5 +The \fIx_root\fR field from the event. +If a virtual-root window manager is being used then the substituted +value is the corresponding x-coordinate in the virtual root. +Valid only for +\fBButtonPress\fR, \fBButtonRelease\fR, \fBKeyPress\fR, \fBKeyRelease\fR, +and \fBMotion\fR events. +.IP \fB%Y\fR 5 +The \fIy_root\fR field from the event. +If a virtual-root window manager is being used then the substituted +value is the corresponding y-coordinate in the virtual root. +Valid only for +\fBButtonPress\fR, \fBButtonRelease\fR, \fBKeyPress\fR, \fBKeyRelease\fR, +and \fBMotion\fR events. +.LP +The replacement string for a %-replacement is formatted as a proper +Tcl list element. +This means that it will be surrounded with braces +if it contains spaces, or special characters such as \fB$\fR and +\fB{\fR may be preceded by backslashes. +This guarantees that the string will be passed through the Tcl +parser when the binding script is evaluated. +Most replacements are numbers or well-defined strings such +as \fBAbove\fR; for these replacements no special formatting +is ever necessary. +The most common case where reformatting occurs is for the \fB%A\fR +substitution. For example, if \fIscript\fR is +.CS +\fBinsert\0%A\fR +.CE +and the character typed is an open square bracket, then the script +actually executed will be +.CS +\fBinsert\0\e[\fR +.CE +This will cause the \fBinsert\fR to receive the original replacement +string (open square bracket) as its first argument. +If the extra backslash hadn't been added, Tcl would not have been +able to parse the script correctly. + +.SH MULTIPLE MATCHES +.PP +It is possible for several bindings to match a given X event. +If the bindings are associated with different \fItag\fR's, +then each of the bindings will be executed, in order. +By default, a binding for the widget will be executed first, followed +by a class binding, a binding for its toplevel, and +an \fBall\fR binding. +The \fBbindtags\fR command may be used to change this order for +a particular window or to associate additional binding tags with +the window. +.PP +The \fBcontinue\fR and \fBbreak\fR commands may be used inside a +binding script to control the processing of matching scripts. +If \fBcontinue\fR is invoked, then the current binding script +is terminated but Tk will continue processing binding scripts +associated with other \fItag\fR's. +If the \fBbreak\fR command is invoked within a binding script, +then that script terminates and no other scripts will be invoked +for the event. +.VS +.PP +If more than one binding matches a particular event and they +have the same \fItag\fR, then the most specific binding +is chosen and its script is evaluated. +The following tests are applied, in order, to determine which of +several matching sequences is more specific: +(a) an event pattern that specifies a specific button or key is more specific +than one that doesn't; +(b) a longer sequence (in terms of number +of events matched) is more specific than a shorter sequence; +(c) if the modifiers specified in one pattern are a subset of the +modifiers in another pattern, then the pattern with more modifiers +is more specific. +.VS +(d) a virtual event whose physical pattern matches the sequence is less +specific than the same physical pattern that is not associated with a +virtual event. +(e) given a sequence that matches two or more virtual events, one +of the virtual events will be chosen, but the order is undefined. +.PP +If the matching sequences contain more than one event, then tests +(c)-(e) are applied in order from the most recent event to the least recent +event in the sequences. If these tests fail to determine a winner, then the +most recently registered sequence is the winner. +.PP +If there are two (or more) virtual events that are both triggered by the +same sequence, and both of those virtual events are bound to the same window +tag, then only one of the virtual events will be triggered, and it will +be picked at random: +.CS +event add <> +event add <> +event add <> +bind Entry <> {puts Paste} +bind Entry <> {puts Scroll} +.CE +If the user types Control-y, the \fB<>\fR binding +will be invoked, but if the user presses button 2 then one of +either the \fB<>\fR or the \fB<>\fR bindings will +be invoked, but exactly which one gets invoked is undefined. +.VE +.PP +If an X event does not match any of the existing bindings, then the +event is ignored. +An unbound event is not considered to be an error. + +.SH "MULTI-EVENT SEQUENCES AND IGNORED EVENTS" +.PP +When a \fIsequence\fR specified in a \fBbind\fR command contains +more than one event pattern, then its script is executed whenever +the recent events (leading up to and including the current event) +match the given sequence. This means, for example, that if button 1 is +clicked repeatedly the sequence \fB\fR will match +each button press but the first. +If extraneous events that would prevent a match occur in the middle +of an event sequence then the extraneous events are +ignored unless they are \fBKeyPress\fR or \fBButtonPress\fR events. +For example, \fB\fR will match a sequence of +presses of button 1, even though there will be \fBButtonRelease\fR +events (and possibly \fBMotion\fR events) between the +\fBButtonPress\fR events. +Furthermore, a \fBKeyPress\fR event may be preceded by any number +of other \fBKeyPress\fR events for modifier keys without the +modifier keys preventing a match. +For example, the event sequence \fBaB\fR will match a press of the +\fBa\fR key, a release of the \fBa\fR key, a press of the \fBShift\fR +key, and a press of the \fBb\fR key: the press of \fBShift\fR is +ignored because it is a modifier key. +Finally, if several \fBMotion\fR events occur in a row, only +the last one is used for purposes of matching binding sequences. + +.SH ERRORS +.PP +If an error occurs in executing the script for a binding then the +\fBbgerror\fR mechanism is used to report the error. +The \fBbgerror\fR command will be executed at global level +(outside the context of any Tcl procedure). + +.SH "SEE ALSO" +bgerror + +.SH KEYWORDS +form, manual diff --git a/tk4.2/doc/bindtags.n b/tk4.2/doc/bindtags.n new file mode 100644 index 0000000..bdfa095 --- /dev/null +++ b/tk4.2/doc/bindtags.n @@ -0,0 +1,79 @@ +'\" +'\" Copyright (c) 1990 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) bindtags.n 1.8 96/03/26 18:20:19 +'\" +.so man.macros +.TH bindtags n 4.0 Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +bindtags \- Determine which bindings apply to a window, and order of evaluation +.SH SYNOPSIS +\fBbindtags \fIwindow \fR?\fItagList\fR? +.BE + +.SH DESCRIPTION +.PP +When a binding is created with the \fBbind\fR command, it is +associated either with a particular window such as \fB.a.b.c\fR, +a class name such as \fBButton\fR, the keyword \fBall\fR, or any +other string. +All of these forms are called \fIbinding tags\fR. +Each window contains a list of binding tags that determine how +events are processed for the window. +When an event occurs in a window, it is applied to each of the +window's tags in order: for each tag, the most specific binding +that matches the given tag and event is executed. +See the \fBbind\fR command for more information on the matching +process. +.PP +By default, each window has four binding tags consisting of the +name of the window, the window's class name, the name of the window's +nearest toplevel ancestor, and \fBall\fR, in that order. +Toplevel windows have only three tags by default, since the toplevel +name is the same as that of the window. +The \fBbindtags\fR command allows the binding tags for a window to be +read and modified. +.PP +If \fBbindtags\fR is invoked with only one argument, then the +current set of binding tags for \fIwindow\fR is returned as a list. +If the \fItagList\fR argument is specified to \fBbindtags\fR, +then it must be a proper list; the tags for \fIwindow\fR are changed +to the elements of the list. +The elements of \fItagList\fR may be arbitrary strings; however, +any tag starting with a dot is treated as the name of a window; if +no window by that name exists at the time an event is processed, +then the tag is ignored for that event. +The order of the elements in \fItagList\fR determines the order in +which binding scripts are executed in response to events. +For example, the command +.CS +\fBbindtags .b {all . Button .b}\fR +.CE +reverses the order in which binding scripts will be evaluated for +a button named \fB.b\fR so that \fBall\fR bindings are invoked +first, following by bindings for \fB.b\fR's toplevel (``.''), followed by +class bindings, followed by bindings for \fB.b\fR. +.PP +The \fBbindtags\fR command may be used to introduce arbitrary +additional binding tags for a window, or to remove standard tags. +For example, the command +.CS +\fBbindtags .b {.b TrickyButton . all}\fR +.CE +replaces the \fBButton\fR tag for \fB.b\fR with \fBTrickyButton\fR. +This means that the default widget bindings for buttons, which are +associated with the \fBButton\fR tag, will no longer apply to \fB.b\fR, +but any bindings associated with \fBTrickyButton\fR (perhaps some +new button behavior) will apply. + +.SH "SEE ALSO" +bind + +.SH KEYWORDS +binding, event, tag diff --git a/tk4.2/doc/bitmap.n b/tk4.2/doc/bitmap.n new file mode 100644 index 0000000..8ede15a --- /dev/null +++ b/tk4.2/doc/bitmap.n @@ -0,0 +1,114 @@ +'\" +'\" Copyright (c) 1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) bitmap.n 1.10 96/03/29 14:48:41 +'\" +.so man.macros +.TH bitmap n 4.0 Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +bitmap \- Images that display two colors +.SH SYNOPSIS +\fBimage create bitmap \fR?\fIname\fR? ?\fIoptions\fR? +.BE + +.SH DESCRIPTION +.PP +A bitmap is an image whose pixels can display either of two colors +or be transparent. +A bitmap image is defined by four things: a background color, +a foreground color, and two bitmaps, called the \fIsource\fR +and the \fImask\fR. +Each of the bitmaps specifies 0/1 values for a rectangular +array of pixels, and the two bitmaps must have the same +dimensions. +For pixels where the mask is zero, the image displays nothing, +producing a transparent effect. +For other pixels, the image displays the foreground color if +the source data is one and the background color if the source +data is zero. + +.SH "CREATING BITMAPS" +.PP +Like all images, bitmaps are created using the \fBimage create\fR +command. +Bitmaps support the following \fIoptions\fR: +.TP +\fB\-background \fIcolor\fR +Specifies a background color for the image in any of the standard +ways accepted by Tk. If this option is set to an empty string +then the background pixels will be transparent. This effect +is achieved by using the source bitmap as the mask bitmap, ignoring +any \fB\-maskdata\fR or \fB\-maskfile\fR options. +.TP +\fB\-data \fIstring\fR +Specifies the contents of the source bitmap as a string. +The string must adhere to X11 bitmap format (e.g., as generated +by the \fBbitmap\fR program). +If both the \fB\-data\fR and \fB\-file\fR options are specified, +the \fB\-data\fR option takes precedence. +.TP +\fB\-file \fIname\fR +\fIname\fR gives the name of a file whose contents define the +source bitmap. +The file must adhere to X11 bitmap format (e.g., as generated +by the \fBbitmap\fR program). +.TP +\fB\-foreground \fIcolor\fR +Specifies a foreground color for the image in any of the standard +ways accepted by Tk. +.TP +\fB\-maskdata \fIstring\fR +Specifies the contents of the mask as a string. +The string must adhere to X11 bitmap format (e.g., as generated +by the \fBbitmap\fR program). +If both the \fB\-maskdata\fR and \fB\-maskfile\fR options are specified, +the \fB\-maskdata\fR option takes precedence. +.TP +\fB\-maskfile \fIname\fR +\fIname\fR gives the name of a file whose contents define the +mask. +The file must adhere to X11 bitmap format (e.g., as generated +by the \fBbitmap\fR program). + +.SH "IMAGE COMMAND" +.PP +When a bitmap image is created, Tk also creates a new command +whose name is the same as the image. +This command may be used to invoke various operations +on the image. +It has the following general form: +.CS +\fIimageName option \fR?\fIarg arg ...\fR? +.CE +\fIOption\fR and the \fIarg\fRs +determine the exact behavior of the command. The following +commands are possible for bitmap images: +.TP +\fIimageName \fBcget\fR \fIoption\fR +Returns the current value of the configuration option given +by \fIoption\fR. +\fIOption\fR may have any of the values accepted by the +\fBimage create bitmap\fR command. +.TP +\fIimageName \fBconfigure\fR ?\fIoption\fR? ?\fIvalue option value ...\fR? +Query or modify the configuration options for the image. +If no \fIoption\fR is specified, returns a list describing all of +the available options for \fIimageName\fR (see \fBTk_ConfigureInfo\fR for +information on the format of this list). If \fIoption\fR is specified +with no \fIvalue\fR, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no \fIoption\fR is specified). If +one or more \fIoption\-value\fR pairs are specified, then the command +modifies the given option(s) to have the given value(s); in +this case the command returns an empty string. +\fIOption\fR may have any of the values accepted by the +\fBimage create bitmap\fR command. + +.SH KEYWORDS +bitmap, image diff --git a/tk3.6/doc/button.n b/tk4.2/doc/button.n similarity index 58% rename from tk3.6/doc/button.n rename to tk4.2/doc/button.n index 309fe97..dd6f954 100644 --- a/tk3.6/doc/button.n +++ b/tk4.2/doc/button.n @@ -1,102 +1,58 @@ '\" -'\" Copyright (c) 1990 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1990-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) button.n 1.37 96/08/27 13:21:38 '\" -'\" $Header: /user6/ouster/wish/man/RCS/button.n,v 1.19 93/04/01 09:52:31 ouster Exp $ SPRITE (Berkeley) -'/" .so man.macros -.HS button tk +.TH button n 4.0 Tk "Tk Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME button \- Create and manipulate button widgets .SH SYNOPSIS \fBbutton\fI \fIpathName \fR?\fIoptions\fR? -.SH "STANDARD OPTIONS" -.LP -.nf -.ta 4c 8c 12c -.VS -\fBactiveBackground\fR \fBbitmap\fR \fBfont\fR \fBrelief\fR -\fBactiveForeground\fR \fBborderWidth\fR \fBforeground\fR \fBtext\fR -\fBanchor\fR \fBcursor\fR \fBpadX\fR \fBtextVariable\fR -\fBbackground\fR \fBdisabledForeground\fR \fBpadY\fR -.VE -.fi -.LP -See the ``options'' manual entry for details on the standard options. +.SO +\-activebackground \-cursor \-highlightthickness \-takefocus +\-activeforeground \-disabledforeground \-image \-text +\-anchor \-font \-justify \-textvariable +\-background \-foreground \-padx \-underline +\-bitmap \-highlightbackground \-pady \-wraplength +\-borderwidth \-highlightcolor \-relief +.SE .SH "WIDGET-SPECIFIC OPTIONS" -.ta 4c -.LP -.nf -Name: \fBcommand\fR -Class: \fBCommand\fR -Command-Line Switch: \fB\-command\fR -.fi -.IP +.OP \-command command Command Specifies a Tcl command to associate with the button. This command is typically invoked when mouse button 1 is released over the button window. -.LP -.nf -.VS -Name: \fBheight\fR -Class: \fBHeight\fR -Command-Line Switch: \fB\-height\fR -.fi -.IP +.OP \-height height Height Specifies a desired height for the button. -If a bitmap is being displayed in the button then the value is in +If an image or bitmap is being displayed in the button then the value is in screen units (i.e. any of the forms acceptable to \fBTk_GetPixels\fR); for text it is in lines of text. If this option isn't specified, the button's desired height is computed -from the size of the bitmap or text being displayed in it. -.LP -.nf -Name: \fBstate\fR -Class: \fBState\fR -Command-Line Switch: \fB\-state\fR -.fi -.IP +from the size of the image or bitmap or text being displayed in it. +.OP \-state state State Specifies one of three states for the button: \fBnormal\fR, \fBactive\fR, or \fBdisabled\fR. In normal state the button is displayed using the \fBforeground\fR and \fBbackground\fR options. The active state is typically used when the pointer is over the button. In active state the button is displayed using the \fBactiveForeground\fR and \fBactiveBackground\fR options. Disabled state means that the button -is insensitive: it doesn't activate and doesn't respond to mouse -button presses. In this state the \fBdisabledForeground\fR and +should be insensitive: the default bindings will refuse to activate +the widget and will ignore mouse button presses. +In this state the \fBdisabledForeground\fR and \fBbackground\fR options determine how the button is displayed. -.LP -.nf -Name: \fBwidth\fR -Class: \fBWidth\fR -Command-Line Switch: \fB\-width\fR -.fi -.IP +.OP \-width width Width Specifies a desired width for the button. -If a bitmap is being displayed in the button then the value is in +If an image or bitmap is being displayed in the button then the value is in screen units (i.e. any of the forms acceptable to \fBTk_GetPixels\fR); for text it is in characters. If this option isn't specified, the button's desired width is computed -from the size of the bitmap or text being displayed in it. -.VE +from the size of the image or bitmap or text being displayed in it. .BE .SH DESCRIPTION @@ -112,13 +68,15 @@ text, and initial relief. The \fBbutton\fR command returns its there must not exist a window named \fIpathName\fR, but \fIpathName\fR's parent must exist. .PP -A button is a widget -.VS -that displays a textual string or bitmap. +A button is a widget that displays a textual string, bitmap or image. +If text is displayed, it must all be in a single font, but it +can occupy multiple lines on the screen (if it contains newlines +or if wrapping occurs because of the \fBwrapLength\fR option) and +one of the characters may optionally be underlined using the +\fBunderline\fR option. It can display itself in either of three different ways, according to the \fBstate\fR option; -.VE it can be made to appear raised, sunken, or flat; and it can be made to flash. When a user invokes the button (by pressing mouse button 1 with the cursor over the @@ -131,22 +89,18 @@ The \fBbutton\fR command creates a new Tcl command whose name is \fIpathName\fR. This command may be used to invoke various operations on the widget. It has the following general form: -.DS C +.CS \fIpathName option \fR?\fIarg arg ...\fR? -.DE +.CE \fIOption\fR and the \fIarg\fRs determine the exact behavior of the command. The following commands are possible for button widgets: .TP -\fIpathName \fBactivate\fR -Change the button's state to \fBactive\fR and redisplay the button -using its active foreground and background colors instead of normal -colors. -.VS -This command is ignored if the button's state is \fBdisabled\fR. -This command is obsolete and will eventually be removed; -use ``\fIpathName \fBconfigure \-state active\fR'' instead. -.VE +\fIpathName \fBcget\fR \fIoption\fR +Returns the current value of the configuration option given +by \fIoption\fR. +\fIOption\fR may have any of the values accepted by the \fBbutton\fR +command. .TP \fIpathName \fBconfigure\fR ?\fIoption\fR? ?\fIvalue option value ...\fR? Query or modify the configuration options of the widget. @@ -162,55 +116,43 @@ this case the command returns an empty string. \fIOption\fR may have any of the values accepted by the \fBbutton\fR command. .TP -\fIpathName \fBdeactivate\fR -Change the button's state to \fBnormal\fR and redisplay the button -using its normal foreground and background colors. -.VS -This command is ignored if the button's state is \fBdisabled\fR. -This command is obsolete and will eventually be removed; -use ``\fIpathName \fBconfigure \-state normal\fR'' instead. -.VE -.TP \fIpathName \fBflash\fR Flash the button. This is accomplished by redisplaying the button several times, alternating between active and normal colors. At the end of the flash the button is left in the same normal/active state as when the command was invoked. -.VS This command is ignored if the button's state is \fBdisabled\fR. -.VE .TP \fIpathName \fBinvoke\fR -.VS Invoke the Tcl command associated with the button, if there is one. The return value is the return value from the Tcl command, or an empty string if there is no command associated with the button. This command is ignored if the button's state is \fBdisabled\fR. -.VE .SH "DEFAULT BINDINGS" .PP -.VS Tk automatically creates class bindings for buttons that give them the following default behavior: .IP [1] -The button activates whenever the mouse passes over it and deactivates +A button activates whenever the mouse passes over it and deactivates whenever the mouse leaves the button. .IP [2] -The button's relief is changed to sunken whenever mouse button 1 is +A button's relief is changed to sunken whenever mouse button 1 is pressed over the button, and the relief is restored to its original value when button 1 is later released. .IP [3] -If mouse button 1 is pressed over the button and later released over +If mouse button 1 is pressed over a button and later released over the button, the button is invoked. However, if the mouse is not over the button when button 1 is released, then no invocation occurs. +.IP [4] +When a button has the input focus, the space key causes the button +to be invoked. .PP If the button's state is \fBdisabled\fR then none of the above actions occur: the button is completely non-responsive. .PP The behavior of buttons can be changed by defining new bindings for individual widgets or by redefining the class bindings. -.VE .SH KEYWORDS button, widget diff --git a/tk3.6/doc/canvas.n b/tk4.2/doc/canvas.n similarity index 81% rename from tk3.6/doc/canvas.n rename to tk4.2/doc/canvas.n index 8d9a840..2c354eb 100644 --- a/tk3.6/doc/canvas.n +++ b/tk4.2/doc/canvas.n @@ -1,116 +1,74 @@ '\" -'\" Copyright (c) 1992 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1992-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" $Header: /user6/ouster/wish/man/RCS/canvas.n,v 1.19 93/08/06 11:11:03 ouster Exp $ SPRITE (Berkeley) -'/" +'\" SCCS: @(#) canvas.n 1.52 96/09/06 11:18:32 +'\" .so man.macros -.HS canvas tk +.TH canvas n 4.0 Tk "Tk Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME canvas \- Create and manipulate canvas widgets .SH SYNOPSIS \fBcanvas\fI \fIpathName \fR?\fIoptions\fR? -.SH "STANDARD OPTIONS" -.LP -.nf -.ta 4c 8c 12c -\fBbackground\fR \fBinsertBorderWidth\fR \fBrelief\fR \fBxScrollCommand\fR -.VS -\fBborderWidth\fR \fBinsertOffTime\fR \fBselectBackground\fR \fByScrollCommand\fR -\fBcursor\fR \fBinsertOnTime\fR \fBselectBorderWidth\fR -\fBinsertBackground\fR \fBinsertWidth\fR \fBselectForeground\fR -.VE -.fi -.LP -See the ``options'' manual entry for details on the standard options. +.SO +\-background \-highlightthickness \-insertwidth \-takefocus +\-borderwidth \-insertbackground \-relief \-xscrollcommand +\-cursor \-insertborderwidth \-selectbackground \-yscrollcommand +\-highlightbackground \-insertofftime \-selectborderwidth +\-highlightcolor \-insertontime \-selectforeground +.SE .SH "WIDGET-SPECIFIC OPTIONS" -.ta 4c -.LP -.nf -Name: \fBcloseEnough\fR -Class: \fBCloseEnough\fR -Command-Line Switch: \fB\-closeenough\fR -.fi -.IP +.OP \-closeenough closeEnough CloseEnough Specifies a floating-point value indicating how close the mouse cursor must be to an item before it is considered to be ``inside'' the item. Defaults to 1.0. -.LP -.nf -.VS -Name: \fBconfine\fR -Class: \fBConfine\fR -Command-Line Switch: \fB\-confine\fR -.fi -.IP +.OP \-confine confine Confine Specifies a boolean value that indicates whether or not it should be allowable to set the canvas's view outside the region defined by the \fBscrollRegion\fR argument. Defaults to true, which means that the view will be constrained within the scroll region. -.VE -.LP -.nf -Name: \fBheight\fR -Class: \fBHeight\fR -Command-Line Switch: \fB\-height\fR -.fi -.IP +.OP \-height height Height Specifies a desired window height that the canvas widget should request from its geometry manager. The value may be specified in any of the forms described in the COORDINATES section below. -.LP -.nf -Name: \fBscrollIncrement\fR -Class: \fBScrollIncrement\fR -Command-Line Switch: \fB\-scrollincrement\fR -.fi -.IP -Specifies a distance used as increment during scrolling: when one of -the arrow buttons on an associated scrollbar is pressed, the picture -will shift by this distance. The distance may be specified in any -of the forms described in the COORDINATES section below. -.LP -.nf -Name: \fBscrollRegion\fR -Class: \fBScrollRegion\fR -Command-Line Switch: \fB\-scrollregion\fR -.fi -.IP +.OP \-scrollregion scrollRegion ScrollRegion Specifies a list with four coordinates describing the left, top, right, and bottom coordinates of a rectangular region. This region is used for scrolling purposes and is considered to be the boundary of the information in the canvas. Each of the coordinates may be specified in any of the forms given in the COORDINATES section below. -.LP -.nf -Name: \fBwidth\fR -Class: \fBwidth\fR -Command-Line Switch: \fB\-width\fR -.fi -.IP +.OP \-width width width Specifies a desired window width that the canvas widget should request from its geometry manager. The value may be specified in any of the forms described in the COORDINATES section below. +.br +.OP \-xscrollincrement xScrollIncrement ScrollIncrement +Specifies an increment for horizontal scrolling, in any of the usual forms +permitted for screen distances. If the value of this option is greater +than zero, the horizontal view in the window will be constrained so that +the canvas x coordinate at the left edge of the window is always an even +multiple of \fBxScrollIncrement\fR; furthermore, the units for scrolling +(e.g., the change in view when the left and right arrows of a scrollbar +are selected) will also be \fBxScrollIncrement\fR. If the value of +this option is less than or equal to zero, then horizontal scrolling +is unconstrained. +.OP \-yscrollincrement yScrollIncrement ScrollIncrement +Specifies an increment for vertical scrolling, in any of the usual forms +permitted for screen distances. If the value of this option is greater +than zero, the vertical view in the window will be constrained so that +the canvas y coordinate at the top edge of the window is always an even +multiple of \fByScrollIncrement\fR; furthermore, the units for scrolling +(e.g., the change in view when the top and bottom arrows of a scrollbar +are selected) will also be \fByScrollIncrement\fR. If the value of +this option is less than or equal to zero, then vertical scrolling +is unconstrained. .BE .SH INTRODUCTION @@ -221,7 +179,7 @@ for scrolling. Canvases do not support scaling or rotation of the canvas coordinate system relative to the window coordinate system. .PP -Indidividual items may be moved or scaled using widget commands +Individual items may be moved or scaled using widget commands described below, but they may not be rotated. .SH "INDICES" @@ -254,8 +212,6 @@ Refers to the character just after the last one in the item (same as the number of characters in the item). .TP 10 \fBinsert\fR -.VS -.VE Refers to the character just before which the insertion cursor is drawn in this item. .TP 10 @@ -281,9 +237,9 @@ The \fBcanvas\fR command creates a new Tcl command whose name is \fIpathName\fR. This command may be used to invoke various operations on the widget. It has the following general form: -.DS C +.CS \fIpathName option \fR?\fIarg arg ...\fR? -.DE +.CE \fIOption\fR and the \fIarg\fRs determine the exact behavior of the command. The following widget commands are possible for canvas widgets: @@ -353,7 +309,6 @@ Selects all the items given by \fItagOrId\fR. .RE .TP \fIpathName \fBbbox \fItagOrId\fR ?\fItagOrId tagOrId ...\fR? -.VS Returns a list with four elements giving an approximate bounding box for all the items named by the \fItagOrId\fR arguments. The list has the form ``\fIx1 y1 x2 y2\fR'' such that the drawn @@ -362,9 +317,10 @@ areas of all the named elements are within the region bounded by and \fIy2\fR on the bottom. The return value may overestimate the actual bounding box by a few pixels. -If no items match any of the \fItagOrId\fR arguments then an -empty string is returned. -.VE +If no items match any of the \fItagOrId\fR arguments or if the +matching items have empty bounding boxes (i.e. they have nothing +to display) +then an empty string is returned. .TP \fIpathName \fBbind \fItagOrId\fR ?\fIsequence\fR? ?\fIcommand\fR? This command associates \fIcommand\fR with all the items given by @@ -388,7 +344,7 @@ If both \fIcommand\fR and \fIsequence\fR are omitted then the command returns a list of all the sequences for which bindings have been defined for \fItagOrId\fR. .RS -.LP +.PP The only events for which bindings may be specified are those related to the mouse and keyboard, such as \fBEnter\fR, \fBLeave\fR, \fBButtonPress\fR, \fBMotion\fR, and \fBKeyPress\fR. @@ -401,32 +357,46 @@ events for windows. Mouse-related events are directed to the current item, if any. Keyboard-related events are directed to the focus item, if any (see the \fBfocus\fR widget command below for more on this). -.LP -It is possible for multiple commands to be bound to a single -event sequence for a single object. -This occurs, for example, if one command is associated with the +.PP +It is possible for multiple bindings to match a particular event. +This could occur, for example, if one binding is associated with the item's id and another is associated with one of the item's tags. -When this occurs, the first matching binding is used. -A binding for the item's id has highest priority, followed by -the oldest tag for the item and proceeding through all of the -item's tags up through the most-recently-added one. -If a binding is associated with the tag \fBall\fR, the binding -will have lower priority than all other bindings associated -with the item. +When this occurs, all of the matching bindings are invoked. +A binding associated with the \fBall\fR tag is invoked first, +followed by one binding for each of the item's tags (in order), +followed by a binding associated with the item's id. +If there are multiple matching bindings for a single tag, +then only the most specific binding is invoked. +A \fBcontinue\fR command in a binding script terminates that +script, and a \fBbreak\fR command terminates that script +and skips any remaining scripts for the event, just as for the +\fBbind\fR command. +.PP +If bindings have been created for a canvas window using the \fBbind\fR +command, then they are invoked in addition to bindings created for +the canvas's items using the \fBbind\fR widget command. +The bindings for items will be invoked before any of the bindings +for the window as a whole. .RE .TP \fIpathName \fBcanvasx \fIscreenx\fR ?\fIgridspacing\fR? -Given a screen x-coordinate \fIscreenx\fR this command returns +Given a window x-coordinate in the canvas \fIscreenx\fR, this command returns the canvas x-coordinate that is displayed at that location. If \fIgridspacing\fR is specified, then the canvas coordinate is rounded to the nearest multiple of \fIgridspacing\fR units. .TP \fIpathName \fBcanvasy \fIscreeny\fR ?\fIgridspacing\fR? -Given a screen y-coordinate \fIscreeny\fR this command returns +Given a window y-coordinate in the canvas \fIscreeny\fR this command returns the canvas y-coordinate that is displayed at that location. If \fIgridspacing\fR is specified, then the canvas coordinate is rounded to the nearest multiple of \fIgridspacing\fR units. .TP +\fIpathName \fBcget\fR \fIoption\fR +Returns the current value of the configuration option given +by \fIoption\fR. +\fIOption\fR may have any of the values accepted by the \fBcanvas\fR +command. +.TP \fIpathName \fBconfigure ?\fIoption\fR? ?\fIvalue\fR? ?\fIoption value ...\fR? Query or modify the configuration options of the widget. If no \fIoption\fR is specified, returns a list describing all of @@ -442,7 +412,6 @@ this case the command returns an empty string. command. .TP \fIpathName\fR \fBcoords \fItagOrId \fR?\fIx0 y0 ...\fR? -.VS Query or modify the coordinates that define an item. If no coordinates are specified, this command returns a list whose elements are the coordinates of the item named by @@ -451,7 +420,6 @@ If coordinates are specified, then they replace the current coordinates for the named item. If \fItagOrId\fR refers to multiple items, then the first one in the display list is used. -.VE .TP \fIpathName \fBcreate \fItype x y \fR?\fIx y ...\fR? ?\fIoption value ...\fR? Create a new item in \fIpathName\fR of type \fItype\fR. @@ -476,11 +444,9 @@ This command returns an empty string. .TP \fIpathName \fBdelete \fR?\fItagOrId tagOrId ...\fR? Delete each of the items given by each \fItagOrId\fR, and return -.VS an empty string. -.VE .TP -\fIpathName \fBdtag \fItagOrId \fR?tagToDelete\fR? +\fIpathName \fBdtag \fItagOrId \fR?\fItagToDelete\fR? For each of the items given by \fItagOrId\fR, delete the tag given by \fItagToDelete\fR from the list of those associated with the item. @@ -510,7 +476,7 @@ If \fItagOrId\fR is not specified then the command returns the id for the item that currently has the focus, or an empty string if no item has the focus. .RS -.LP +.PP Once the focus has been set to an item, the item will display the insertion cursor and all keyboard events will be directed to that item. @@ -533,7 +499,6 @@ If \fItagOrId\fR doesn't refer to any items, or if the item contains no tags, then an empty string is returned. .TP \fIpathName \fBicursor \fItagOrId index\fR -.VS Set the position of the insertion cursor for the item(s) given by \fItagOrId\fR to just before the character whose position is given by \fIindex\fR. @@ -546,7 +511,6 @@ that item currently has the keyboard focus (see the widget command \fBfocus\fR, below), but the cursor position may be set even when the item doesn't have the focus. This command returns an empty string. -.VE .TP \fIpathName \fBindex \fItagOrId index\fR This command returns a decimal string giving the numerical index @@ -567,6 +531,16 @@ See INDICES above for information about the forms allowed for \fIbeforeThis\fR. This command returns an empty string. .TP +\fIpathName \fBitemcget\fR \fItagOrId\fR \fIoption\fR +Returns the current value of the configuration option for the +item given by \fItagOrId\fR whose name is \fIoption\fR. +This command is similar to the \fBcget\fR widget command except that +it applies to a particular item rather than the widget as a whole. +\fIOption\fR may have any of the values accepted by the \fBcreate\fR +widget command when the item was created. +If \fItagOrId\fR is a tag that refers to more than one item, +the first (lowest) such item is used. +.TP \fIpathName \fBitemconfigure \fItagOrId\fR ?\fIoption\fR? ?\fIvalue\fR? ?\fIoption value ...\fR? This command is similar to the \fBconfigure\fR widget command except that it modifies item-specific options for the items given by @@ -606,20 +580,26 @@ each point associated with the item. This command returns an empty string. .TP \fIpathName \fBpostscript \fR?\fIoption value option value ...\fR? -.VS Generate a Postscript representation for part or all of the canvas. If the \fB\-file\fR option is specified then the Postscript is written to a file and an empty string is returned; otherwise the Postscript is returned as the result of the command. The Postscript is created in Encapsulated Postscript form using version 3.0 of the Document Structuring Conventions. +Note: by default Postscript is only generated for information that +appears in the canvas's window on the screen. If the canvas is +freshly created it may still have its initial size of 1x1 pixel +so nothing will appear in the Postscript. To get around this problem +either invoke the "update" command to wait for the canvas window +to reach its final size, or else use the \fB\-width\fR and \fB\-height\fR +options to specify the area of the canvas to print. The \fIoption\fR\-\fIvalue\fR argument pairs provide additional information to control the generation of Postscript. The following options are supported: .RS .TP \fB\-colormap \fIvarName\fR -\fIVarName\fR must be the name of a global array variable +\fIVarName\fR must be the name of an array variable that specifies a color mapping to use in the Postscript. Each element of \fIvarName\fR must consist of Postscript code to set a particular color value (e.g. ``\fB1.0 1.0 0.0 setrgbcolor\fR''). @@ -644,7 +624,7 @@ If this option isn't specified then the Postscript is returned as the result of the command instead of being written to a file. .TP \fB\-fontmap \fIvarName\fR -\fIVarName\fR must be the name of a global array variable +\fIVarName\fR must be the name of an array variable that specifies a font mapping to use in the Postscript. Each element of \fIvarName\fR must consist of a Tcl list with two elements, which are the name and point size of a Postscript font. @@ -666,12 +646,12 @@ Specifies the height of the area of the canvas to print. Defaults to the height of the canvas window. .TP \fB\-pageanchor \fIanchor\fR -Specifies which point of the printed area should be appear over +Specifies which point of the printed area of the canvas should appear over the positioning point on the page (which is given by the \fB\-pagex\fR and \fB\-pagey\fR options). For example, \fB\-pageanchor n\fR means that the top center of the -printed area should be over the positioning point. -Defaults to \fBcenter\fR. +area of the canvas being printed (as it appears in the canvas window) +should be over the positioning point. Defaults to \fBcenter\fR. .TP \fB\-pageheight \fIsize\fR Specifies that the Postscript should be scaled in both x and y so @@ -681,7 +661,7 @@ that the printed area is \fIsize\fR high on the Postscript page. or \fBp\fR or nothing for printer's points (1/72 inch). Defaults to the height of the printed area on the screen. If both \fB\-pageheight\fR and \fB\-pagewidth\fR are specified then -the scale factor from the later option is used (non-uniform scaling +the scale factor from \fB\-pagewidth\fR is used (non-uniform scaling is not implemented). .TP \fB\-pagewidth \fIsize\fR @@ -690,7 +670,7 @@ that the printed area is \fIsize\fR wide on the Postscript page. \fISize\fR has the same form as for \fB\-pageheight\fR. Defaults to the width of the printed area on the screen. If both \fB\-pageheight\fR and \fB\-pagewidth\fR are specified then -the scale factor from the later option is used (non-uniform scaling +the scale factor from \fB\-pagewidth\fR is used (non-uniform scaling is not implemented). .TP \fB\-pagex \fIposition\fR @@ -732,7 +712,6 @@ canvas that is to be printed, in canvas coordinates, not window coordinates. Defaults to the coordinate of the top edge of the window. .RE -.VE .TP \fIpathName \fBraise \fItagOrId \fR?\fIaboveThis\fR? Move all of the items given by \fItagOrId\fR to a new position @@ -849,27 +828,79 @@ of the first item in the display list is returned. If \fItagOrId\fR doesn't refer to any items at all then an empty string is returned. .TP -\fIpathName \fBxview\fI index\fR -Change the view in the canvas so that the canvas position given by -\fIindex\fR appears at the left edge of the window. -This command is typically used by scrollbars to scroll the -canvas. -\fIIndex\fR counts in units of scroll increments (the value of the -\fBscrollIncrement\fR option): a value of 0 corresponds to the left -edge of the scroll region (as defined by the \fBscrollRegion\fR -option), a value of 1 means one scroll unit to the right of this, -and so on. The return value is an empty string. +\fIpathName \fBxview \fR?\fIargs\fR? +This command is used to query and change the horizontal position of the +information displayed in the canvas's window. +It can take any of the following forms: +.RS .TP -\fIpathName \fByview\fI index\fR -Change the view in the canvas so that the canvas position given by -\fIindex\fR appears at the top edge of the window. -This command is typically used by scrollbars to scroll the -canvas. -\fIIndex\fR counts in units of scroll increments (the value of the -\fBscrollIncrement\fR option): a value of 0 corresponds to the top -edge of the scroll region (as defined by the \fBscrollRegion\fR -option), a value of 1 means one scroll unit below this, -and so on. The return value is an empty string. +\fIpathName \fBxview\fR +Returns a list containing two elements. +Each element is a real fraction between 0 and 1; together they describe +the horizontal span that is visible in the window. +For example, if the first element is .2 and the second element is .6, +20% of the canvas's area (as defined by the \fB\-scrollregion\fR option) +is off-screen to the left, the middle 40% is visible +in the window, and 40% of the canvas is off-screen to the right. +These are the same values passed to scrollbars via the \fB\-xscrollcommand\fR +option. +.TP +\fIpathName \fBxview moveto\fI fraction\fR +Adjusts the view in the window so that \fIfraction\fR of the +total width of the canvas is off-screen to the left. +\fIFraction\fR must be a fraction between 0 and 1. +.TP +\fIpathName \fBxview scroll \fInumber what\fR +This command shifts the view in the window left or right according to +\fInumber\fR and \fIwhat\fR. +\fINumber\fR must be an integer. +\fIWhat\fR must be either \fBunits\fR or \fBpages\fR or an abbreviation +of one of these. +If \fIwhat\fR is \fBunits\fR, the view adjusts left or right in units +of the \fBxScrollIncrement\fR option, if it is greater than zero, +or in units of one-tenth the window's width otherwise. +If \fIwhat is \fBpages\fR then the view +adjusts in units of nine-tenths the window's width. +If \fInumber\fR is negative then information farther to the left +becomes visible; if it is positive then information farther to the right +becomes visible. +.RE +.TP +\fIpathName \fByview \fI?args\fR? +This command is used to query and change the vertical position of the +information displayed in the canvas's window. +It can take any of the following forms: +.RS +.TP +\fIpathName \fByview\fR +Returns a list containing two elements. +Each element is a real fraction between 0 and 1; together they describe +the vertical span that is visible in the window. +For example, if the first element is .6 and the second element is 1.0, +the lowest 40% of the canvas's area (as defined by the \fB\-scrollregion\fR +option) is visible in the window. +These are the same values passed to scrollbars via the \fB\-yscrollcommand\fR +option. +.TP +\fIpathName \fByview moveto\fI fraction\fR +Adjusts the view in the window so that \fIfraction\fR of the canvas's +area is off-screen to the top. +\fIFraction\fR is a fraction between 0 and 1. +.TP +\fIpathName \fByview scroll \fInumber what\fR +This command adjusts the view in the window up or down according to +\fInumber\fR and \fIwhat\fR. +\fINumber\fR must be an integer. +\fIWhat\fR must be either \fBunits\fR or \fBpages\fR. +If \fIwhat\fR is \fBunits\fR, the view adjusts up or down in units +of the \fByScrollIncrement\fR option, if it is greater than zero, +or in units of one-tenth the window's height otherwise. +If \fIwhat\fR is \fBpages\fR then +the view adjusts in units of nine-tenths the window's height. +If \fInumber\fR is negative then higher information becomes +visible; if it is positive then lower information +becomes visible. +.RE .SH "OVERVIEW OF ITEM TYPES" .PP @@ -887,19 +918,18 @@ this support). .SH "ARC ITEMS" .PP -.VS Items of type \fBarc\fR appear on the display as arc-shaped regions. An arc is a section of an oval delimited by two angles (specified by the \fB\-start\fR and \fB\-extent\fR options) and displayed in one of several ways (specified by the \fB\-style\fR option). Arcs are created with widget commands of the following form: -.DS +.CS \fIpathName \fBcreate arc \fIx1 y1 x2 y2 \fR?\fIoption value option value ...\fR? -.DE +.CE The arguments \fIx1\fR, \fIy1\fR, \fIx2\fR, and \fIy2\fR give the coordinates of two diagonally opposite corners of a rectangular region enclosing the oval that defines the arc. -After the coordinates there may be any number of \fIoption\fR-\fIvalue\fR +After the coordinates there may be any number of \fIoption\fR\-\fIvalue\fR pairs, each of which sets one of the configuration options for the item. These same \fIoption\fR\-\fIvalue\fR pairs may be used in \fBitemconfigure\fR widget commands to change the item's @@ -911,6 +941,8 @@ Specifies the size of the angular range occupied by the arc. The arc's range extends for \fIdegrees\fR degrees counter-clockwise from the starting angle given by the \fB\-start\fR option. \fIDegrees\fR may be negative. +If it is greater than 360 or less than -360, then \fIdegrees\fR +modulo 360 is used as the extent. .TP \fB\-fill \fIcolor\fR Fill the region of the arc with \fIcolor\fR. @@ -921,11 +953,18 @@ then the arc will not be filled. \fB\-outline \fIcolor\fR \fIColor\fR specifies a color to use for drawing the arc's outline; it may have any of the forms accepted by \fBTk_GetColor\fR. -This option defaults to \fBblack\fR. If the arc's style is -\fBarc\fR then this option is ignored (the section of perimeter is -filled using the \fB\-fill\fR option). If \fIcolor\fR is specified +This option defaults to \fBblack\fR. If \fIcolor\fR is specified as an empty string then no outline is drawn for the arc. .TP +\fB\-outlinestipple \fIbitmap\fR +Indicates that the outline for the arc should be drawn with a stipple pattern; +\fIbitmap\fR specifies the stipple pattern to use, in any of the +forms accepted by \fBTk_GetBitmap\fR. +If the \fB\-outline\fR option hasn't been specified then this option +has no effect. +If \fIbitmap\fR is an empty string (the default), then the outline is drawn +in a solid fashion. +.TP \fB\-start \fIdegrees\fR Specifies the beginning of the angular range occupied by the arc. @@ -950,8 +989,8 @@ If \fItype\fR is \fBchord\fR then the arc's region is defined by a section of the oval's perimeter plus a single line segment connecting the two end points of the perimeter section. If \fItype\fR is \fBarc\fR then the arc's region consists of -a section of the perimeter alone. In this last case there is -no outline for the arc and the \fB\-outline\fR option is ignored. +a section of the perimeter alone. +In this last case the \fB\-fill\fR option is ignored. .TP \fB\-tags \fItagList\fR Specifies a set of tags to apply to the item. @@ -973,13 +1012,13 @@ This option defaults to 1.0. Items of type \fBbitmap\fR appear on the display as images with two colors, foreground and background. Bitmaps are created with widget commands of the following form: -.DS +.CS \fIpathName \fBcreate bitmap \fIx y \fR?\fIoption value option value ...\fR? -.DE +.CE The arguments \fIx\fR and \fIy\fR specify the coordinates of a point used to position the bitmap on the display (see the \fB\-anchor\fR option below for more information on how bitmaps are displayed). -After the coordinates there may be any number of \fIoption\fR-\fIvalue\fR +After the coordinates there may be any number of \fIoption\fR\-\fIvalue\fR pairs, each of which sets one of the configuration options for the item. These same \fIoption\fR\-\fIvalue\fR pairs may be used in \fBitemconfigure\fR widget commands to change the item's @@ -1000,7 +1039,8 @@ Specifies a color to use for each of the bitmap pixels whose value is 0. \fIColor\fR may have any of the forms accepted by \fBTk_GetColor\fR. If this option isn't specified, or if it is specified as an empty -string, then the background color for the canvas is used. +string, then nothing is displayed where the bitmap pixels are 0; this +produces a transparent effect. .TP \fB\-bitmap \fIbitmap\fR Specifies the bitmap to display in the item. @@ -1017,20 +1057,56 @@ Specifies a set of tags to apply to the item. \fITagList\fR consists of a list of tag names, which replace any existing tags for the item. \fITagList\fR may be an empty list. -.VE + +.SH "IMAGE ITEMS" +.PP +Items of type \fBimage\fR are used to display images on a +canvas. +Images are created with widget commands of the following form: +.CS +\fIpathName \fBcreate image \fIx y \fR?\fIoption value option value ...\fR? +.CE +The arguments \fIx\fR and \fIy\fR specify the coordinates of a +point used to position the image on the display (see the \fB\-anchor\fR +option below for more information). +After the coordinates there may be any number of \fIoption\fR\-\fIvalue\fR +pairs, each of which sets one of the configuration options +for the item. These same \fIoption\fR\-\fIvalue\fR pairs may be +used in \fBitemconfigure\fR widget commands to change the item's +configuration. +The following options are supported for images: +.TP +\fB\-anchor \fIanchorPos\fR +\fIAnchorPos\fR tells how to position the image relative to the +positioning point for the item; it may have any of the forms +accepted by \fBTk_GetAnchor\fR. For example, if \fIanchorPos\fR +is \fBcenter\fR then the image is centered on the point; if +\fIanchorPos\fR is \fBn\fR then the image will be drawn so that +its top center point is at the positioning point. +This option defaults to \fBcenter\fR. +.TP +\fB\-image \fIname\fR +Specifies the name of the image to display in the item. +This image must have been created previously with the +\fBimage create\fR command. +.TP +\fB\-tags \fItagList\fR +Specifies a set of tags to apply to the item. +\fITagList\fR consists of a list of tag names, which replace any +existing tags for the item; it may be an empty list. .SH "LINE ITEMS" .PP Items of type \fBline\fR appear on the display as one or more connected line segments or curves. Lines are created with widget commands of the following form: -.DS +.CS \fIpathName \fBcreate line \fIx1 y1... xn yn \fR?\fIoption value option value ...\fR? -.DE +.CE The arguments \fIx1\fR through \fIyn\fR give the coordinates for a series of two or more points that describe a series of connected line segments. -After the coordinates there may be any number of \fIoption\fR-\fIvalue\fR +After the coordinates there may be any number of \fIoption\fR\-\fIvalue\fR pairs, each of which sets one of the configuration options for the item. These same \fIoption\fR\-\fIvalue\fR pairs may be used in \fBitemconfigure\fR widget commands to change the item's @@ -1083,7 +1159,6 @@ If the line only contains two points then this option is irrelevant. .TP \fB\-smooth \fIboolean\fR -.VS \fIBoolean\fR must have one of the forms accepted by \fBTk_GetBoolean\fR. It indicates whether or not the line should be drawn as a curve. If so, the line is rendered as a set of Bezier splines: one spline @@ -1095,7 +1170,6 @@ a curve by duplicating the end-points of the desired line segment. Specifies the degree of smoothness desired for curves: each spline will be approximated with \fInumber\fR line segments. This option is ignored unless the \fB\-smooth\fR option is true. -.VE .TP \fB\-stipple \fIbitmap\fR Indicates that the line should be filled in a stipple pattern; @@ -1105,12 +1179,10 @@ If \fIbitmap\fR is an empty string (the default), then filling is done in a solid fashion. .TP \fB\-tags \fItagList\fR -.VS Specifies a set of tags to apply to the item. \fITagList\fR consists of a list of tag names, which replace any existing tags for the item. \fITagList\fR may be an empty list. -.VE .TP \fB\-width \fIlineWidth\fR \fILineWidth\fR specifies the width of the line, in any of the forms @@ -1125,9 +1197,9 @@ Items of type \fBoval\fR appear as circular or oval regions on the display. Each oval may have an outline, a fill, or both. Ovals are created with widget commands of the following form: -.DS +.CS \fIpathName \fBcreate oval \fIx1 y1 x2 y2 \fR?\fIoption value option value ...\fR? -.DE +.CE The arguments \fIx1\fR, \fIy1\fR, \fIx2\fR, and \fIy2\fR give the coordinates of two diagonally opposite corners of a rectangular region enclosing the oval. @@ -1135,7 +1207,7 @@ The oval will include the top and left edges of the rectangle not the lower or right edges. If the region is square then the resulting oval is circular; otherwise it is elongated in shape. -After the coordinates there may be any number of \fIoption\fR-\fIvalue\fR +After the coordinates there may be any number of \fIoption\fR\-\fIvalue\fR pairs, each of which sets one of the configuration options for the item. These same \fIoption\fR\-\fIvalue\fR pairs may be used in \fBitemconfigure\fR widget commands to change the item's @@ -1165,22 +1237,18 @@ If \fIbitmap\fR is an empty string (the default), then filling is done in a solid fashion. .TP \fB\-tags \fItagList\fR -.VS Specifies a set of tags to apply to the item. \fITagList\fR consists of a list of tag names, which replace any existing tags for the item. \fITagList\fR may be an empty list. -.VE .TP \fB\-width \fIoutlineWidth\fR \fIoutlineWidth\fR specifies the width of the outline to be drawn around the oval, in any of the forms described in the COORDINATES section above. If the \fB\-outline\fR option hasn't been specified then this option has no effect. -.VS Wide outlines are drawn centered on the oval path defined by \fIx1\fR, \fIy1\fR, \fIx2\fR, and \fIy2\fR. -.VE This option defaults to 1.0. .SH "POLYGON ITEMS" @@ -1188,14 +1256,14 @@ This option defaults to 1.0. Items of type \fBpolygon\fR appear as polygonal or curved filled regions on the display. Polygons are created with widget commands of the following form: -.DS +.CS \fIpathName \fBcreate polygon \fIx1 y1 ... xn yn \fR?\fIoption value option value ...\fR? -.DE +.CE The arguments \fIx1\fR through \fIyn\fR specify the coordinates for three or more points that define a closed polygon. The first and last points may be the same; whether they are or not, Tk will draw the polygon as a closed polygon. -After the coordinates there may be any number of \fIoption\fR-\fIvalue\fR +After the coordinates there may be any number of \fIoption\fR\-\fIvalue\fR pairs, each of which sets one of the configuration options for the item. These same \fIoption\fR\-\fIvalue\fR pairs may be used in \fBitemconfigure\fR widget commands to change the item's @@ -1209,8 +1277,14 @@ If \fIcolor\fR is an empty string then the polygon will be transparent. This option defaults to \fBblack\fR. .TP +\fB\-outline \fIcolor\fR +\fIColor\fR specifies a color to use for drawing the polygon's +outline; it may have any of the forms accepted by \fBTk_GetColor\fR. +If \fIcolor\fR is an empty string then no outline will be +drawn for the polygon. +This option defaults to empty (no outline). +.TP \fB\-smooth \fIboolean\fR -.VS \fIBoolean\fR must have one of the forms accepted by \fBTk_GetBoolean\fR It indicates whether or not the polygon should be drawn with a curved perimeter. @@ -1223,7 +1297,6 @@ smoothed polygon by duplicating the end-points of the desired line segment. Specifies the degree of smoothness desired for curves: each spline will be approximated with \fInumber\fR line segments. This option is ignored unless the \fB\-smooth\fR option is true. -.VE .TP \fB\-stipple \fIbitmap\fR Indicates that the polygon should be filled in a stipple pattern; @@ -1233,12 +1306,26 @@ If \fIbitmap\fR is an empty string (the default), then filling is done in a solid fashion. .TP \fB\-tags \fItagList\fR -.VS Specifies a set of tags to apply to the item. \fITagList\fR consists of a list of tag names, which replace any existing tags for the item. \fITagList\fR may be an empty list. -.VE +.TP +\fB\-width \fIoutlineWidth\fR +\fIOutlineWidth\fR specifies the width of the outline to be drawn around +the polygon, in any of the forms described in the COORDINATES section above. +If the \fB\-outline\fR option hasn't been specified then this option +has no effect. This option defaults to 1.0. +.PP +Polygon items are different from other items such as rectangles, ovals +and arcs in that interior points are considered to be ``inside'' a +polygon (e.g. for purposes of the \fBfind closest\fR and +\fBfind overlapping\fR widget commands) even if it is not filled. +For most other item types, an +interior point is considered to be inside the item only if the item +is filled or if it has neither a fill nor an outline. If you would +like an unfilled polygon whose interior points are not considered +to be inside the polygon, use a line item instead. .SH "RECTANGLE ITEMS" .PP @@ -1246,14 +1333,14 @@ Items of type \fBrectangle\fR appear as rectangular regions on the display. Each rectangle may have an outline, a fill, or both. Rectangles are created with widget commands of the following form: -.DS +.CS \fIpathName \fBcreate rectangle \fIx1 y1 x2 y2 \fR?\fIoption value option value ...\fR? -.DE +.CE The arguments \fIx1\fR, \fIy1\fR, \fIx2\fR, and \fIy2\fR give the coordinates of two diagonally opposite corners of the rectangle (the rectangle will include its upper and left edges but not its lower or right edges). -After the coordinates there may be any number of \fIoption\fR-\fIvalue\fR +After the coordinates there may be any number of \fIoption\fR\-\fIvalue\fR pairs, each of which sets one of the configuration options for the item. These same \fIoption\fR\-\fIvalue\fR pairs may be used in \fBitemconfigure\fR widget commands to change the item's @@ -1263,7 +1350,7 @@ The following options are supported for rectangles: \fB\-fill \fIcolor\fR Fill the area of the rectangle with \fIcolor\fR, which may be specified in any of the forms accepted by \fBTk_GetColor\fR. -If \fIcolor\fR is an empty string (the default), then +If \fIcolor\fR is an empty string (the default), then the rectangle will not be filled. .TP \fB\-outline \fIcolor\fR @@ -1283,22 +1370,18 @@ If \fIbitmap\fR is an empty string (the default), then filling is done in a solid fashion. .TP \fB\-tags \fItagList\fR -.VS Specifies a set of tags to apply to the item. \fITagList\fR consists of a list of tag names, which replace any existing tags for the item. \fITagList\fR may be an empty list. -.VE .TP \fB\-width \fIoutlineWidth\fR \fIOutlineWidth\fR specifies the width of the outline to be drawn around the rectangle, in any of the forms described in the COORDINATES section above. If the \fB\-outline\fR option hasn't been specified then this option has no effect. -.VS Wide outlines are drawn centered on the rectangular path defined by \fIx1\fR, \fIy1\fR, \fIx2\fR, and \fIy2\fR. -.VE This option defaults to 1.0. .SH "TEXT ITEMS" @@ -1308,18 +1391,16 @@ or more lines. Text items support indexing and selection, along with the following text-related canvas widget commands: \fBdchars\fR, \fBfocus\fR, \fBicursor\fR, \fBindex\fR, \fBinsert\fR, -.VS -.VE \fBselect\fR. Text items are created with widget commands of the following form: -.DS +.CS \fIpathName \fBcreate text \fIx y \fR?\fIoption value option value ...\fR? -.DE +.CE The arguments \fIx\fR and \fIy\fR specify the coordinates of a point used to position the text on the display (see the options below for more information on how text is displayed). -After the coordinates there may be any number of \fIoption\fR-\fIvalue\fR +After the coordinates there may be any number of \fIoption\fR\-\fIvalue\fR pairs, each of which sets one of the configuration options for the item. These same \fIoption\fR\-\fIvalue\fR pairs may be used in \fBitemconfigure\fR widget commands to change the item's @@ -1364,12 +1445,10 @@ If \fIbitmap\fR is an empty string (the default) then the text is drawn in a solid fashion. .TP \fB\-tags \fItagList\fR -.VS Specifies a set of tags to apply to the item. \fITagList\fR consists of a list of tag names, which replace any existing tags for the item. \fITagList\fR may be an empty list. -.VE .TP \fB\-text \fIstring\fR \fIString\fR specifies the characters to be displayed in the text item. @@ -1380,7 +1459,7 @@ This option defaults to an empty string. .TP \fB\-width \fIlineLength\fR Specifies a maximum line length for the text, in any of the forms -described in the COORDINATES section abov. +described in the COORDINATES section above. If this option is zero (the default) the text is broken into lines only at newline characters. However, if this option is non-zero then any line that would @@ -1391,17 +1470,16 @@ character. .SH "WINDOW ITEMS" .PP -.VS Items of type \fBwindow\fR cause a particular window to be displayed at a given position on the canvas. Window items are created with widget commands of the following form: -.DS +.CS \fIpathName \fBcreate window \fIx y \fR?\fIoption value option value ...\fR? -.DE +.CE The arguments \fIx\fR and \fIy\fR specify the coordinates of a point used to position the window on the display (see the \fB\-anchor\fR option below for more information on how bitmaps are displayed). -After the coordinates there may be any number of \fIoption\fR-\fIvalue\fR +After the coordinates there may be any number of \fIoption\fR\-\fIvalue\fR pairs, each of which sets one of the configuration options for the item. These same \fIoption\fR\-\fIvalue\fR pairs may be used in \fBitemconfigure\fR widget commands to change the item's @@ -1442,16 +1520,12 @@ Specifies the window to associate with this item. The window specified by \fIpathName\fR must either be a child of the canvas widget or a child of some ancestor of the canvas widget. \fIPathName\fR may not refer to a top-level window. -.VE .SH "APPLICATION-DEFINED ITEM TYPES" .PP It is possible for individual applications to define new item types for canvas widgets using C code. -The interfaces for this mechanism are not presently documented, -and it's possible they may change, but you should be able to -see how they work by examining the code for some of the existing -item types. +See the documentation for \fBTk_CreateItemType\fR. .SH BINDINGS .PP diff --git a/tk4.2/doc/checkbutton.n b/tk4.2/doc/checkbutton.n new file mode 100644 index 0000000..37ea5c9 --- /dev/null +++ b/tk4.2/doc/checkbutton.n @@ -0,0 +1,221 @@ +'\" +'\" Copyright (c) 1990-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) checkbutton.n 1.39 96/08/27 13:21:39 +'\" +.so man.macros +.TH checkbutton n 4.0 Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +checkbutton \- Create and manipulate checkbutton widgets +.SH SYNOPSIS +\fBcheckbutton\fI pathName \fR?\fIoptions\fR? +.SO +\-activebackground \-cursor \-highlightthickness \-takefocus +\-activeforeground \-disabledforeground \-image \-text +\-anchor \-font \-justify \-textvariable +\-background \-foreground \-padx \-underline +\-bitmap \-highlightbackground \-pady \-wraplength +\-borderwidth \-highlightcolor \-relief +.SE +.SH "WIDGET-SPECIFIC OPTIONS" +.OP \-command command Command +Specifies a Tcl command to associate with the button. This command +is typically invoked when mouse button 1 is released over the button +window. The button's global variable (\fB\-variable\fR option) will +be updated before the command is invoked. +.OP \-height height Height +Specifies a desired height for the button. +If an image or bitmap is being displayed in the button then the value is in +screen units (i.e. any of the forms acceptable to \fBTk_GetPixels\fR); +for text it is in lines of text. +If this option isn't specified, the button's desired height is computed +from the size of the image or bitmap or text being displayed in it. +.OP \-indicatoron indicatorOn IndicatorOn +Specifies whether or not the indicator should be drawn. Must be a +proper boolean value. If false, the \fBrelief\fR option is +ignored and the widget's relief is always sunken if the widget is +selected and raised otherwise. +.OP \-offvalue offValue Value +Specifies value to store in the button's associated variable whenever +this button is deselected. Defaults to ``0''. +.OP \-onvalue onValue Value +Specifies value to store in the button's associated variable whenever +this button is selected. Defaults to ``1''. +.OP \-selectcolor selectColor Background +Specifies a background color to use when the button is selected. +If \fBindicatorOn\fR is true then the color applicies to the indicator. +If \fBindicatorOn\fR is false, this color is used as the background +for the entire widget, in place of \fBbackground\fR or \fBactiveBackground\fR, +whenever the widget is selected. +If specified as an empty string then no special color is used for +displaying when the widget is selected. +.OP \-selectimage selectImage SelectImage +Specifies an image to display (in place of the \fBimage\fR option) +when the checkbutton is selected. +This option is ignored unless the \fBimage\fR option has been +specified. +.OP \-state state State +Specifies one of three states for the checkbutton: \fBnormal\fR, \fBactive\fR, +or \fBdisabled\fR. In normal state the checkbutton is displayed using the +\fBforeground\fR and \fBbackground\fR options. The active state is +typically used when the pointer is over the checkbutton. In active state +the checkbutton is displayed using the \fBactiveForeground\fR and +\fBactiveBackground\fR options. Disabled state means that the checkbutton +should be insensitive: the default bindings will refuse to activate +the widget and will ignore mouse button presses. +In this state the \fBdisabledForeground\fR and +\fBbackground\fR options determine how the checkbutton is displayed. +.OP \-variable variable Variable +Specifies name of global variable to set to indicate whether +or not this button is selected. Defaults to the name of the +button within its parent (i.e. the last element of the button +window's path name). +.OP \-width width Width +Specifies a desired width for the button. +If an image or bitmap is being displayed in the button then the value is in +screen units (i.e. any of the forms acceptable to \fBTk_GetPixels\fR); +for text it is in characters. +If this option isn't specified, the button's desired width is computed +from the size of the image or bitmap or text being displayed in it. +.BE + +.SH DESCRIPTION +.PP +The \fBcheckbutton\fR command creates a new window (given by the +\fIpathName\fR argument) and makes it into a checkbutton widget. +Additional +options, described above, may be specified on the command line +or in the option database +to configure aspects of the checkbutton such as its colors, font, +text, and initial relief. The \fBcheckbutton\fR command returns its +\fIpathName\fR argument. At the time this command is invoked, +there must not exist a window named \fIpathName\fR, but +\fIpathName\fR's parent must exist. +.PP +A checkbutton is a widget +that displays a textual string, bitmap or image +and a square called an \fIindicator\fR. +If text is displayed, it must all be in a single font, but it +can occupy multiple lines on the screen (if it contains newlines +or if wrapping occurs because of the \fBwrapLength\fR option) and +one of the characters may optionally be underlined using the +\fBunderline\fR option. +A checkbutton has +all of the behavior of a simple button, including the +following: it can display itself in either of three different +ways, according to the \fBstate\fR option; +it can be made to appear +raised, sunken, or flat; it can be made to flash; and it invokes +a Tcl command whenever mouse button 1 is clicked over the +checkbutton. +.PP +In addition, checkbuttons can be \fIselected\fR. +If a checkbutton is selected then the indicator is normally +drawn with a sunken relief and a special color, and +a Tcl variable associated with the checkbutton is set to a particular +value (normally 1). +If the checkbutton is not selected, then the indicator is drawn with a +raised relief and no special color, and the associated variable is +set to a different value (typically 0). +By default, the name of the variable associated with a checkbutton is the +same as the \fIname\fR used to create the checkbutton. +The variable name, and the ``on'' and ``off'' values stored in it, +may be modified with options on the command line or in the option +database. +Configuration options may also be used to modify the way the +indicator is displayed (or whether it is displayed at all). +By default a checkbutton is configured to select and deselect +itself on alternate button clicks. +In addition, each checkbutton monitors its associated variable and +automatically selects and deselects itself when the variables value +changes to and from the button's ``on'' value. + +.SH "WIDGET COMMAND" +.PP +The \fBcheckbutton\fR command creates a new Tcl command whose +name is \fIpathName\fR. This +command may be used to invoke various +operations on the widget. It has the following general form: +.CS +\fIpathName option \fR?\fIarg arg ...\fR? +.CE +\fIOption\fR and the \fIarg\fRs +determine the exact behavior of the command. The following +commands are possible for checkbutton widgets: +.TP +\fIpathName \fBcget\fR \fIoption\fR +Returns the current value of the configuration option given +by \fIoption\fR. +\fIOption\fR may have any of the values accepted by the \fBcheckbutton\fR +command. +.TP +\fIpathName \fBconfigure\fR ?\fIoption\fR? ?\fIvalue option value ...\fR? +Query or modify the configuration options of the widget. +If no \fIoption\fR is specified, returns a list describing all of +the available options for \fIpathName\fR (see \fBTk_ConfigureInfo\fR for +information on the format of this list). If \fIoption\fR is specified +with no \fIvalue\fR, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no \fIoption\fR is specified). If +one or more \fIoption\-value\fR pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +\fIOption\fR may have any of the values accepted by the \fBcheckbutton\fR +command. +.TP +\fIpathName \fBdeselect\fR +Deselects the checkbutton and sets the associated variable to its ``off'' +value. +.TP +\fIpathName \fBflash\fR +Flashes the checkbutton. This is accomplished by redisplaying the checkbutton +several times, alternating between active and normal colors. At +the end of the flash the checkbutton is left in the same normal/active +state as when the command was invoked. +This command is ignored if the checkbutton's state is \fBdisabled\fR. +.TP +\fIpathName \fBinvoke\fR +Does just what would have happened if the user invoked the checkbutton +with the mouse: toggle the selection state of the button and invoke +the Tcl command associated with the checkbutton, if there is one. +The return value is the return value from the Tcl command, or an +empty string if there is no command associated with the checkbutton. +This command is ignored if the checkbutton's state is \fBdisabled\fR. +.TP +\fIpathName \fBselect\fR +Selects the checkbutton and sets the associated variable to its ``on'' +value. +.TP +\fIpathName \fBtoggle\fR +Toggles the selection state of the button, redisplaying it and +modifying its associated variable to reflect the new state. + +.SH BINDINGS +.PP +Tk automatically creates class bindings for checkbuttons that give them +the following default behavior: +.IP [1] +A checkbutton activates whenever the mouse passes over it and deactivates +whenever the mouse leaves the checkbutton. +.IP [2] +When mouse button 1 is pressed over a checkbutton it is invoked (its +selection state toggles and the command associated with the button is +invoked, if there is one). +.IP [3] +When a checkbutton has the input focus, the space key causes the checkbutton +to be invoked. +.PP +If the checkbutton's state is \fBdisabled\fR then none of the above +actions occur: the checkbutton is completely non-responsive. +.PP +The behavior of checkbuttons can be changed by defining new bindings for +individual widgets or by redefining the class bindings. + +.SH KEYWORDS +checkbutton, widget diff --git a/tk4.2/doc/chooseColor.n b/tk4.2/doc/chooseColor.n new file mode 100644 index 0000000..8e4f210 --- /dev/null +++ b/tk4.2/doc/chooseColor.n @@ -0,0 +1,49 @@ +'\" +'\" Copyright (c) 1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) chooseColor.n 1.4 96/09/19 17:01:44 +'\" +.so man.macros +.TH tk_chooseColor n 4.2 Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +tk_chooseColor \- pops up a dialog box for the user to select a color. +.PP +.SH SYNOPSIS +\fBtk_chooseColor \fR?\fIoption value ...\fR? +.BE + +.SH DESCRIPTION +.PP +The procedure \fBtk_chooseColor\fR pops up a dialog box for the +user to select a color. The following \fIoption\-value\fR pairs are +possible as command line arguments: +.TP +\fB\-initialcolor\fR \fIcolor\fR +Specifies the color to display in the color dialog when it pops +up. \fIcolor\fR must be in a form acceptable to the \fBTk_GetColor\fR +function. +.TP +\fB\-parent\fR \fIwindow\fR +Makes \fIwindow\fR the logical parent of the color dialog. The color +dialog is displayed on top of its parent window. +.TP +\fB\-title\fR \fItitleString\fR +Specifies a string to display as the title of the dialog box. If this +option is not specified, then a default title will be displayed. +.LP +If the user selects a color, \fBtk_chooseColor\fR will return the +name of the color in a form acceptable to \fBTk_GetColor\fR. If the +user cancels the operation, both commands will return the empty +string. +.SH EXAMPLE +.CS +button .b \-fg [tk_chooseColor \-initialcolor gray \-title "Choose color"] +.CE + +.SH KEYWORDS +color selection dialog diff --git a/tk4.2/doc/clipboard.n b/tk4.2/doc/clipboard.n new file mode 100644 index 0000000..770463d --- /dev/null +++ b/tk4.2/doc/clipboard.n @@ -0,0 +1,81 @@ +'\" +'\" Copyright (c) 1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) clipboard.n 1.9 96/03/26 18:21:12 +'\" +.so man.macros +.TH clipboard n 4.0 Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +clipboard \- Manipulate Tk clipboard +.SH SYNOPSIS +\fBclipboard \fIoption\fR ?\fIarg arg ...\fR? +.BE + +.SH DESCRIPTION +.PP +This command provides a Tcl interface to the Tk clipboard, +which stores data for later retrieval using the selection mechanism. +In order to copy data into the clipboard, \fBclipboard clear\fR must +be called, followed by a sequence of one or more calls to \fBclipboard +append\fR. To ensure that the clipboard is updated atomically, all +appends should be completed before returning to the event loop. +.PP +The first argument to \fBclipboard\fR determines the format of the +rest of the arguments and the behavior of the command. The following +forms are currently supported: +.PP +.TP +\fBclipboard clear\fR ?\fB\-displayof\fR \fIwindow\fR? +Claims ownership of the clipboard on \fIwindow\fR's display and removes +any previous contents. \fIWindow\fR defaults to ``.''. Returns an +empty string. +.TP +\fBclipboard append\fR ?\fB\-displayof\fR \fIwindow\fR? ?\fB\-format\fR \fIformat\fR? ?\fB\-type\fR \fItype\fR? ?\fB\-\|\-\fR? \fIdata\fR +Appends \fIdata\fR to the clipboard on \fIwindow\fR's +display in the form given by \fItype\fR with the representation given +by \fIformat\fR and claims ownership of the clipboard on \fIwindow\fR's +display. +.RS +.PP +\fIType\fR specifies the form in which the selection is to be returned +(the desired ``target'' for conversion, in ICCCM terminology), and +should be an atom name such as STRING or FILE_NAME; see the +Inter-Client Communication Conventions Manual for complete details. +\fIType\fR defaults to STRING. +.PP +The \fIformat\fR argument specifies the representation that should be +used to transmit the selection to the requester (the second column of +Table 2 of the ICCCM), and defaults to STRING. If \fIformat\fR is +STRING, the selection is transmitted as 8-bit ASCII characters. If +\fIformat\fR is ATOM, then the \fIdata\fR is +divided into fields separated by white space; each field is converted +to its atom value, and the 32-bit atom value is transmitted instead of +the atom name. For any other \fIformat\fR, \fIdata\fR is divided +into fields separated by white space and each +field is converted to a 32-bit integer; an array of integers is +transmitted to the selection requester. Note that strings passed to +\fBclipboard append\fR are concatenated before conversion, so the +caller must take care to ensure appropriate spacing across string +boundaries. All items appended to the clipboard with the same +\fItype\fR must have the same \fIformat\fR. +.PP +The \fIformat\fR argument is needed only for compatibility with +clipboard requesters that don't use Tk. If the Tk toolkit is being +used to retrieve the CLIPBOARD selection then the value is converted back to +a string at the requesting end, so \fIformat\fR is +irrelevant. +.PP +A \fB\-\|\-\fR argument may be specified to mark the end of options: the +next argument will always be used as \fIdata\fR. +This feature may be convenient if, for example, \fIdata\fR starts +with a \fB\-\fR. +.RE + +.SH KEYWORDS +clear, format, clipboard, append, selection, type diff --git a/tk4.2/doc/destroy.n b/tk4.2/doc/destroy.n new file mode 100644 index 0000000..8a460e8 --- /dev/null +++ b/tk4.2/doc/destroy.n @@ -0,0 +1,31 @@ +'\" +'\" Copyright (c) 1990 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) destroy.n 1.13 96/03/26 18:21:26 +'\" +.so man.macros +.TH destroy n "" Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +destroy \- Destroy one or more windows +.SH SYNOPSIS +\fBdestroy \fR?\fIwindow window ...\fR? +.BE + +.SH DESCRIPTION +.PP +This command deletes the windows given by the +\fIwindow\fR arguments, plus all of their descendants. +If a \fIwindow\fR ``.'' is deleted then the entire application +will be destroyed. +The \fIwindow\fRs are destroyed in order, and if an error occurs +in destroying a window the command aborts without destroying the +remaining windows. + +.SH KEYWORDS +application, destroy, window diff --git a/tk3.6/doc/dialog.n b/tk4.2/doc/dialog.n similarity index 62% rename from tk3.6/doc/dialog.n rename to tk4.2/doc/dialog.n index 4e82685..e4c71b3 100644 --- a/tk3.6/doc/dialog.n +++ b/tk4.2/doc/dialog.n @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1992 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) dialog.n 1.8 96/08/27 13:21:40 '\" -'\" $Header: /user6/ouster/wish/man/RCS/dialog.n,v 1.1 93/07/09 11:36:32 ouster Exp $ SPRITE (Berkeley) -'/" .so man.macros -.HS tk_dialog tk 7.0 +.TH tk_dialog n 4.1 Tk "Tk Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -67,6 +54,8 @@ select one of the buttons either by clicking on the button with the mouse or by typing return to invoke the default button (if any). Then it returns the index of the selected button: 0 for the leftmost button, 1 for the button next to it, and so on. +If the dialog's window is destroyed before the user selects one +of the buttons, then -1 is returned. .PP While waiting for the user to respond, \fBtk_dialog\fR sets a local grab. This prevents the user from interacting with the application diff --git a/tk4.2/doc/entry.n b/tk4.2/doc/entry.n new file mode 100644 index 0000000..236beda --- /dev/null +++ b/tk4.2/doc/entry.n @@ -0,0 +1,419 @@ +'\" +'\" Copyright (c) 1990-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) entry.n 1.39 96/08/27 13:21:32 +'\" +.so man.macros +.TH entry n 4.1 Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +entry \- Create and manipulate entry widgets +.SH SYNOPSIS +\fBentry\fI \fIpathName \fR?\fIoptions\fR? +.SO +\-background \-highlightbackground \-insertontime \-selectforeground +\-borderwidth \-highlightcolor \-insertwidth \-takefocus +\-cursor \-highlightthickness \-justify \-textvariable +\-exportselection \-insertbackground \-relief \-xscrollcommand +\-font \-insertborderwidth \-selectbackground +\-foreground \-insertofftime \-selectborderwidth +.SE +.SH "WIDGET-SPECIFIC OPTIONS" +.OP \-show show Show +If this option is specified, then the true contents of the entry +are not displayed in the window. +Instead, each character in the entry's value will be displayed as +the first character in the value of this option, such as ``*''. +This is useful, for example, if the entry is to be used to enter +a password. +If characters in the entry are selected and copied elsewhere, the +information copied will be what is displayed, not the true contents +of the entry. +.OP \-state state State +Specifies one of two states for the entry: \fBnormal\fR or \fBdisabled\fR. +If the entry is disabled then the value may not be changed using widget +commands and no insertion cursor will be displayed, even if the input focus is +in the widget. +.OP \-width width Width +Specifies an integer value indicating the desired width of the entry window, +in average-size characters of the widget's font. +If the value is less than or equal to zero, the widget picks a +size just large enough to hold its current text. +.BE + +.SH DESCRIPTION +.PP +The \fBentry\fR command creates a new window (given by the +\fIpathName\fR argument) and makes it into an entry widget. +Additional options, described above, may be specified on the +command line or in the option database +to configure aspects of the entry such as its colors, font, +and relief. The \fBentry\fR command returns its +\fIpathName\fR argument. At the time this command is invoked, +there must not exist a window named \fIpathName\fR, but +\fIpathName\fR's parent must exist. +.PP +An entry is a widget that displays a one-line text string and +allows that string to be edited using widget commands described below, which +are typically bound to keystrokes and mouse actions. +When first created, an entry's string is empty. +A portion of the entry may be selected as described below. +If an entry is exporting its selection (see the \fBexportSelection\fR +option), then it will observe the standard X11 protocols for handling the +selection; entry selections are available as type \fBSTRING\fR. +Entries also observe the standard Tk rules for dealing with the +input focus. When an entry has the input focus it displays an +\fIinsertion cursor\fR to indicate where new characters will be +inserted. +.PP +Entries are capable of displaying strings that are too long to +fit entirely within the widget's window. In this case, only a +portion of the string will be displayed; commands described below +may be used to change the view in the window. Entries use +the standard \fBxScrollCommand\fR mechanism for interacting with +scrollbars (see the description of the \fBxScrollCommand\fR option +for details). They also support scanning, as described below. + +.SH "WIDGET COMMAND" +.PP +The \fBentry\fR command creates a new Tcl command whose +name is \fIpathName\fR. This +command may be used to invoke various +operations on the widget. It has the following general form: +.CS +\fIpathName option \fR?\fIarg arg ...\fR? +.CE +\fIOption\fR and the \fIarg\fRs +determine the exact behavior of the command. +.PP +Many of the widget commands for entries take one or more indices as +arguments. An index specifies a particular character in the entry's +string, in any of the following ways: +.TP 12 +\fInumber\fR +Specifies the character as a numerical index, where 0 corresponds +to the first character in the string. +.TP 12 +\fBanchor\fR +Indicates the anchor point for the selection, which is set with the +\fBselect from\fR and \fBselect adjust\fR widget commands. +.TP 12 +\fBend\fR +Indicates the character just after the last one in the entry's string. +This is equivalent to specifying a numerical index equal to the length +of the entry's string. +.TP 12 +\fBinsert\fR +Indicates the character adjacent to and immediately following the +insertion cursor. +.TP 12 +\fBsel.first\fR +Indicates the first character in the selection. It is an error to +use this form if the selection isn't in the entry window. +.TP 12 +\fBsel.last\fR +Indicates the character just after the last one in the selection. +It is an error to use this form if the selection isn't in the +entry window. +.TP 12 +\fB@\fInumber\fR +In this form, \fInumber\fR is treated as an x-coordinate in the +entry's window; the character spanning that x-coordinate is used. +For example, ``\fB@0\fR'' indicates the left-most character in the +window. +.LP +Abbreviations may be used for any of the forms above, e.g. ``\fBe\fR'' +or ``\fBsel.f\fR''. In general, out-of-range indices are automatically +rounded to the nearest legal value. +.PP +The following commands are possible for entry widgets: +.TP +\fIpathName \fBbbox \fIindex\fR +Returns a list of four numbers describing the bounding box of the +character given by \fIindex\fR. +The first two elements of the list give the x and y coordinates of +the upper-left corner of the screen area covered by the character +(in pixels relative to the widget) and the last two elements give +the width and height of the character, in pixels. +The bounding box may refer to a region outside the visible area +of the window. +.TP +\fIpathName \fBcget\fR \fIoption\fR +Returns the current value of the configuration option given +by \fIoption\fR. +\fIOption\fR may have any of the values accepted by the \fBentry\fR +command. +.TP +\fIpathName \fBconfigure\fR ?\fIoption\fR? ?\fIvalue option value ...\fR? +Query or modify the configuration options of the widget. +If no \fIoption\fR is specified, returns a list describing all of +the available options for \fIpathName\fR (see \fBTk_ConfigureInfo\fR for +information on the format of this list). If \fIoption\fR is specified +with no \fIvalue\fR, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no \fIoption\fR is specified). If +one or more \fIoption\-value\fR pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +\fIOption\fR may have any of the values accepted by the \fBentry\fR +command. +.TP +\fIpathName \fBdelete \fIfirst \fR?\fIlast\fR? +Delete one or more elements of the entry. +\fIFirst\fR is the index of the first character to delete, and +\fIlast\fR is the index of the character just after the last +one to delete. +If \fIlast\fR isn't specified it defaults to \fIfirst\fR+1, +i.e. a single character is deleted. +This command returns an empty string. +.TP +\fIpathName \fBget\fR +Returns the entry's string. +.TP +\fIpathName \fBicursor \fIindex\fR +Arrange for the insertion cursor to be displayed just before the character +given by \fIindex\fR. Returns an empty string. +.TP +\fIpathName \fBindex\fI index\fR +Returns the numerical index corresponding to \fIindex\fR. +.TP +\fIpathName \fBinsert \fIindex string\fR +Insert the characters of \fIstring\fR just before the character +indicated by \fIindex\fR. Returns an empty string. +.TP +\fIpathName \fBscan\fR \fIoption args\fR +This command is used to implement scanning on entries. It has +two forms, depending on \fIoption\fR: +.RS +.TP +\fIpathName \fBscan mark \fIx\fR +Records \fIx\fR and the current view in the entry window; used in +conjunction with later \fBscan dragto\fR commands. Typically this +command is associated with a mouse button press in the widget. It +returns an empty string. +.TP +\fIpathName \fBscan dragto \fIx\fR +This command computes the difference between its \fIx\fR argument +and the \fIx\fR argument to the last \fBscan mark\fR command for +the widget. It then adjusts the view left or right by 10 times the +difference in x-coordinates. This command is typically associated +with mouse motion events in the widget, to produce the effect of +dragging the entry at high speed through the window. The return +value is an empty string. +.RE +.TP +\fIpathName \fBselection \fIoption arg\fR +This command is used to adjust the selection within an entry. It +has several forms, depending on \fIoption\fR: +.RS +.TP +\fIpathName \fBselection adjust \fIindex\fR +Locate the end of the selection nearest to the character given by +\fIindex\fR, and adjust that end of the selection to be at \fIindex\fR +(i.e including but not going beyond \fIindex\fR). The other +end of the selection is made the anchor point for future +\fBselect to\fR commands. If the selection +isn't currently in the entry, then a new selection is created to +include the characters between \fIindex\fR and the most recent +selection anchor point, inclusive. +Returns an empty string. +.TP +\fIpathName \fBselection clear\fR +Clear the selection if it is currently in this widget. If the +selection isn't in this widget then the command has no effect. +Returns an empty string. +.TP +\fIpathName \fBselection from \fIindex\fR +Set the selection anchor point to just before the character +given by \fIindex\fR. Doesn't change the selection. +Returns an empty string. +.TP +\fIpathName \fBselection present\fR +Returns 1 if there is are characters selected in the entry, +0 if nothing is selected. +.TP +\fIpathName \fBselection range \fIstart\fR \fIend\fR +Sets the selection to include the characters starting with +the one indexed by \fIstart\fR and ending with the one just +before \fIend\fR. +If \fIend\fR refers to the same character as \fIstart\fR or an +earlier one, then the entry's selection is cleared. +.TP +\fIpathName \fBselection to \fIindex\fR +If \fIindex\fR is before the anchor point, set the selection +to the characters from \fIindex\fR up to but not including +the anchor point. +If \fIindex\fR is the same as the anchor point, do nothing. +If \fIindex\fR is after the anchor point, set the selection +to the characters from the anchor point up to but not including +\fIindex\fR. +The anchor point is determined by the most recent \fBselect from\fR +or \fBselect adjust\fR command in this widget. +If the selection isn't in this widget then a new selection is +created using the most recent anchor point specified for the widget. +Returns an empty string. +.RE +.TP +\fIpathName \fBxview \fIargs\fR +This command is used to query and change the horizontal position of the +text in the widget's window. It can take any of the following +forms: +.RS +.TP +\fIpathName \fBxview\fR +Returns a list containing two elements. +Each element is a real fraction between 0 and 1; together they describe +the horizontal span that is visible in the window. +For example, if the first element is .2 and the second element is .6, +20% of the entry's text is off-screen to the left, the middle 40% is visible +in the window, and 40% of the text is off-screen to the right. +These are the same values passed to scrollbars via the \fB\-xscrollcommand\fR +option. +.TP +\fIpathName \fBxview\fR \fIindex\fR +Adjusts the view in the window so that the character given by \fIindex\fR +is displayed at the left edge of the window. +.TP +\fIpathName \fBxview moveto\fI fraction\fR +Adjusts the view in the window so that the character \fIfraction\fR of the +way through the text appears at the left edge of the window. +\fIFraction\fR must be a fraction between 0 and 1. +.TP +\fIpathName \fBxview scroll \fInumber what\fR +This command shifts the view in the window left or right according to +\fInumber\fR and \fIwhat\fR. +\fINumber\fR must be an integer. +\fIWhat\fR must be either \fBunits\fR or \fBpages\fR or an abbreviation +of one of these. +If \fIwhat\fR is \fBunits\fR, the view adjusts left or right by +\fInumber\fR average-width characters on the display; if it is +\fBpages\fR then the view adjusts by \fInumber\fR screenfuls. +If \fInumber\fR is negative then characters farther to the left +become visible; if it is positive then characters farther to the right +become visible. +.RE + +.SH "DEFAULT BINDINGS" +.PP +Tk automatically creates class bindings for entries that give them +the following default behavior. +In the descriptions below, ``word'' refers to a contiguous group +of letters, digits, or ``_'' characters, or any single character +other than these. +.IP [1] +Clicking mouse button 1 positions the insertion cursor +just before the character underneath the mouse cursor, sets the +input focus to this widget, and clears any selection in the widget. +Dragging with mouse button 1 strokes out a selection between +the insertion cursor and the character under the mouse. +.IP [2] +Double-clicking with mouse button 1 selects the word under the mouse +and positions the insertion cursor at the beginning of the word. +Dragging after a double click will stroke out a selection consisting +of whole words. +.IP [3] +Triple-clicking with mouse button 1 selects all of the text in the +entry and positions the insertion cursor before the first character. +.IP [4] +The ends of the selection can be adjusted by dragging with mouse +button 1 while the Shift key is down; this will adjust the end +of the selection that was nearest to the mouse cursor when button +1 was pressed. +If the button is double-clicked before dragging then the selection +will be adjusted in units of whole words. +.IP [5] +Clicking mouse button 1 with the Control key down will position the +insertion cursor in the entry without affecting the selection. +.IP [6] +If any normal printing characters are typed in an entry, they are +inserted at the point of the insertion cursor. +.IP [7] +The view in the entry can be adjusted by dragging with mouse button 2. +If mouse button 2 is clicked without moving the mouse, the selection +is copied into the entry at the position of the mouse cursor. +.IP [8] +If the mouse is dragged out of the entry on the left or right sides +while button 1 is pressed, the entry will automatically scroll to +make more text visible (if there is more text off-screen on the side +where the mouse left the window). +.IP [9] +The Left and Right keys move the insertion cursor one character to the +left or right; they also clear any selection in the entry and set +the selection anchor. +If Left or Right is typed with the Shift key down, then the insertion +cursor moves and the selection is extended to include the new character. +Control-Left and Control-Right move the insertion cursor by words, and +Control-Shift-Left and Control-Shift-Right move the insertion cursor +by words and also extend the selection. +Control-b and Control-f behave the same as Left and Right, respectively. +Meta-b and Meta-f behave the same as Control-Left and Control-Right, +respectively. +.IP [10] +The Home key, or Control-a, will move the insertion cursor to the +beginning of the entry and clear any selection in the entry. +Shift-Home moves the insertion cursor to the beginning of the entry +and also extends the selection to that point. +.IP [11] +The End key, or Control-e, will move the insertion cursor to the +end of the entry and clear any selection in the entry. +Shift-End moves the cursor to the end and extends the selection +to that point. +.IP [12] +The Select key and Control-Space set the selection anchor to the position +of the insertion cursor. They don't affect the current selection. +Shift-Select and Control-Shift-Space adjust the selection to the +current position of the insertion cursor, selecting from the anchor +to the insertion cursor if there was not any selection previously. +.IP [13] +Control-/ selects all the text in the entry. +.IP [14] +Control-\e clears any selection in the entry. +.IP [15] +The F16 key (labelled Copy on many Sun workstations) or Meta-w +copies the selection in the widget to the clipboard, if there is a selection. +.IP [16] +The F20 key (labelled Cut on many Sun workstations) or Control-w +copies the selection in the widget to the clipboard and deletes +the selection. +If there is no selection in the widget then these keys have no effect. +.IP [17] +The F18 key (labelled Paste on many Sun workstations) or Control-y +inserts the contents of the clipboard at the position of the +insertion cursor. +.IP [18] +The Delete key deletes the selection, if there is one in the entry. +If there is no selection, it deletes the character to the right of +the insertion cursor. +.IP [19] +The BackSpace key and Control-h delete the selection, if there is one +in the entry. +If there is no selection, it deletes the character to the left of +the insertion cursor. +.IP [20] +Control-d deletes the character to the right of the insertion cursor. +.IP [21] +Meta-d deletes the word to the right of the insertion cursor. +.IP [22] +Control-k deletes all the characters to the right of the insertion +cursor. +.IP [23] +Control-w deletes the word to the left of the insertion cursor. +.IP [24] +Control-t reverses the order of the two characters to the right of +the insertion cursor. +.PP +If the entry is disabled using the \fB\-state\fR option, then the entry's +view can still be adjusted and text in the entry can still be selected, +but no insertion cursor will be displayed and no text modifications will +take place. +.PP +The behavior of entries can be changed by defining new bindings for +individual widgets or by redefining the class bindings. + +.SH KEYWORDS +entry, widget diff --git a/tk4.2/doc/event.n b/tk4.2/doc/event.n new file mode 100644 index 0000000..f5d4988 --- /dev/null +++ b/tk4.2/doc/event.n @@ -0,0 +1,334 @@ +'\" +'\" Copyright (c) 1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) event.n 1.4 96/10/03 18:39:43 +'\" +.so man.macros +.TH event n 4.2 Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +event \- Miscellaneous event facilities: define virtual events and generate events +.SH SYNOPSIS +\fBevent\fI option \fR?\fIarg arg ...\fR? +.BE + +.SH DESCRIPTION +.PP +The \fBevent\fR command provides several facilities for dealing with +window system events, such as defining virtual events and synthesizing +events. The command has several different forms, determined by the +first argument. The following forms are currently supported: +.TP +\fBevent add <<\fIvirtual\fB>>\fI sequence \fR?\fIsequence ...\fR? +Associates the virtual event \fIvirtual\fR with the physical +event sequence(s) given by the \fIsequence\fR arguments, so that +the virtual event will trigger whenever any one of the \fIsequence\fRs +occurs. +\fIVirtual\fR may be any string value and \fIsequence\fR may have +any of the values allowed for the \fIsequence\fR argument to the +\fBbind\fR command. +If \fIvirtual\fR is already defined, the new physical event sequences +add to the existing sequences for the event. +.TP +\fBevent delete <<\fIvirtual\fB>> \fR?\fIsequence \fIsequence ...\fR? +Deletes each of the \fIsequence\fRs from those associated with +the virtual event given by \fIvirtual\fR. +\fIVirtual\fR may be any string value and \fIsequence\fR may have +any of the values allowed for the \fIsequence\fR argument to the +\fBbind\fR command. +Any \fIsequence\fRs not currently associated with \fIvirtual\fR +are ignored. +If no \fIsequence\fR argument is provided, all physical event sequences +are removed for \fIvirtual\fR, so that the virtual event will not +trigger anymore. +.TP +\fBevent generate \fIwindow event \fR?\fIoption value option value ...\fR? +Generates a window event and arranges for it to be processed just as if +it had come from the window system. +\fIWindow\fR gives the path name of the window for which the event +will be generated, and \fIevent\fR provides a basic description of +the event, such as \fB\fR or \fB<>\fR. +\fIEvent\fR may have any of the forms allowed for the \fIsequence\fR +argument of the \fBbind\fR command except that it must consist +of a single event pattern, not a sequence. +\fIOption-value\fR pairs may be used to specify additional +attributes of the event, such as the x and y mouse position; see +EVENT FIELDS below. If the \fB\-when\fR option is not specified, the +event is processed immediately: all of the handlers for the event +will complete before the \fBevent generate\fR command returns. +If the \fB\-when\fR option is specified then it determines when the +event is processed. +.TP +\fBevent info \fR?<<\fIvirtual\fB>>\fR? +Returns information about virtual events. +If the \fB<<\fIvirtual\fB>>\fR argument is omitted, the return value +is a list of all the virtual events that are currently defined. +If \fB<<\fIvirtual\fB>>\fR is specified then the return value is +a list whose elements are the physical event sequences currently +defined for the given virtual event; if the virtual event is +not defined then an empty string is returned. + +.SH "EVENT FIELDS" +.PP +The following options are supported for the \fBevent generate\fR +command. These correspond to the ``%'' expansions +allowed in binding scripts for the \fBbind\fR command. +.TP +\fB\-above\fI window\fR +\fIWindow\fR specifies the \fIabove\fR field for the event, +either as a window path name or as an integer window id. +Valid for \fBConfigure\fR events. +Corresponds to the \fB%a\fR substitution for binding scripts. +.TP +\fB\-borderwidth\fI size\fR +\fISize\fR must be a screen distance; it specifies the +\fIborder_width\fR field for the event. +Valid for \fBConfigure\fR events. +Corresponds to the \fB%B\fR substitution for binding scripts. +.TP +\fB\-button\fI number\fR +\fINumber\fR must be an integer; it specifies the \fIdetail\fR field +for a \fBButtonPress\fR or \fBButtonRelease\fR event, overriding +any button number provided in the base \fIevent\fR argument. +Corresponds to the \fB%b\fR substitution for binding scripts. +.TP +\fB\-count\fI number\fR +\fINumber\fR must be an integer; it specifies the \fIcount\fR field +for the event. Valid for \fBExpose\fR events. +Corresponds to the \fB%c\fR substitution for binding scripts. +.TP +\fB\-detail\fI detail\fR +\fIDetail\fR specifies the \fIdetail\fR field for the event +and must be one of the following: +.RS +.DS +.ta 6c +\fBNotifyAncestor NotifyNonlinearVirtual +NotifyDetailNone NotifyPointer +NotifyInferior NotifyPointerRoot +NotifyNonlinear NotifyVirtual\fR +.DE +Valid for \fBEnter\fR, \fBLeave\fR, \fBFocusIn\fR and +\fBFocusOut\fR events. +Corresponds to the \fB%d\fR substitution for binding scripts. +.RE +.TP +\fB\-focus\fI boolean\fR +\fIBoolean\fR must be a boolean value; it specifies the \fIfocus\fR +field for the event. +Valid for \fBEnter\fR and \fBLeave\fR events. +Corresponds to the \fB%f\fR substitution for binding scripts. +.TP +\fB\-height\fI size\fR +\fISize\fR must be a screen distance; it specifies the \fIheight\fR +field for the event. Valid for \fBConfigure\fR events. +Corresponds to the \fB%h\fR substitution for binding scripts. +.TP +\fB\-keycode\fI number\fR +\fINumber\fR must be an integer; it specifies the \fIkeycode\fR +field for the event. +Valid for \fBKeyPress\fR and \fBKeyRelease\fR events. +Corresponds to the \fB%k\fR substitution for binding scripts. +.TP +\fB\-keysym\fI name\fR +\fIName\fR must be the name of a valid keysym, such as \fBg\fR, +\fBspace\fR, or \fBReturn\fR; its corresponding +keycode value is used as the \fIkeycode\fR field for event, overriding +any detail specified in the base \fIevent\fR argument. +Valid for \fBKeyPress\fR and \fBKeyRelease\fR events. +Corresponds to the \fB%K\fR substitution for binding scripts. +.TP +\fB\-mode\fI notify\fR +\fINotify\fR specifies the \fImode\fR field for the event and must be +one of \fBNotifyNormal\fR, \fBNotifyGrab\fR, \fBNotifyUngrab\fR, or +\fBNotifyWhileGrabbed\fR. +Valid for \fBEnter\fR, \fBLeave\fR, \fBFocusIn\fR, and +\fBFocusOut\fR events. +Corresponds to the \fB%m\fR substitution for binding scripts. +.TP +\fB\-override\fI boolean\fR +\fIBoolean\fR must be a boolean value; it specifies the +\fIoverride_redirect\fR field for the event. +Valid for \fBMap\fR, \fBReparent\fR, and \fBConfigure\fR events. +Corresponds to the \fB%o\fR substitution for binding scripts. +.TP +\fB\-place\fI where\fR +\fIWhere\fR specifies the \fIplace\fR field for the event; it must be +either \fBPlaceOnTop\fR or \fBPlaceOnBottom\fR. +Valid for \fBCirculate\fR events. +Corresponds to the \fB%p\fR substitution for binding scripts. +.TP +\fB\-root\fI window\fR +\fIWindow\fR must be either a window path name or an integer window +identifier; it specifies the \fIroot\fR field for the event. +Valid for \fBKeyPress\fR, \fBKeyRelease\fR, \fBButtonPress\fR, +\fBButtonRelease\fR, \fBEnter\fR, \fBLeave\fR, and \fBMotion\fR +events. +Corresponds to the \fB%R\fR substitution for binding scripts. +.TP +\fB\-rootx\fI coord\fR +\fICoord\fR must be a screen distance; it specifies the \fIx_root\fR +field for the event. +Valid for \fBKeyPress\fR, \fBKeyRelease\fR, \fBButtonPress\fR, +\fBButtonRelease\fR, \fBEnter\fR, \fBLeave\fR, and \fBMotion\fR +events. Corresponds to the \fB%X\fR substitution for binding scripts. +.TP +\fB\-rooty\fI coord\fR +\fICoord\fR must be a screen distance; it specifies th \fIy_root\fR +field for the event. +Valid for \fBKeyPress\fR, \fBKeyRelease\fR, \fBButtonPress\fR, +\fBButtonRelease\fR, \fBEnter\fR, \fBLeave\fR, and \fBMotion\fR +events. +Corresponds to the \fB%Y\fR substitution for binding scripts. +.TP +\fB\-sendevent\fI boolean\fR +\fBBoolean\fR must be a boolean value; it specifies the \fIsend_event\fR +field for the event. Valid for all events. Corresponds to the +\fB%E\fR substitution for binding scripts. +.TP +\fB\-serial\fI number\fR +\fINumber\fR must be an integer; it specifies the \fIserial\fR field +for the event. Valid for all events. +Corresponds to the \fB%#\fR substitution for binding scripts. +.TP +\fB\-state\fI state\fR +\fIState\fR specifies the \fIstate\fR field for the event. +For \fBKeyPress\fR, \fBKeyRelease\fR, \fBButtonPress\fR, +\fBButtonRelease\fR, \fBEnter\fR, \fBLeave\fR, and \fBMotion\fR events +it must be an integer value. +For \fBVisibility\fR events it must be one of \fBVisibilityUnobscured\fR, +\fBVisibilityPartiallyObscured\fR, or \fBVisibilityFullyObscured\fR. +This option overrides any modifiers such as \fBMeta\fR or \fBControl\fR +specified in the base \fIevent\fR. +Corresponds to the \fB%s\fR substitution for binding scripts. +.TP +\fB\-subwindow\fI window\fR +\fIWindow\fR specifies the \fIsubwindow\fR field for the event, either +as a path name for a Tk widget or as an integer window identifier. +Valid for \fBKeyPress\fR, \fBKeyRelease\fR, \fBButtonPress\fR, +\fBButtonRelease\fR, \fBEnter\fR, \fBLeave\fR, and \fBMotion\fR events. +Similar to \fB%S\fR substitution for binding scripts. +.TP +\fB\-time\fI integer\fR +\fIInteger\fR must be an integer value; it specifies the \fItime\fR field +for the event. +Valid for \fBKeyPress\fR, \fBKeyRelease\fR, \fBButtonPress\fR, +\fBButtonRelease\fR, \fBEnter\fR, \fBLeave\fR, \fBMotion\fR, +and \fBProperty\fR events. +Corresponds to the \fB%t\fR substitution for binding scripts. +.TP +\fB\-width\fI size\fR +\fISize\fR must be a screen distance; it specifies the \fIwidth\fR field +for the event. +Valid for \fBConfigure\fR events. +Corresponds to the \fB%w\fR substitution for binding scripts. +.TP +\fB\-when\fI when\fR +\fIWhen\fR determines when the event will be processed; it must have one +of the following values: +.RS +.IP \fBnow\fR 10 +Process the event immediately, before the command returns. +This also happens if the \fB\-when\fR option is omitted. +.IP \fBtail\fR 10 +Place the event on Tcl's event queue behind any events already +queued for this application. +.IP \fBhead\fR 10 +Place the event at the front of Tcl's event queue, so that it +will be handled before any other events already queued. +.IP \fBmark\fR 10 +Place the event at the front of Tcl's event queue but behind any +other events already queued with \fB\-when mark\fR. +This option is useful when generating a series of events that should +be processed in order but at the front of the queue. +.RE +.TP +\fB\-x\fI coord\fR +\fICoord\fR must be a screen distance; it specifies the \fIx\fR field +for the event. +Valid for \fBKeyPress\fR, \fBKeyRelease\fR, \fBButtonPress\fR, +\fBButtonRelease\fR, \fBMotion\fR, \fBEnter\fR, \fBLeave\fR, +\fBExpose\fR, \fBConfigure\fR, \fBGravity\fR, and \fBReparent\fR +events. +Corresponds to the the \fB%x\fR substitution for binding scripts. +.TP +\fB\-y\fI coord\fR +\fICoord\fR must be a screen distance; it specifies the \fIy\fR +field for the event. +Valid for \fBKeyPress\fR, \fBKeyRelease\fR, \fBButtonPress\fR, +\fBButtonRelease\fR, \fBMotion\fR, \fBEnter\fR, \fBLeave\fR, +\fBExpose\fR, \fBConfigure\fR, \fBGravity\fR, and \fBReparent\fR +events. +Corresponds to the the \fB%y\fR substitution for binding scripts. +.PP +Any options that are not specified when generating an event are filled +with the value 0, except for \fIserial\fR, which is filled with the +next X event serial number. + +.SH "VIRTUAL EVENT EXAMPLES" +.PP +In order for a virtual event binding to trigger, two things must +happen. First, the virtual event must be defined with the +\fBevent add\fR command. Second, a binding must be created for +the virtual event with the \fBbind\fR command. +Consider the following virtual event definitions: +.CS +event add <> +event add <> +event add <> +event add <> +.CE +In the \fBbind\fR command, a virtual event can be bound like any other +builtin event type as follows: +.CS +bind Entry <> {%W insert [selection get]} +.CE +The double angle brackets are used to specify that a virtual event is being +bound. If the user types Control-y or presses button 2, or if +a \fB<>\fR virtual event is synthesized with \fBevent generate\fR, +then the \fB<>\fR binding will be invoked. +.PP +If a virtual binding has the exact same sequence as a separate +physical binding, then the physical binding will take precedence. +Consider the following example: +.CS +event add <> +bind Entry {puts Control-y} +bind Entry <> {puts Paste} +.CE +When the user types Control-y the \fB\fR binding +will be invoked, because a physical event is considered +more specific than a virtual event, all other things being equal. +However, when the user types Meta-Control-y the +\fB<>\fR binding will be invoked, because the +\fBMeta\fR modifier in the physical pattern associated with the +virtual binding is more specific than the \fB sequence for +the physical event. +.PP +Bindings on a virtual event may be created before the virtual event exists. +Indeed, the virtual event never actually needs to be defined, for instance, +on platforms where the specific virtual event would meaningless or +ungeneratable. +.PP +When a definition of a virtual event changes at run time, all windows +will respond immediately to the new definition. +Starting from the preceding example, if the following code is executed: +.CS +bind {} +event add <> +.CE +the behavior will change such in two ways. First, the shadowed +\fB<>\fR binding will emerge. +Typing Control-y will no longer invoke the \fB\fR binding, +but instead invoke the virtual event \fB<>\fR. Second, +pressing the F6 key will now also invoke the \fB<>\fR binding. + +.SH "SEE ALSO" +bind + +.SH KEYWORDS +event, binding, define, handle, virtual event diff --git a/tk4.2/doc/focus.n b/tk4.2/doc/focus.n new file mode 100644 index 0000000..8bf4897 --- /dev/null +++ b/tk4.2/doc/focus.n @@ -0,0 +1,113 @@ +'\" +'\" Copyright (c) 1990-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) focus.n 1.22 96/08/27 13:21:42 +'\" +.so man.macros +.TH focus n 4.0 Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +focus \- Manage the input focus +.SH SYNOPSIS +\fBfocus\fR +.sp +\fBfocus \fIwindow\fR +.sp +\fBfocus \fIoption\fR ?\fIarg arg ...\fR? +.BE + +.SH DESCRIPTION +.PP +The \fBfocus\fR command is used to manage the Tk input focus. +At any given time, one window on each display is designated as +the \fIfocus window\fR; any key press or key release events for the +display are sent to that window. +It is normally up to the window manager to redirect the focus among the +top-level windows of a display. For example, some window managers +automatically set the input focus to a top-level window whenever +the mouse enters it; others redirect the input focus only when +the user clicks on a window. +Usually the window manager will set the focus +only to top-level windows, leaving it up to the application to +redirect the focus among the children of the top-level. +.PP +Tk remembers one focus window for each top-level (the most recent +descendant of that top-level to receive the focus); when the window +manager gives the focus +to a top-level, Tk automatically redirects it to the remembered +window. Within a top-level Tk uses an \fIexplicit\fR focus model +by default. Moving the mouse within a top-level does not normally +change the focus; the focus changes only when a widget +decides explicitly to claim the focus (e.g., because of a button +click), or when the user types a key such as Tab that moves the +focus. +.PP +The Tcl procedure \fBtk_focusFollowsMouse\fR may be invoked to +create an \fIimplicit\fR focus model: it reconfigures Tk so that +the focus is set to a window whenever the mouse enters it. +The Tcl procedures \fBtk_focusNext\fR and \fBtk_focusPrev\fR +implement a focus order among the windows of a top-level; they +are used in the default bindings for Tab and Shift-Tab, among other +things. +.PP +The \fBfocus\fR command can take any of the following forms: +.TP +\fBfocus\fR +Returns the path name of the focus window on the display containing +the application's main window, or an empty string if no window in +this application has the focus on that display. Note: it is +better to specify the display explicitly using \fB\-displayof\fR +(see below) so that the code will work in applications using multiple +displays. +.TP +\fBfocus \fIwindow\fR +If the application currently has the input focus on \fIwindow\fR's +display, this command resets the input focus for \fIwindow\fR's display +to \fIwindow\fR and returns an empty string. +If the application doesn't currently have the input focus on +\fIwindow\fR's display, \fIwindow\fR will be remembered as the focus +for its top-level; the next time the focus arrives at the top-level, +Tk will redirect it to \fIwindow\fR. +If \fIwindow\fR is an empty string then the command does nothing. +.TP +\fBfocus \-displayof\fR \fIwindow\fR +Returns the name of the focus window on the display containing \fIwindow\fR. +If the focus window for \fIwindow\fR's display isn't in this +application, the return value is an empty string. +.TP +\fBfocus \-force \fIwindow\fR +Sets the focus of \fIwindow\fR's display to \fIwindow\fR, even if +the application doesn't currently have the input focus for the display. +This command should be used sparingly, if at all. +In normal usage, an application should not claim the focus for +itself; instead, it should wait for the window manager to give it +the focus. +If \fIwindow\fR is an empty string then the command does nothing. +.TP +\fBfocus \-lastfor\fR \fIwindow\fR +Returns the name of the most recent window to have the input focus +among all the windows in the same top-level as \fIwindow\fR. +If no window in that top-level has ever had the input focus, or +if the most recent focus window has been deleted, then the name +of the top-level is returned. The return value is the window that +will receive the input focus the next time the window manager gives +the focus to the top-level. + +.SH "QUIRKS" +.PP +When an internal window receives the input focus, Tk doesn't actually +set the X focus to that window; as far as X is concerned, the focus +will stay on the top-level window containing the window with the focus. +However, Tk generates FocusIn and FocusOut events just as if the X +focus were on the internal window. This approach gets around a +number of problems that would occur if the X focus were actually moved; +the fact that the X focus is on the top-level is invisible unless +you use C code to query the X server directly. + +.SH KEYWORDS +events, focus, keyboard, top-level, window manager diff --git a/tk4.2/doc/focusNext.n b/tk4.2/doc/focusNext.n new file mode 100644 index 0000000..e1f8fe7 --- /dev/null +++ b/tk4.2/doc/focusNext.n @@ -0,0 +1,60 @@ +'\" +'\" Copyright (c) 1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) focusNext.n 1.10 96/03/26 18:22:23 +'\" +.so man.macros +.TH tk_focusNext n 4.0 Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +tk_focusNext, tk_focusPrev, tk_focusFollowsMouse \- Utility procedures for managing the input focus. +.SH SYNOPSIS +\fBtk_focusNext \fIwindow\fR +.sp +\fBtk_focusPrev \fIwindow\fR +.sp +\fBtk_focusFollowsMouse\fR +.BE + +.SH DESCRIPTION +.PP +\fBtk_focusNext\fR is a utility procedure used for keyboard traversal. +It returns the ``next'' window after \fIwindow\fR in focus order. +The focus order is determined by +the stacking order of windows and the structure of the window hierarchy. +Among siblings, the focus order is the same as the stacking order, with the +lowest window being first. +If a window has children, the window is visited first, followed by +its children (recursively), followed by its next sibling. +Top-level windows other than \fIwindow\fR are skipped, so that +\fBtk_focusNext\fR never returns a window in a different top-level +from \fIwindow\fR. +.PP +After computing the next window, \fBtk_focusNext\fR examines the +window's \fB\-takefocus\fR option to see whether it should be skipped. +If so, \fBtk_focusNext\fR continues on to the next window in the focus +order, until it eventually finds a window that will accept the focus +or returns back to \fIwindow\fR. +.PP +\fBtk_focusPrev\fR is similar to \fBtk_focusNext\fR except that it +returns the window just before \fIwindow\fR in the focus order. +.PP +\fBtk_focusFollowsMouse\fR changes the focus model for the application +to an implicit one where the window under the mouse gets the focus. +After this procedure is called, whenever the mouse enters a window +Tk will automatically give it the input focus. +The \fBfocus\fR command may be used to move the focus to a window +other than the one under the mouse, but as soon as the mouse moves +into a new window the focus will jump to that window. +Note: at present there is no built-in support for returning the +application to an explicit focus model; to do this you'll have +to write a script that deletes the bindings created by +\fBtk_focusFollowsMouse\fR. + +.SH KEYWORDS +focus, keyboard traversal, top-level diff --git a/tk4.2/doc/frame.n b/tk4.2/doc/frame.n new file mode 100644 index 0000000..da311ad --- /dev/null +++ b/tk4.2/doc/frame.n @@ -0,0 +1,123 @@ +'\" +'\" Copyright (c) 1990-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" +'\" SCCS: @(#) frame.n 1.26 96/08/27 13:21:43 +'\" +.so man.macros +.TH frame n 4.0 Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +frame \- Create and manipulate frame widgets +.SH SYNOPSIS +\fBframe\fI \fIpathName ?\fIoptions\fR? +.SO +\-borderwidth \-highlightbackground \-highlightthickness \-takefocus +\-cursor \-highlightcolor \-relief +.SE +.SH "WIDGET-SPECIFIC OPTIONS" +.OP \-background background Background +This option is the same as the standard \fBbackground\fR option +except that its value may also be specified as an empty string. +In this case, the widget will display no background or border, and +no colors will be consumed from its colormap for its background +and border. +.OP \-class class Class +Specifies a class for the window. +This class will be used when querying the option database for +the window's other options, and it will also be used later for +other purposes such as bindings. +The \fBclass\fR option may not be changed with the \fBconfigure\fR +widget command. +.OP \-colormap colormap Colormap +Specifies a colormap to use for the window. +The value may be either \fBnew\fR, in which case a new colormap is +created for the window and its children, or the name of another +window (which must be on the same screen and have the same visual +as \fIpathName\fR), in which case the new window will use the colormap +from the specified window. +If the \fBcolormap\fR option is not specified, the new window +uses the same colormap as its parent. +This option may not be changed with the \fBconfigure\fR +widget command. +.OP \-height height Height +Specifies the desired height for the window in any of the forms +acceptable to \fBTk_GetPixels\fR. +If this option is less than or equal to zero then the window will +not request any size at all. +.OP \-visual visual Visual +Specifies visual information for the new window in any of the +forms accepted by \fBTk_GetVisual\fR. +If this option is not specified, the new window will use the same +visual as its parent. +The \fBvisual\fR option may not be modified with the \fBconfigure\fR +widget command. +.OP \-width width Width +Specifies the desired width for the window in any of the forms +acceptable to \fBTk_GetPixels\fR. +If this option is less than or equal to zero then the window will +not request any size at all. +.BE + +.SH DESCRIPTION +.PP +The \fBframe\fR command creates a new window (given by the +\fIpathName\fR argument) and makes it into a frame widget. +Additional +options, described above, may be specified on the command line +or in the option database +to configure aspects of the frame such as its background color +and relief. The \fBframe\fR command returns the +path name of the new window. +.PP +A frame is a simple widget. Its primary purpose is to act as a +spacer or container for complex window layouts. The only features +of a frame are its background color and an optional 3-D border to make the +frame appear raised or sunken. + +.SH "WIDGET COMMAND" +.PP +The \fBframe\fR command creates a new Tcl command whose +name is the same as the path name of the frame's window. This +command may be used to invoke various +operations on the widget. It has the following general form: +.CS +\fIpathName option \fR?\fIarg arg ...\fR? +.CE +\fIPathName\fR is the name of the command, which is the same as +the frame widget's path name. \fIOption\fR and the \fIarg\fRs +determine the exact behavior of the command. The following +commands are possible for frame widgets: +.TP +\fIpathName \fBcget\fR \fIoption\fR +Returns the current value of the configuration option given +by \fIoption\fR. +\fIOption\fR may have any of the values accepted by the \fBframe\fR +command. +.TP +\fIpathName \fBconfigure\fR ?\fIoption\fR? \fI?value option value ...\fR? +Query or modify the configuration options of the widget. +If no \fIoption\fR is specified, returns a list describing all of +the available options for \fIpathName\fR (see \fBTk_ConfigureInfo\fR for +information on the format of this list). If \fIoption\fR is specified +with no \fIvalue\fR, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no \fIoption\fR is specified). If +one or more \fIoption\-value\fR pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +\fIOption\fR may have any of the values accepted by the \fBframe\fR +command. + +.SH BINDINGS +.PP +When a new frame is created, it has no default event bindings: +frames are not intended to be interactive. + +.SH KEYWORDS +frame, widget diff --git a/tk4.2/doc/getOpenFile.n b/tk4.2/doc/getOpenFile.n new file mode 100644 index 0000000..853ca40 --- /dev/null +++ b/tk4.2/doc/getOpenFile.n @@ -0,0 +1,152 @@ +'\" +'\" Copyright (c) 1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) getOpenFile.n 1.7 96/09/19 17:02:01 +'\" +.so man.macros +.TH tk_getOpenFile n 4.2 Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +tk_getOpenFile, tk_getSaveFile \- pop up a dialog box for the user to select a file to open or save. +.PP +.PP +.SH SYNOPSIS +\fBtk_getOpenFile \fR?\fIoption value ...\fR? +.br +\fBtk_getSaveFile \fR?\fIoption value ...\fR? +.BE + +.SH DESCRIPTION +.PP +The procedures \fBtk_getOpenFile\fR and \fBtk_getSaveFile\fR pop up a +dialog box for the user to select a file to open or save. The +\fBtk_getOpenFile\fR command is usually associated with the \fBOpen\fR +command in the \fBFile\fR menu. Its purpose is for the user to select an +existing file \fIonly\fR. If the user enters an non-existent file, the +dialog box gives the user an error prompt and requires the user to give +an alternative selection. If an application allows the user to create +new files, it should do so by providing a separate \fBNew\fR menu command. +.PP +The \fBtk_getSaveFile\fR command is usually associated with the \fBSave +as\fR command in the \fBFile\fR menu. If the user enters a file that +already exists, the dialog box prompts the user for confirmation +whether the existing file should be overwritten or not. +.PP +The following \fIoption\-value\fR pairs are possible as command line +arguments to these two commands: +.TP +\fB\-defaultextension\fR \fIextension\fR +Specifies a string that will be appended to the filename if the user +enters a filename without an extension. The defaut value is the empty +string, which means no extension will be appended to the filename in +any case. This option is ignored on the Macintosh platform, which +does not require extensions to filenames. +.TP +\fB\-filetypes\fR \fIfilePatternList\fR +If a \fBFile types\fR listbox exists in the file dialog on the particular +platform, this option gives the \fIfiletype\fRs in this listbox. When +the user choose a filetype in the listbox, only the files of that type +are listed. If this option is unspecified, or if it is set to the +empty list, or if the \fBFile types\fR listbox is not supported by the +particular platform then all files are listed regardless of their +types. See the section SPECIFYING FILE PATTERNS below for a +discussion on the contents of \fIfilePatternList\fR. +.TP +\fB\-initialdir\fR \fIdirectory\fR +Specifies that the files in \fIdirectory\fR should be displayed +when the dialog pops up. If this parameter is not specified, then +the files in the current working directory are displayed. +.TP +\fB\-initialfile\fR \fIfilename\fR +Specifies a filename to be displayed in the dialog when it pops +up. This option is ignored by the \fBtk_getOpenFile\fR command. +.TP +\fB\-parent\fR \fIwindow\fR +Makes \fIwindow\fR the logical parent of the file dialog. The file +dialog is displayed on top of its parent window. +.TP +\fB\-title\fR \fItitleString\fR +Specifies a string to display as the title of the dialog box. If this +option is not specified, then a default title is displayed. This +option is ignored on the Macintosh platform. +.PP +If the user selects a file, both \fBtk_getOpenFile\fR and +\fBtk_getSaveFile\fR return the full pathname of this file. If the +user cancels the operation, both commands return the empty string. +.SH "SPECIFYING FILE PATTERNS" + +The \fIfilePatternList\fR value given by the \fB\-filetypes\fR option +is a list of file patterns. Each file pattern is a list of the +form +.CS +\fItypeName\fR {\fIextension\fR ?\fIextension ...\fR?} ?{\fImacType\fR ?\fImacType ...\fR?}? +.CE +\fItypeName\fR is the name of the file type described by this +file pattern and is the text string that appears in the \fBFile types\fR +listbox. \fIextension\fR is a file extension for this file pattern. +\fImacType\fR is a four-character Macintosh file type. The list of +\fImacType\fRs is optional and may be omitted for applications that do +not need to execute on the Macintosh platform. +.PP +Several file patterns may have the same \fItypeName,\fR in which case +they refer to the same file type and share the same entry in the +listbox. When the user selects an entry in the listbox, all the files +that match at least one of the file patterns corresponding +to that entry are listed. Usually, each file pattern corresponds to a +distinct type of file. The use of more than one file patterns for one +type of file is necessary on the Macintosh platform only. +.PP +On the Macintosh platform, a file matches a file pattern if its +name matches at least one of the \fIextension\fR(s) AND it +belongs to at least one of the \fImacType\fR(s) of the +file pattern. For example, the \fBC Source Files\fR file pattern in the +sample code matches with files that have a \fB\.c\fR extension AND +belong to the \fImacType\fR \fBTEXT\fR. To use the OR rule instead, +you can use two file patterns, one with the \fIextensions\fR only and +the other with the \fImacType\fR only. The \fBGIF Files\fR file type +in the sample code matches files that EITHER have a \fB\.gif\fR +extension OR belong to the \fImacType\fR \fBGIFF\fR. +.PP +On the Unix and Windows platforms, a file matches a file pattern +if its name matches at at least one of the \fIextension\fR(s) of +the file pattern. The \fImacType\fRs are ignored. +.SH "SPECIFYING EXTENSIONS" +.PP +On the Unix and Macintosh platforms, extensions are matched using +glob-style pattern matching. On the Windows platforms, extensions are +matched by the underlying operating system. The types of possible +extensions are: (1) the special extension * matches any +file; (2) the special extension "" matches any files that +do not have an extension (i.e., the filename contains no full stop +character); (3) any character string that does not contain any wild +card characters (* and ?). +.PP +Due to the different pattern matching rules on the various platforms, +to ensure portability, wild card characters are not allowed in the +extensions, except as in the special extension *. Extensions +without a full stop character (e.g, ~) are allowed but may not +work on all platforms. + +.SH EXAMPLE +.CS +set types { + {{Text Files} {.txt} } + {{TCL Scripts} {.tcl} } + {{C Source Files} {.c} TEXT} + {{GIF Files} {.gif} } + {{GIF Files} {} GIFF} + {{All Files} * } +} +set filename [tk_getOpenFile -filetypes $types] + +if {$filename != ""} { + # Open the file ... +} +.CE + +.SH KEYWORDS +file selection dialog diff --git a/tk3.6/doc/grab.n b/tk4.2/doc/grab.n similarity index 80% rename from tk3.6/doc/grab.n rename to tk4.2/doc/grab.n index 6667762..4b36134 100644 --- a/tk3.6/doc/grab.n +++ b/tk4.2/doc/grab.n @@ -1,37 +1,22 @@ '\" '\" Copyright (c) 1992 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) grab.n 1.15 96/03/26 18:22:48 '\" -'\" $Header: /user6/ouster/wish/man/RCS/grab.n,v 1.7 93/04/01 09:52:41 ouster Exp $ SPRITE (Berkeley) -'/" .so man.macros -.HS grab tk +.TH grab n "" Tk "Tk Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME grab \- Confine pointer and keyboard events to a window sub-tree .SH SYNOPSIS \fBgrab \fR?\fB\-global\fR? \fIwindow\fR -.br -.VS -\fBgrab \fIoption \fR?arg arg \fR...? -.VE +.sp +\fBgrab \fIoption \fR?\fIarg arg \fR...? .BE .SH DESCRIPTION @@ -90,7 +75,6 @@ grab on a given display at once. The \fBgrab\fR command can take any of the following forms: .TP \fBgrab \fR?\fB\-global\fR? \fIwindow\fR -.VS Same as \fBgrab set\fR, described below. .TP \fBgrab current \fR?\fIwindow\fR? @@ -118,7 +102,6 @@ does nothing. Returns an empty string. Returns \fBnone\fR if no grab is currently set on \fIwindow\fR, \fBlocal\fR if a local grab is set on \fIwindow\fR, and \fBglobal\fR if a global grab is set. -.VE .SH BUGS .PP @@ -130,12 +113,10 @@ procedures. If applications try to manipulate X's grab mechanisms directly, things will probably break. .PP -.VS If a single process is managing several different Tk applications, only one of those applications can have a local grab for a given display at any given time. If the applications are in different processes, this restriction doesn't exist. -.VE .SH KEYWORDS grab, keyboard events, pointer events, window diff --git a/tk4.2/doc/grid.n b/tk4.2/doc/grid.n new file mode 100644 index 0000000..4ab98d1 --- /dev/null +++ b/tk4.2/doc/grid.n @@ -0,0 +1,337 @@ +'\" +'\" Copyright (c) 1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) grid.n 1.14 96/10/02 15:44:29 +'\" +.so man.macros +.TH grid n 4.1 Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +grid \- Geometry manager that arranges widgets in a grid +.SH SYNOPSIS +\fBgrid \fIoption arg \fR?\fIarg ...\fR? +.BE + +.SH DESCRIPTION +.PP +The \fBgrid\fR command is used to communicate with the grid +geometry manager that arranges widgets in rows and columns inside +of another window, called the geometry master (or master window). +The \fBgrid\fR command can have any of several forms, depending +on the \fIoption\fR argument: +.TP +\fBgrid \fIslave \fR?\fIslave ...\fR? ?\fIoptions\fR? +If the first argument to \fBgrid\fR is a window name (any value +starting with ``.''), then the command is processed in the same +way as \fBgrid configure\fR. +.TP +\fBgrid bbox \fImaster\fR ?\fIcolumn row\fR? ?\fIcolumn2 row2\fR? +.VS +With no arguments, +the bounding box (in pixels) of the grid is returned. +The return value consists of 4 integers. The first two are the pixel +offset from the master window (x then y) of the top-left corner of the +grid, and the second two integers are the width and height of the grid, +also in pixels. If a single \fIcolumn\fP and \fIrow\fP is specified on +the command line, then the bounding box for that cell is returned, where the +top left cell is numbered from zero. If both \fIcolumn\fP and \fIrow\fP +arguments are specified, then the bounding box spanning the rows and columns +indicated is returned. +.VE +.TP +\fBgrid columnconfigure \fImaster index \fR?\fI\-option value...\fR? +Query or set the column properties of the \fIindex\fP column of the +geometry master, \fImaster\fP. +The valid options are \fB\-minsize\fP, \fB\-weight\fP and \fB-pad\fP. +The \fB\-minsize\fP option sets the minimum size, in screen units, +that will be permitted for this column. +The \fB\-weight\fP option (an integer value) +sets the relative weight for apportioning +any extra spaces among +columns. +A weight of zero (0) indicates the column will not deviate from its requested +size. A column whose weight is two will grow at twice the rate as a column +of weight one when extra space is allocated to the layout. +.VS +The \fB-pad\fP option specifies the number of screen units that will be +added to the largest window contained completely in that column when the +grid geometry manager requests a size from the containing window. +.VE +If only an option is specified, with no value, +the current value of that option is returned. +If only the master window and index is specified, all the current settings +are returned in an list of "-option value" pairs. +.TP +\fBgrid configure \fIslave \fR?\fIslave ...\fR? ?\fIoptions\fR? +The arguments consist of the names of one or more slave windows +followed by pairs of arguments that specify how +to manage the slaves. +The characters \fB\-\fP, \fBx\fP and \fB^\fP, +can be specified instead of a window name to alter the default +location of a \fIslave\fP, as described in the ``RELATIVE PLACEMENT'' +section, below. +The following options are supported: +.RS +.TP +\fB\-column \fIn\fR +Insert the slave so that it occupies the \fIn\fPth column in the grid. +Column numbers start with 0. If this option is not supplied, then the +slave is arranged just to the right of previous slave specified on this +call to \fIgrid\fP, or column "0" if it is the first slave. For each +\fBx\fP that immediately precedes the \fIslave\fP, the column position +is incremented by one. Thus the \fBx\fP represents a blank column +for this row in the grid. +.TP +\fB\-columnspan \fIn\fR +Insert the slave so that it occupies \fIn\fP columns in the grid. +The default is one column, unless the window name is followed by a +\fB\-\fP, in which case the columnspan is incremented once for each immediately +following \fB\-\fP. +.TP +\fB\-in \fIother\fR +Insert the slave(s) in the master +window given by \fIother\fR. The default is the first slave's +parent window. +.TP +\fB\-ipadx \fIamount\fR +The \fIamount\fR specifies how much horizontal internal padding to +leave on each side of the slave(s). This is space is added +inside the slave(s) border. +The \fIamount\fR must be a valid screen distance, such as \fB2\fR or \fB.5c\fR. +It defaults to 0. +.TP +\fB\-ipady \fIamount\fR +The \fIamount\fR specifies how much vertical internal padding to +leave on on the top and bottom of the slave(s). +This space is added inside the slave(s) border. +The \fIamount\fR defaults to 0. +.TP +\fB\-padx \fIamount\fR +The \fIamount\fR specifies how much horizontal external padding to +leave on each side of the slave(s), in screen units. +The \fIamount\fR defaults to 0. +This space is added outside the slave(s) border. +.TP +\fB\-pady \fIamount\fR +The \fIamount\fR specifies how much vertical external padding to +leave on the top and bottom of the slave(s), in screen units. +The \fIamount\fR defaults to 0. +This space is added outside the slave(s) border. +.TP +\fB\-row \fIn\fR +Insert the slave so that it occupies the \fIn\fPth row in the grid. +Row numbers start with 0. If this option is not supplied, then the +slave is arranged on the same row as the previous slave specified on this +call to \fBgrid\fP, or the first unoccupied row if this is the first slave. +.TP +\fB\-rowspan \fIn\fR +Insert the slave so that it occupies \fIn\fP rows in the grid. +The default is one row. If the next \fBgrid\fP command contains +\fB^\fP characters instead of \fIslaves\fP that line up with the columns +of this \fIslave\fP, then the \fBrowspan\fP of this \fIslave\fP is +extended by one. +.TP +\fB\-sticky \fIstyle\fR +If a slave's cell is larger than its requested dimensions, this +option may be used to position (or stretch) the slave within its cell. +\fIStyle\fR is a string that contains zero or more of the characters +\fBn\fP, \fBs\fP, \fBe\fP or \fBw\fP. +The string can optionally contains spaces or +commas, but they are ignored. Each letter refers to a side (north, south, +east, or west) that the slave will "stick" to. If both \fBn\fP and \fBs\fP (or +\fBe\fP and \fBw\fP) are specified, the slave will be stretched to fill the entire +height (or width) of its cavity. The \fBsticky\fP option subsumes the +combination of \fB\-anchor\fP and \fB\-fill\fP that is used by \fBpack\fP. +The default is \fB{}\fP, which causes the slave to be centered in its cavity, +at its requested size. +.LP +If any of the slaves are already managed by the geometry manager +then any unspecified options for them retain their previous values rather +than receiving default values. +.RE +.TP +\fBgrid forget \fIslave \fR?\fIslave ...\fR? +Removes each of the \fIslave\fRs from grid for its +master and unmaps their windows. +The slaves will no longer be managed by the grid geometry manager. +The configuration options for that window are forgotten, so that if the +slave is managed once more by the grid geometry manager, the initial +default settings are used. +.TP +\fBgrid info \fIslave\fR +Returns a list whose elements are the current configuration state of +the slave given by \fIslave\fR in the same option-value form that +might be specified to \fBgrid configure\fR. +The first two elements of the list are ``\fB\-in \fImaster\fR'' where +\fImaster\fR is the slave's master. +.TP +\fBgrid location \fImaster x y\fR +Given \fIx\fP and \fIy\fP values in screen units relative to the master window, +the column and row number at that \fIx\fP and \fIy\fP location is returned. +For locations that are above or to the left of the grid, \fB-1\fP is returned. +.TP +\fBgrid propagate \fImaster\fR ?\fIboolean\fR? +If \fIboolean\fR has a true boolean value such as \fB1\fR or \fBon\fR +then propagation is enabled for \fImaster\fR, which must be a window +name (see ``GEOMETRY PROPAGATION'' below). +If \fIboolean\fR has a false boolean value then propagation is +disabled for \fImaster\fR. +In either of these cases an empty string is returned. +If \fIboolean\fR is omitted then the command returns \fB0\fR or +\fB1\fR to indicate whether propagation is currently enabled +for \fImaster\fR. +Propagation is enabled by default. +.TP +\fBgrid rowconfigure \fImaster index \fR?\fI\-option value...\fR? +Query or set the row properties of the \fIindex\fP row of the +geometry master, \fImaster\fP. +The valid options are \fB\-minsize\fP, \fB\-weight\fP and \fB-pad\fP. +The \fB\-minsize\fP option sets the minimum size, in screen units, +that will be permitted for this row. +The \fB\-weight\fP option (an integer value) +sets the relative weight for apportioning +any extra spaces among +rows. +A weight of zero (0) indicates the row will not deviate from its requested +size. A row whose weight is two will grow at twice the rate as a row +of weight one when extra space is allocated to the layout. +.VS +The \fB-pad\fP option specifies the number of screen units that will be +added to the largest window contained completely in that row when the +grid geometry manager requests a size from the containing window. +.VE +If only an option is specified, with no value, +the current value of that option is returned. +If only the master window and index is specified, all the current settings +are returned in an list of "-option value" pairs. +.TP +\fBgrid remove \fIslave \fR?\fIslave ...\fR? +Removes each of the \fIslave\fRs from grid for its +master and unmaps their windows. +The slaves will no longer be managed by the grid geometry manager. +However, the configuration options for that window are remembered, +so that if the +slave is managed once more by the grid geometry manager, the previous +values are retained. +.TP +\fBgrid size \fImaster\fR +Returns the size of the grid (in columns then rows) for \fImaster\fP. +The size is determined either by the \fIslave\fP occupying the largest +row or column, or the largest column or row with a \fBminsize\fP, +\fBweight\fP, or \fBpad\fP that is non-zero. +.TP +\fBgrid slaves \fImaster\fR ?\fI\-option value\fR? +If no options are supplied, a list of all of the slaves in \fImaster\fR +are returned, most recently manages first. +\fIOption\fP can be either \fB\-row\fP or \fB\-column\fP which +causes only the slaves in the row (or column) specified by \fIvalue\fP +to be returned. +.SH "RELATIVE PLACEMENT" +.PP +The \fBgrid\fP command contains a limited set of capabilities that +permit layouts to be created without specifying the row and column +information for each slave. This permits slaves to be rearranged, +added, or removed without the need to explicitly specify row and +column information. +When no column or row information is specified for a \fIslave\fP, +default values are chosen for +\fBcolumn\fP, \fBrow\fP, \fBcolumnspan\fP and \fBrowspan\fP +at the time the \fIslave\fP is managed. The values are chosen +based upon the current layout of the grid, the position of the \fIslave\fP +relative to other \fIslave\fPs in the same grid command, and the presence +of the characters \fB\-\fP, \fB^\fP, and \fB^\fP in \fBgrid\fP +command where \fIslave\fP names are normally expected. +.RS +.TP +\fB\-\fP +This increases the columnspan of the \fIslave\fP to the left. Several +\fB\-\fP's in a row will successively increase the columnspan. A \fB\-\fP +may not follow a \fB^\fP or a \fBx\fP. +.TP +\fBx\fP +This leaves an empty column between the \fIslave\fP on the left and +the \fIslave\fP on the right. +.TP +\fB^\fP +This extends the \fBrowspan\fP of the \fIslave\fP above the \fB^\fP's +in the grid. The number of \fB^\fP's in a row must match the number of +columns spanned by the \fIslave\fP above it. +.RE +.SH "THE GRID ALGORITHM" +.PP +The grid geometry manager lays out its slaves in three steps. +In the first step, the minimum size needed to fit all of the slaves +is computed, then (if propagation is turned on), a request is made +of the master window to become that size. +In the second step, the requested size is compared against the actual size +of the master. If the sizes are different, then spaces is added to or taken +away from the layout as needed. +For the final step, each slave is positioned in its row(s) and column(s) +based on the setting of its \fIsticky\fP flag. +.PP +To compute the minimum size of a layout, the grid geometry manager +first looks at all slaves whose columnspan and rowspan values are one, +and computes the nominal size of each row or column to be either the +\fIminsize\fP for that row or column, or the sum of the \fIpad\fPding +plus the size of the largest slave, whichever is greater. Then the +slaves whose rowspans or columnspans are greater than one are +examined. If a group of rows or columns need to be increased in size +in order to accommodate these slaves, then extra space is added to each +row or column in the group according to its \fIweight\fP. For each +group whose weights are all zero, the additional space is apportioned +equally. +.PP +For masters whose size is larger than the requested layout, the additional +space is apportioned according to the row and column weights. If all of +the weights are zero, the layout is centered within its master. +For masters whose size is smaller than the requested layout, space is taken +away from columns and rows according to their weights. However, once a +column or row shrinks to its minsize, its weight is taken to be zero. +If more space needs to be removed from a layout than would be permitted, as +when all the rows or columns are at there minimum sizes, the layout is +clipped on the bottom and right. +.SH "GEOMETRY PROPAGATION" +.PP +The grid geometry manager normally computes how large a master must be to +just exactly meet the needs of its slaves, and it sets the +requested width and height of the master to these dimensions. +This causes geometry information to propagate up through a +window hierarchy to a top-level window so that the entire +sub-tree sizes itself to fit the needs of the leaf windows. +However, the \fBgrid propagate\fR command may be used to +turn off propagation for one or more masters. +If propagation is disabled then grid will not set +the requested width and height of the master window. +This may be useful if, for example, you wish for a master +window to have a fixed size that you specify. + +.SH "RESTRICTIONS ON MASTER WINDOWS" +.PP +The master for each slave must either be the slave's parent +(the default) or a descendant of the slave's parent. +This restriction is necessary to guarantee that the +slave can be placed over any part of its master that is +visible without danger of the slave being clipped by its parent. +.VS +In addition, all slaves in one call to \fBgrid\fP must have the same master. +.VE +.SH "STACKING ORDER" +.PP +If the master for a slave is not its parent then you must make sure +that the slave is higher in the stacking order than the master. +Otherwise the master will obscure the slave and it will appear as +if the slave hasn't been managed correctly. +The easiest way to make sure the slave is higher than the master is +to create the master window first: the most recently created window +will be highest in the stacking order. +.SH CREDITS +.PP +The \fBgrid\fP command is based on ideas taken from the \fIGridBag\fP +geometry manager written by Doug. Stein, and the \fBblt_table\fR geometry +manager, written by George Howlett. +.SH KEYWORDS +geometry manager, location, grid, cell, propagation, size, pack diff --git a/tk4.2/doc/image.n b/tk4.2/doc/image.n new file mode 100644 index 0000000..8189838 --- /dev/null +++ b/tk4.2/doc/image.n @@ -0,0 +1,90 @@ +'\" +'\" Copyright (c) 1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) image.n 1.10 96/03/26 18:23:05 +'\" +.so man.macros +.TH image n 4.0 Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +image \- Create and manipulate images +.SH SYNOPSIS +\fBimage\fR \fIoption \fR?\fIarg arg ...\fR? +.BE + +.SH DESCRIPTION +.PP +The \fBimage\fR command is used to create, delete, and query images. +It can take several different forms, depending on the +\fIoption\fR argument. The legal forms are: +.TP +\fBimage create \fItype \fR?\fIname\fR? ?\fIoption value ...\fR? +Creates a new image and returns its name. +\fItype\fR specifies the type of the image, which must be one of +the types currently defined (e.g., \fBbitmap\fR). +\fIname\fR specifies the name for the image; if it is omitted then +Tk picks a name of the form \fBimage\fIx\fR, where \fIx\fR is +an integer. +There may be any number of \fIoption\fR\-\fIvalue\fR pairs, +which provide configuration options for the new image. +The legal set of options is defined separately for each image +type; see below for details on the options for built-in image types. +If an image already exists by the given name then it is replaced +with the new image and any instances of that image will redisplay +with the new contents. +.TP +\fBimage delete \fR?\fIname name\fR ...? +Deletes each of the named images and returns an empty string. +If there are instances of the images displayed in widgets, +the images won't actually be deleted until all of the instances +are released. +However, the association between the instances and the image +manager will be dropped. +Existing instances will retain their sizes but redisplay as +empty areas. +If a deleted image is recreated with another call to \fBimage create\fR, +the existing instances will use the new image. +.TP +\fBimage height \fIname\fR +Returns a decimal string giving the height of image \fIname\fR +in pixels. +.TP +\fBimage names\fR +Returns a list containing the names of all existing images. +.TP +\fBimage type \fIname\fR +Returns the type of image \fIname\fR (the value of the \fItype\fR +argument to \fBimage create\fR when the image was created). +.TP +\fBimage types\fR +Returns a list whose elements are all of the valid image types +(i.e., all of the values that may be supplied for the \fItype\fR +argument to \fBimage create\fR). +.TP +\fBimage width \fIname\fR +Returns a decimal string giving the width of image \fIname\fR +in pixels. + +.SH "BUILT-IN IMAGE TYPES" +.PP +The following image types are defined by Tk so they will be available +in any Tk application. +Individual applications or extensions may define additional types. +.TP +\fBbitmap\fR +Each pixel in the image displays a foreground color, a background +color, or nothing. +See the \fBbitmap\fR manual entry for more information. +.TP +\fBphoto\fR +Displays a variety of full-color images, using dithering to +approximate colors on displays with limited color capabilities. +See the \fBphoto\fR manual entry for more information. + +.SH KEYWORDS +height, image, types of images, width diff --git a/tk3.6/doc/label.n b/tk4.2/doc/label.n similarity index 57% rename from tk3.6/doc/label.n rename to tk4.2/doc/label.n index 7b278ae..0db0d3a 100644 --- a/tk3.6/doc/label.n +++ b/tk4.2/doc/label.n @@ -1,74 +1,42 @@ '\" -'\" Copyright (c) 1990 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1990-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) label.n 1.29 96/08/27 13:21:44 '\" -'\" $Header: /user6/ouster/wish/man/RCS/label.n,v 1.13 93/04/01 09:52:42 ouster Exp $ SPRITE (Berkeley) -'/" .so man.macros -.HS label tk +.TH label n 4.0 Tk "Tk Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME label \- Create and manipulate label widgets .SH SYNOPSIS \fBlabel\fI \fIpathName \fR?\fIoptions\fR? -.SH "STANDARD OPTIONS" -.LP -.nf -.ta 4c 8c 12c -.VS -\fBanchor \fBborderWidth\fR \fBforeground\fR \fBrelief\fR -\fBbackground\fR \fBcursor\fR \fBpadX\fR \fBtext\fR -\fBbitmap\fR \fBfont\fR \fBpadY\fR \fBtextVariable\fR -.VE -.fi -.LP -See the ``options'' manual entry for details on the standard options. +.SO +\-anchor \-font \-image \-takefocus +\-background \-foreground \-justify \-text +\-bitmap \-highlightbackground \-padx \-textvariable +\-borderwidth \-highlightcolor \-pady \-underline +\-cursor \-highlightthickness \-relief \-wraplength +.SE .SH "WIDGET-SPECIFIC OPTIONS" -.LP -.nf -.VS -Name: \fBheight\fR -Class: \fBHeight\fR -Command-Line Switch: \fB\-height\fR -.fi -.IP +.OP \-height height Height Specifies a desired height for the label. -If a bitmap is being displayed in the label then the value is in +If an image or bitmap is being displayed in the label then the value is in screen units (i.e. any of the forms acceptable to \fBTk_GetPixels\fR); for text it is in lines of text. If this option isn't specified, the label's desired height is computed -from the size of the bitmap or text being displayed in it. -.LP -.nf -Name: \fBwidth\fR -Class: \fBWidth\fR -Command-Line Switch: \fB\-width\fR -.fi -.IP +from the size of the image or bitmap or text being displayed in it. +.OP \-width width Width Specifies a desired width for the label. -If a bitmap is being displayed in the label then the value is in +If an image or bitmap is being displayed in the label then the value is in screen units (i.e. any of the forms acceptable to \fBTk_GetPixels\fR); for text it is in characters. If this option isn't specified, the label's desired width is computed -from the size of the bitmap or text being displayed in it. -.VE +from the size of the image or bitmap or text being displayed in it. .BE .SH DESCRIPTION @@ -84,10 +52,12 @@ text, and initial relief. The \fBlabel\fR command returns its there must not exist a window named \fIpathName\fR, but \fIpathName\fR's parent must exist. .PP -A label is a widget -.VS -that displays a textual string or bitmap. -.VE +A label is a widget that displays a textual string, bitmap or image. +If text is displayed, it must all be in a single font, but it +can occupy multiple lines on the screen (if it contains newlines +or if wrapping occurs because of the \fBwrapLength\fR option) and +one of the characters may optionally be underlined using the +\fBunderline\fR option. The label can be manipulated in a few simple ways, such as changing its relief or text, using the commands described below. @@ -97,13 +67,19 @@ The \fBlabel\fR command creates a new Tcl command whose name is \fIpathName\fR. This command may be used to invoke various operations on the widget. It has the following general form: -.DS C +.CS \fIpathName option \fR?\fIarg arg ...\fR? -.DE +.CE \fIOption\fR and the \fIarg\fRs determine the exact behavior of the command. The following commands are possible for label widgets: .TP +\fIpathName \fBcget\fR \fIoption\fR +Returns the current value of the configuration option given +by \fIoption\fR. +\fIOption\fR may have any of the values accepted by the \fBlabel\fR +command. +.TP \fIpathName \fBconfigure\fR ?\fIoption\fR? ?\fIvalue option value ...\fR? Query or modify the configuration options of the widget. If no \fIoption\fR is specified, returns a list describing all of diff --git a/tk4.2/doc/license.terms b/tk4.2/doc/license.terms new file mode 100644 index 0000000..03ca6fc --- /dev/null +++ b/tk4.2/doc/license.terms @@ -0,0 +1,39 @@ +This software is copyrighted by the Regents of the University of +California, Sun Microsystems, Inc., and other parties. The following +terms apply to all files associated with the software unless explicitly +disclaimed in individual files. + +The authors hereby grant permission to use, copy, modify, distribute, +and license this software and its documentation for any purpose, provided +that existing copyright notices are retained in all copies and that this +notice is included verbatim in any distributions. No written agreement, +license, or royalty fee is required for any of the authorized uses. +Modifications to this software may be copyrighted by their authors +and need not follow the licensing terms described here, provided that +the new terms are clearly indicated on the first page of each file where +they apply. + +IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY +FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES +ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY +DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + +THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE +IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE +NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR +MODIFICATIONS. + +GOVERNMENT USE: If you are acquiring this software on behalf of the +U.S. government, the Government shall have only "Restricted Rights" +in the software and related documentation as defined in the Federal +Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you +are acquiring the software on behalf of the Department of Defense, the +software shall be classified as "Commercial Computer Software" and the +Government shall have only "Restricted Rights" as defined in Clause +252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the +authors grant the U.S. Government and others acting in its behalf +permission to use and distribute the software in accordance with the +terms specified in this license. diff --git a/tk4.2/doc/listbox.n b/tk4.2/doc/listbox.n new file mode 100644 index 0000000..4f78963 --- /dev/null +++ b/tk4.2/doc/listbox.n @@ -0,0 +1,470 @@ +'\" +'\" Copyright (c) 1990 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) listbox.n 1.36 96/08/27 13:21:36 +'\" +.so man.macros +.TH listbox n "" Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +listbox \- Create and manipulate listbox widgets +.SH SYNOPSIS +\fBlistbox\fI \fIpathName \fR?\fIoptions\fR? +.SO +\-background \-foreground \-relief \-takefocus +\-borderwidth \-height \-selectbackground \-width +\-cursor \-highlightbackground \-selectborderwidth \-xscrollcommand +\-exportselection \-highlightcolor \-selectforeground \-yscrollcommand +\-font \-highlightthickness \-setgrid +.SE +.SH "WIDGET-SPECIFIC OPTIONS" +.OP \-height height Height +Specifies the desired height for the window, in lines. +If zero or less, then the desired height for the window is made just +large enough to hold all the elements in the listbox. +.OP \-selectmode selectMode SelectMode +Specifies one of several styles for manipulating the selection. +The value of the option may be arbitrary, but the default bindings +expect it to be either \fBsingle\fR, \fBbrowse\fR, \fBmultiple\fR, +or \fBextended\fR; the default value is \fBbrowse\fR. +.OP \-width width Width +Specifies the desired width for the window in characters. +If the font doesn't have a uniform width then the width of the +character ``0'' is used in translating from character units to +screen units. +If zero or less, then the desired width for the window is made just +large enough to hold all the elements in the listbox. +.BE + +.SH DESCRIPTION +.PP +The \fBlistbox\fR command creates a new window (given by the +\fIpathName\fR argument) and makes it into a listbox widget. +Additional +options, described above, may be specified on the command line +or in the option database +to configure aspects of the listbox such as its colors, font, +text, and relief. The \fBlistbox\fR command returns its +\fIpathName\fR argument. At the time this command is invoked, +there must not exist a window named \fIpathName\fR, but +\fIpathName\fR's parent must exist. +.PP +A listbox is a widget that displays a list of strings, one per line. +When first created, a new listbox has no elements. +Elements may be added or deleted using widget commands described +below. In addition, one or more elements may be selected as described +below. +If a listbox is exporting its selection (see \fBexportSelection\fR +option), then it will observe the standard X11 protocols +for handling the selection. +Listbox selections are available as type \fBSTRING\fR; +the value of the selection will be the text of the selected elements, with +newlines separating the elements. +.PP +It is not necessary for all the elements to be +displayed in the listbox window at once; commands described below +may be used to change the view in the window. Listboxes allow +scrolling in both directions using the standard \fBxScrollCommand\fR +and \fByScrollCommand\fR options. +They also support scanning, as described below. + +.SH "INDICES" +.PP +Many of the widget commands for listboxes take one or more indices +as arguments. +An index specifies a particular element of the listbox, in any of +the following ways: +.TP 12 +\fInumber\fR +Specifies the element as a numerical index, where 0 corresponds +to the first element in the listbox. +.TP 12 +\fBactive\fR +Indicates the element that has the location cursor. This element +will be displayed with an underline when the listbox has the +keyboard focus, and it is specified with the \fBactivate\fR +widget command. +.TP 12 +\fBanchor\fR +Indicates the anchor point for the selection, which is set with the +\fBselection anchor\fR widget command. +.TP 12 +\fBend\fR +Indicates the end of the listbox. +For some commands this means just after the last element; +for other commands it means the last element. +.TP 12 +\fB@\fIx\fB,\fIy\fR +Indicates the element that covers the point in the listbox window +specified by \fIx\fR and \fIy\fR (in pixel coordinates). If no +element covers that point, then the closest element to that +point is used. +.LP +In the widget command descriptions below, arguments named \fIindex\fR, +\fIfirst\fR, and \fIlast\fR always contain text indices in one of +the above forms. + +.SH "WIDGET COMMAND" +.PP +The \fBlistbox\fR command creates a new Tcl command whose +name is \fIpathName\fR. This +command may be used to invoke various +operations on the widget. It has the following general form: +.CS +\fIpathName option \fR?\fIarg arg ...\fR? +.CE +\fIOption\fR and the \fIarg\fRs +determine the exact behavior of the command. The following +commands are possible for listbox widgets: +.TP +\fIpathName \fBactivate\fR \fIindex\fR +Sets the active element to the one indicated by \fIindex\fR. +The active element is drawn with an underline when the widget +has the input focus, and its index may be retrieved with the +index \fBactive\fR. +.TP +\fIpathName \fBbbox\fR \fIindex\fR +Returns a list of four numbers describing the bounding box of +the text in the element given by \fIindex\fR. +The first two elements of the list give the x and y coordinates +of the upper-left corner of the screen area covered by the text +(specified in pixels relative to the widget) and the last two +elements give the width and height of the area, in pixels. +If no part of the element given by \fIindex\fR is visible on the +screen then the result is an empty string; if the element is +partially visible, the result gives the full area of the element, +including any parts that are not visible. +.TP +\fIpathName \fBcget\fR \fIoption\fR +Returns the current value of the configuration option given +by \fIoption\fR. +\fIOption\fR may have any of the values accepted by the \fBlistbox\fR +command. +.TP +\fIpathName \fBconfigure\fR ?\fIoption\fR? ?\fIvalue option value ...\fR? +Query or modify the configuration options of the widget. +If no \fIoption\fR is specified, returns a list describing all of +the available options for \fIpathName\fR (see \fBTk_ConfigureInfo\fR for +information on the format of this list). If \fIoption\fR is specified +with no \fIvalue\fR, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no \fIoption\fR is specified). If +one or more \fIoption\-value\fR pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +\fIOption\fR may have any of the values accepted by the \fBlistbox\fR +command. +.TP +\fIpathName \fBcurselection\fR +Returns a list containing the numerical indices of +all of the elements in the listbox that are currently selected. +If there are no elements selected in the listbox then an empty +string is returned. +.TP +\fIpathName \fBdelete \fIfirst \fR?\fIlast\fR? +Deletes one or more elements of the listbox. \fIFirst\fR and \fIlast\fR +are indices specifying the first and last elements in the range +to delete. If \fIlast\fR isn't specified it defaults to +\fIfirst\fR, i.e. a single element is deleted. +.TP +\fIpathName \fBget \fIfirst\fR ?\fIlast\fR? +If \fIlast\fR is omitted, returns the contents of the listbox +element indicated by \fIfirst\fR. +If \fIlast\fR is specified, the command returns a list whose elements +are all of the listbox elements between \fIfirst\fR and \fIlast\fR, +inclusive. +Both \fIfirst\fR and \fIlast\fR may have any of the standard +forms for indices. +.TP +\fIpathName \fBindex \fIindex\fR +Returns a decimal string giving the integer index value that +corresponds to \fIindex\fR. +.TP +\fIpathName \fBinsert \fIindex \fR?\fIelement element ...\fR? +Inserts zero or more new elements in the list just before the +element given by \fIindex\fR. If \fIindex\fR is specified as +\fBend\fR then the new elements are added to the end of the +list. Returns an empty string. +.TP +\fIpathName \fBnearest \fIy\fR +Given a y-coordinate within the listbox window, this command returns +the index of the (visible) listbox element nearest to that y-coordinate. +.TP +\fIpathName \fBscan\fR \fIoption args\fR +This command is used to implement scanning on listboxes. It has +two forms, depending on \fIoption\fR: +.RS +.TP +\fIpathName \fBscan mark \fIx y\fR +Records \fIx\fR and \fIy\fR and the current view in the listbox +window; used in conjunction with later \fBscan dragto\fR commands. +Typically this command is associated with a mouse button press in +the widget. It returns an empty string. +.TP +\fIpathName \fBscan dragto \fIx y\fR. +This command computes the difference between its \fIx\fR and \fIy\fR +arguments and the \fIx\fR and \fIy\fR arguments to the last +\fBscan mark\fR command for the widget. +It then adjusts the view by 10 times the +difference in coordinates. This command is typically associated +with mouse motion events in the widget, to produce the effect of +dragging the list at high speed through the window. The return +value is an empty string. +.RE +.TP +\fIpathName \fBsee \fIindex\fR +Adjust the view in the listbox so that the element given by \fIindex\fR +is visible. +If the element is already visible then the command has no effect; +if the element is near one edge of the window then the listbox +scrolls to bring the element into view at the edge; otherwise +the listbox scrolls to center the element. +.TP +\fIpathName \fBselection \fIoption arg\fR +This command is used to adjust the selection within a listbox. It +has several forms, depending on \fIoption\fR: +.RS +.TP +\fIpathName \fBselection anchor \fIindex\fR +Sets the selection anchor to the element given by \fIindex\fR. +The selection anchor is the end of the selection that is fixed +while dragging out a selection with the mouse. +The index \fBanchor\fR may be used to refer to the anchor +element. +.TP +\fIpathName \fBselection clear \fIfirst \fR?\fIlast\fR? +If any of the elements between \fIfirst\fR and \fIlast\fR +(inclusive) are selected, they are deselected. +The selection state is not changed for elements outside +this range. +.TP +\fIpathName \fBselection includes \fIindex\fR +Returns 1 if the element indicated by \fIindex\fR is currently +selected, 0 if it isn't. +.TP +\fIpathName \fBselection set \fIfirst \fR?\fIlast\fR? +Selects all of the elements in the range between +\fIfirst\fR and \fIlast\fR, inclusive, without affecting +the selection state of elements outside that range. +.RE +.TP +\fIpathName \fBsize\fR +Returns a decimal string indicating the total number of elements +in the listbox. +.TP +\fIpathName \fBxview \fIargs\fR +This command is used to query and change the horizontal position of the +information in the widget's window. It can take any of the following +forms: +.RS +.TP +\fIpathName \fBxview\fR +Returns a list containing two elements. +Each element is a real fraction between 0 and 1; together they describe +the horizontal span that is visible in the window. +For example, if the first element is .2 and the second element is .6, +20% of the listbox's text is off-screen to the left, the middle 40% is visible +in the window, and 40% of the text is off-screen to the right. +These are the same values passed to scrollbars via the \fB\-xscrollcommand\fR +option. +.TP +\fIpathName \fBxview\fR \fIindex\fR +Adjusts the view in the window so that the character position given by +\fIindex\fR is displayed at the left edge of the window. +Character positions are defined by the width of the character \fB0\fR. +.TP +\fIpathName \fBxview moveto\fI fraction\fR +Adjusts the view in the window so that \fIfraction\fR of the +total width of the listbox text is off-screen to the left. +\fIfraction\fR must be a fraction between 0 and 1. +.TP +\fIpathName \fBxview scroll \fInumber what\fR +This command shifts the view in the window left or right according to +\fInumber\fR and \fIwhat\fR. +\fINumber\fR must be an integer. +\fIWhat\fR must be either \fBunits\fR or \fBpages\fR or an abbreviation +of one of these. +If \fIwhat\fR is \fBunits\fR, the view adjusts left or right by +\fInumber\fR character units (the width of the \fB0\fR character) +on the display; if it is \fBpages\fR then the view adjusts by +\fInumber\fR screenfuls. +If \fInumber\fR is negative then characters farther to the left +become visible; if it is positive then characters farther to the right +become visible. +.RE +.TP +\fIpathName \fByview \fI?args\fR? +This command is used to query and change the vertical position of the +text in the widget's window. +It can take any of the following forms: +.RS +.TP +\fIpathName \fByview\fR +Returns a list containing two elements, both of which are real fractions +between 0 and 1. +The first element gives the position of the listbox element at the +top of the window, relative to the listbox as a whole (0.5 means +it is halfway through the listbox, for example). +The second element gives the position of the listbox element just after +the last one in the window, relative to the listbox as a whole. +These are the same values passed to scrollbars via the \fB\-yscrollcommand\fR +option. +.TP +\fIpathName \fByview\fR \fIindex\fR +Adjusts the view in the window so that the element given by +\fIindex\fR is displayed at the top of the window. +.TP +\fIpathName \fByview moveto\fI fraction\fR +Adjusts the view in the window so that the element given by \fIfraction\fR +appears at the top of the window. +\fIFraction\fR is a fraction between 0 and 1; 0 indicates the first +element in the listbox, 0.33 indicates the element one-third the +way through the listbox, and so on. +.TP +\fIpathName \fByview scroll \fInumber what\fR +This command adjusts the view in the window up or down according to +\fInumber\fR and \fIwhat\fR. +\fINumber\fR must be an integer. +\fIWhat\fR must be either \fBunits\fR or \fBpages\fR. +If \fIwhat\fR is \fBunits\fR, the view adjusts up or down by +\fInumber\fR lines; if it is \fBpages\fR then +the view adjusts by \fInumber\fR screenfuls. +If \fInumber\fR is negative then earlier elements +become visible; if it is positive then later elements +become visible. +.RE + +.SH "DEFAULT BINDINGS" +.PP +Tk automatically creates class bindings for listboxes that give them +Motif-like behavior. Much of the behavior of a listbox is determined +by its \fBselectMode\fR option, which selects one of four ways +of dealing with the selection. +.PP +If the selection mode is \fBsingle\fR or \fBbrowse\fR, at most one +element can be selected in the listbox at once. +In both modes, clicking button 1 on an element selects +it and deselects any other selected item. +In \fBbrowse\fR mode it is also possible to drag the selection +with button 1. +.PP +If the selection mode is \fBmultiple\fR or \fBextended\fR, +any number of elements may be selected at once, including discontiguous +ranges. In \fBmultiple\fR mode, clicking button 1 on an element +toggles its selection state without affecting any other elements. +In \fBextended\fR mode, pressing button 1 on an element selects +it, deselects everything else, and sets the anchor to the element +under the mouse; dragging the mouse with button 1 +down extends the selection to include all the elements between +the anchor and the element under the mouse, inclusive. +.PP +Most people will probably want to use \fBbrowse\fR mode for +single selections and \fBextended\fR mode for multiple selections; +the other modes appear to be useful only in special situations. +.PP +In addition to the above behavior, the following additional behavior +is defined by the default bindings: +.IP [1] +In \fBextended\fR mode, the selected range can be adjusted by pressing +button 1 with the Shift key down: this modifies the selection to +consist of the elements between the anchor and the element under +the mouse, inclusive. +The un-anchored end of this new selection can also be dragged with +the button down. +.IP [2] +In \fBextended\fR mode, pressing button 1 with the Control key down +starts a toggle operation: the anchor is set to the element under +the mouse, and its selection state is reversed. The selection state +of other elements isn't changed. +If the mouse is dragged with button 1 down, then the selection state +of all elements between the anchor and the element under the mouse +is set to match that of the anchor element; the selection state of +all other elements remains what it was before the toggle operation +began. +.IP [3] +If the mouse leaves the listbox window with button 1 down, the window +scrolls away from the mouse, making information visible that used +to be off-screen on the side of the mouse. +The scrolling continues until the mouse re-enters the window, the +button is released, or the end of the listbox is reached. +.IP [4] +Mouse button 2 may be used for scanning. +If it is pressed and dragged over the listbox, the contents of +the listbox drag at high speed in the direction the mouse moves. +.IP [5] +If the Up or Down key is pressed, the location cursor (active +element) moves up or down one element. +If the selection mode is \fBbrowse\fR or \fBextended\fR then the +new active element is also selected and all other elements are +deselected. +In \fBextended\fR mode the new active element becomes the +selection anchor. +.IP [6] +In \fBextended\fR mode, Shift-Up and Shift-Down move the location +cursor (active element) up or down one element and also extend +the selection to that element in a fashion similar to dragging +with mouse button 1. +.IP [7] +The Left and Right keys scroll the listbox view left and right +by the width of the character \fB0\fR. +Control-Left and Control-Right scroll the listbox view left and +right by the width of the window. +Control-Prior and Control-Next also scroll left and right by +the width of the window. +.IP [8] +The Prior and Next keys scroll the listbox view up and down +by one page (the height of the window). +.IP [9] +The Home and End keys scroll the listbox horizontally to +the left and right edges, respectively. +.IP [10] +Control-Home sets the location cursor to the the first element in +the listbox, selects that element, and deselects everything else +in the listbox. +.IP [11] +Control-End sets the location cursor to the the last element in +the listbox, selects that element, and deselects everything else +in the listbox. +.IP [12] +In \fBextended\fR mode, Control-Shift-Home extends the selection +to the first element in the listbox and Control-Shift-End extends +the selection to the last element. +.IP [13] +In \fBmultiple\fR mode, Control-Shift-Home moves the location cursor +to the first element in the listbox and Control-Shift-End moves +the location cursor to the last element. +.IP [14] +The space and Select keys make a selection at the location cursor +(active element) just as if mouse button 1 had been pressed over +this element. +.IP [15] +In \fBextended\fR mode, Control-Shift-space and Shift-Select +extend the selection to the active element just as if button 1 +had been pressed with the Shift key down. +.IP [16] +In \fBextended\fR mode, the Escape key cancels the most recent +selection and restores all the elements in the selected range +to their previous selection state. +.IP [17] +Control-slash selects everything in the widget, except in +\fBsingle\fR and \fBbrowse\fR modes, in which case it selects +the active element and deselects everything else. +.IP [18] +Control-backslash deselects everything in the widget, except in +\fBbrowse\fR mode where it has no effect. +.IP [19] +The F16 key (labelled Copy on many Sun workstations) or Meta-w +copies the selection in the widget to the clipboard, if there is +a selection. + +.PP +The behavior of listboxes can be changed by defining new bindings for +individual widgets or by redefining the class bindings. + +.SH KEYWORDS +listbox, widget diff --git a/tk4.2/doc/lower.n b/tk4.2/doc/lower.n new file mode 100644 index 0000000..2bb7412 --- /dev/null +++ b/tk4.2/doc/lower.n @@ -0,0 +1,38 @@ +'\" +'\" Copyright (c) 1990 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) lower.n 1.8 96/05/16 08:37:36 +'\" +.so man.macros +.TH lower n 3.3 Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +lower \- Change a window's position in the stacking order +.SH SYNOPSIS +\fBlower \fIwindow \fR?\fIbelowThis\fR? +.BE + +.SH DESCRIPTION +.PP +If the \fIbelowThis\fR argument is omitted then the command lowers +\fIwindow\fR so that it is below all of its siblings in the stacking +order (it will be obscured by any siblings that overlap it and +will not obscure any siblings). +If \fIbelowThis\fR is specified then it must be the path name of +a window that is either a sibling of \fIwindow\fR or the descendant +of a sibling of \fIwindow\fR. +In this case the \fBlower\fR command will insert +\fIwindow\fR into the stacking order just below \fIbelowThis\fR +(or the ancestor of \fIbelowThis\fR that is a sibling of \fIwindow\fR); +this could end up either raising or lowering \fIwindow\fR. + +.SH "SEE ALSO" +raise + +.SH KEYWORDS +lower, obscure, stacking order diff --git a/tk4.2/doc/man.macros b/tk4.2/doc/man.macros new file mode 100644 index 0000000..67e6012 --- /dev/null +++ b/tk4.2/doc/man.macros @@ -0,0 +1,234 @@ +'\" The definitions below are for supplemental macros used in Tcl/Tk +'\" manual entries. +'\" +'\" .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. +'\" +'\" .CS +'\" Begin code excerpt. +'\" +'\" .CE +'\" End code excerpt. +'\" +'\" .VS ?br? +'\" Begin vertical sidebar, for use in marking newly-changed parts +'\" of man pages. If an argument is present, then a line break is +'\" forced before starting the sidebar. +'\" +'\" .VE +'\" End of vertical sidebar. +'\" +'\" .DS +'\" Begin an indented unfilled display. +'\" +'\" .DE +'\" End of indented unfilled display. +'\" +'\" .SO +'\" Start of list of standard options for a Tk widget. The +'\" options follow on successive lines, in four columns separated +'\" by tabs. +'\" +'\" .SE +'\" End of list of standard options for a Tk widget. +'\" +'\" .OP cmdName dbName dbClass +'\" Start of description of a specific option. cmdName gives the +'\" option's name as specified in the class command, dbName gives +'\" the option's name in the option database, and dbClass gives +'\" the option's class in the option database. +'\" +'\" .UL arg1 arg2 +'\" Print arg1 underlined, then print arg2 normally. +'\" +'\" SCCS: @(#) man.macros 1.8 96/02/15 20:02:24 +'\" +'\" # Set up traps and other miscellaneous stuff for Tcl/Tk man pages. +.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 +.. +.AS Tcl_Interp Tcl_CreateInterp in/out +'\" # 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 +.if !"\\$1"" .br +.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 +.. +'\" # SO - start of list of standard options +.de SO +.SH "STANDARD OPTIONS" +.LP +.nf +.ta 4c 8c 12c +.ft B +.. +'\" # SE - end of list of standard options +.de SE +.fi +.ft R +.LP +See the \\fBoptions\\fR manual entry for details on the standard options. +.. +'\" # OP - start of full description for a single option +.de OP +.LP +.nf +.ta 4c +Command-Line Name: \\fB\\$1\\fR +Database Name: \\fB\\$2\\fR +Database Class: \\fB\\$3\\fR +.fi +.IP +.. +'\" # CS - begin code excerpt +.de CS +.RS +.nf +.ta .25i .5i .75i 1i +.. +'\" # CE - end code excerpt +.de CE +.fi +.RE +.. +.de UL +\\$1\l'|0\(ul'\\$2 +.. diff --git a/tk4.2/doc/menu.n b/tk4.2/doc/menu.n new file mode 100644 index 0000000..56abf76 --- /dev/null +++ b/tk4.2/doc/menu.n @@ -0,0 +1,623 @@ +'\" +'\" Copyright (c) 1990-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) menu.n 1.48 96/08/27 13:21:20 +'\" +.so man.macros +.TH menu n 4.1 Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +menu \- Create and manipulate menu widgets +.SH SYNOPSIS +\fBmenu\fI \fIpathName \fR?\fIoptions\fR? +.SO +\-activebackground \-background \-disabledforeground \-relief +\-activeborderwidth \-borderwidth \-font \-takefocus +\-activeforeground \-cursor \-foreground +.SE +.SH "WIDGET-SPECIFIC OPTIONS" +.OP \-postcommand postCommand Command +If this option is specified then it provides a Tcl command to execute +each time the menu is posted. The command is invoked by the \fBpost\fR +widget command before posting the menu. +.OP \-selectcolor selectColor Background +For menu entries that are check buttons or radio buttons, this option +specifies the color to display in the indicator when the check button +or radio button is selected. +.OP \-tearoff tearOff TearOff +This option must have a proper boolean value, which specifies +whether or not the menu should include a tear-off entry at the +top. If so, it will exist as entry 0 of the menu and the other +entries will number starting at 1. The default +menu bindings arrange for the menu to be torn off when the tear-off +entry is invoked. +.OP \-tearoffcommand tearOffCommand TearOffCommand +If this option has a non-empty value, then it specifies a Tcl command +to invoke whenever the menu is torn off. The actual command will +consist of the value of this option, followed by a space, followed +by the name of the menu window, followed by a space, followed by +the name of the name of the torn off menu window. For example, if +the option's is ``\fBa b\fR'' and menu \fB.x.y\fR is torn off to +create a new menu \fB.x.tearoff1\fR, then the command +``\fBa b .x.y .x.tearoff1\fR'' will be invoked. +.OP \-transient transient Transient +This option must have a boolean value. True means that the menu +is used on a transient basis, e.g. as a pop-up, pull-down, or +cascaded menu. False means that the menu will be displayed +on the screen continuously, for example as a torn-off menu. +If the option is true, no window manager border +will be displayed around the menu and redisplay will be optimized +using X's ``save under'' facility. +.BE + +.SH INTRODUCTION +.PP +The \fBmenu\fR command creates a new top-level window (given +by the \fIpathName\fR argument) and makes it into a menu widget. +Additional +options, described above, may be specified on the command line +or in the option database +to configure aspects of the menu such as its colors and font. +The \fBmenu\fR command returns its +\fIpathName\fR argument. At the time this command is invoked, +there must not exist a window named \fIpathName\fR, but +\fIpathName\fR's parent must exist. +.PP +A menu is a widget that displays a collection of one-line entries arranged +in a column. There exist several different types of entries, +each with different properties. Entries of different types may be +combined in a single menu. Menu entries are not the same as +entry widgets. In fact, menu entries are not even distinct widgets; +the entire menu is one widget. +.PP +Menu entries are displayed with up to three separate fields. +The main field is a label in the form of a text string, +a bitmap, or an image, controlled by the \fB\-label\fR, +\fB\-bitmap\fR, and \fB\-image\fR options for the entry. +If the \fB\-accelerator\fR option is specified for an entry then a second +textual field is displayed to the right of the label. The accelerator +typically describes a keystroke sequence that may be typed in the +application to cause the same result as invoking the menu entry. +The third field is an \fIindicator\fR. The indicator is present only for +checkbutton or radiobutton entries. It indicates whether the entry +is selected or not, and is displayed to the left of the entry's +string. +.PP +In normal use, an entry becomes active (displays itself differently) +whenever the mouse pointer is over the entry. If a mouse +button is released over the entry then the entry is \fIinvoked\fR. +The effect of invocation is different for each type of entry; +these effects are described below in the sections on individual +entries. +.PP +Entries may be \fIdisabled\fR, which causes their labels +and accelerators to be displayed +with dimmer colors. +The default menu bindings will not allow +a disabled entry to be activated or invoked. +Disabled entries may be re-enabled, at which point it becomes +possible to activate and invoke them again. + +.SH "COMMAND ENTRIES" +.PP +The most common kind of menu entry is a command entry, which +behaves much like a button widget. When a command entry is +invoked, a Tcl command is executed. The Tcl +command is specified with the \fB\-command\fR option. + +.SH "SEPARATOR ENTRIES" +.PP +A separator is an entry that is displayed as a horizontal dividing +line. A separator may not be activated or invoked, and it has +no behavior other than its display appearance. + +.SH "CHECKBUTTON ENTRIES" +.PP +A checkbutton menu entry behaves much like a checkbutton widget. +When it is invoked it toggles back and forth between the selected +and deselected states. When the entry is selected, a particular +value is stored in a particular global variable (as determined by +the \fB\-onvalue\fR and \fB\-variable\fR options for the entry); when +the entry is deselected another value (determined by the +\fB\-offvalue\fR option) is stored in the global variable. +An indicator box is displayed to the left of the label in a checkbutton +entry. If the entry is selected then the indicator's center is displayed +in the color given by the \fB-selectcolor\fR option for the entry; +otherwise the indicator's center is displayed in the background color for +the menu. If a \fB\-command\fR option is specified for a checkbutton +entry, then its value is evaluated as a Tcl command each time the entry +is invoked; this happens after toggling the entry's +selected state. + +.SH "RADIOBUTTON ENTRIES" +.PP +A radiobutton menu entry behaves much like a radiobutton widget. +Radiobutton entries are organized in groups of which only one +entry may be selected at a time. Whenever a particular entry +becomes selected it stores a particular value into a particular +global variable (as determined by the \fB\-value\fR and +\fB\-variable\fR options for the entry). This action +causes any previously-selected entry in the same group +to deselect itself. +Once an entry has become selected, any change to the entry's +associated variable will cause the entry to deselect itself. +Grouping of radiobutton entries is determined by their +associated variables: if two entries have the same associated +variable then they are in the same group. +An indicator diamond is displayed to the left of the label in each +radiobutton entry. If the entry is selected then the indicator's +center is displayed in the color given by the \fB\-selectcolor\fR option +for the entry; +otherwise the indicator's center is displayed in the background color for +the menu. If a \fB\-command\fR option is specified for a radiobutton +entry, then its value is evaluated as a Tcl command each time the entry +is invoked; this happens after selecting the entry. + +.SH "CASCADE ENTRIES" +.PP +A cascade entry is one with an associated menu (determined +by the \fB\-menu\fR option). Cascade entries allow the construction +of cascading menus. +The \fBpostcascade\fR widget command can be used to post and unpost +the associated menu just to the right of the cascade entry. +The associated menu must be a child of the menu containing +the cascade entry (this is needed in order for menu traversal to +work correctly). +.PP +A cascade entry posts its associated menu by invoking a +Tcl command of the form +.CS +\fImenu\fB post \fIx y\fR +.CE +where \fImenu\fR is the path name of the associated menu, and \fIx\fR +and \fIy\fR are the root-window coordinates of the upper-right +corner of the cascade entry. +The lower-level menu is unposted by executing a Tcl command with +the form +.CS +\fImenu\fB unpost\fR +.CE +where \fImenu\fR is the name of the associated menu. +.PP +If a \fB\-command\fR option is specified for a cascade entry then it is +evaluated as a Tcl command whenever the entry is invoked. + +.SH "TEAR-OFF ENTRIES" +.PP +A tear-off entry appears at the top of the menu if enabled with the +\fBtearOff\fR option. It is not like other menu entries in that +it cannot be created with the \fBadd\fR widget command and +cannot be deleted with the \fBdelete\fR widget command. +When a tear-off entry is created it appears as a dashed line at +the top of the menu. Under the default bindings, invoking the +tear-off entry causes a torn-off copy to be made of the menu and +all of its submenus. + +.SH "WIDGET COMMAND" +.PP +The \fBmenu\fR command creates a new Tcl command whose +name is \fIpathName\fR. This +command may be used to invoke various +operations on the widget. It has the following general form: +.CS +\fIpathName option \fR?\fIarg arg ...\fR? +.CE +\fIOption\fR and the \fIarg\fRs +determine the exact behavior of the command. +.PP +Many of the widget commands for a menu take as one argument an +indicator of which entry of the menu to operate on. These +indicators are called \fIindex\fRes and may be specified in +any of the following forms: +.TP 12 +\fInumber\fR +Specifies the entry numerically, where 0 corresponds +to the top-most entry of the menu, 1 to the entry below it, and +so on. +.TP 12 +\fBactive\fR +Indicates the entry that is currently active. If no entry is +active then this form is equivalent to \fBnone\fR. This form may +not be abbreviated. +.TP 12 +\fBend\fR +Indicates the bottommost entry in the menu. If there are no +entries in the menu then this form is equivalent to \fBnone\fR. +This form may not be abbreviated. +.TP 12 +\fBlast\fR +Same as \fBend\fR. +.TP 12 +\fBnone\fR +Indicates ``no entry at all''; this is used most commonly with +the \fBactivate\fR option to deactivate all the entries in the +menu. In most cases the specification of \fBnone\fR causes +nothing to happen in the widget command. +This form may not be abbreviated. +.TP 12 +\fB@\fInumber\fR +In this form, \fInumber\fR is treated as a y-coordinate in the +menu's window; the entry closest to that y-coordinate is used. +For example, ``\fB@0\fR'' indicates the top-most entry in the +window. +.TP 12 +\fIpattern\fR +If the index doesn't satisfy one of the above forms then this +form is used. \fIPattern\fR is pattern-matched against the label of +each entry in the menu, in order from the top down, until a +matching entry is found. The rules of \fBTcl_StringMatch\fR +are used. +.PP +The following widget commands are possible for menu widgets: +.TP +\fIpathName \fBactivate \fIindex\fR +Change the state of the entry indicated by \fIindex\fR to \fBactive\fR +and redisplay it using its active colors. +Any previously-active entry is deactivated. If \fIindex\fR +is specified as \fBnone\fR, or if the specified entry is +disabled, then the menu ends up with no active entry. +Returns an empty string. +.TP +\fIpathName \fBadd \fItype \fR?\fIoption value option value ...\fR? +Add a new entry to the bottom of the menu. The new entry's type +is given by \fItype\fR and must be one of \fBcascade\fR, +\fBcheckbutton\fR, \fBcommand\fR, \fBradiobutton\fR, or \fBseparator\fR, +or a unique abbreviation of one of the above. If additional arguments +are present, they specify any of the following options: +.RS +.TP +\fB\-activebackground \fIvalue\fR +Specifies a background color to use for displaying this entry when it +is active. +If this option is specified as an empty string (the default), then the +\fBactiveBackground\fR option for the overall menu is used. +If the \fBtk_strictMotif\fR variable has been set to request strict +Motif compliance, then this option is ignored and the \fB\-background\fR +option is used in its place. +This option is not available for separator or tear-off entries. +.TP +\fB\-activeforeground \fIvalue\fR +Specifies a foreground color to use for displaying this entry when it +is active. +If this option is specified as an empty string (the default), then the +\fBactiveForeground\fR option for the overall menu is used. +This option is not available for separator or tear-off entries. +.TP +\fB\-accelerator \fIvalue\fR +Specifies a string to display at the right side of the menu entry. +Normally describes an accelerator keystroke sequence that may be +typed to invoke the same function as the menu entry. This option +is not available for separator or tear-off entries. +.TP +\fB\-background \fIvalue\fR +Specifies a background color to use for displaying this entry when it +is in the normal state (neither active nor disabled). +If this option is specified as an empty string (the default), then the +\fBbackground\fR option for the overall menu is used. +This option is not available for separator or tear-off entries. +.TP +\fB\-bitmap \fIvalue\fR +Specifies a bitmap to display in the menu instead of a textual +label, in any of the forms accepted by \fBTk_GetBitmap\fR. +This option overrides the \fB\-label\fR option but may be reset +to an empty string to enable a textual label to be displayed. +If a \fB\-image\fR option has been specified, it overrides +\fB\-bitmap\fR. +This option is not available for separator or tear-off entries. +.TP +\fB\-command \fIvalue\fR +Specifies a Tcl command to execute when the menu entry is invoked. +Not available for separator or tear-off entries. +.TP +\fB\-font \fIvalue\fR +Specifies the font to use when drawing the label or accelerator +string in this entry. +If this option is specified as an empty string (the default) then +the \fBfont\fR option for the overall menu is used. +This option is not available for separator or tear-off entries. +.TP +\fB\-foreground \fIvalue\fR +Specifies a foreground color to use for displaying this entry when it +is in the normal state (neither active nor disabled). +If this option is specified as an empty string (the default), then the +\fBforeground\fR option for the overall menu is used. +This option is not available for separator or tear-off entries. +.TP +\fB\-image \fIvalue\fR +Specifies an image to display in the menu instead of a text string +or bitmap +The image must have been created by some previous invocation of +\fBimage create\fR. +This option overrides the \fB\-label\fR and \fB\-bitmap\fR options +but may be reset to an empty string to enable a textual or +bitmap label to be displayed. +This option is not available for separator or tear-off entries. +.TP +\fB\-indicatoron \fIvalue\fR +Available only for checkbutton and radiobutton entries. +\fIValue\fR is a boolean that determines whether or not the +indicator should be displayed. +.TP +\fB\-label \fIvalue\fR +Specifies a string to display as an identifying label in the menu +entry. Not available for separator or tear-off entries. +.TP +\fB\-menu \fIvalue\fR +Available only for cascade entries. Specifies the path name of +the submenu associated with this entry. +The submenu must be a child of the menu. +.TP +\fB\-offvalue \fIvalue\fR +Available only for checkbutton entries. Specifies the value to +store in the entry's associated variable when the entry is +deselected. +.TP +\fB\-onvalue \fIvalue\fR +Available only for checkbutton entries. Specifies the value to +store in the entry's associated variable when the entry is selected. +.TP +\fB\-selectcolor \fIvalue\fR +Available only for checkbutton and radiobutton entries. +Specifies the color to display in the indicator when the entry is +selected. +If the value is an empty string (the default) then the \fBselectColor\fR +option for the menu determines the indicator color. +.TP +\fB\-selectimage \fIvalue\fR +Available only for checkbutton and radiobutton entries. +Specifies an image to display in the entry (in place of +the \fB\-image\fR option) when it is selected. +\fIValue\fR is the name of an image, which must have been created +by some previous invocation of \fBimage create\fR. +This option is ignored unless the \fB\-image\fR option has +been specified. +.TP +\fB\-state \fIvalue\fR +Specifies one of three states for the entry: \fBnormal\fR, \fBactive\fR, +or \fBdisabled\fR. In normal state the entry is displayed using the +\fBforeground\fR option for the menu and the \fBbackground\fR +option from the entry or the menu. +The active state is typically used when the pointer is over the entry. +In active state the entry is displayed using the \fBactiveForeground\fR +option for the menu along with the \fBactivebackground\fR option from +the entry. Disabled state means that the entry +should be insensitive: the default bindings will refuse to activate +or invoke the entry. +In this state the entry is displayed according to the +\fBdisabledForeground\fR option for the menu and the +\fBbackground\fR option from the entry. +This option is not available for separator entries. +.TP +\fB\-underline \fIvalue\fR +Specifies the integer index of a character to underline in the entry. +This option is also queried by the default bindings and used to +implement keyboard traversal. +0 corresponds to the first character of the text displayed in the entry, +1 to the next character, and so on. +If a bitmap or image is displayed in the entry then this option is ignored. +This option is not available for separator or tear-off entries. +.TP +\fB\-value \fIvalue\fR +Available only for radiobutton entries. Specifies the value to +store in the entry's associated variable when the entry is selected. +If an empty string is specified, then the \fB\-label\fR option +for the entry as the value to store in the variable. +.TP +\fB\-variable \fIvalue\fR +Available only for checkbutton and radiobutton entries. Specifies +the name of a global value to set when the entry is selected. +For checkbutton entries the variable is also set when the entry +is deselected. For radiobutton entries, changing the variable +causes the currently-selected entry to deselect itself. +.LP +The \fBadd\fR widget command returns an empty string. +.RE +.TP +\fIpathName \fBcget\fR \fIoption\fR +Returns the current value of the configuration option given +by \fIoption\fR. +\fIOption\fR may have any of the values accepted by the \fBmenu\fR +command. +.TP +\fIpathName \fBconfigure\fR ?\fIoption\fR? ?\fIvalue option value ...\fR? +Query or modify the configuration options of the widget. +If no \fIoption\fR is specified, returns a list describing all of +the available options for \fIpathName\fR (see \fBTk_ConfigureInfo\fR for +information on the format of this list). If \fIoption\fR is specified +with no \fIvalue\fR, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no \fIoption\fR is specified). If +one or more \fIoption\-value\fR pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +\fIOption\fR may have any of the values accepted by the \fBmenu\fR +command. +.TP +\fIpathName \fBdelete \fIindex1\fR ?\fIindex2\fR? +Delete all of the menu entries between \fIindex1\fR and +\fIindex2\fR inclusive. +If \fIindex2\fR is omitted then it defaults to \fIindex1\fR. +Attempts to delete a tear-off menu entry are ignored (instead, you +should change the \fBtearOff\fR option to remove the tear-off entry). +.TP +\fIpathName \fBentrycget\fR \fIindex option\fR +Returns the current value of a configuration option for +the entry given by \fIindex\fR. +\fIOption\fR may have any of the values accepted by the \fBadd\fR +widget command. +.TP +\fIpathName \fBentryconfigure \fIindex \fR?\fIoptions\fR? +This command is similar to the \fBconfigure\fR command, except that +it applies to the options for an individual entry, whereas \fBconfigure\fR +applies to the options for the menu as a whole. +\fIOptions\fR may have any of the values accepted by the \fBadd\fR +widget command. If \fIoptions\fR are specified, options are modified +as indicated +in the command and the command returns an empty string. +If no \fIoptions\fR are specified, returns a list describing +the current options for entry \fIindex\fR (see \fBTk_ConfigureInfo\fR for +information on the format of this list). +.TP +\fIpathName \fBindex \fIindex\fR +Returns the numerical index corresponding to \fIindex\fR, or +\fBnone\fR if \fIindex\fR was specified as \fBnone\fR. +.TP +\fIpathName \fBinsert \fIindex\fR \fItype \fR?\fIoption value option value ...\fR? +Same as the \fBadd\fR widget command except that it inserts the new +entry just before the entry given by \fIindex\fR, instead of appending +to the end of the menu. The \fItype\fR, \fIoption\fR, and \fIvalue\fR +arguments have the same interpretation as for the \fBadd\fR widget +command. It is not possible to insert new menu entries before the +tear-off entry, if the menu has one. +.TP +\fIpathName \fBinvoke \fIindex\fR +Invoke the action of the menu entry. See the sections on the +individual entries above for details on what happens. If the +menu entry is disabled then nothing happens. If the +entry has a command associated with it then the result of that +command is returned as the result of the \fBinvoke\fR widget +command. Otherwise the result is an empty string. Note: invoking +a menu entry does not automatically unpost the menu; the default +bindings normally take care of this before invoking the \fBinvoke\fR +widget command. +.TP +\fIpathName \fBpost \fIx y\fR +Arrange for the menu to be displayed on the screen at the root-window +coordinates given by \fIx\fR and \fIy\fR. These coordinates are +adjusted if necessary to guarantee that the entire menu is visible on +the screen. This command normally returns an empty string. +If the \fBpostCommand\fR option has been specified, then its value is +executed as a Tcl script before posting the menu and the result of +that script is returned as the result of the \fBpost\fR widget +command. +If an error returns while executing the command, then the error is +returned without posting the menu. +.TP +\fIpathName \fBpostcascade \fIindex\fR +Posts the submenu associated with the cascade entry given by +\fIindex\fR, and unposts any previously posted submenu. +If \fIindex\fR doesn't correspond to a cascade entry, +or if \fIpathName\fR isn't posted, +the command has no effect except to unpost any currently posted +submenu. +.TP +\fIpathName \fBtype \fIindex\fR +Returns the type of the menu entry given by \fIindex\fR. +This is the \fItype\fR argument passed to the \fBadd\fR widget +command when the entry was created, such as \fBcommand\fR +or \fBseparator\fR, or \fBtearoff\fR for a tear-off entry. +.TP +\fIpathName \fBunpost\fR +Unmap the window so that it is no longer displayed. If a +lower-level cascaded menu is posted, unpost that menu. Returns an +empty string. +.TP +\fIpathName \fByposition \fIindex\fR +Returns a decimal string giving the y-coordinate within the menu +window of the topmost pixel in the entry specified by \fIindex\fR. + +.SH "MENU CONFIGURATIONS" +.PP +The default bindings support four different ways of using menus: +.TP +\fBPulldown Menus\fR +This is the most common case. You create one menubutton widget for +each top-level menu, and typically you arrange a series of menubuttons +in a row in a menubar window. You also create the top-level menus +and any cascaded submenus, and tie them together with \fB\-menu\fR +options in menubuttons and cascade menu entries. The top-level menu must +be a child of the menubutton, and each submenu must be a child of the +menu that refers to it. Once you have done this, the default bindings +will allow users to traverse and invoke the tree of menus via its +menubutton; see the \fBmenubutton\fR manual entry for details. +.TP +\fBPopup Menus\fR +Popup menus typically post in response to a mouse button press or +keystroke. You create the popup menus and any cascaded submenus, +then you call the \fBtk_popup\fR procedure at the appropriate time +to post the top-level menu. +.TP +\fBOption Menus\fR +An option menu consists of a menubutton with an associated menu +that allows you to select one of several values. The current value +is displayed in the menubutton and is also stored in a global +variable. Use the \fBtk_optionMenu\fR procedure to create option +menubuttons and their menus. +.TP +\fBTorn-off Menus\fR +You create a torn-off menu by invoking the tear-off entry at +the top of an existing menu. The default bindings will create a new menu +that is a copy of the original menu and leave it permanently +posted as a top-level window. The torn-off menu behaves just +the same as the original menu. + +.SH "DEFAULT BINDINGS" +.PP +Tk automatically creates class bindings for menus that give them +the following default behavior: +.IP [1] +When the mouse enters a menu, the entry underneath the mouse +cursor activates; as the mouse moves around the menu, the active +entry changes to track the mouse. +.IP [2] +When the mouse leaves a menu all of the entries in the menu +deactivate, except in the special case where the mouse moves from +a menu to a cascaded submenu. +.IP [3] +When a button is released over a menu, the active entry (if any) is invoked. +The menu also unposts unless it is a torn-off menu. +.IP [4] +The Space and Return keys invoke the active entry and +unpost the menu. +.IP [5] +If any of the entries in a menu have letters underlined with +with \fB\-underline\fR option, then pressing one of the underlined +letters (or its upper-case or lower-case equivalent) invokes that +entry and unposts the menu. +.IP [6] +The Escape key aborts a menu selection in progress without invoking any +entry. It also unposts the menu unless it is a torn-off menu. +.IP [7] +The Up and Down keys activate the next higher or lower entry +in the menu. When one end of the menu is reached, the active +entry wraps around to the other end. +.IP [8] +The Left key moves to the next menu to the left. +If the current menu is a cascaded submenu, then the submenu is +unposted and the current menu entry becomes the cascade entry +in the parent. +If the current menu is a top-level menu posted from a +menubutton, then the current menubutton is unposted and the +next menubutton to the left is posted. +Otherwise the key has no effect. +The left-right order of menubuttons is determined by their stacking +order: Tk assumes that the lowest menubutton (which by default +is the first one created) is on the left. +.IP [9] +The Right key moves to the next menu to the right. +If the current entry is a cascade entry, then the submenu is +posted and the current menu entry becomes the first entry +in the submenu. +Otherwise, if the current menu was posted from a +menubutton, then the current menubutton is unposted and the +next menubutton to the right is posted. +.PP +Disabled menu entries are non-responsive: they don't activate and +they ignore mouse button presses and releases. +.PP +The behavior of menus can be changed by defining new bindings for +individual widgets or by redefining the class bindings. + +.SH BUGS +.PP +At present it isn't possible to use the +option database to specify values for the options to individual +entries. + +.SH KEYWORDS +menu, widget diff --git a/tk4.2/doc/menubar.n b/tk4.2/doc/menubar.n new file mode 100644 index 0000000..09ea053 --- /dev/null +++ b/tk4.2/doc/menubar.n @@ -0,0 +1,33 @@ +'\" +'\" Copyright (c) 1992 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) menubar.n 1.13 96/08/27 13:21:45 +'\" +.so man.macros +.TH tk_menuBar n "" Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +tk_menuBar, tk_bindForTraversal \- Obsolete support for menu bars +.SH SYNOPSIS +\fBtk_menuBar \fIframe \fR?\fImenu menu ...\fR? +.sp +\fBtk_bindForTraversal \fIarg arg ... \fR +.BE + +.SH DESCRIPTION +.PP +These procedures were used in Tk 3.6 and earlier releases to help +manage pulldown menus and to implement keyboard traversal of menus. +In Tk 4.0 and later releases they are no +longer needed. Stubs for these procedures have been retained for +backward compatibility, but they have no effect. You should remove +calls to these procedures from your code, since eventually the +procedures will go away. + +.SH KEYWORDS +keyboard traversal, menu, menu bar, post diff --git a/tk4.2/doc/menubutton.n b/tk4.2/doc/menubutton.n new file mode 100644 index 0000000..c171af1 --- /dev/null +++ b/tk4.2/doc/menubutton.n @@ -0,0 +1,185 @@ +'\" +'\" Copyright (c) 1990-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) menubutton.n 1.32 96/08/27 13:21:45 +'\" +.so man.macros +.TH menubutton n 4.0 Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +menubutton \- Create and manipulate menubutton widgets +.SH SYNOPSIS +\fBmenubutton\fI \fIpathName \fR?\fIoptions\fR? +.SO +\-activebackground \-cursor \-highlightthickness \-takefocus +\-activeforeground \-disabledforeground \-image \-text +\-anchor \-font \-justify \-textvariable +\-background \-foreground \-padx \-underline +\-bitmap \-highlightbackground \-pady \-wraplength +\-borderwidth \-highlightcolor \-relief +.SE +.SH "WIDGET-SPECIFIC OPTIONS" +.OP \-height height Height +Specifies a desired height for the menubutton. +If an image or bitmap is being displayed in the menubutton then the value is in +screen units (i.e. any of the forms acceptable to \fBTk_GetPixels\fR); +for text it is in lines of text. +If this option isn't specified, the menubutton's desired height is computed +from the size of the image or bitmap or text being displayed in it. +.OP \-indicatoron indicatorOn IndicatorOn +The value must be a proper boolean value. If it is true then +a small indicator rectangle will be displayed on the right side +of the menubutton and the default menu bindings will treat this +as an option menubutton. If false then no indicator will be +displayed. +.OP \-menu menu MenuName +Specifies the path name of the menu associated with this menubutton. +The menu must be a child of the menubutton. +.OP \-state state State +Specifies one of three states for the menubutton: \fBnormal\fR, \fBactive\fR, +or \fBdisabled\fR. In normal state the menubutton is displayed using the +\fBforeground\fR and \fBbackground\fR options. The active state is +typically used when the pointer is over the menubutton. In active state +the menubutton is displayed using the \fBactiveForeground\fR and +\fBactiveBackground\fR options. Disabled state means that the menubutton +should be insensitive: the default bindings will refuse to activate +the widget and will ignore mouse button presses. +In this state the \fBdisabledForeground\fR and +\fBbackground\fR options determine how the button is displayed. +.OP \-width width Width +Specifies a desired width for the menubutton. +If an image or bitmap is being displayed in the menubutton then the value is in +screen units (i.e. any of the forms acceptable to \fBTk_GetPixels\fR); +for text it is in characters. +If this option isn't specified, the menubutton's desired width is computed +from the size of the image or bitmap or text being displayed in it. +.BE + +.SH INTRODUCTION +.PP +The \fBmenubutton\fR command creates a new window (given by the +\fIpathName\fR argument) and makes it into a menubutton widget. +Additional +options, described above, may be specified on the command line +or in the option database +to configure aspects of the menubutton such as its colors, font, +text, and initial relief. The \fBmenubutton\fR command returns its +\fIpathName\fR argument. At the time this command is invoked, +there must not exist a window named \fIpathName\fR, but +\fIpathName\fR's parent must exist. +.PP +A menubutton is a widget that displays a textual string, bitmap, or image +and is associated with a menu widget. +If text is displayed, it must all be in a single font, but it +can occupy multiple lines on the screen (if it contains newlines +or if wrapping occurs because of the \fBwrapLength\fR option) and +one of the characters may optionally be underlined using the +\fBunderline\fR option. In normal usage, pressing +mouse button 1 over the menubutton causes the associated menu to +be posted just underneath the menubutton. If the mouse is moved over +the menu before releasing the mouse button, the button release +causes the underlying menu entry to be invoked. When the button +is released, the menu is unposted. +.PP +Menubuttons are typically organized into groups called menu bars +that allow scanning: +if the mouse button is pressed over one menubutton (causing it +to post its menu) and the mouse is moved over another menubutton +in the same menu bar without releasing the mouse button, then the +menu of the first menubutton is unposted and the menu of the +new menubutton is posted instead. +.PP +There are several interactions between menubuttons and menus; see +the \fBmenu\fR manual entry for information on various menu configurations, +such as pulldown menus and option menus. + +.SH "WIDGET COMMAND" +.PP +The \fBmenubutton\fR command creates a new Tcl command whose +name is \fIpathName\fR. This +command may be used to invoke various +operations on the widget. It has the following general form: +.CS +\fIpathName option \fR?\fIarg arg ...\fR? +.CE +\fIOption\fR and the \fIarg\fRs +determine the exact behavior of the command. The following +commands are possible for menubutton widgets: +.TP +\fIpathName \fBcget\fR \fIoption\fR +Returns the current value of the configuration option given +by \fIoption\fR. +\fIOption\fR may have any of the values accepted by the \fBmenubutton\fR +command. +.TP +\fIpathName \fBconfigure\fR ?\fIoption\fR? ?\fIvalue option value ...\fR? +Query or modify the configuration options of the widget. +If no \fIoption\fR is specified, returns a list describing all of +the available options for \fIpathName\fR (see \fBTk_ConfigureInfo\fR for +information on the format of this list). If \fIoption\fR is specified +with no \fIvalue\fR, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no \fIoption\fR is specified). If +one or more \fIoption\-value\fR pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +\fIOption\fR may have any of the values accepted by the \fBmenubutton\fR +command. + +.SH "DEFAULT BINDINGS" +.PP +Tk automatically creates class bindings for menubuttons that give them +the following default behavior: +.IP [1] +A menubutton activates whenever the mouse passes over it and deactivates +whenever the mouse leaves it. +.IP [2] +Pressing mouse button 1 over a menubutton posts the menubutton: +its relief changes to raised and its associated menu is posted +under the menubutton. If the mouse is dragged down into the menu +with the button still down, and if the mouse button is then +released over an entry in the menu, the menubutton is unposted +and the menu entry is invoked. +.IP [3] +If button 1 is pressed over a menubutton and then released over that +menubutton, the menubutton stays posted: you can still move the mouse +over the menu and click button 1 on an entry to invoke it. +Once a menu entry has been invoked, the menubutton unposts itself. +.IP [4] +If button 1 is pressed over a menubutton and then dragged over some +other menubutton, the original menubutton unposts itself and the +new menubutton posts. +.IP [5] +If button 1 is pressed over a menubutton and released outside +any menubutton or menu, the menubutton unposts without invoking +any menu entry. +.IP [6] +When a menubutton is posted, its associated menu claims the input +focus to allow keyboard traversal of the menu and its submenus. +See the \fBmenu\fR manual entry for details on these bindings. +.IP [7] +If the \fBunderline\fR option has been specified for a menubutton +then keyboard traversal may be used to post the menubutton: +Alt+\fIx\fR, where \fIx\fR is the underlined character (or its +lower-case or upper-case equivalent), may be typed in any window +under the menubutton's toplevel to post the menubutton. +.IP [8] +The F10 key may be typed in any window to post the first menubutton +under its toplevel window that isn't disabled. +.IP [9] +If a menubutton has the input focus, the space and return keys +post the menubutton. +.PP +If the menubutton's state is \fBdisabled\fR then none of the above +actions occur: the menubutton is completely non-responsive. +.PP +The behavior of menubuttons can be changed by defining new bindings for +individual widgets or by redefining the class bindings. + +.SH KEYWORDS +menubutton, widget diff --git a/tk3.6/doc/message.n b/tk4.2/doc/message.n similarity index 75% rename from tk3.6/doc/message.n rename to tk4.2/doc/message.n index 25c62d2..8407a80 100644 --- a/tk3.6/doc/message.n +++ b/tk4.2/doc/message.n @@ -1,76 +1,41 @@ '\" -'\" Copyright (c) 1990 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1990-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) message.n 1.31 96/08/27 13:21:46 '\" -'\" $Header: /user6/ouster/wish/man/RCS/message.n,v 1.17 93/04/01 09:52:47 ouster Exp $ SPRITE (Berkeley) -'/" .so man.macros -.HS message tk +.TH message n 4.0 Tk "Tk Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME message \- Create and manipulate message widgets .SH SYNOPSIS \fBmessage\fI \fIpathName \fR?\fIoptions\fR? -.SH "STANDARD OPTIONS" -.LP -.nf -.ta 4c 8c 12c -.VS -\fBanchor\fR \fBcursor\fR \fBpadX\fR \fBtext\fR -\fBbackground\fR \fBfont\fR \fBpadY\fR \fBtextVariable\fR -\fBborderWidth\fR \fBforeground\fR \fBrelief\fR \fBwidth\fR -.VE -.fi -.LP -See the ``options'' manual entry for details on the standard options. +.SO +\-anchor \-font \-highlightthickness \-takefocus +\-background \-foreground \-padx \-text +\-borderwidth \-highlightbackground \-pady \-textvariable +\-cursor \-highlightcolor \-relief \-width +.SE .SH "WIDGET-SPECIFIC OPTIONS" -.ta 4c -.LP -.nf -Name: \fBaspect\fR -Class: \fBAspect\fR -Command-Line Switch: \fB\-aspect\fR -.fi -.IP +.OP \-aspect aspect Aspect Specifies a non-negative integer value indicating desired aspect ratio for the text. The aspect ratio is specified as 100*width/height. 100 means the text should be as wide as it is tall, 200 means the text should be twice as wide as it is tall, 50 means the text should be twice as tall as it is wide, and so on. -.VS Used to choose line length for text if \fBwidth\fR option isn't specified. -.VE Defaults to 150. -.LP -.nf -Name: \fBjustify\fR -Class: \fBJustify\fR -Command-Line Switch: \fB\-justify\fR -.fi -.IP +.OP \-justify justify Justify Specifies how to justify lines of text. Must be one of \fBleft\fR, \fBcenter\fR, or \fBright\fR. Defaults to \fBleft\fR. -.VS This option works together with the \fBanchor\fR, \fBaspect\fR, \fBpadX\fR, \fBpadY\fR, and \fBwidth\fR options to provide a variety of arrangements of the text within the window. @@ -87,15 +52,7 @@ The the text will displayed so that the left edges of all the lines line up and the right edge of the longest line is \fBpadX\fR from the right side of the window; the entire text block will be centered in the vertical span of the window. -.VE -.LP -.nf -.VS -Name: \fBwidth\fR -Class: \fBWidth\fR -Command-Line Switch: \fB\-width\fR -.fi -.IP +.OP \-width width Width Specifies the length of lines in the window. The value may have any of the forms acceptable to \fBTk_GetPixels\fR. If this option has a value greater than zero then the \fBaspect\fR @@ -103,7 +60,6 @@ option is ignored and the \fBwidth\fR option determines the line length. If this option has a value less than or equal to zero, then the \fBaspect\fR option determines the line length. -.VE .BE .SH DESCRIPTION @@ -150,13 +106,19 @@ The \fBmessage\fR command creates a new Tcl command whose name is \fIpathName\fR. This command may be used to invoke various operations on the widget. It has the following general form: -.DS C +.CS \fIpathName option \fR?\fIarg arg ...\fR? -.DE +.CE \fIOption\fR and the \fIarg\fRs determine the exact behavior of the command. The following commands are possible for message widgets: .TP +\fIpathName \fBcget\fR \fIoption\fR +Returns the current value of the configuration option given +by \fIoption\fR. +\fIOption\fR may have any of the values accepted by the \fBmessage\fR +command. +.TP \fIpathName \fBconfigure\fR ?\fIoption\fR? ?\fIvalue option value ...\fR? Query or modify the configuration options of the widget. If no \fIoption\fR is specified, returns a list describing all of diff --git a/tk4.2/doc/messageBox.n b/tk4.2/doc/messageBox.n new file mode 100644 index 0000000..7b6a5e6 --- /dev/null +++ b/tk4.2/doc/messageBox.n @@ -0,0 +1,90 @@ +'\" +'\" Copyright (c) 1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) messageBox.n 1.5 96/09/19 17:02:40 +'\" +.so man.macros +.TH tk_messageBox n 4.2 Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +tk_messageBox \- pops up a message window and waits for user response. +.SH SYNOPSIS +\fBtk_messageBox \fR?\fIoption value ...\fR? +.BE + +.SH DESCRIPTION +.PP +This procedure creates and displays a message window with an +application-specified message, an icon and a set of buttons. Each of +the buttons in the message window is identified by a unique symbolic +name (see the \fB\-type\fR options). After the message window is +popped up, \fBtk_messageBox\fR waits for the user to select one of the +buttons. Then it returns the symbolic name of the selected button. + +The following option-value pairs are supported: +.TP +\fB\-default\fR \fIname\fR +\fIName\fR gives the symbolic name of the default button for +this message window ('ok', 'cancel', and so on). See \fB\-type\fR +for a list of the symbolic names. If the message box has just one +button it will automatically be made the default, otherwise if this +option is not specified, there won't be any default button. +.TP +\fB\-icon\fR \fIiconImage\fR +Specifies an icon to display. \fIIconImage\fR must be one of the +following: \fBerror\fR, \fBinfo\fR, \fBquestion\fR or +\fBwarning\fR. If this option is not specified, then no icon will be +displayed. +.TP +\fB\-message\fR \fIstring\fR +Specifies the message to display in this message box. +.TP +\fB\-parent\fR \fIwindow\fR +Makes \fIwindow\fR the logical parent of the message box. The message +box is displayed on top of its parent window. +.TP +\fB\-title\fR \fItitleString\fR +Specifies a string to display as the title of the message box. The +default value is an empty string. +.TP +\fB\-type\fR \fIpredefinedType\fR +Arranges for a predefined set of buttons to be displayed. The +following values are possible for \fIpredefinedType\fR: +.RS +.TP 18 +\fBabortretryignore\fR +Displays three buttons whose symbolic names are \fBabort\fR, +\fBretry\fR and \fBignore\fR. +.TP 18 +\fBok\fR +Displays one button whose symbolic name is \fBok\fR. +.TP 18 +\fBokcancel\fR +Displays two buttons whose symbolic names are \fBok\fR and \fBcancel\fR. +.TP 18 +\fBretrycancel\fR +Displays two buttons whose symbolic names are \fBretry\fR and \fBcancel\fR. +.TP 18 +\fByesno\fR +Displays two buttons whose symbolic names are \fByes\fR and \fBno\fR. +.TP 18 +\fByesnocancel\fR +Displays three buttons whose symbolic names are \fByes\fR, \fBno\fR +and \fBcancel\fR. +.RE +.PP +.SH EXAMPLE +.CS +set answer [tk_messageBox \-message "Really quit?" \-type yesno \-icon question] +case $answer { + yes exit + no {tk_messageBox \-message "I know you like this application!" \-type ok} +} +.CE + +.SH KEYWORDS +message box diff --git a/tk3.6/doc/option.n b/tk4.2/doc/option.n similarity index 75% rename from tk3.6/doc/option.n rename to tk4.2/doc/option.n index 96a025e..33feaf8 100644 --- a/tk3.6/doc/option.n +++ b/tk4.2/doc/option.n @@ -1,27 +1,14 @@ '\" '\" Copyright (c) 1990 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) option.n 1.10 96/03/26 18:25:08 '\" -'\" $Header: /user6/ouster/wish/man/RCS/option.n,v 1.5 93/04/01 09:52:48 ouster Exp $ SPRITE (Berkeley) -'/" .so man.macros -.HS option tk +.TH option n "" Tk "Tk Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/tk4.2/doc/optionMenu.n b/tk4.2/doc/optionMenu.n new file mode 100644 index 0000000..3303847 --- /dev/null +++ b/tk4.2/doc/optionMenu.n @@ -0,0 +1,40 @@ +'\" +'\" Copyright (c) 1990-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) optionMenu.n 1.5 96/03/26 18:25:21 +'\" +.so man.macros +.TH tk_optionMenu n 4.0 Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +tk_optionMenu \- Create an option menubutton and its menu +.SH SYNOPSIS +\fBtk_optionMenu \fIw varName value \fR?\fIvalue value ...\fR? +.BE + +.SH DESCRIPTION +.PP +This procedure creates an option menubutton whose name is \fIw\fR, +plus an associated menu. +Together they allow the user to select one of the values +given by the \fIvalue\fR arguments. +The current value will be stored in the global variable whose +name is given by \fIvarName\fR and it will also be displayed as the label +in the option menubutton. +The user can click on the menubutton to display a menu containing +all of the \fIvalue\fRs and thereby select a new value. +Once a new value is selected, it will be stored in the variable +and appear in the option menubutton. +The current value can also be changed by setting the variable. +.PP +The return value from \fBtk_optionMenu\fR is the name of the menu +associated with \fIw\fR, so that the caller can change its configuration +options or manipulate it in other ways. + +.SH KEYWORDS +option menu diff --git a/tk3.6/doc/options.n b/tk4.2/doc/options.n similarity index 52% rename from tk3.6/doc/options.n rename to tk4.2/doc/options.n index edeb874..f4b7f92 100644 --- a/tk3.6/doc/options.n +++ b/tk4.2/doc/options.n @@ -1,27 +1,14 @@ '\" -'\" Copyright (c) 1990 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1990-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) options.n 1.44 96/08/27 13:21:40 '\" -'\" $Header: /user6/ouster/wish/man/RCS/options.n,v 1.15 93/08/18 12:09:27 ouster Exp $ SPRITE (Berkeley) -'/" .so man.macros -.HS options tk +.TH options n 4.0 Tk "Tk Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -36,88 +23,49 @@ of the standard options supported by that widget), but if a widget does support an option with one of the names listed below, then the option has exactly the effect described below. .PP -In the descriptions below, -``Name'' refers to the option's name in the option database (e.g. -in .Xdefaults files). ``Class'' refers to the option's class value -in the option database. ``Command-Line Switch'' refers to the -switch used in widget-creation and \fBconfigure\fR widget commands to +In the descriptions below, ``Command-Line Name'' refers to the +switch used in class commands and \fBconfigure\fR widget commands to set this value. For example, if an option's command-line switch is \fB\-foreground\fR and there exists a widget \fB.a.b.c\fR, then the command -.DS +.CS \&\fB.a.b.c\0\0configure\0\0\-foreground black\fR -.DE +.CE may be used to specify the value \fBblack\fR for the option in the the widget \fB.a.b.c\fR. Command-line switches may be abbreviated, as long as the abbreviation is unambiguous. -.ta 4c -.LP -.nf -Name: \fBactiveBackground\fR -Class: \fBForeground\fR -Command-Line Switch: \fB\-activebackground\fR -.fi -.IP +``Database Name'' refers to the option's name in the option database (e.g. +in .Xdefaults files). ``Database Class'' refers to the option's class value +in the option database. +.OP \-activebackground activeBackground Foreground Specifies background color to use when drawing active elements. An element (a widget or portion of a widget) is active if the mouse cursor is positioned over the element and pressing a mouse button will cause some action to occur. -.LP -.nf -Name: \fBactiveBorderWidth\fR -Class: \fBBorderWidth\fR -Command-Line Switch: \fB\-activeborderwidth\fR -.fi -.IP +If strict Motif compliance has been requested by setting the +\fBtk_strictMotif\fR variable, this option will normally be +ignored; the normal background color will be used instead. +.OP \-activeborderwidth activeBorderWidth BorderWidth Specifies a non-negative value indicating the width of the 3-D border drawn around active elements. See above for definition of active elements. -.VS The value may have any of the forms acceptable to \fBTk_GetPixels\fR. -.VE This option is typically only available in widgets displaying more than one element at a time (e.g. menus but not buttons). -.LP -.nf -Name: \fBactiveForeground\fR -Class: \fBBackground\fR -Command-Line Switch: \fB\-activeforeground\fR -.fi -.IP +.OP \-activeforeground activeForeground Background Specifies foreground color to use when drawing active elements. See above for definition of active elements. -.LP -.nf -.VS -Name: \fBanchor\fR -Class: \fBAnchor\fR -Command-Line Switch: \fB\-anchor\fR -.fi -.IP +.OP \-anchor anchor Anchor Specifies how the information in a widget (e.g. text or a bitmap) is to be displayed in the widget. Must be one of the values \fBn\fR, \fBne\fR, \fBe\fR, \fBse\fR, \fBs\fR, \fBsw\fR, \fBw\fR, \fBnw\fR, or \fBcenter\fR. For example, \fBnw\fR means display the information such that its top-left corner is at the top-left corner of the widget. -.VE -.LP -.nf -Name: \fBbackground\fR -Class: \fBBackground\fR -Command-Line Switch: \fB\-background or \-bg\fR -.fi -.IP +.OP "\-background or \-bg" background Background Specifies the normal background color to use when displaying the widget. -.LP -.nf -Name: \fBbitmap\fR -.VS -Class: \fBBitmap\fR -Command-Line Switch: \fB\-bitmap\fR -.fi -.IP +.OP \-bitmap bitmap Bitmap Specifies a bitmap to display in the widget, in any of the forms acceptable to \fBTk_GetBitmap\fR. The exact way in which the bitmap is displayed may be affected by @@ -126,129 +74,25 @@ Typically, if this option is specified then it overrides other options that specify a textual value to display in the widget; the \fBbitmap\fR option may be reset to an empty string to re-enable a text display. -.VE -.LP -.nf -Name: \fBborderWidth\fR -Class: \fBBorderWidth\fR -Command-Line Switch: \fB\-borderwidth or \-bd\fR -.fi -.IP +In widgets that support both \fBbitmap\fR and \fBimage\fR options, +\fBimage\fR will usually override \fBbitmap\fR. +.OP "\-borderwidth or \-bd" borderWidth BorderWidth Specifies a non-negative value indicating the width of the 3-D border to draw around the outside of the widget (if such a border is being drawn; the \fBrelief\fR option typically determines this). The value may also be used when drawing 3-D effects in the interior of the widget. -.VS The value may have any of the forms acceptable to \fBTk_GetPixels\fR. -.VE -.LP -.nf -Name: \fBcursor\fR -Class: \fBCursor\fR -Command-Line Switch: \fB\-cursor\fR -.fi -.IP +.OP \-cursor cursor Cursor Specifies the mouse cursor to be used for the widget. The value may have any of the forms acceptable to \fBTk_GetCursor\fR. -.LP -.nf -Name: \fBcursorBackground\fR -Class: \fBForeground\fR -Command-Line Switch: \fB\-cursorbackground\fR -.fi -.IP -Specifies the color to use as background in the area covered by the -insertion cursor. This color will normally override either the normal -background for the widget (or the selection background if the insertion -cursor happens to fall in the selection). -.VS -\fIThis option is obsolete and is gradually being replaced by -the \fBinsertBackground\fR option.\fR -.VE -.LP -.nf -Name: \fBcursorBorderWidth\fR -Class: \fBBorderWidth\fR -Command-Line Switch: \fB\-cursorborderwidth\fR -.fi -.IP -Specifies a non-negative value indicating the width -of the 3-D border to draw around the insertion cursor. -.VS -The value may have any of the forms acceptable to \fBTk_GetPixels\fR. -\fIThis option is obsolete and is gradually being replaced by -the \fBinsertBorderWidth\fR option.\fR -.VE -.LP -.nf -Name: \fBcursorOffTime\fR -Class: \fBOffTime\fR -Command-Line Switch: \fB\-cursorofftime\fR -.fi -.IP -Specifies a non-negative integer value indicating the number of -milliseconds the cursor should remain ``off'' in each blink cycle. -If this option is zero then the cursor doesn't blink: it is on -all the time. -.VS -\fIThis option is obsolete and is gradually being replaced by -the \fBinsertOffTime\fR option.\fR -.VE -.LP -.nf -Name: \fBcursorOnTime\fR -Class: \fBOnTime\fR -Command-Line Switch: \fB\-cursorontime\fR -.fi -.IP -Specifies a non-negative integer value indicating the number of -milliseconds the cursor should remain ``on'' in each blink cycle. -.VS -\fIThis option is obsolete and is gradually being replaced by -the \fBinsertOnTime\fR option.\fR -.VE -.LP -.nf -Name: \fBcursorWidth\fR -Class: \fBCursorWidth\fR -Command-Line Switch: \fB\-cursorwidth\fR -.fi -.IP -Specifies a value indicating the total width of the insertion cursor. -.VS -The value may have any of the forms acceptable to \fBTk_GetPixels\fR. -.VE -If a border has been specified for -the cursor (using the \fBcursorBorderWidth\fR option), the border -will be drawn inside the width specified by the \fBcursorWidth\fR -option. -.VS -\fIThis option is obsolete and is gradually being replaced by -the \fBinsertWidth\fR option.\fR -.VE -.LP -.nf -.VS -Name: \fBdisabledForeground\fR -Class: \fBDisabledForeground\fR -Command-Line Switch: \fB\-disabledforeground\fR -.fi -.IP +.OP \-disabledforeground disabledForeground DisabledForeground Specifies foreground color to use when drawing a disabled element. If the option is specified as an empty string (which is typically the case on monochrome displays), disabled elements are drawn with the -normal fooreground color but they are dimmed by drawing them +normal foreground color but they are dimmed by drawing them with a stippled fill pattern. -.VE -.LP -.nf -.VS -Name: \fBexportSelection\fR -Class: \fBExportSelection\fR -Command-Line Switch: \fB\-exportselection\fR -.fi -.IP +.OP \-exportselection exportSelection ExportSelection Specifies whether or not a selection in the widget should also be the X selection. The value may have any of the forms accepted by \fBTcl_GetBoolean\fR, @@ -258,30 +102,11 @@ the current X selection, selecting outside the widget deselects any widget selection, and the widget will respond to selection retrieval requests when it has a selection. The default is usually for widgets to export selections. -.VE -.LP -.nf -Name: \fBfont\fR -Class: \fBFont\fR -Command-Line Switch: \fB\-font\fR -.fi -.IP +.OP \-font font Font Specifies the font to use when drawing text inside the widget. -.LP -.nf -Name: \fBforeground\fR -Class: \fBForeground\fR -Command-Line Switch: \fB\-foreground or \-fg\fR -.fi -.IP +.OP "\-foreground or \-fg" foreground Foreground Specifies the normal foreground color to use when displaying the widget. -.LP -.nf -Name: \fBgeometry\fR -Class: \fBGeometry\fR -Command-Line Switch: \fB\-geometry\fR -.fi -.IP +.OP \-geometry geometry Geometry Specifies the desired geometry for the widget's window, in the form \fIwidth\fBx\fIheight\fR, where \fIwidth\fR is the desired width of the window and \fIheight\fR is the desired height. The @@ -289,216 +114,124 @@ units for \fIwidth\fR and \fIheight\fR depend on the particular widget. For widgets displaying text the units are usually the size of the characters in the font being displayed; for other widgets the units are usually pixels. -.LP -.nf -.VS -Name: \fBinsertBackground\fR -Class: \fBForeground\fR -Command-Line Switch: \fB\-insertbackground\fR -.fi -.IP +.OP \-highlightbackground highlightBackground HighlightBackground +Specifies the color to display in the traversal highlight region when +the widget does not have the input focus. +.OP \-highlightcolor highlightColor HighlightColor +Specifies the color to use for the traversal highlight rectangle that is +drawn around the widget when it has the input focus. +.OP \-highlightthickness highlightThickness HighlightThickness +Specifies a non-negative value indicating the width of the highlight +rectangle to draw around the outside of the widget when it has the +input focus. +The value may have any of the forms acceptable to \fBTk_GetPixels\fR. +If the value is zero, no focus highlight is drawn around the widget. +.OP \-image image Image +Specifies an image to display in the widget, which must have been +created with the \fBimage create\fR command. +Typically, if the \fBimage\fR option is specified then it overrides other +options that specify a bitmap or textual value to display in the widget; +the \fBimage\fR option may be reset to an empty string to re-enable +a bitmap or text display. +.OP \-insertbackground insertBackground Foreground Specifies the color to use as background in the area covered by the insertion cursor. This color will normally override either the normal background for the widget (or the selection background if the insertion cursor happens to fall in the selection). -.LP -.nf -Name: \fBinsertBorderWidth\fR -Class: \fBBorderWidth\fR -Command-Line Switch: \fB\-insertborderwidth\fR -.fi -.IP +.OP \-insertborderwidth insertBorderWidth BorderWidth Specifies a non-negative value indicating the width of the 3-D border to draw around the insertion cursor. The value may have any of the forms acceptable to \fBTk_GetPixels\fR. -.LP -.nf -Name: \fBinsertOffTime\fR -Class: \fBOffTime\fR -Command-Line Switch: \fB\-insertofftime\fR -.fi -.IP +.OP \-insertofftime insertOffTime OffTime Specifies a non-negative integer value indicating the number of milliseconds the insertion cursor should remain ``off'' in each blink cycle. If this option is zero then the cursor doesn't blink: it is on all the time. -.LP -.nf -Name: \fBinsertOnTime\fR -Class: \fBOnTime\fR -Command-Line Switch: \fB\-insertontime\fR -.fi -.IP +.OP \-insertontime insertOnTime OnTime Specifies a non-negative integer value indicating the number of milliseconds the insertion cursor should remain ``on'' in each blink cycle. -.LP -.nf -Name: \fBinsertWidth\fR -Class: \fBInsertWidth\fR -Command-Line Switch: \fB\-insertwidth\fR -.fi -.IP +.OP \-insertwidth insertWidth InsertWidth Specifies a value indicating the total width of the insertion cursor. The value may have any of the forms acceptable to \fBTk_GetPixels\fR. If a border has been specified for the insertion cursor (using the \fBinsertBorderWidth\fR option), the border will be drawn inside the width specified by the \fBinsertWidth\fR option. -.VE -.LP -.nf -Name: \fBorient\fR -Class: \fBOrient\fR -Command-Line Switch: \fB\-orient\fR -.fi -.IP +.OP \-jump jump Jump +For widgets with a slider that can be dragged to adjust a value, +such as scrollbars, this option determines when +notifications are made about changes in the value. +The option's value must be a boolean of the form accepted by +\fBTcl_GetBoolean\fR. +If the value is false, updates are made continuously as the +slider is dragged. +If the value is true, updates are delayed until the mouse button +is released to end the drag; at that point a single notification +is made (the value ``jumps'' rather than changing smoothly). +.OP \-justify justify Justify +When there are multiple lines of text displayed in a widget, this +option determines how the lines line up with each other. +Must be one of \fBleft\fR, \fBcenter\fR, or \fBright\fR. +\fBLeft\fR means that the lines' left edges all line up, \fBcenter\fR +means that the lines' centers are aligned, and \fBright\fR means +that the lines' right edges line up. +.OP \-orient orient Orient For widgets that can lay themselves out with either a horizontal or vertical orientation, such as scrollbars, this option specifies which orientation should be used. Must be either \fBhorizontal\fR or \fBvertical\fR or an abbreviation of one of these. -.LP -.nf -Name: \fBpadX\fR -Class: \fBPad\fR -Command-Line Switch: \fB\-padx\fR -.fi -.IP +.OP \-padx padX Pad Specifies a non-negative value indicating how much extra space to request for the widget in the X-direction. -.VS The value may have any of the forms acceptable to \fBTk_GetPixels\fR. -.VE When computing how large a window it needs, the widget will add this amount to the width it would normally need (as determined by the width of the things displayed in the widget); if the geometry manager can satisfy this request, the widget will end up with extra internal space to the left and/or right of what it displays inside. -.LP -.nf -Name: \fBpadY\fR -Class: \fBPad\fR -Command-Line Switch: \fB\-pady\fR -.fi -.IP +Most widgets only use this option for padding text: if they are +displaying a bitmap or image, then they usually ignore padding +options. +.OP \-pady padY Pad Specifies a non-negative value indicating how much extra space to request for the widget in the Y-direction. -.VS The value may have any of the forms acceptable to \fBTk_GetPixels\fR. -.VE When computing how large a window it needs, the widget will add this amount to the height it would normally need (as determined by the height of the things displayed in the widget); if the geometry manager can satisfy this request, the widget will end up with extra internal space above and/or below what it displays inside. -.LP -.nf -Name: \fBrelief\fR -Class: \fBRelief\fR -Command-Line Switch: \fB\-relief\fR -.fi -.IP +Most widgets only use this option for padding text: if they are +displaying a bitmap or image, then they usually ignore padding +options. +.OP \-relief relief Relief Specifies the 3-D effect desired for the widget. Acceptable -.VS values are \fBraised\fR, \fBsunken\fR, \fBflat\fR, \fBridge\fR, and \fBgroove\fR. -.VE The value indicates how the interior of the widget should appear relative to its exterior; for example, \fBraised\fR means the interior of the widget should appear to protrude from the screen, relative to the exterior of the widget. -.LP -.nf -Name: \fBrepeatDelay\fR -Class: \fBRepeatDelay\fR -Command-Line Switch: \fB\-repeatdelay\fR -.fi -.IP +.OP \-repeatdelay repeatDelay RepeatDelay Specifies the number of milliseconds a button or key must be held down before it begins to auto-repeat. Used, for example, on the up- and down-arrows in scrollbars. -.LP -.nf -Name: \fBrepeatInterval\fR -Class: \fBRepeatInterval\fR -Command-Line Switch: \fB\-repeatinterval\fR -.fi -.IP +.OP \-repeatinterval repeatInterval RepeatInterval Used in conjunction with \fBrepeatDelay\fR: once auto-repeat begins, this option determines the number of milliseconds between auto-repeats. -.LP -.nf -Name: \fBscrollCommand\fR -Class: \fBScrollCommand\fR -Command-Line Switch: \fB\-scrollcommand\fR -.fi -.IP -Specifies the prefix for a command used to communicate with scrollbar -widgets. When the view in the widget's window changes (or -whenever anything else occurs that could change the display in a -scrollbar, such as a change in the total size of the widget's -contents), the widget will -generate a Tcl command by concatenating the scroll command and four -numbers. The four numbers are, in order: the total size of the -widget's contents, in unspecified units -(``unit'' is a widget-specific term; for widgets -displaying text, the unit is a line); the maximum number of units that -may be displayed at once in the widget's window, given its current size; the -index of the top-most or left-most unit currently visible in the window -(index 0 corresponds to the first unit); and the index of the bottom-most -or right-most unit currently visible in the window. This command is -then passed to the Tcl interpreter for execution. Typically the -\fBscrollCommand\fR option consists of the path name of a scrollbar -widget followed by ``set'', e.g. ``.x.scrollbar set'': this will cause -the scrollbar to be updated whenever the view in the window changes. -If this option is not specified, then no command will be executed. -.IP -.VS -The \fBscrollCommand\fR option is used for widgets that support scrolling -in only one direction. -For widgets that support scrolling in both directions, this -option is replaced with the \fBxScrollCommand\fR and \fByScrollCommand\fR -options. -.VE -.LP -.nf -Name: \fBselectBackground\fR -Class: \fBForeground\fR -Command-Line Switch: \fB\-selectbackground\fR -.fi -.IP +.OP \-selectbackground selectBackground Foreground Specifies the background color to use when displaying selected items. -.LP -.nf -Name: \fBselectBorderWidth\fR -Class: \fBBorderWidth\fR -Command-Line Switch: \fB\-selectborderwidth\fR -.fi -.IP +.OP \-selectborderwidth selectBorderWidth BorderWidth Specifies a non-negative value indicating the width of the 3-D border to draw around selected items. -.VS The value may have any of the forms acceptable to \fBTk_GetPixels\fR. -.VE -.LP -.nf -Name: \fBselectForeground\fR -Class: \fBBackground\fR -Command-Line Switch: \fB\-selectforeground\fR -.fi -.IP +.OP \-selectforeground selectForeground Background Specifies the foreground color to use when displaying selected items. -.LP -.nf -.VS -Name: \fBsetGrid\fR -Class: \fBSetGrid\fR -Command-Line Switch: \fB\-setgrid\fR -.fi -.IP +.OP \-setgrid setGrid SetGrid Specifies a boolean value that determines whether this widget controls the resizing grid for its top-level window. This option is typically used in text widgets, where the information @@ -512,72 +245,88 @@ the window will be displayed to the user in grid units and the window size will be constrained to integral numbers of grid units. See the section GRIDDED GEOMETRY MANAGEMENT in the \fBwm\fR manual entry for more details. -.VE -.LP -.nf -Name: \fBtext\fR -Class: \fBText\fR -Command-Line Switch: \fB\-text\fR -.fi -.IP +.OP \-takefocus takeFocus TakeFocus +Determines whether the window accepts the focus during keyboard +traversal (e.g., Tab and Shift-Tab). +Before setting the focus to a window, the traversal scripts +consult the value of the \fBtakeFocus\fR option. +A value of \fB0\fR means that the window should be skipped entirely +during keyboard traversal. +\fB1\fR means that the window should receive the input +focus as long as it is viewable (it and all of its ancestors are mapped). +An empty value for the option means that the traversal scripts make +the decision about whether or not to focus on the window: the current +algorithm is to skip the window if it is +disabled, if it has no key bindings, or if it is not viewable. +If the value has any other form, then the traversal scripts take +the value, append the name of the window to it (with a separator space), +and evaluate the resulting string as a Tcl script. +The script must return \fB0\fR, \fB1\fR, or an empty string: a +\fB0\fR or \fB1\fR value specifies whether the window will receive +the input focus, and an empty string results in the default decision +described above. +Note: this interpretation of the option is defined entirely by +the Tcl scripts that implement traversal: the widget implementations +ignore the option entirely, so you can change its meaning if you +redefine the keyboard traversal scripts. +.OP \-text text Text Specifies a string to be displayed inside the widget. The way in which the string is displayed depends on the particular widget and may be determined by other options, such as \fBanchor\fR or \fBjustify\fR. -.LP -.nf -.VS -Name: \fBtextVariable\fR -Class: \fBVariable\fR -Command-Line Switch: \fB\-textvariable\fR -.fi -.IP +.OP \-textvariable textVariable Variable Specifies the name of a variable. The value of the variable is a text string to be displayed inside the widget; if the variable value changes then the widget will automatically update itself to reflect the new value. The way in which the string is displayed in the widget depends on the particular widget and may be determined by other options, such as \fBanchor\fR or \fBjustify\fR. -.LP -.nf -Name: \fBunderline\fR -Class: \fBUnderline\fR -Command-Line Switch: \fB\-underline\fR -.fi -.IP +.OP \-troughcolor troughColor Background +Specifies the color to use for the rectangular trough areas +in widgets such as scrollbars and scales. +.OP \-underline underline Underline Specifies the integer index of a character to underline in the widget. -This option is typically used to indicate keyboard traversal characters -in menu buttons and menu entries. 0 corresponds to the first character -of the text displayed in the widget, 1 to the next character, and so -on. -.LP -.nf -Name: \fBxScrollCommand\fR -Class: \fBScrollCommand\fR -Command-Line Switch: \fB\-xscrollcommand\fR -.fi -.IP +This option is used by the default bindings to implement keyboard +traversal for menu buttons and menu entries. +0 corresponds to the first character of the text displayed in the +widget, 1 to the next character, and so on. +.OP \-wraplength wrapLength WrapLength +For widgets that can perform word-wrapping, this option specifies +the maximum line length. +Lines that would exceed this length are wrapped onto the next line, +so that no line is longer than the specified length. +The value may be specified in any of the standard forms for +screen distances. +If this value is less than or equal to 0 then no wrapping is done: lines +will break only at newline characters in the text. +.OP \-xscrollcommand xScrollCommand ScrollCommand Specifies the prefix for a command used to communicate with horizontal -scrollbars. This option is treated in the same way as the -\fBscrollCommand\fR option, except that it is used for horizontal -scrollbars associated with widgets that support both horizontal -and vertical scrolling. -See the description of \fBscrollCommand\fR for complete details -on how this option is used. -.LP -.nf -Name: \fByScrollCommand\fR -Class: \fBScrollCommand\fR -Command-Line Switch: \fB\-yscrollcommand\fR -.fi -.IP +scrollbars. +When the view in the widget's window changes (or +whenever anything else occurs that could change the display in a +scrollbar, such as a change in the total size of the widget's +contents), the widget will +generate a Tcl command by concatenating the scroll command and +two numbers. +Each of the numbers is a fraction between 0 and 1, which indicates +a position in the document. 0 indicates the beginning of the document, +1 indicates the end, .333 indicates a position one third the way through +the document, and so on. +The first fraction indicates the first information in the document +that is visible in the window, and the second fraction indicates +the information just after the last portion that is visible. +The command is +then passed to the Tcl interpreter for execution. Typically the +\fBxScrollCommand\fR option consists of the path name of a scrollbar +widget followed by ``set'', e.g. ``.x.scrollbar set'': this will cause +the scrollbar to be updated whenever the view in the window changes. +If this option is not specified, then no command will be executed. +.OP \-yscrollcommand yScrollCommand ScrollCommand Specifies the prefix for a command used to communicate with vertical scrollbars. This option is treated in the same way as the -\fBscrollCommand\fR option, except that it is used for vertical -scrollbars associated with widgets that support both horizontal -and vertical scrolling. -See the description of \fBscrollCommand\fR for complete details +\fBxScrollCommand\fR option, except that it is used for vertical +scrollbars and is provided by widgets that support vertical scrolling. +See the description of \fBxScrollCommand\fR for details on how this option is used. -.VE .SH KEYWORDS class, name, standard option, switch diff --git a/tk3.6/doc/pack-old.n b/tk4.2/doc/pack-old.n similarity index 80% rename from tk3.6/doc/pack-old.n rename to tk4.2/doc/pack-old.n index b724640..a0638b6 100644 --- a/tk3.6/doc/pack-old.n +++ b/tk4.2/doc/pack-old.n @@ -1,27 +1,14 @@ '\" -'\" Copyright (c) 1990-1992 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1990-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) pack-old.n 1.12 96/03/26 18:25:44 '\" -'\" $Header: /user6/ouster/wish/man/RCS/pack-old.n,v 1.4 93/09/12 21:43:19 ouster Exp $ SPRITE (Berkeley) -'/" .so man.macros -.HS pack-old tk +.TH pack-old n 4.0 Tk "Tk Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -33,15 +20,13 @@ pack \- Obsolete syntax for packer geometry manager .sp \fBpack before \fIsibling \fIwindow options\fR ?\fIwindow options \fR...? .sp -\fBpack info \fIparent\fR -.sp \fBpack unpack \fIwindow\fR .BE .SH DESCRIPTION .PP \fINote: this manual entry describes the syntax for the \fBpack\fI -command as it before Tk version 3.3. +command as it existed before Tk version 3.3. Although this syntax continues to be supported for backward compatibility, it is obsolete and should not be used anymore. At some point in the future it may cease to be supported.\fR @@ -68,12 +53,10 @@ its parent, it is removed from its current position in the packing order and repositioned as indicated by the command. All of these commands return an empty string as result. .PP -.VS The \fBunpack\fR form of the \fBpack\fR command removes \fIwindow\fR from the packing order of its parent and unmaps it. After the execution of this command the packer will no longer manage \fIwindow\fR's geometry. -.VE .PP The placement of each child is actually a four-step process; the \fIoptions\fR argument following each \fIwindow\fR consists of @@ -133,7 +116,7 @@ other children, and may be zero. If several windows have all specified \fBexpand\fR then the extra width will be divided equally among all the \fBleft\fR and \fBright\fR windows that specified \fBexpand\fR and the extra height will be divided equally among all the \fBtop\fR and -\fBbottom\fR windows that specified \fBexpand. +\fBbottom\fR windows that specified \fBexpand\fR. .LP If the desired width or height for a parcel is larger than the corresponding dimension of the cavity, then the cavity's dimension is used instead. @@ -199,17 +182,6 @@ the parcel. Position the window with its upper-left corner at the upper-left corner of the parcel. .PP -The \fBpack info\fR command may be used to retrieve information about -the packing order for a parent. It returns a list in the form -.DS C -\fIwindow options window options ...\fR -.DE -Each \fIwindow\fR is a name of a window packed in \fIparent\fR, -and the following \fIoptions\fR describes all of the options for that -window, just as they would be typed to \fBpack append\fR. -The order of the list is the same as the packing order for -\fIparent\fR. -.PP The packer manages the mapped/unmapped state of all the packed children windows. It automatically maps the windows when it packs them, and it unmaps any windows for which there was no space left diff --git a/tk3.6/doc/pack.n b/tk4.2/doc/pack.n similarity index 89% rename from tk3.6/doc/pack.n rename to tk4.2/doc/pack.n index c498305..580f252 100644 --- a/tk3.6/doc/pack.n +++ b/tk4.2/doc/pack.n @@ -1,27 +1,14 @@ '\" -'\" Copyright (c) 1990-1992 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1990-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) pack.n 1.19 96/08/27 13:21:48 '\" -'\" $Header: /user6/ouster/wish/man/RCS/pack.n,v 1.11 93/09/12 21:43:11 ouster Exp $ SPRITE (Berkeley) -'/" .so man.macros -.HS pack tk +.TH pack n 4.0 Tk "Tk Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -143,13 +130,12 @@ Removes each of the \fIslave\fRs from the packing order for its master and unmaps their windows. The slaves will no longer be managed by the packer. .TP -\fBpack newinfo \fIslave\fR +\fBpack info \fIslave\fR Returns a list whose elements are the current configuration state of the slave given by \fIslave\fR in the same option-value form that might be specified to \fBpack configure\fR. The first two elements of the list are ``\fB\-in \fImaster\fR'' where \fImaster\fR is the slave's master. -Starting with Tk 4.0 this option will be renamed "pack info". .TP \fBpack propagate \fImaster\fR ?\fIboolean\fR? If \fIboolean\fR has a true boolean value such as \fB1\fR or \fBon\fR diff --git a/tk4.2/doc/palette.n b/tk4.2/doc/palette.n new file mode 100644 index 0000000..7a54eb9 --- /dev/null +++ b/tk4.2/doc/palette.n @@ -0,0 +1,73 @@ +'\" +'\" Copyright (c) 1995-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) palette.n 1.5 96/03/26 18:26:11 +'\" +.so man.macros +.TH tk_setPalette n 4.0 Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +tk_setPalette, tk_bisque \- Modify the Tk color palette +.SH SYNOPSIS +\fBtk_setPalette \fIbackground\fR +.sp +\fBtk_setPalette \fIname value \fR?\fIname value ...\fR? +.sp +\fBtk_bisque\fR +.BE + +.SH DESCRIPTION +.PP +The \fBtk_setPalette\fR procedure changes the color scheme for Tk. +It does this by modifying the colors of existing widgets and by changing +the option database so that future widgets will use the new color scheme. +If \fBtk_setPalette\fR is invoked with a single argument, the +argument is the name of a color to use as the normal background +color; \fBtk_setPalette\fR will compute a complete color palette +from this background color. +Alternatively, the arguments to \fBtk_setPalette\fR may consist of any number +of \fIname\fR\-\fIvalue\fR pairs, where the first argument of the pair +is the name of an option in the Tk option database and the second +argument is the new value to use for that option. The following +database names are currently supported: +.DS L +.ta 4c 8c +\fBactiveBackground foreground selectColor +activeForeground highlightBackground selectBackground +background highlightColor selectForeground +disabledForeground insertBackground troughColor\fR +.DE +\fBtk_setPalette\fR tries to compute reasonable defaults for any +options that you don't specify. You can specify options other +than the above ones and Tk will change those options on widgets as +well. This feature may be useful if you are using custom widgets with +additional color options. +.PP +Once it has computed the new value to use for each of the color options, +\fBtk_setPalette\fR scans the widget hierarchy to modify the options +of all existing widgets. For each widget, it checks to see if any +of the above options is defined for the widget. If so, and if the +option's current value is the default, then the value is changed; if +the option has a value other than the default, \fBtk_setPalette\fR +will not change it. The default for an option is the one provided by +the widget (\fB[lindex [$w configure $option] 3]\fR) unless +\fBtk_setPalette\fR has been run previously, in which case it is the +value specified in the previous invocation of \fBtk_setPalette\fR. +.PP +After modifying all the widgets in the application, \fBtk_setPalette\fR +adds options to the option database to change the defaults for +widgets created in the future. The new options are added at +priority \fBwidgetDefault\fR, so they will be overridden by options +from the .Xdefaults file or options specified on the command-line +that creates a widget. +.PP +The procedure \fBtk_bisque\fR is provided for backward compatibility: +it restores the application's colors to the light brown (``bisque'') +color scheme used in Tk 3.6 and earlier versions. + +.SH KEYWORDS +bisque, color, palette diff --git a/tk4.2/doc/photo.n b/tk4.2/doc/photo.n new file mode 100644 index 0000000..f1cb80c --- /dev/null +++ b/tk4.2/doc/photo.n @@ -0,0 +1,344 @@ +'\" +'\" Copyright (c) 1994 The Australian National University +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" Author: Paul Mackerras (paulus@cs.anu.edu.au), +'\" Department of Computer Science, +'\" Australian National University. +'\" +'\" "@(#) photo.n 1.10 96/03/26 18:26:22" +'\" +.so man.macros +.TH photo n 4.0 Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +photo \- Full-color images +.SH SYNOPSIS +\fBimage create photo \fR?\fIname\fR? ?\fIoptions\fR? +.BE + +.SH DESCRIPTION +.PP +A photo is an image whose pixels can display any color or be +transparent. A photo image is stored internally in full color (24 +bits per pixel), and is displayed using dithering if necessary. Image +data for a photo image can be obtained from a file or a string, or it +can be supplied from +C code through a procedural interface. At present, only GIF and PPM/PGM +formats are supported, but an interface exists to allow additional +image file formats to be added easily. A photo image is transparent +in regions where no image data has been supplied. + +.SH "CREATING PHOTOS" +.PP +Like all images, photos are created using the \fBimage create\fR +command. +Photos support the following \fIoptions\fR: +.TP +\fB\-data \fIstring\fR +Specifies the contents of the image as a string. The format of the +string must be one of those for which there is an image file format +handler that will accept string data. If both the \fB\-data\fR +and \fB\-file\fR options are specified, the \fB\-file\fR option takes +precedence. +.TP +\fB\-format \fIformat-name\fR +Specifies the name of the file format for the data specified with the +\fB\-data\fR or \fB\-file\fR option. +.TP +\fB\-file \fIname\fR +\fIname\fR gives the name of a file that is to be read to supply data +for the photo image. The file format must be one of those for which +there is an image file format handler that can read data from a file. +.TP +\fB\-gamma \fIvalue\fR +Specifies that the colors allocated for displaying this image in a +window should be corrected for a non-linear display with the specified +gamma exponent value. (The intensity produced by most +CRT displays is a power function of the input value, to a good +approximation; gamma is the exponent and is typically around 2). +The value specified must be greater than zero. The default +value is one (no correction). In general, values greater than one +will make the image lighter, and values less than one will make it +darker. +.TP +\fB\-height \fInumber\fR +Specifies the height of the image, in pixels. This option is useful +primarily in situations where the user wishes to build up the contents +of the image piece by piece. A value of zero (the default) allows the +image to expand or shrink vertically to fit the data stored in it. +.TP +\fB\-palette \fIpalette-spec\fR +Specifies the resolution of the color cube to be allocated for +displaying this image, and thus the number of colors used from the +colormaps of the windows where it is displayed. The +\fIpalette-spec\fR string may be either a single decimal number, +specifying the number of shades of gray to use, or three decimal +numbers separated by slashes (/), specifying the number of shades of +red, green and blue to use, respectively. If the first form (a single +number) is used, the image will be displayed in monochrome (i.e., +grayscale). +.TP +\fB\-width \fInumber\fR +Specifies the width of the image, in pixels. This option is useful +primarily in situations where the user wishes to build up the contents +of the image piece by piece. A value of zero (the default) allows the +image to expand or shrink horizontally to fit the data stored in it. + +.SH "IMAGE COMMAND" +.PP +When a photo image is created, Tk also creates a new command +whose name is the same as the image. +This command may be used to invoke various operations +on the image. +It has the following general form: +.CS +\fIimageName option \fR?\fIarg arg ...\fR? +.CE +\fIOption\fR and the \fIarg\fRs +determine the exact behavior of the command. +.PP +Those options that write data to the image generally expand the size +of the image, if necessary, to accommodate the data written to the +image, unless the user has specified non-zero values for the +\fB\-width\fR and/or \fB\-height\fR configuration options, in which +case the width and/or height, respectively, of the image will not be +changed. +.PP +The following commands are possible for photo images: +.TP +\fIimageName \fBblank\fR +Blank the image; that is, set the entire image to have no data, so it +will be displayed as transparent, and the background of whatever +window it is displayed in will show through. +.TP +\fIimageName \fBcget\fR \fIoption\fR +Returns the current value of the configuration option given +by \fIoption\fR. +\fIOption\fR may have any of the values accepted by the +\fBimage create photo\fR command. +.TP +\fIimageName \fBconfigure\fR ?\fIoption\fR? ?\fIvalue option value ...\fR? +Query or modify the configuration options for the image. +If no \fIoption\fR is specified, returns a list describing all of +the available options for \fIimageName\fR (see \fBTk_ConfigureInfo\fR for +information on the format of this list). If \fIoption\fR is specified +with no \fIvalue\fR, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no \fIoption\fR is specified). If +one or more \fIoption\-value\fR pairs are specified, then the command +modifies the given option(s) to have the given value(s); in +this case the command returns an empty string. +\fIOption\fR may have any of the values accepted by the +\fBimage create photo\fR command. +.TP +\fIimageName \fBcopy\fR \fIsourceImage\fR ?\fIoption value(s) ...\fR? +Copies a region from the image called \fIsourceImage\fR (which must +be a photo image) to the image called \fIimageName\fR, possibly with +pixel zooming and/or subsampling. If no options are specified, this +command copies the whole of \fIsourceImage\fR into \fIimageName\fR, +starting at coordinates (0,0) in \fIimageName\fR. The following +options may be specified: +.RS +.TP +\fB\-from \fIx1 y1 x2 y2\fR +Specifies a rectangular sub-region of the source image to be copied. +(\fIx1,y1\fR) and (\fIx2,y2\fR) specify diagonally opposite corners of +the rectangle. If \fIx2\fR and \fIy2\fR are not specified, the +default value is the bottom-right corner of the source image. The +pixels copied will include the left and top edges of the specified +rectangle but not the bottom or right edges. If the \fB\-from\fR +option is not given, the default is the whole source image. +.TP +\fB\-to \fIx1 y1 x2 y2\fR +Specifies a rectangular sub-region of the destination image to be +affected. (\fIx1,y1\fR) and (\fIx2,y2\fR) specify diagonally opposite +corners of the rectangle. If \fIx2\fR and \fIy2\fR are not specified, +the default value is (\fIx1,y1\fR) plus the size of the source +region (after subsampling and zooming, if specified). If \fIx2\fR and +\fIy2\fR are specified, the source region will be replicated if +necessary to fill the destination region in a tiled fashion. +.TP +\fB\-shrink\fR +Specifies that the size of the destination image should be reduced, if +necessary, so that the region being copied into is at the bottom-right +corner of the image. This option will not affect the width or height +of the image if the user has specified a non-zero value for the +\fB\-width\fR or \fB\-height\fR configuration option, respectively. +.TP +\fB\-zoom \fIx y\fR +Specifies that the source region should be magnified by a factor of +\fIx\fR in the X direction and \fIy\fR in the Y direction. If \fIy\fR +is not given, the default value is the same as \fIx\fR. With this +option, each pixel in the source image will be expanded into a block +of \fIx\fR x \fIy\fR pixels in the destination image, all the same +color. \fIx\fR and \fIy\fR must be greater than 0. +.TP +\fB\-subsample \fIx y\fR +Specifies that the source image should be reduced in size by using +only every \fIx\fRth pixel in the X direction and \fIy\fRth pixel in +the Y direction. Negative values will cause the image to be flipped +about the Y or X axes, respectively. If \fIy\fR is not given, the +default value is the same as \fIx\fR. +.RE +.TP +\fIimageName \fBget\fR \fIx y\fR +Returns the color of the pixel at coordinates (\fIx\fR,\fIy\fR) in the +image as a list of three integers between 0 and 255, representing the +red, green and blue components respectively. +.TP +\fIimageName \fBput \fIdata\fR ?\fB\-to\fI x1 y1 x2 y2\fR? +Sets pixels in \fIimageName\fR to the colors specified in \fIdata\fR. +\fIdata\fR is used to form a two-dimensional array of pixels that are +then copied into the \fIimageName\fR. \fIdata\fR is structured as a +list of horizontal rows, from top to bottom, each of which is a list +of colors, listed from left to right. Each color may be specified by name +(e.g., blue) or in hexadecimal form (e.g., #2376af). The +\fB\-to\fR option can be used to specify the area of \fIimageName\fR to be +affected. If only \fIx1\fR and \fIy1\fR are given, the area affected +has its top-left corner at (\fIx1,y1\fR) and is the same size as the +array given in \fIdata\fR. If all four coordinates are given, they +specify diagonally opposite corners of the affected rectangle, and the +array given in \fIdata\fR will be replicated as necessary in the X and +Y directions to fill the rectangle. +.TP +\fIimageName \fBread\fR \fIfilename\fR ?\fIoption value(s) ...\fR? +Reads image data from the file named \fIfilename\fR into the image. +This command first searches the list of +image file format handlers for a handler that can interpret the data +in \fIfilename\fR, and then reads the image in \fIfilename\fR into +\fIimageName\fR (the destination image). The following options may be +specified: +.RS +.TP +\fB\-format \fIformat-name\fR +Specifies the format of the image data in \fIfilename\fR. +Specifically, only image file format handlers whose names begin with +\fIformat-name\fR will be used while searching for an image data +format handler to read the data. +.TP +\fB\-from \fIx1 y1 x2 y2\fR +Specifies a rectangular sub-region of the image file data to be copied +to the destination image. If only \fIx1\fR and \fIy1\fR are +specified, the region extends from (\fIx1,y1\fR) to the bottom-right +corner of the image in the image file. If all four coordinates are +specified, they specify diagonally opposite corners or the region. +The default, if this option is not specified, is the whole of the +image in the image file. +.TP +\fB\-shrink\fR +If this option, the size of \fIimageName\fR will be reduced, if +necessary, so that the region into which the image file data are read +is at the bottom-right corner of the \fIimageName\fR. This option +will not affect the width or height of the image if the user has +specified a non-zero value for the \fB\-width\fR or \fB\-height\fR +configuration option, respectively. +.TP +\fB\-to \fIx y\fR +Specifies the coordinates of the top-left corner of the region of +\fIimageName\fR into which data from \fIfilename\fR are to be read. +The default is (0,0). +.RE +.TP +\fIimageName \fBredither\fR +The dithering algorithm used in displaying photo images propagates +quantization errors from one pixel to its neighbors. +If the image data for \fIimageName\fR is supplied in pieces, the +dithered image may not be exactly correct. Normally the difference is +not noticeable, but if it is a problem, this command can be used to +recalculate the dithered image in each window where the image is +displayed. +.TP +\fIimageName \fBwrite \fIfilename\fR ?\fIoption value(s) ...\fR? +Writes image data from \fIimageName\fR to a file named \fIfilename\fR. +The following options may be specified: +.RS +.TP +\fB\-format\fI format-name\fR +Specifies the name of the image file format handler to be used to +write the data to the file. Specifically, this subcommand searches +for the first handler whose name matches a initial substring of +\fIformat-name\fR and which has the capability to write an image +file. If this option is not given, this subcommand uses the first +handler that has the capability to write an image file. +.TP +\fB\-from \fIx1 y1 x2 y2\fR +Specifies a rectangular region of \fIimageName\fR to be written to the +image file. If only \fIx1\fR and \fIy1\fR are specified, the region +extends from \fI(x1,y1)\fR to the bottom-right corner of +\fIimageName\fR. If all four coordinates are given, they specify +diagonally opposite corners of the rectangular region. The default, +if this option is not given, is the whole image. +.RE +.SH "IMAGE FORMATS" +.PP +The photo image code is structured to allow handlers for additional +image file formats to be added easily. The photo image code maintains +a list of these handlers. Handlers are added to the list by +registering them with a call to \fBTk_CreatePhotoImageFormat\fR. The +standard Tk distribution comes with handlers for PPM/PGM and GIF formats, +which are automatically registered on initialization. +.PP +When reading an image file or processing +string data specified with the \fB\-data\fR configuration option, the +photo image code invokes each handler in turn until one is +found that claims to be able to read the data in the file or string. +Usually this will find the correct handler, but if it doesn't, the +user may give a format name with the \fB\-format\fR option to specify +which handler to use. In fact the photo image code will try those +handlers whose names begin with the string specified for the +\fB\-format\fR option (the comparison is case-insensitive). For +example, if the user specifies \fB\-format gif\fR, then a handler +named GIF87 or GIF89 may be invoked, but a handler +named JPEG may not (assuming that such handlers had been +registered). +.PP +When writing image data to a file, the processing of the +\fB\-format\fR option is slightly different: the string value given +for the \fB\-format\fR option must begin with the complete name of the +requested handler, and may contain additional information following +that, which the handler can use, for example, to specify which variant +to use of the formats supported by the handler. + +.SH "COLOR ALLOCATION" +.PP +When a photo image is displayed in a window, the photo image code +allocates colors to use to display the image and dithers the image, if +necessary, to display a reasonable approximation to the image using +the colors that are available. The colors are allocated as a color +cube, that is, the number of colors allocated is the product of the +number of shades of red, green and blue. +.PP +Normally, the number of +colors allocated is chosen based on the depth of the window. For +example, in an 8-bit PseudoColor window, the photo image code will +attempt to allocate seven shades of red, seven shades of green and +four shades of blue, for a total of 198 colors. In a 1-bit StaticGray +(monochrome) window, it will allocate two colors, black and white. In +a 24-bit DirectColor or TrueColor window, it will allocate 256 shades +each of red, green and blue. Fortunately, because of the way that +pixel values can be combined in DirectColor and TrueColor windows, +this only requires 256 colors to be allocated. If not all of the +colors can be allocated, the photo image code reduces the number of +shades of each primary color and tries again. +.PP +The user can exercise some control over the number of colors that a +photo image uses with the \fB\-palette\fR configuration option. If +this option is used, it specifies the maximum number of shades of +each primary color to try to allocate. It can also be used to force +the image to be displayed in shades of gray, even on a color display, +by giving a single number rather than three numbers separated by +slashes. + +.SH CREDITS +.PP +The photo image type was designed and implemented by Paul Mackerras, +based on his earlier photo widget and some suggestions from +John Ousterhout. + +.SH KEYWORDS +photo, image, color diff --git a/tk3.6/doc/place.n b/tk4.2/doc/place.n similarity index 89% rename from tk3.6/doc/place.n rename to tk4.2/doc/place.n index aa2c011..6084118 100644 --- a/tk3.6/doc/place.n +++ b/tk4.2/doc/place.n @@ -1,32 +1,18 @@ '\" '\" Copyright (c) 1992 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) place.n 1.13 96/08/27 13:21:49 '\" -'\" $Header: /user6/ouster/wish/man/RCS/place.n,v 1.4 93/04/01 09:52:51 ouster Exp $ SPRITE (Berkeley) -'/" .so man.macros -.HS place tk +.TH place n "" Tk "Tk Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME place \- Geometry manager for fixed or rubber-sheet placement -.VS .SH SYNOPSIS \fBplace \fIwindow option value \fR?\fIoption value ...\fR? .sp @@ -37,8 +23,6 @@ place \- Geometry manager for fixed or rubber-sheet placement \fBplace info \fIwindow\fR .sp \fBplace slaves \fIwindow\fR -.VS -.VE .BE .SH DESCRIPTION @@ -92,6 +76,10 @@ In this case the location is specified in a relative fashion as a floating-point number: 0.0 corresponds to the left edge of the master and 1.0 corresponds to the right edge of the master. \fILocation\fR need not be in the range 0.0\-1.0. +If both \fB\-x\fR and \fB\-relx\fR are specified for a slave +then their values are summed. For example, \fB\-relx 0.5 \-x \-2\fR +positions the left edge of the slave 2 pixels to the left of the +center of its master. .TP \fB\-y \fIlocation\fR \fILocation\fR specifies the y-coordinate within the master window @@ -107,6 +95,10 @@ In this case the value is specified in a relative fashion as a floating-point number: 0.0 corresponds to the top edge of the master and 1.0 corresponds to the bottom edge of the master. \fILocation\fR need not be in the range 0.0\-1.0. +If both \fB\-y\fR and \fB\-rely\fR are specified for a slave +then their values are summed. For example, \fB\-rely 0.5 \-x 3\fR +positions the top edge of the slave 3 pixels below the +center of its master. .TP \fB\-anchor \fIwhere\fR \fIWhere\fR specifies which point of \fIwindow\fR is to be positioned @@ -134,6 +126,9 @@ In this case the width is specified as a floating-point number relative to the width of the master: 0.5 means \fIwindow\fR will be half as wide as the master, 1.0 means \fIwindow\fR will have the same width as the master, and so on. +If both \fB\-width\fR and \fB\-relwidth\fR are specified for a slave, +their values are summed. For example, \fB\-relwidth 1.0 \-width 5\fR +makes the slave 5 pixels wider than the master. .TP \fB\-height \fIsize\fR \fISize\fR specifies the height for \fIwindow\fR in screen units @@ -150,6 +145,9 @@ In this case the height is specified as a floating-point number relative to the height of the master: 0.5 means \fIwindow\fR will be half as high as the master, 1.0 means \fIwindow\fR will have the same height as the master, and so on. +If both \fB\-height\fR and \fB\-relheight\fR are specified for a slave, +their values are summed. For example, \fB\-relheight 1.0 \-height \-2\fR +makes the slave 2 pixels shorter than the master. .TP \fB\-bordermode \fImode\fR \fIMode\fR determines the degree to which borders within the @@ -176,8 +174,6 @@ two different options, such as \fB\-x\fR and \fB\-relx\fR, then the most recent option is used and the older one is ignored. .PP The \fBplace slaves\fR command returns a list of all the slave -.VS -.VE windows for which \fIwindow\fR is the master. If there are no slaves for \fIwindow\fR then an empty string is returned. @@ -224,9 +220,9 @@ parent is to tie two siblings together. For example, the placer can be used to force a window always to be positioned centered just below one of its siblings by specifying the configuration -.DS C +.CS \fB\-in \fIsibling\fB \-relx 0.5 \-rely 1.0 \-anchor n \-bordermode outside\fR -.DE +.CE Whenever the sibling is repositioned in the future, the slave will be repositioned as well. .PP @@ -239,4 +235,3 @@ frames and canvases that provide configuration options for this purpose. .SH KEYWORDS geometry manager, height, location, master, place, rubber sheet, slave, width -.VE diff --git a/tk4.2/doc/popup.n b/tk4.2/doc/popup.n new file mode 100644 index 0000000..7728e6c --- /dev/null +++ b/tk4.2/doc/popup.n @@ -0,0 +1,33 @@ +'\" +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) popup.n 1.5 96/03/26 18:26:45 +'\" +.so man.macros +.TH tk_popup n 4.0 Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +tk_popup \- Post a popup menu +.SH SYNOPSIS +\fBtk_popup \fImenu x y \fR?\fIentry\fR? +.BE + +.SH DESCRIPTION +.PP +This procedure posts a menu at a given position on the screen and +configures Tk so that the menu and its cascaded children can be +traversed with the mouse or the keyboard. +\fIMenu\fR is the name of a menu widget and \fIx\fR and \fIy\fR +are the root coordinates at which to display the menu. +If \fIentry\fR is omitted or an empty string, the +menu's upper left corner is positioned at the given point. +Otherwise \fIentry\fR gives the index of an entry in \fImenu\fR and +the menu will be positioned so that the entry is positioned over +the given point. + +.SH KEYWORDS +menu, popup diff --git a/tk4.2/doc/radiobutton.n b/tk4.2/doc/radiobutton.n new file mode 100644 index 0000000..f284075 --- /dev/null +++ b/tk4.2/doc/radiobutton.n @@ -0,0 +1,216 @@ +'\" +'\" Copyright (c) 1990-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) radiobutton.n 1.39 96/08/27 13:21:49 +'\" +.so man.macros +.TH radiobutton n 4.0 Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +radiobutton \- Create and manipulate radiobutton widgets +.SH SYNOPSIS +\fBradiobutton\fI \fIpathName \fR?\fIoptions\fR? +.SO +\-activebackground \-cursor \-highlightthickness \-takefocus +\-activeforeground \-disabledforeground \-image \-text +\-anchor \-font \-justify \-textvariable +\-background \-foreground \-padx \-underline +\-bitmap \-highlightbackground \-pady \-wraplength +\-borderwidth \-highlightcolor \-relief +.SE +.SH "WIDGET-SPECIFIC OPTIONS" +.OP \-command command Command +Specifies a Tcl command to associate with the button. This command +is typically invoked when mouse button 1 is released over the button +window. The button's global variable (\fB\-variable\fR option) will +be updated before the command is invoked. +.OP \-height height Height +Specifies a desired height for the button. +If an image or bitmap is being displayed in the button then the value is in +screen units (i.e. any of the forms acceptable to \fBTk_GetPixels\fR); +for text it is in lines of text. +If this option isn't specified, the button's desired height is computed +from the size of the image or bitmap or text being displayed in it. +.OP \-indicatoron indicatorOn IndicatorOn +Specifies whether or not the indicator should be drawn. Must be a +proper boolean value. If false, the \fBrelief\fR option is +ignored and the widget's relief is always sunken if the widget is +selected and raised otherwise. +.OP \-selectcolor selectColor Background +Specifies a background color to use when the button is selected. +If \fBindicatorOn\fR is true, the color applicies to the indicator. +If \fBindicatorOn\fR is false, this color is used as the background +for the entire widget, in place of \fBbackground\fR or \fBactiveBackground\fR, +whenever the widget is selected. +If specified as an empty string, no special color is used for +displaying when the widget is selected. +.OP \-selectimage selectImage SelectImage +Specifies an image to display (in place of the \fBimage\fR option) +when the radiobutton is selected. +This option is ignored unless the \fBimage\fR option has been +specified. +.OP \-state state State +Specifies one of three states for the radiobutton: \fBnormal\fR, \fBactive\fR, +or \fBdisabled\fR. In normal state the radiobutton is displayed using the +\fBforeground\fR and \fBbackground\fR options. The active state is +typically used when the pointer is over the radiobutton. In active state +the radiobutton is displayed using the \fBactiveForeground\fR and +\fBactiveBackground\fR options. Disabled state means that the radiobutton +should be insensitive: the default bindings will refuse to activate +the widget and will ignore mouse button presses. +In this state the \fBdisabledForeground\fR and +\fBbackground\fR options determine how the radiobutton is displayed. +.OP \-value value Value +Specifies value to store in the button's associated variable whenever +this button is selected. +.OP \-variable variable Variable +Specifies name of global variable to set whenever this button is +selected. Changes in this variable also cause the button to select +or deselect itself. +Defaults to the value \fBselectedButton\fR. +.OP \-width width Width +Specifies a desired width for the button. +If an image or bitmap is being displayed in the button, the value is in +screen units (i.e. any of the forms acceptable to \fBTk_GetPixels\fR); +for text it is in characters. +If this option isn't specified, the button's desired width is computed +from the size of the image or bitmap or text being displayed in it. +.BE + +.SH DESCRIPTION +.PP +The \fBradiobutton\fR command creates a new window (given by the +\fIpathName\fR argument) and makes it into a radiobutton widget. +Additional +options, described above, may be specified on the command line +or in the option database +to configure aspects of the radiobutton such as its colors, font, +text, and initial relief. The \fBradiobutton\fR command returns its +\fIpathName\fR argument. At the time this command is invoked, +there must not exist a window named \fIpathName\fR, but +\fIpathName\fR's parent must exist. +.PP +A radiobutton is a widget that displays a textual string, bitmap or image +and a diamond called an \fIindicator\fR. +If text is displayed, it must all be in a single font, but it +can occupy multiple lines on the screen (if it contains newlines +or if wrapping occurs because of the \fBwrapLength\fR option) and +one of the characters may optionally be underlined using the +\fBunderline\fR option. A radiobutton has +all of the behavior of a simple button: it can display itself in either +of three different ways, according to the \fBstate\fR option; +it can be made to appear +raised, sunken, or flat; it can be made to flash; and it invokes +a Tcl command whenever mouse button 1 is clicked over the +check button. +.PP +In addition, radiobuttons can be \fIselected\fR. +If a radiobutton is selected, the indicator is normally +drawn with a sunken relief and a special color, and +a Tcl variable associated with the radiobutton is set to a particular +value. +If the radiobutton is not selected, the indicator is drawn with a +raised relief and no special color. +Typically, several radiobuttons share a single variable and the +value of the variable indicates which radiobutton is to be selected. +When a radiobutton is selected it sets the value of the variable to +indicate that fact; each radiobutton also monitors the value of +the variable and automatically selects and deselects itself when the +variable's value changes. +By default the variable \fBselectedButton\fR +is used; its contents give the name of the button that is +selected, or the empty string if no button associated with that +variable is selected. +The name of the variable for a radiobutton, +plus the variable to be stored into it, may be modified with options +on the command line or in the option database. +Configuration options may also be used to modify the way the +indicator is displayed (or whether it is displayed at all). +By default a radiobutton is configured to select itself on button clicks. + +.SH "WIDGET COMMAND" +.PP +The \fBradiobutton\fR command creates a new Tcl command whose +name is \fIpathName\fR. This +command may be used to invoke various +operations on the widget. It has the following general form: +.CS +\fIpathName option \fR?\fIarg arg ...\fR? +.CE +\fIOption\fR and the \fIarg\fRs +determine the exact behavior of the command. The following +commands are possible for radiobutton widgets: +.TP +\fIpathName \fBcget\fR \fIoption\fR +Returns the current value of the configuration option given +by \fIoption\fR. +\fIOption\fR may have any of the values accepted by the \fBradiobutton\fR +command. +.TP +\fIpathName \fBconfigure\fR ?\fIoption\fR? ?\fIvalue option value ...\fR? +Query or modify the configuration options of the widget. +If no \fIoption\fR is specified, returns a list describing all of +the available options for \fIpathName\fR (see \fBTk_ConfigureInfo\fR for +information on the format of this list). If \fIoption\fR is specified +with no \fIvalue\fR, the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no \fIoption\fR is specified). If +one or more \fIoption\-value\fR pairs are specified, the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +\fIOption\fR may have any of the values accepted by the \fBradiobutton\fR +command. +.TP +\fIpathName \fBdeselect\fR +Deselects the radiobutton and sets the associated variable to an +empty string. +If this radiobutton was not currently selected, the command has +no effect. +.TP +\fIpathName \fBflash\fR +Flashes the radiobutton. This is accomplished by redisplaying the radiobutton +several times, alternating between active and normal colors. At +the end of the flash the radiobutton is left in the same normal/active +state as when the command was invoked. +This command is ignored if the radiobutton's state is \fBdisabled\fR. +.TP +\fIpathName \fBinvoke\fR +Does just what would have happened if the user invoked the radiobutton +with the mouse: selects the button and invokes +its associated Tcl command, if there is one. +The return value is the return value from the Tcl command, or an +empty string if there is no command associated with the radiobutton. +This command is ignored if the radiobutton's state is \fBdisabled\fR. +.TP +\fIpathName \fBselect\fR +Selects the radiobutton and sets the associated variable to the +value corresponding to this widget. + +.SH BINDINGS +.PP +Tk automatically creates class bindings for radiobuttons that give them +the following default behavior: +.IP [1] +The radiobutton activates whenever the mouse passes over it and deactivates +whenever the mouse leaves the radiobutton. +.IP [2] +When mouse button 1 is pressed over a radiobutton it is invoked (it +becomes selected and the command associated with the button is +invoked, if there is one). +.IP [3] +When a radiobutton has the input focus, the space key causes the radiobutton +to be invoked. +.PP +If the radiobutton's state is \fBdisabled\fR then none of the above +actions occur: the radiobutton is completely non-responsive. +.PP +The behavior of radiobuttons can be changed by defining new bindings for +individual widgets or by redefining the class bindings. + +.SH KEYWORDS +radiobutton, widget diff --git a/tk4.2/doc/raise.n b/tk4.2/doc/raise.n new file mode 100644 index 0000000..397f773 --- /dev/null +++ b/tk4.2/doc/raise.n @@ -0,0 +1,38 @@ +'\" +'\" Copyright (c) 1990 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) raise.n 1.8 96/05/16 08:37:34 +'\" +.so man.macros +.TH raise n 3.3 Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +raise \- Change a window's position in the stacking order +.SH SYNOPSIS +\fBraise \fIwindow \fR?\fIaboveThis\fR? +.BE + +.SH DESCRIPTION +.PP +If the \fIaboveThis\fR argument is omitted then the command raises +\fIwindow\fR so that it is above all of its siblings in the stacking +order (it will not be obscured by any siblings and will obscure +any siblings that overlap it). +If \fIaboveThis\fR is specified then it must be the path name of +a window that is either a sibling of \fIwindow\fR or the descendant +of a sibling of \fIwindow\fR. +In this case the \fBraise\fR command will insert +\fIwindow\fR into the stacking order just above \fIaboveThis\fR +(or the ancestor of \fIaboveThis\fR that is a sibling of \fIwindow\fR); +this could end up either raising or lowering \fIwindow\fR. + +.SH "SEE ALSO" +lower + +.SH KEYWORDS +obscure, raise, stacking order diff --git a/tk4.2/doc/scale.n b/tk4.2/doc/scale.n new file mode 100644 index 0000000..5277dd7 --- /dev/null +++ b/tk4.2/doc/scale.n @@ -0,0 +1,246 @@ +'\" +'\" Copyright (c) 1990-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) scale.n 1.31 96/08/27 13:21:41 +'\" +.so man.macros +.TH scale n 4.1 Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +scale \- Create and manipulate scale widgets +.SH SYNOPSIS +\fBscale\fI \fIpathName \fR?\fIoptions\fR? +.SO +\-activebackground \-font \-highlightthickness \-repeatinterval +\-background \-foreground \-orient \-takefocus +\-borderwidth \-highlightbackground \-relief \-troughcolor +\-cursor \-highlightcolor \-repeatdelay +.SE +.SH "WIDGET-SPECIFIC OPTIONS" +.OP \-bigincrement bigIncrement BigIncrement +Some interactions with the scale cause its value to change by +``large'' increments; this option specifies the size of the +large increments. If specified as 0, the large increments default +to 1/10 the range of the scale. +.OP \-command command Command +Specifies the prefix of a Tcl command to invoke whenever the scale's +value is changed via a widget command. +The actual command consists +of this option followed by a space and a real number indicating the +new value of the scale. +.OP \-digits digits Digits +An integer specifying how many significant digits should be retained +when converting the value of the scale to a string. +If the number is less than or equal to zero, then the scale picks +the smallest value that guarantees that every possible slider +position prints as a different string. +.OP \-from from From +A real value corresponding to the left or top end of the scale. +.OP \-label label Label +A string to display as a label for the scale. For +vertical scales the label is displayed just to the right of the +top end of the scale. For horizontal scales the label is displayed +just above the left end of the scale. If the option is specified +as an empty string, no label is displayed. +.OP \-length length Length +Specifies the desired long dimension of the scale in screen units +(i.e. any of the forms acceptable to \fBTk_GetPixels\fR). +For vertical scales this is the scale's height; for horizontal scales +it is the scale's width. +.OP \-resolution resolution Resolution +A real value specifying the resolution for the scale. +If this value is greater than zero then the scale's value will always be +rounded to an even multiple of this value, as will tick marks and +the endpoints of the scale. If the value is less than zero then no +rounding occurs. Defaults to 1 (i.e., the value will be integral). +.OP \-showvalue showValue ShowValue +Specifies a boolean value indicating whether or not the current +value of the scale is to be displayed. +.OP \-sliderlength sliderLength SliderLength +Specfies the size of the slider, measured in screen units along the slider's +long dimension. The value may be specified in any of the forms acceptable +to \fBTk_GetPixels\fR. +.OP \-sliderrelief sliderRelief SliderRelief +Specifies the relief to use when drawing the slider, such as \fBraised\fR +or \fBsunken\fR. +.OP \-state state State +Specifies one of three states for the scale: \fBnormal\fR, +\fBactive\fR, or \fBdisabled\fR. +If the scale is disabled then the value may not be changed and the scale +won't activate. +If the scale is active, the slider is displayed using the color +specified by the \fBactiveBackground\fR option. +.OP \-tickinterval tickInterval TickInterval +Must be a real value. +Determines the spacing between numerical +tick marks displayed below or to the left of the slider. +If 0, no tick marks will be displayed. +.OP \-to to To +Specifies a real value corresponding +to the right or bottom end of the scale. +This value may be either less than or greater than the \fBfrom\fR option. +.OP \-variable variable Variable +Specifies the name of a global variable to link to the scale. Whenever the +value of the variable changes, the scale will update to reflect this +value. +Whenever the scale is manipulated interactively, the variable +will be modified to reflect the scale's new value. +.OP \-width width Width +Specifies the desired narrow dimension of the trough in screen units +(i.e. any of the forms acceptable to \fBTk_GetPixels\fR). +For vertical scales this is the trough's width; for horizontal scales +this is the trough's height. +.BE + +.SH DESCRIPTION +.PP +The \fBscale\fR command creates a new window (given by the +\fIpathName\fR argument) and makes it into a scale widget. +Additional +options, described above, may be specified on the command line +or in the option database +to configure aspects of the scale such as its colors, orientation, +and relief. The \fBscale\fR command returns its +\fIpathName\fR argument. At the time this command is invoked, +there must not exist a window named \fIpathName\fR, but +\fIpathName\fR's parent must exist. +.PP +A scale is a widget that displays a rectangular \fItrough\fR and a +small \fIslider\fR. The trough corresponds to a range +of real values (determined by the \fBfrom\fR, \fBto\fR, and +\fBresolution\fR options), +and the position of the slider selects a particular real value. +The slider's position (and hence the scale's value) may be adjusted +with the mouse or keyboard as described in the BINDINGS +section below. Whenever the scale's value is changed, a Tcl +command is invoked (using the \fBcommand\fR option) to notify +other interested widgets of the change. +In addition, the value +of the scale can be linked to a Tcl variable (using the \fBvariable\fR +option), so that changes in either are reflected in the other. +.PP +Three annotations may be displayed in a scale widget: a label +appearing at the top right of the widget (top left for horizontal +scales), a number displayed just to the left of the slider +(just above the slider for horizontal scales), and a collection +of numerical tick marks just to the left of the current value +(just below the trough for horizontal scales). Each of these three +annotations may be enabled or disabled using the +configuration options. + +.SH "WIDGET COMMAND" +.PP +The \fBscale\fR command creates a new Tcl command whose +name is \fIpathName\fR. This +command may be used to invoke various +operations on the widget. It has the following general form: +.CS +\fIpathName option \fR?\fIarg arg ...\fR? +.CE +\fIOption\fR and the \fIarg\fRs +determine the exact behavior of the command. The following +commands are possible for scale widgets: +.TP +\fIpathName \fBcget\fR \fIoption\fR +Returns the current value of the configuration option given +by \fIoption\fR. +\fIOption\fR may have any of the values accepted by the \fBscale\fR +command. +.TP +\fIpathName \fBconfigure\fR ?\fIoption\fR? ?\fIvalue option value ...\fR? +Query or modify the configuration options of the widget. +If no \fIoption\fR is specified, returns a list describing all of +the available options for \fIpathName\fR (see \fBTk_ConfigureInfo\fR for +information on the format of this list). If \fIoption\fR is specified +with no \fIvalue\fR, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no \fIoption\fR is specified). If +one or more \fIoption\-value\fR pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +\fIOption\fR may have any of the values accepted by the \fBscale\fR +command. +.TP +\fIpathName \fBcoords \fR?\fIvalue\fR? +Returns a list whose elements are the x and y coordinates of +the point along the centerline of the trough that corresponds +to \fIvalue\fR. +If \fIvalue\fR is omitted then the scale's current value is used. +.TP +\fIpathName \fBget\fR ?\fIx y\fR? +If \fIx\fR and \fIy\fR are omitted, returns the current value +of the scale. If \fIx\fR and \fIy\fR are specified, they give +pixel coordinates within the widget; the command returns +the scale value corresponding to the given pixel. +Only one of \fIx\fR or \fIy\fR is used: for horizontal scales +\fIy\fR is ignored, and for vertical scales \fIx\fR is ignored. +.TP +\fIpathName \fBidentify\fR \fIx y\fR +Returns a string indicating what part of the scale lies under +the coordinates given by \fIx\fR and \fIy\fR. +A return value of \fBslider\fR means that the point is over +the slider; \fBtrough1\fR means that the point is over the +portion of the slider above or to the left of the slider; +and \fBtrough2\fR means that the point is over the portion +of the slider below or to the right of the slider. +If the point isn't over one of these elements, an empty string +is returned. +.TP +\fIpathName \fBset\fR \fIvalue\fR +This command is invoked to change the current value of the scale, +and hence the position at which the slider is displayed. \fIValue\fR +gives the new value for the scale. +The command has no effect if the scale is disabled. + +.SH BINDINGS +.PP +Tk automatically creates class bindings for scales that give them +the following default behavior. +Where the behavior is different for vertical and horizontal scales, +the horizontal behavior is described in parentheses. +.IP [1] +If button 1 is pressed in the trough, the scale's value will +be incremented or decremented by the value of the \fBresolution\fR +option so that the slider moves in the direction of the cursor. +If the button is held down, the action auto-repeats. +.IP [2] +If button 1 is pressed over the slider, the slider can be dragged +with the mouse. +.IP [3] +If button 1 is pressed in the trough with the Control key down, +the slider moves all the way to the end of its range, in the +direction towards the mouse cursor. +.IP [4] +If button 2 is pressed, the scale's value is set to the mouse +position. If the mouse is dragged with button 2 down, the scale's +value changes with the drag. +.IP [5] +The Up and Left keys move the slider up (left) by the value +of the \fBresolution\fR option. +.IP [6] +The Down and Right keys move the slider down (right) by the value +of the \fBresolution\fR option. +.IP [7] +Control-Up and Control-Left move the slider up (left) by the +value of the \fBbigIncrement\fR option. +.IP [8] +Control-Down and Control-Right move the slider down (right) by the +value of the \fBbigIncrement\fR option. +.IP [9] +Home moves the slider to the top (left) end of its range. +.IP [10] +End moves the slider to the bottom (right) end of its range. +.PP +If the scale is disabled using the \fBstate\fR option then +none of the above bindings have any effect. +.PP +The behavior of scales can be changed by defining new bindings for +individual widgets or by redefining the class bindings. + +.SH KEYWORDS +scale, slider, trough, widget diff --git a/tk4.2/doc/scrollbar.n b/tk4.2/doc/scrollbar.n new file mode 100644 index 0000000..de021d3 --- /dev/null +++ b/tk4.2/doc/scrollbar.n @@ -0,0 +1,340 @@ +'\" +'\" Copyright (c) 1990-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) scrollbar.n 1.31 96/09/17 14:00:47 +'\" +.so man.macros +.TH scrollbar n 4.1 Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +scrollbar \- Create and manipulate scrollbar widgets +.SH SYNOPSIS +\fBscrollbar\fI pathName \fR?\fIoptions\fR? +.SO +\-activebackground \-highlightbackground \-orient \-takefocus +\-background \-highlightcolor \-relief \-troughcolor +\-borderwidth \-highlightthickness \-repeatdelay +\-cursor \-jump \-repeatinterval +.SE +.SH "WIDGET-SPECIFIC OPTIONS" +.OP \-activerelief activeRelief ActiveRelief +Specifies the relief to use when displaying the element that is +active, if any. +Elements other than the active element are always displayed with +a raised relief. +.OP \-command command Command +Specifies the prefix of a Tcl command to invoke to change the view +in the widget associated with the scrollbar. When a user requests +a view change by manipulating the scrollbar, a Tcl command is +invoked. The actual command consists of this option followed by +additional information as described later. This option almost always has +a value such as \fB.t xview\fR or \fB.t yview\fR, consisting of the +name of a widget and either \fBxview\fR (if the scrollbar is for +horizontal scrolling) or \fByview\fR (for vertical scrolling). +All scrollable widgets have \fBxview\fR and \fByview\fR commands +that take exactly the additional arguments appended by the scrollbar +as described in SCROLLING COMMANDS below. +.OP \-elementborderwidth elementBorderWidth BorderWidth +Specifies the width of borders drawn around the internal elements +of the scrollbar (the two arrows and the slider). The value may +have any of the forms acceptable to \fBTk_GetPixels\fR. +If this value is less than zero, the value of the \fBborderWidth\fR +option is used in its place. +.OP \-width width Width +Specifies the desired narrow dimension of the scrollbar window, +not including 3-D border, if any. For vertical +scrollbars this will be the width and for horizontal scrollbars +this will be the height. +The value may have any of the forms acceptable to \fBTk_GetPixels\fR. +.BE + +.SH DESCRIPTION +.PP +The \fBscrollbar\fR command creates a new window (given by the +\fIpathName\fR argument) and makes it into a scrollbar widget. +Additional options, described above, may be specified on the command +line or in the option database to configure aspects of the scrollbar +such as its colors, orientation, and relief. +The \fBscrollbar\fR command returns its \fIpathName\fR argument. +At the time this command is invoked, there must not exist a window +named \fIpathName\fR, but \fIpathName\fR's parent must exist. +.PP +A scrollbar is a widget that displays two arrows, one at each end of +the scrollbar, and a \fIslider\fR in the middle portion of the +scrollbar. +It provides information about what is visible in an \fIassociated window\fR +that displays an document of some sort (such as a file being edited or +a drawing). +The position and size of the slider indicate which portion of the +document is visible in the associated window. For example, if the +slider in a vertical scrollbar covers the top third of the area +between the two arrows, it means that the associated window displays +the top third of its document. +.PP +Scrollbars can be used to adjust the view in the associated window +by clicking or dragging with the mouse. See the BINDINGS section +below for details. + +.SH "ELEMENTS" +.PP +A scrollbar displays five elements, which are referred to in the +widget commands for the scrollbar: +.TP 10 +\fBarrow1\fR +The top or left arrow in the scrollbar. +.TP 10 +\fBtrough1\fR +The region between the slider and \fBarrow1\fR. +.TP 10 +\fBslider\fR +The rectangle that indicates what is visible in the associated widget. +.TP 10 +\fBtrough2\fR +The region between the slider and \fBarrow2\fR. +.TP 10 +\fBarrow2\fR +The bottom or right arrow in the scrollbar. + +.SH "WIDGET COMMAND" +.PP +The \fBscrollbar\fR command creates a new Tcl command whose +name is \fIpathName\fR. This +command may be used to invoke various +operations on the widget. It has the following general form: +.CS +\fIpathName option \fR?\fIarg arg ...\fR? +.CE +\fIOption\fR and the \fIarg\fRs +determine the exact behavior of the command. The following +commands are possible for scrollbar widgets: +.TP +\fIpathName \fBactivate \fR?\fIelement\fR? +Marks the element indicated by \fIelement\fR as active, which +causes it to be displayed as specified by the \fBactiveBackground\fR +and \fBactiveRelief\fR options. +The only element values understood by this command are \fBarrow1\fR, +\fBslider\fR, or \fBarrow2\fR. +If any other value is specified then no element of the scrollbar +will be active. +If \fIelement\fR is not specified, the command returns +the name of the element that is currently active, or an empty string +if no element is active. +.TP +\fIpathName \fBcget\fR \fIoption\fR +Returns the current value of the configuration option given +by \fIoption\fR. +\fIOption\fR may have any of the values accepted by the \fBscrollbar\fR +command. +.TP +\fIpathName \fBconfigure\fR ?\fIoption\fR? ?\fIvalue option value ...\fR? +Query or modify the configuration options of the widget. +If no \fIoption\fR is specified, returns a list describing all of +the available options for \fIpathName\fR (see \fBTk_ConfigureInfo\fR for +information on the format of this list). If \fIoption\fR is specified +with no \fIvalue\fR, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no \fIoption\fR is specified). If +one or more \fIoption\-value\fR pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +\fIOption\fR may have any of the values accepted by the \fBscrollbar\fR +command. +.TP +\fIpathName \fBdelta \fIdeltaX deltaY\fR +Returns a real number indicating the fractional change in +the scrollbar setting that corresponds to a given change +in slider position. For example, if the scrollbar is horizontal, +the result indicates how much the scrollbar setting must change +to move the slider \fIdeltaX\fR pixels to the right (\fIdeltaY\fR is +ignored in this case). +If the scrollbar is vertical, the result indicates how much the +scrollbar setting must change to move the slider \fIdeltaY\fR pixels +down. The arguments and the result may be zero or negative. +.TP +\fIpathName \fBfraction \fIx y\fR +Returns a real number between 0 and 1 indicating where the point +given by \fIx\fR and \fIy\fR lies in the trough area of the scrollbar. +The value 0 corresponds to the top or left of the trough, the +value 1 corresponds to the bottom or right, 0.5 corresponds to +the middle, and so on. +\fIX\fR and \fIy\fR must be pixel coordinates relative to the scrollbar +widget. +If \fIx\fR and \fIy\fR refer to a point outside the trough, the closest +point in the trough is used. +.TP +\fIpathName \fBget\fR +Returns the scrollbar settings in the form of a list whose +elements are the arguments to the most recent \fBset\fR widget command. +.TP +\fIpathName \fBidentify\fR \fIx y\fR +Returns the name of the element under the point given by \fIx\fR and +\fIy\fR (such as \fBarrow1\fR), or an empty string if the point does +not lie in any element of the scrollbar. +\fIX\fR and \fIy\fR must be pixel coordinates relative to the scrollbar +widget. +.TP +\fIpathName \fBset\fR \fIfirst last\fR +This command is invoked by the scrollbar's associated widget to +tell the scrollbar about the current view in the widget. +The command takes two arguments, each of which is a real fraction +between 0 and 1. +The fractions describe the range of the document that is visible in +the associated widget. +For example, if \fIfirst\fR is 0.2 and \fIlast\fR is 0.4, it means +that the first part of the document visible in the window is 20% +of the way through the document, and the last visible part is 40% +of the way through. + +.SH "SCROLLING COMMANDS" +.PP +When the user interacts with the scrollbar, for example by dragging +the slider, the scrollbar notifies the associated widget that it +must change its view. +The scrollbar makes the notification by evaluating a Tcl command +generated from the scrollbar's \fB\-command\fR option. +The command may take any of the following forms. +In each case, \fIprefix\fR is the contents of the +\fB\-command\fR option, which usually has a form like \fB.t yview\fR +.TP +\fIprefix \fBmoveto \fIfraction\fR +\fIFraction\fR is a real number between 0 and 1. +The widget should adjust its view so that the point given +by \fIfraction\fR appears at the beginning of the widget. +If \fIfraction\fR is 0 it refers to the beginning of the +document. 1.0 refers to the end of the document, 0.333 +refers to a point one-third of the way through the document, +and so on. +.TP +\fIprefix \fBscroll \fInumber \fBunit\fR +The widget should adjust its view by \fInumber\fR units. +The units are defined in whatever way makes sense for the widget, +such as characters or lines in a text widget. +\fINumber\fR is either 1, which means one unit should scroll off +the top or left of the window, or \-1, which means that one unit +should scroll off the bottom or right of the window. +.TP +\fIprefix \fBscroll \fInumber \fBpage\fR +The widget should adjust its view by \fInumber\fR pages. +It is up to the widget to define the meaning of a page; typically +it is slightly less than what fits in the window, so that there +is a slight overlap between the old and new views. +\fINumber\fR is either 1, which means the next page should +become visible, or \-1, which means that the previous page should +become visible. + +.SH "OLD COMMAND SYNTAX" +.PP +In versions of Tk before 4.0, the \fBset\fR and \fBget\fR widget +commands used a different form. +This form is still supported for backward compatibility, but it +is deprecated. +In the old command syntax, the \fBset\fR widget command has the +following form: +.TP +\fIpathName \fBset\fR \fItotalUnits windowUnits firstUnit lastUnit\fR +In this form the arguments are all integers. +\fITotalUnits\fR gives the total size of the object being displayed in the +associated widget. The meaning of one unit depends on the associated +widget; for example, in a text editor widget units might +correspond to lines of +text. \fIWindowUnits\fR indicates the total number of units that +can fit in the associated window at one time. \fIFirstUnit\fR +and \fIlastUnit\fR give the indices of the first and last units +currently visible in the associated window (zero corresponds to the +first unit of the object). +.LP +Under the old syntax the \fBget\fR widget command returns a list +of four integers, consisting of the \fItotalUnits\fR, \fIwindowUnits\fR, +\fIfirstUnit\fR, and \fIlastUnit\fR values from the last \fBset\fR +widget command. +.PP +The commands generated by scrollbars also have a different form +when the old syntax is being used: +.TP +\fIprefix \fIunit\fR +\fIUnit\fR is an integer that indicates what should appear at +the top or left of the associated widget's window. +It has the same meaning as the \fIfirstUnit\fR and \fIlastUnit\fR +arguments to the \fBset\fR widget command. +.LP +The most recent \fBset\fR widget command determines whether or not +to use the old syntax. +If it is given two real arguments then the new syntax will be +used in the future, and if it is given four integer arguments then +the old syntax will be used. + +.SH BINDINGS +Tk automatically creates class bindings for scrollbars that give them +the following default behavior. +If the behavior is different for vertical and horizontal scrollbars, +the horizontal behavior is described in parentheses. + +.IP [1] +Pressing button 1 over \fBarrow1\fR causes the view in the +associated widget to shift up (left) by one unit so that the +document appears to move down (right) one unit. +If the button is held down, the action auto-repeats. +.IP [2] +Pressing button 1 over \fBtrough1\fR causes the view in the +associated widget to shift up (left) by one screenful so that the +document appears to move down (right) one screenful. +If the button is held down, the action auto-repeats. +.IP [3] +Pressing button 1 over the slider and dragging causes the view +to drag with the slider. +If the \fBjump\fR option is true, then the view doesn't drag along +with the slider; it changes only when the mouse button is released. +.IP [4] +Pressing button 1 over \fBtrough2\fR causes the view in the +associated widget to shift down (right) by one screenful so that the +document appears to move up (left) one screenful. +If the button is held down, the action auto-repeats. +.IP [5] +Pressing button 1 over \fBarrow2\fR causes the view in the +associated widget to shift down (right) by one unit so that the +document appears to move up (left) one unit. +If the button is held down, the action auto-repeats. +.IP [6] +If button 2 is pressed over the trough or the slider, it sets +the view to correspond to the mouse position; dragging the +mouse with button 2 down causes the view to drag with the mouse. +If button 2 is pressed over one of the arrows, it causes the +same behavior as pressing button 1. +.IP [7] +If button 1 is pressed with the Control key down, then if the +mouse is over \fBarrow1\fR or \fBtrough1\fR the view changes +to the very top (left) of the document; if the mouse is over +\fBarrow2\fR or \fBtrough2\fR the view changes +to the very bottom (right) of the document; if the mouse is +anywhere else then the button press has no effect. +.IP [8] +In vertical scrollbars the Up and Down keys have the same behavior +as mouse clicks over \fBarrow1\fR and \fBarrow2\fR, respectively. +In horizontal scrollbars these keys have no effect. +.IP [9] +In vertical scrollbars Control-Up and Control-Down have the same +behavior as mouse clicks over \fBtrough1\fR and \fBtrough2\fR, respectively. +In horizontal scrollbars these keys have no effect. +.IP [10] +In horizontal scrollbars the Up and Down keys have the same behavior +as mouse clicks over \fBarrow1\fR and \fBarrow2\fR, respectively. +In vertical scrollbars these keys have no effect. +.IP [11] +In horizontal scrollbars Control-Up and Control-Down have the same +behavior as mouse clicks over \fBtrough1\fR and \fBtrough2\fR, respectively. +In vertical scrollbars these keys have no effect. +.IP [12] +The Prior and Next keys have the same behavior +as mouse clicks over \fBtrough1\fR and \fBtrough2\fR, respectively. +.IP [13] +The Home key adjusts the view to the top (left edge) of the document. +.IP [14] +The End key adjusts the view to the bottom (right edge) of the document. + +.SH KEYWORDS +scrollbar, widget diff --git a/tk4.2/doc/selection.n b/tk4.2/doc/selection.n new file mode 100644 index 0000000..294a243 --- /dev/null +++ b/tk4.2/doc/selection.n @@ -0,0 +1,128 @@ +'\" +'\" Copyright (c) 1990-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) selection.n 1.18 96/08/27 13:21:51 +'\" +.so man.macros +.TH selection n 4.0 Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +selection \- Manipulate the X selection +.SH SYNOPSIS +\fBselection \fIoption\fR ?\fIarg arg ...\fR? +.BE + +.SH DESCRIPTION +.PP +This command provides a Tcl interface to the X selection mechanism and +implements the full selection functionality described in the +X Inter-Client Communication Conventions Manual (ICCCM). +.PP +The first argument to \fBselection\fR determines the format of the +rest of the arguments and the behavior of the command. The following +forms are currently supported: +.PP +.TP +\fBselection clear\fR ?\fB\-displayof\fR \fIwindow\fR? ?\fB\-selection\fR \fIselection\fR? +If \fIselection\fR exists anywhere on \fIwindow\fR's display, clear it +so that no window owns the selection anymore. \fISelection\fR +specifies the X selection that should be cleared, and should be an +atom name such as PRIMARY or CLIPBOARD; see the Inter-Client +Communication Conventions Manual for complete details. +\fISelection\fR defaults to PRIMARY and \fIwindow\fR defaults to ``.''. +Returns an empty string. +.TP +\fBselection get\fR ?\fB\-displayof\fR \fIwindow\fR? ?\fB\-selection\fR \fIselection\fR? ?\fB\-type\fR \fItype\fR? +Retrieves the value of \fIselection\fR from \fIwindow\fR's display and +returns it as a result. \fISelection\fR defaults to PRIMARY and +\fIwindow\fR defaults to ``.''. +\fIType\fR specifies the form in which the selection is to be returned +(the desired ``target'' for conversion, in ICCCM terminology), and +should be an atom name such as STRING or FILE_NAME; see the +Inter-Client Communication Conventions Manual for complete details. +\fIType\fR defaults to STRING. The selection owner may choose to +return the selection in any of several different representation +formats, such as STRING, ATOM, INTEGER, etc. (this format is different +than the selection type; see the ICCCM for all the confusing details). +If the selection is returned in a non-string format, such as INTEGER +or ATOM, the \fBselection\fR command converts it to string format as a +collection of fields separated by spaces: atoms are converted to their +textual names, and anything else is converted to hexadecimal integers. +.TP +\fBselection handle\fR ?\fB\-selection\fR \fIselection\fR? ?\fB\-type\fR \fItype\fR? ?\fB\-format\fR \fIformat\fR? \fIwindow command\fR +Creates a handler for selection requests, such that \fIcommand\fR will +be executed whenever \fIselection\fR is owned by \fIwindow\fR and +someone attempts to retrieve it in the form given by \fItype\fR +(e.g. \fItype\fR is specified in the \fBselection get\fR command). +\fISelection\fR defaults to PRIMARY, \fItype\fR defaults to STRING, and +\fIformat\fR defaults to STRING. If \fIcommand\fR is an empty string +then any existing handler for \fIwindow\fR, \fItype\fR, and +\fIselection\fR is removed. +.RS +.PP +When \fIselection\fR is requested, \fIwindow\fR is the selection owner, +and \fItype\fR is the requested type, \fIcommand\fR will be executed +as a Tcl command with two additional numbers appended to it +(with space separators). +The two additional numbers +are \fIoffset\fR and \fImaxBytes\fR: \fIoffset\fR specifies a starting +character position in the selection and \fImaxBytes\fR gives the maximum +number of bytes to retrieve. The command should return a value consisting +of at most \fImaxBytes\fR of the selection, starting at position +\fIoffset\fR. For very large selections (larger than \fImaxBytes\fR) +the selection will be retrieved using several invocations of \fIcommand\fR +with increasing \fIoffset\fR values. If \fIcommand\fR returns a string +whose length is less than \fImaxBytes\fR, the return value is assumed to +include all of the remainder of the selection; if the length of +\fIcommand\fR's result is equal to \fImaxBytes\fR then +\fIcommand\fR will be invoked again, until it eventually +returns a result shorter than \fImaxBytes\fR. The value of \fImaxBytes\fR +will always be relatively large (thousands of bytes). +.PP +If \fIcommand\fR returns an error then the selection retrieval is rejected +just as if the selection didn't exist at all. +.PP +The \fIformat\fR argument specifies the representation that should be +used to transmit the selection to the requester (the second column of +Table 2 of the ICCCM), and defaults to STRING. If \fIformat\fR is +STRING, the selection is transmitted as 8-bit ASCII characters (i.e. +just in the form returned by \fIcommand\fR). If \fIformat\fR is +ATOM, then the return value from \fIcommand\fR is divided into fields +separated by white space; each field is converted to its atom value, +and the 32-bit atom value is transmitted instead of the atom name. +For any other \fIformat\fR, the return value from \fIcommand\fR is +divided into fields separated by white space and each field is +converted to a 32-bit integer; an array of integers is transmitted +to the selection requester. +.PP +The \fIformat\fR argument is needed only for compatibility with +selection requesters that don't use Tk. If Tk is being +used to retrieve the selection then the value is converted back to +a string at the requesting end, so \fIformat\fR is +irrelevant. +.RE +.TP +\fBselection own\fR ?\fB\-displayof\fR \fIwindow\fR? ?\fB\-selection\fR \fIselection\fR? +.TP +\fBselection own\fR ?\fB\-command\fR \fIcommand\fR? ?\fB\-selection\fR \fIselection\fR? \fIwindow\fR +The first form of \fBselection own\fR returns the path name of the +window in this application that owns \fIselection\fR on the display +containing \fIwindow\fR, or an empty string if no window in this +application owns the selection. \fISelection\fR defaults to PRIMARY and +\fIwindow\fR defaults to ``.''. +.PP +The second form of \fBselection own\fR causes \fIwindow\fR to become +the new owner of \fIselection\fR on \fIwindow\fR's display, returning +an empty string as result. The existing owner, if any, is notified +that it has lost the selection. +If \fIcommand\fR is specified, it is a Tcl script to execute when +some other window claims ownership of the selection away from +\fIwindow\fR. \fISelection\fR defaults to PRIMARY. + +.SH KEYWORDS +clear, format, handler, ICCCM, own, selection, target, type diff --git a/tk4.2/doc/send.n b/tk4.2/doc/send.n new file mode 100644 index 0000000..e949c18 --- /dev/null +++ b/tk4.2/doc/send.n @@ -0,0 +1,92 @@ +'\" +'\" Copyright (c) 1990-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) send.n 1.18 96/08/27 13:21:47 +'\" +.so man.macros +.TH send n 4.0 Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +send \- Execute a command in a different application +.SH SYNOPSIS +\fBsend ?\fIoptions\fR? \fIapp cmd \fR?\fIarg arg ...\fR? +.BE + +.SH DESCRIPTION +.PP +This command arranges for \fIcmd\fR (and \fIarg\fRs) to be executed in the +application named by \fIapp\fR. It returns the result or +error from that command execution. +\fIApp\fR may be the name of any application whose main window is +on the display containing the sender's main window; it need not +be within the same process. +If no \fIarg\fR arguments are present, then the command to be executed is +contained entirely within the \fIcmd\fR argument. If one or +more \fIarg\fRs are present, they are concatenated to form the +command to be executed, just as for the \fBeval\fR command. +.PP +If the initial arguments of the command begin with ``\-'' +they are treated as options. The following options are +currently defined: +.TP +\fB\-async\fR +Requests asynchronous invocation. In this case the \fBsend\fR +command will complete immediately without waiting for \fIcmd\fR +to complete in the target application; no result will be available +and errors in the sent command will be ignored. +If the target application is in the same process as the sending +application then the \fB\-async\fR option is ignored. +.TP +\fB\-displayof\fR \fIpathName\fR +Specifies that the target application's main window is on the display +of the window given by \fIpathName\fR, instead of the display containing +the application's main window. +.TP +\fB\-\|\-\fR +Serves no purpose except to terminate the list of options. This +option is needed only if \fIapp\fR could contain a leading ``\-'' +character. + +.SH "APPLICATION NAMES" +.PP +The name of an application is set initially from the name of the +program or script that created the application. +You can query and change the name of an application with the +\fBtk appname\fR command. + +.SH "DISABLING SENDS" +.PP +If the \fBsend\fR command is removed from an application (e.g. +with the command \fBrename send {}\fR) then the application +will not respond to incoming send requests anymore, nor will it +be able to issue outgoing requests. +Communication can be reenabled by invoking the \fBtk appname\fR +command. + +.SH SECURITY +.PP +The \fBsend\fR command is potentially a serious security loophole, +since any application that can connect to your X server can send +scripts to your applications. +These incoming scripts can use Tcl to read and +write your files and invoke subprocesses under your name. +Host-based access control such as that provided by \fBxhost\fR +is particularly insecure, since it allows anyone with an account +on particular hosts to connect to your server, and if disabled it +allows anyone anywhere to connect to your server. +In order to provide at least a small amount of +security, Tk checks the access control being used by the server +and rejects incoming sends unless (a) \fBxhost\fR-style access control +is enabled (i.e. only certain hosts can establish connections) and (b) the +list of enabled hosts is empty. +This means that applications cannot connect to your server unless +they use some other form of authorization +such as that provide by \fBxauth\fR. + +.SH KEYWORDS +application, name, remote execution, security, send diff --git a/tk4.2/doc/text.n b/tk4.2/doc/text.n new file mode 100644 index 0000000..5d55678 --- /dev/null +++ b/tk4.2/doc/text.n @@ -0,0 +1,1489 @@ +'\" +'\" Copyright (c) 1992 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) text.n 1.64 96/08/27 13:21:22 +'\" +.so man.macros +.TH text n 4.0 Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +text \- Create and manipulate text widgets +.SH SYNOPSIS +\fBtext\fI \fIpathName \fR?\fIoptions\fR? +.SO +\-background \-highlightbackground \-insertontime \-selectborderwidth +\-borderwidth \-highlightcolor \-insertwidth \-selectforeground +\-cursor \-highlightthickness \-padx \-setgrid +\-exportselection \-insertbackground \-pady \-takefocus +\-font \-insertborderwidth \-relief \-xscrollcommand +\-foreground \-insertofftime \-selectbackground \-yscrollcommand +.SE +.SH "WIDGET-SPECIFIC OPTIONS" +.OP \-height height Height +Specifies the desired height for the window, in units of characters +in the font given by the \fB\-font\fR option. +Must be at least one. +.OP \-spacing1 spacing1 Spacing1 +Requests additional space above each text line in the widget, +using any of the standard forms for screen distances. +If a line wraps, this option only applies to the first line +on the display. +This option may be overriden with \fB\-spacing1\fR options in +tags. +.OP \-spacing2 spacing2 Spacing2 +For lines that wrap (so that they cover more than one line on the +display) this option specifies additional space to provide between +the display lines that represent a single line of text. +The value may have any of the standard forms for screen distances. +This option may be overriden with \fB\-spacing2\fR options in +tags. +.OP \-spacing3 spacing3 Spacing3 +Requests additional space below each text line in the widget, +using any of the standard forms for screen distances. +If a line wraps, this option only applies to the last line +on the display. +This option may be overriden with \fB\-spacing3\fR options in +tags. +.OP \-state state State +Specifies one of two states for the text: \fBnormal\fR or \fBdisabled\fR. +If the text is disabled then characters may not be inserted or deleted +and no insertion cursor will be displayed, even if the input focus is +in the widget. +.OP \-tabs tabs Tabs +Specifies a set of tab stops for the window. The option's value consists +of a list of screen distances giving the positions of the tab stops. Each +position may optionally be followed in the next list element +by one of the keywords \fBleft\fR, \fBright\fR, \fBcenter\fR, +or \fBnumeric\fR, which specifies how to justify +text relative to the tab stop. \fBLeft\fR is the default; it causes +the text following the tab character to be positioned with its left edge +at the tab position. \fBRight\fR means that the right edge of the text +following the tab character is positioned at the tab position, and +\fBcenter\fR means that the text is centered at the tab position. +\fBNumeric\fR means that the decimal point in the text is positioned +at the tab position; if there is no decimal point then the least +significant digit of the number is positioned just to the left of the +tab position; if there is no number in the text then the text is +right-justified at the tab position. +For example, \fB\-tabs {2c left 4c 6c center}\fR creates three +tab stops at two-centimeter intervals; the first two use left +justification and the third uses center justification. +If the list of tab stops does not have enough elements to cover all +of the tabs in a text line, then Tk extrapolates new tab stops using +the spacing and alignment from the last tab stop in the list. +The value of the \fBtabs\fR option may be overridden by \fB\-tabs\fR +options in tags. +If no \fB\-tabs\fR option is specified, or if it is specified as +an empty list, then Tk uses default tabs spaced every eight +(average size) characters. +.OP \-width width Width +Specifies the desired width for the window in units of characters +in the font given by the \fB\-font\fR option. +If the font doesn't have a uniform width then the width of the +character ``0'' is used in translating from character units to +screen units. +.OP \-wrap wrap Wrap +Specifies how to handle lines in the text that are too long to be +displayed in a single line of the text's window. +The value must be \fBnone\fR or \fBchar\fR or \fBword\fR. +A wrap mode of \fBnone\fR means that each line of text appears as +exactly one line on the screen; extra characters that don't fit +on the screen are not displayed. +In the other modes each line of text will be broken up into several +screen lines if necessary to keep all the characters visible. +In \fBchar\fR mode a screen line break may occur after any character; +in \fBword\fR mode a line break will only be made at word boundaries. +.BE + +.SH DESCRIPTION +.PP +The \fBtext\fR command creates a new window (given by the +\fIpathName\fR argument) and makes it into a text widget. +Additional +options, described above, may be specified on the command line +or in the option database +to configure aspects of the text such as its default background color +and relief. The \fBtext\fR command returns the +path name of the new window. +.PP +A text widget displays one or more lines of text and allows that +text to be edited. +Text widgets support three different kinds of annotations on the +text, called tags, marks, and embedded windows. +Tags allow different portions of the text +to be displayed with different fonts and colors. +In addition, Tcl commands can be associated with tags so +that scripts are invoked when particular actions such as keystrokes +and mouse button presses occur in particular ranges of the text. +See TAGS below for more details. +.PP +The second form of annotation consists of marks, which are floating +markers in the text. +Marks are used to keep track of various interesting positions in the +text as it is edited. +See MARKS below for more details. +.PP +The third form of annotation allows arbitrary windows to be +embedded in a text widget. +See EMBEDDED WINDOWS below for more details. + +.SH INDICES +.PP +Many of the widget commands for texts take one or more indices +as arguments. +An index is a string used to indicate a particular place within +a text, such as a place to insert characters or one endpoint of a +range of characters to delete. +Indices have the syntax +.CS +\fIbase modifier modifier modifier ...\fR +.CE +Where \fIbase\fR gives a starting point and the \fImodifier\fRs +adjust the index from the starting point (e.g. move forward or +backward one character). Every index must contain a \fIbase\fR, +but the \fImodifier\fRs are optional. +.PP +The \fIbase\fR for an index must have one of the following forms: +.TP 12 +\fIline\fB.\fIchar\fR +Indicates \fIchar\fR'th character on line \fIline\fR. +Lines are numbered from 1 for consistency with other UNIX programs +that use this numbering scheme. +Within a line, characters are numbered from 0. +If \fIchar\fR is \fBend\fR then it refers to the newline character +that ends the line. +.TP 12 +\fB@\fIx\fB,\fIy\fR +Indicates the character that covers the pixel whose x and y coordinates +within the text's window are \fIx\fR and \fIy\fR. +.TP 12 +\fBend\fR +Indicates the end of the text (the character just after the last +newline). +.TP 12 +\fImark\fR +Indicates the character just after the mark whose name is \fImark\fR. +.TP 12 +\fItag\fB.first\fR +Indicates the first character in the text that has been tagged with +\fItag\fR. +This form generates an error if no characters are currently tagged +with \fItag\fR. +.TP 12 +\fItag\fB.last\fR +Indicates the character just after the last one in the text that has +been tagged with \fItag\fR. +This form generates an error if no characters are currently tagged +with \fItag\fR. +.TP 12 +\fIpathName\fR +Indicates the position of the embedded window whose name is +\fIpathName\fR. +This form generates an error if there is no embedded window +by the given name. +.PP +If modifiers follow the base index, each one of them must have one +of the forms listed below. Keywords such as \fBchars\fR and \fBwordend\fR +may be abbreviated as long as the abbreviation is unambiguous. +.TP +\fB+ \fIcount\fB chars\fR +Adjust the index forward by \fIcount\fR characters, moving to later +lines in the text if necessary. If there are fewer than \fIcount\fR +characters in the text after the current index, then set the index +to the last character in the text. +Spaces on either side of \fIcount\fR are optional. +.TP +\fB\- \fIcount\fB chars\fR +Adjust the index backward by \fIcount\fR characters, moving to earlier +lines in the text if necessary. If there are fewer than \fIcount\fR +characters in the text before the current index, then set the index +to the first character in the text. +Spaces on either side of \fIcount\fR are optional. +.TP +\fB+ \fIcount\fB lines\fR +Adjust the index forward by \fIcount\fR lines, retaining the same +character position within the line. If there are fewer than \fIcount\fR +lines after the line containing the current index, then set the index +to refer to the same character position on the last line of the text. +Then, if the line is not long enough to contain a character at the indicated +character position, adjust the character position to refer to the last +character of the line (the newline). +Spaces on either side of \fIcount\fR are optional. +.TP +\fB\- \fIcount\fB lines\fR +Adjust the index backward by \fIcount\fR lines, retaining the same +character position within the line. If there are fewer than \fIcount\fR +lines before the line containing the current index, then set the index +to refer to the same character position on the first line of the text. +Then, if the line is not long enough to contain a character at the indicated +character position, adjust the character position to refer to the last +character of the line (the newline). +Spaces on either side of \fIcount\fR are optional. +.TP +\fBlinestart\fR +Adjust the index to refer to the first character on the line. +.TP +\fBlineend\fR +Adjust the index to refer to the last character on the line (the newline). +.TP +\fBwordstart\fR +Adjust the index to refer to the first character of the word containing +the current index. A word consists of any number of adjacent characters +that are letters, digits, or underscores, or a single character that +is not one of these. +.TP +\fBwordend\fR +Adjust the index to refer to the character just after the last one of the +word containing the current index. If the current index refers to the last +character of the text then it is not modified. +.PP +If more than one modifier is present then they are applied in +left-to-right order. For example, the index ``\fBend \- 1 chars\fR'' +refers to the next-to-last character in the text and +``\fBinsert wordstart \- 1 c\fR'' refers to the character just before +the first one in the word containing the insertion cursor. + +.SH TAGS +.PP +The first form of annotation in text widgets is a tag. +A tag is a textual string that is associated with some of the characters +in a text. +Tags may contain arbitrary characters, but it is probably best to +avoid using the the characters `` '' (space), \fB+\fR, or \fB\-\fR: +these characters have special meaning in indices, so tags containing +them can't be used as indices. +There may be any number of tags associated with characters in a +text. +Each tag may refer to a single character, a range of characters, or +several ranges of characters. +An individual character may have any number of tags associated with it. +.PP +A priority order is defined among tags, and this order is used in +implementing some of the tag-related functions described below. +When a tag is defined (by associating it with characters or setting +its display options or binding commands to it), it is given +a priority higher than any existing tag. +The priority order of tags may be redefined using the +``\fIpathName \fBtag raise\fR'' and ``\fIpathName \fBtag lower\fR'' +widget commands. +.PP +Tags serve three purposes in text widgets. +First, they control the way information is displayed on the screen. +By default, characters are displayed as determined by the +\fBbackground\fR, \fBfont\fR, and \fBforeground\fR options for the +text widget. +However, display options may be associated with individual tags +using the ``\fIpathName \fBtag configure\fR'' widget command. +If a character has been tagged, then the display options associated +with the tag override the default display style. +The following options are currently supported for tags: +.TP +\fB\-background \fIcolor\fR +\fIColor\fR specifies the background color to use for characters +associated with the tag. +It may have any of the forms accepted by \fBTk_GetColor\fR. +.TP +\fB\-bgstipple \fIbitmap\fR +\fIBitmap\fR specifies a bitmap that is used as a stipple pattern +for the background. +It may have any of the forms accepted by \fBTk_GetBitmap\fR. +If \fIbitmap\fR hasn't been specified, or if it is specified +as an empty string, then a solid fill will be used for the +background. +.TP +\fB\-borderwidth \fIpixels\fR +\fIPixels\fR specifies the width of a 3-D border to draw around +the background. +It may have any of the forms accepted by \fBTk_GetPixels\fR. +This option is used in conjunction with the \fB\-relief\fR +option to give a 3-D appearance to the background for characters; +it is ignored unless the \fB\-background\fR option +has been set for the tag. +.TP +\fB\-fgstipple \fIbitmap\fR +\fIBitmap\fR specifies a bitmap that is used as a stipple pattern +when drawing text and other foreground information such as +underlines. +It may have any of the forms accepted by \fBTk_GetBitmap\fR. +If \fIbitmap\fR hasn't been specified, or if it is specified +as an empty string, then a solid fill will be used. +.TP +\fB\-font \fIfontName\fR +\fIFontName\fR is the name of a font to use for drawing characters. +It may have any of the forms accepted by \fBTk_GetFontStruct\fR. +.TP +\fB\-foreground \fIcolor\fR +\fIColor\fR specifies the color to use when drawing text and other +foreground information such as underlines. +It may have any of the forms accepted by \fBTk_GetColor\fR. +.TP +\fB\-justify \fIjustify\fR +If the first character of a display line has a tag for which this +option has been specified, then \fIjustify\fR determines how to +justify the line. +It must be one of \fBleft\fR, \fBright\fR, or \fBcenter\fR. +If a line wraps, then the justification for each line on the +display is determined by the first character of that display line. +.TP +\fB\-lmargin1 \fIpixels\fR +If the first character of a text line has a tag for which this +option has been specified, then \fIpixels\fR specifies how +much the line should be indented from the left edge of the +window. +\fIPixels\fR may have any of the standard forms for screen +distances. +If a line of text wraps, this option only applies to the +first line on the display; the \fB\-lmargin2\fR option controls +the indentation for subsequent lines. +.TP +\fB\-lmargin2 \fIpixels\fR +If the first character of a display line has a tag for which this +option has been specified, and if the display line is not the +first for its text line (i.e., the text line has wrapped), then +\fIpixels\fR specifies how much the line should be indented from +the left edge of the window. +\fIPixels\fR may have any of the standard forms for screen +distances. +This option is only used when wrapping is enabled, and it only +applies to the second and later display lines for a text line. +.TP +\fB\-offset \fIpixels\fR +\fIPixels\fR specifies an amount by which the text's baseline +should be offset vertically from the baseline of the overall +line, in pixels. +For example, a positive offset can be used for superscripts +and a negative offset can be used for subscripts. +\fIPixels\fR may have any of the standard forms for screen +distances. +.TP +\fB\-overstrike \fIboolean\fR +Specifies whether or not to draw a horizontal rule through +the middle of characters. +\fIBoolean\fR may have any of the forms accepted by \fBTk_GetBoolean\fR. +.TP +\fB\-relief \fIrelief\fR +\fIRelief\fR specifies the 3-D relief to use for drawing backgrounds, +in any of the forms accepted by \fBTk_GetRelief\fR. +This option is used in conjunction with the \fB\-borderwidth\fR +option to give a 3-D appearance to the background for characters; +it is ignored unless the \fB\-background\fR option +has been set for the tag. +.TP +\fB\-rmargin \fIpixels\fR +If the first character of a display line has a tag for which this +option has been specified, then \fIpixels\fR specifies how wide +a margin to leave between the end of the line and the right +edge of the window. +\fIPixels\fR may have any of the standard forms for screen +distances. +This option is only used when wrapping is enabled. +If a text line wraps, the right margin for each line on the +display is determined by the first character of that display +line. +.TP +\fB\-spacing1 \fIpixels\fR +\fIPixels\fR specifies how much additional space should be +left above each text line, using any of the standard forms for +screen distances. +If a line wraps, this option only applies to the first +line on the display. +.TP +\fB\-spacing2 \fIpixels\fR +For lines that wrap, this option specifies how much additional +space to leave between the display lines for a single text line. +\fIPixels\fR may have any of the standard forms for screen +distances. +.TP +\fB\-spacing3 \fIpixels\fR +\fIPixels\fR specifies how much additional space should be +left below each text line, using any of the standard forms for +screen distances. +If a line wraps, this option only applies to the last +line on the display. +.TP +\fB\-tabs \fItabList\fR +\fITabList\fR specifies a set of tab stops in the same form +as for the \fB\-tabs\fR option for the text widget. This +option only applies to a display line if it applies to the +first character on that display line. +If this option is specified as an empty string, it cancels +the option, leaving it unspecified for the tag (the default). +If the option is specified as a non-empty string that is +an empty list, such as \fB\-tags\0{\0}\fR, then it requests +default 8-character tabs as described for the \fBtags\fR +widget option. +.TP +\fB\-underline \fIboolean\fR +\fIBoolean\fR specifies whether or not to draw an underline underneath +characters. +It may have any of the forms accepted by \fBTk_GetBoolean\fR. +.TP +\fB\-wrap \fImode\fR +\fIMode\fR specifies how to handle lines that are wider than the +text's window. +It has the same legal values as the \fB\-wrap\fR option +for the text widget: \fBnone\fR, \fBchar\fR, or \fBword\fR. +If this tag option is specified, it overrides the \fB\-wrap\fR option +for the text widget. +.PP +If a character has several tags associated with it, and if their +display options conflict, then the options of the highest priority +tag are used. +If a particular display option hasn't been specified for a +particular tag, or if it is specified as an empty string, then +that option will never be used; the next-highest-priority +tag's option will used instead. +If no tag specifies a particular display option, then the default +style for the widget will be used. +.PP +The second purpose for tags is event bindings. +You can associate bindings with a tag in much the same way you can +associate bindings with a widget class: whenever particular X +events occur on characters with the given tag, a given +Tcl command will be executed. +Tag bindings can be used to give behaviors to ranges of characters; +among other things, this allows hypertext-like +features to be implemented. +For details, see the description of the \fBtag bind\fR widget +command below. +.PP +The third use for tags is in managing the selection. +See THE SELECTION below. + +.SH MARKS +.PP +The second form of annotation in text widgets is a mark. +Marks are used for remembering particular places in a text. +They are something like tags, in that they have names and +they refer to places in the file, but a mark isn't associated +with particular characters. +Instead, a mark is associated with the gap between two characters. +Only a single position may be associated with a mark at any given +time. +If the characters around a mark are deleted the mark will still +remain; it will just have new neighbor characters. +In contrast, if the characters containing a tag are deleted then +the tag will no longer have an association with characters in +the file. +Marks may be manipulated with the ``\fIpathName \fBmark\fR'' widget +command, and their current locations may be determined by using the +mark name as an index in widget commands. +.PP +Each mark also has a \fIgravity\fR, which is either \fBleft\fR or +\fBright\fR. +The gravity for a mark specifies what happens to the mark when +text is inserted at the point of the mark. +If a mark has left gravity, then the mark is treated as if it +were attached to the character on its left, so the mark will +remain to the left of any text inserted at the mark position. +If the mark has right gravity, new text inserted at the mark +position will appear to the right of the mark. The gravity +for a mark defaults to \fBright\fR. +.PP +The name space for marks is different from that for tags: the +same name may be used for both a mark and a tag, but they will refer +to different things. +.PP +Two marks have special significance. +First, the mark \fBinsert\fR is associated with the insertion cursor, +as described under THE INSERTION CURSOR below. +Second, the mark \fBcurrent\fR is associated with the character +closest to the mouse and is adjusted automatically to track the +mouse position and any changes to the text in the widget (one +exception: \fBcurrent\fR is not updated in response to mouse +motions if a mouse button is down; the update will be deferred +until all mouse buttons have been released). +Neither of these special marks may be deleted. + +.SH EMBEDDED WINDOWS +.PP +The third form of annotation in text widgets is an embedded window. +Each embedded window annotation causes a window to be displayed +at a particular point in the text. +There may be any number of embedded windows in a text widget, +and any widget may be used as an embedded window (subject to the +usual rules for geometry management, which require the text window +to be the parent of the embedded window or a descendant of its +parent). +The embedded window's position on the screen will be updated as the +text is modified or scrolled, and it will be mapped and unmapped as +it moves into and out of the visible area of the text widget. +Each embedded window occupies one character's worth of index space +in the text widget, and it may be referred to either by the name +of its embedded window or by its position in the widget's +index space. +If the range of text containing the embedded window is deleted then +the window is destroyed. +.PP +When an embedded window is added to a text widget with the +\fBwindow create\fR widget command, several configuration +options may be associated with it. +These options may be modified later with the \fBwindow configure\fR +widget command. +The following options are currently supported: +.TP +\fB\-align \fIwhere\fR +If the window is not as tall as the line in which it is displayed, +this option determines where the window is displayed in the line. +\fIWhere\fR must have one of the values \fBtop\fR (align the top of the window +with the top of the line), \fBcenter\fR (center the window +within the range of the line), \fBbottom\fR (align the bottom of the +window with the bottom of the line's area), +or \fBbaseline\fR (align the bottom of the window with the baseline +of the line). +.TP +\fB\-create \fIscript\fR +Specifies a Tcl script that may be evaluated to create the window +for the annotation. +If no \fB\-window\fR option has been specified for the annotation +this script will be evaluated when the annotation is about to +be displayed on the screen. +\fIScript\fR must create a window for the annotation and return +the name of that window as its result. +If the annotation's window should ever be deleted, \fIscript\fR +will be evaluated again the next time the annotation is displayed. +.TP +\fB\-padx \fIpixels\fR +\fIPixels\fR specifies the amount of extra space to leave on +each side of the embedded window. +It may have any of the usual forms defined for a screen distance. +.TP +\fB\-pady \fIpixels\fR +\fIPixels\fR specifies the amount of extra space to leave on +the top and on the bottom of the embedded window. +It may have any of the usual forms defined for a screen distance. +.TP +\fB\-stretch \fIboolean\fR +If the requested height of the embedded window is less than the +height of the line in which it is displayed, this option can be +used to specify whether the window should be stretched vertically +to fill its line. +If the \fB\-pady\fR option has been specified as well, then the +requested padding will be retained even if the window is +stretched. +.TP +\fB\-window \fIpathName\fR +Specifies the name of a window to display in the annotation. + +.SH THE SELECTION +.PP +Text widgets support the standard X selection. +Selection support is implemented via tags. +If the \fBexportSelection\fR option for the text widget is true +then the \fBsel\fR tag will be associated with the selection: +.IP [1] +Whenever characters are tagged with \fBsel\fR the text widget +will claim ownership of the selection. +.IP [2] +Attempts to retrieve the +selection will be serviced by the text widget, returning all the +characters with the \fBsel\fR tag. +.IP [3] +If the selection is claimed away by another application or by another +window within this application, then the \fBsel\fR tag will be removed +from all characters in the text. +.PP +The \fBsel\fR tag is automatically defined when a text widget is +created, and it may not be deleted with the ``\fIpathName \fBtag delete\fR'' +widget command. Furthermore, the \fBselectBackground\fR, +\fBselectBorderWidth\fR, and \fBselectForeground\fR options for +the text widget are tied to the \fB\-background\fR, +\fB\-borderwidth\fR, and \fB\-foreground\fR options for the \fBsel\fR +tag: changes in either will automatically be reflected in the +other. + +.SH THE INSERTION CURSOR +.PP +The mark named \fBinsert\fR has special significance in text widgets. +It is defined automatically when a text widget is created and it +may not be unset with the ``\fIpathName \fBmark unset\fR'' widget +command. +The \fBinsert\fR mark represents the position of the insertion +cursor, and the insertion cursor will automatically be drawn at +this point whenever the text widget has the input focus. + +.SH "WIDGET COMMAND" +.PP +The \fBtext\fR command creates a new Tcl command whose +name is the same as the path name of the text's window. This +command may be used to invoke various +operations on the widget. It has the following general form: +.CS +\fIpathName option \fR?\fIarg arg ...\fR? +.CE +\fIPathName\fR is the name of the command, which is the same as +the text widget's path name. \fIOption\fR and the \fIarg\fRs +determine the exact behavior of the command. The following +commands are possible for text widgets: +.TP +\fIpathName \fBbbox \fIindex\fR +Returns a list of four elements describing the screen area +of the character given by \fIindex\fR. +The first two elements of the list give the x and y coordinates +of the upper-left corner of the area occupied by the +character, and the last two elements give the width and height +of the area. +If the character is only partially visible on the screen, then +the return value reflects just the visible part. +If the character is not visible on the screen then the return +value is an empty list. +.TP +\fIpathName \fBcget\fR \fIoption\fR +Returns the current value of the configuration option given +by \fIoption\fR. +\fIOption\fR may have any of the values accepted by the \fBtext\fR +command. +.TP +\fIpathName \fBcompare\fR \fIindex1 op index2\fR +Compares the indices given by \fIindex1\fR and \fIindex2\fR according +to the relational operator given by \fIop\fR, and returns 1 if +the relationship is satisfied and 0 if it isn't. +\fIOp\fR must be one of the operators <, <=, ==, >=, >, or !=. +If \fIop\fR is == then 1 is returned if the two indices refer to +the same character, if \fIop\fR is < then 1 is returned if \fIindex1\fR +refers to an earlier character in the text than \fIindex2\fR, and +so on. +.TP +\fIpathName \fBconfigure\fR ?\fIoption\fR? \fI?value option value ...\fR? +Query or modify the configuration options of the widget. +If no \fIoption\fR is specified, returns a list describing all of +the available options for \fIpathName\fR (see \fBTk_ConfigureInfo\fR for +information on the format of this list). If \fIoption\fR is specified +with no \fIvalue\fR, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no \fIoption\fR is specified). If +one or more \fIoption\-value\fR pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +\fIOption\fR may have any of the values accepted by the \fBtext\fR +command. +.TP +\fIpathName \fBdebug \fR?\fIboolean\fR? +If \fIboolean\fR is specified, then it must have one of the true or +false values accepted by Tcl_GetBoolean. +If the value is a true one then internal consistency checks will be +turned on in the B-tree code associated with text widgets. +If \fIboolean\fR has a false value then the debugging checks will +be turned off. +In either case the command returns an empty string. +If \fIboolean\fR is not specified then the command returns \fBon\fR +or \fBoff\fR to indicate whether or not debugging is turned on. +There is a single debugging switch shared by all text widgets: turning +debugging on or off in any widget turns it on or off for all widgets. +For widgets with large amounts of text, the consistency checks may +cause a noticeable slow-down. +.TP +\fIpathName \fBdelete \fIindex1 \fR?\fIindex2\fR? +Delete a range of characters from the text. +If both \fIindex1\fR and \fIindex2\fR are specified, then delete +all the characters starting with the one given by \fIindex1\fR +and stopping just before \fIindex2\fR (i.e. the character at +\fIindex2\fR is not deleted). +If \fIindex2\fR doesn't specify a position later in the text +than \fIindex1\fR then no characters are deleted. +If \fIindex2\fR isn't specified then the single character at +\fIindex1\fR is deleted. +It is not allowable to delete characters in a way that would leave +the text without a newline as the last character. +The command returns an empty string. +.TP +\fIpathName \fBdlineinfo \fIindex\fR +Returns a list with five elements describing the area occupied +by the display line containing \fIindex\fR. +The first two elements of the list give the x and y coordinates +of the upper-left corner of the area occupied by the +line, the third and fourth elements give the width and height +of the area, and the fifth element gives the position of the baseline +for the line, measured down from the top of the area. +All of this information is measured in pixels. +If the current wrap mode is \fBnone\fR and the line extends beyond +the boundaries of the window, +the area returned reflects the entire area of the line, including the +portions that are out of the window. +If the line is shorter than the full width of the window then the +area returned reflects just the portion of the line that is occupied +by characters and embedded windows. +If the display line containing \fIindex\fR is not visible on +the screen then the return value is an empty list. +.TP +\fIpathName \fBdump \fR?\fIswitches\fR? \fIindex1 \fR?\fIindex2\fR? +Return the contents of the text widget from \fIindex1\fR up to, +but not including \fIindex2\fR, +including the text and +information about marks, tags, and embedded windows. +If \fIindex2\fR is not specified, then it defaults to +one character past \fIindex1\fR. The information is returned +in the following format: +.LP +.RS +\fIkey1 value1 index1 key2 value2 index2\fR ... +.LP +The possible \fIkey\fP values are \fBtext\fP, \fBmark\fP, +\fBtagon\fP, \fBtagoff\fP, and \fBwindow\fP. The corresponding +\fIvalue\fP is the text, mark name, tag name, or window name. +The \fIindex\fP information is the index of the +start of the text, the mark, the tag transition, or the window. +One or more of the following switches (or abbreviations thereof) +may be specified to control the dump: +.TP +\fB\-all\fR +Return information about all elements: text, marks, tags, and windows. +This is the default. +.TP +\fB\-command \fIcommand\fR +Instead of returning the information as the result of the dump operation, +invoke the \fIcommand\fR on each element of the text widget within the range. +The command has three arguments appended to it before it is evaluated: +the \fIkey\fP, \fIvalue\fP, and \fIindex\fP. +.TP +\fB\-mark\fR +Include information about marks in the dump results. +.TP +\fB\-tag\fR +Include information about tag transitions in the dump results. Tag information is +returned as \fBtagon\fP and \fBtagoff\fP elements that indicate the +begin and end of each range of each tag, respectively. +.TP +\fB\-text\fR +Include information about text in the dump results. The value is the +text up to the next element or the end of range indicated by \fIindex2\fR. +A text element does not span newlines. A multi-line block of text that +contains no marks or tag transitions will still be dumped as a set +of text seqments that each end with a newline. The newline is part +of the value. +.TP +\fB\-window\fR +Include information about embedded windows in the dump results. +The value of a window is its Tk pathname, unless the window +has not been created yet. (It must have a create script.) +In this case an empty string is returned, and you must query the +window by its index position to get more information. +.RE +.TP +\fIpathName \fBget \fIindex1 \fR?\fIindex2\fR? +Return a range of characters from the text. +The return value will be all the characters in the text starting +with the one whose index is \fIindex1\fR and ending just before +the one whose index is \fIindex2\fR (the character at \fIindex2\fR +will not be returned). +If \fIindex2\fR is omitted then the single character at \fIindex1\fR +is returned. +If there are no characters in the specified range (e.g. \fIindex1\fR +is past the end of the file or \fIindex2\fR is less than or equal +to \fIindex1\fR) then an empty string is returned. +If the specified range contains embedded windows, no information +about them is included in the returned string. +.TP +\fIpathName \fBindex \fIindex\fR +Returns the position corresponding to \fIindex\fR in the form +\fIline.char\fR where \fIline\fR is the line number and \fIchar\fR +is the character number. +\fIIndex\fR may have any of the forms described under INDICES above. +.TP +\fIpathName \fBinsert \fIindex chars \fR?\fItagList chars tagList ...\fR? +Inserts all of the \fIchars\fR arguments just before the character at +\fIindex\fR. +If \fIindex\fR refers to the end of the text (the character after +the last newline) then the new text is inserted just before the +last newline instead. +If there is a single \fIchars\fR argument and no \fItagList\fR, then +the new text will receive any tags that are present on both the +character before and the character after the insertion point; if a tag +is present on only one of these characters then it will not be +applied to the new text. +If \fItagList\fR is specified then it consists of a list of +tag names; the new characters will receive all of the tags in +this list and no others, regardless of the tags present around +the insertion point. +If multiple \fIchars\fR\-\fItagList\fR argument pairs are present, +they produce the same effect as if a separate \fBinsert\fR widget +command had been issued for each pair, in order. +The last \fItagList\fR argument may be omitted. +.TP +\fIpathName \fBmark \fIoption \fR?\fIarg arg ...\fR? +This command is used to manipulate marks. The exact behavior of +the command depends on the \fIoption\fR argument that follows +the \fBmark\fR argument. The following forms of the command +are currently supported: +.RS +.TP +\fIpathName \fBmark gravity \fImarkName\fR ?\fIdirection\fR? +If \fIdirection\fR is not specified, returns \fBleft\fR or \fBright\fR +to indicate which of its adjacent characters \fImarkName\fR is attached +to. +If \fIdirection\fR is specified, it must be \fBleft\fR or \fBright\fR; +the gravity of \fImarkName\fR is set to the given value. +.TP +\fIpathName \fBmark names\fR +Returns a list whose elements are the names of all the marks that +are currently set. +.TP +\fIpathName \fBmark next \fIindex\fR +Returns the name of the next mark at or after \fIindex\fR. +If \fIindex\fR is specified in numerical form, then the search for +the next mark begins at that index. +If \fIindex\fR is the name of a mark, then the search for +the next mark begins immediately after that mark. +This can still return a mark at the same position if +there are multiple marks at the same index. +These semantics mean that the \fBmark next\fP operation can be used to +step through all the marks in a text widget in the same order +as the mark information returned by the \fBdump\fP operation. +If a mark has been set to the special \fBend\fB index, +then it appears to be \fIafter\fP \fBend\fP with respect to the \fBmark next\fP operation. +An empty string is returned if there are no marks after \fIindex\fR. +.TP +\fIpathName \fBmark previous \fIindex\fR +Returns the name of the mark at or before \fIindex\fR. +If \fIindex\fR is specified in numerical form, then the search for +the previous mark begins with the character just before that index. +If \fIindex\fR is the name of a mark, then the search for +the next mark begins immediately before that mark. +This can still return a mark at the same position if +there are multiple marks at the same index. +These semantics mean that the \fBmark previous\fP operation can be used to +step through all the marks in a text widget in the reverse order +as the mark information returned by the \fBdump\fP operation. +An empty string is returned if there are no marks before \fIindex\fR. +.TP +\fIpathName \fBmark set \fImarkName index\fR +Sets the mark named \fImarkName\fR to a position just before the +character at \fIindex\fR. +If \fImarkName\fR already exists, it is moved from its old position; +if it doesn't exist, a new mark is created. +This command returns an empty string. +.TP +\fIpathName \fBmark unset \fImarkName \fR?\fImarkName markName ...\fR? +Remove the mark corresponding to each of the \fImarkName\fR arguments. +The removed marks will not be usable in indices and will not be +returned by future calls to ``\fIpathName \fBmark names\fR''. +This command returns an empty string. +.RE +.TP +\fIpathName \fBscan\fR \fIoption args\fR +This command is used to implement scanning on texts. It has +two forms, depending on \fIoption\fR: +.RS +.TP +\fIpathName \fBscan mark \fIx y\fR +Records \fIx\fR and \fIy\fR and the current view in the text window, +for use in conjunction with later \fBscan dragto\fR commands. +Typically this command is associated with a mouse button press in +the widget. It returns an empty string. +.TP +\fIpathName \fBscan dragto \fIx y\fR +This command computes the difference between its \fIx\fR and \fIy\fR +arguments and the \fIx\fR and \fIy\fR arguments to the last +\fBscan mark\fR command for the widget. +It then adjusts the view by 10 times the difference in coordinates. +This command is typically associated +with mouse motion events in the widget, to produce the effect of +dragging the text at high speed through the window. The return +value is an empty string. +.RE +.TP +\fIpathName \fBsearch \fR?\fIswitches\fR? \fIpattern index \fR?\fIstopIndex\fR? +Searches the text in \fIpathName\fR starting at \fIindex\fR for a range +of characters that matches \fIpattern\fR. +If a match is found, the index of the first character in the match is +returned as result; otherwise an empty string is returned. +One or more of the following switches (or abbreviations thereof) +may be specified to control the search: +.RS +.TP +\fB\-forwards\fR +The search will proceed forward through the text, finding the first +matching range starting at or after the position given by \fIindex\fR. +This is the default. +.TP +\fB\-backwards\fR +The search will proceed backward through the text, finding the +matching range closest to \fIindex\fR whose first character +is before \fIindex\fR. +.TP +\fB\-exact\fR +Use exact matching: the characters in the matching range must be +identical to those in \fIpattern\fR. +This is the default. +.TP +\fB\-regexp\fR +Treat \fIpattern\fR as a regular expression and match it against +the text using the rules for regular expressions (see the \fBregexp\fR +command for details). +.TP +\fB\-nocase\fR +Ignore case differences between the pattern and the text. +.TP +\fB\-count\fI varName\fR +The argument following \fB\-count\fR gives the name of a variable; +if a match is found, the number of characters in the matching +range will be stored in the variable. +.TP +\fB\-\|\-\fR +This switch has no effect except to terminate the list of switches: +the next argument will be treated as \fIpattern\fR even if it starts +with \fB\-\fR. +.LP +The matching range must be entirely within a single line of text. +For regular expression matching the newlines are removed from the ends +of the lines before matching: use the \fB$\fR feature in regular +expressions to match the end of a line. +For exact matching the newlines are retained. +If \fIstopIndex\fR is specified, the search stops at that index: +for forward searches, no match at or after \fIstopIndex\fR will +be considered; for backward searches, no match earlier in the +text than \fIstopIndex\fR will be considered. +If \fIstopIndex\fR is omitted, the entire text will be searched: +when the beginning or end of the text is reached, the search +continues at the other end until the starting location is reached +again; if \fIstopIndex\fR is specified, no wrap-around will occur. +.RE +.TP +\fIpathName \fBsee \fIindex\fR +Adjusts the view in the window so that the character given by \fIindex\fR +is completely visible. +If \fIindex\fR is already visible then the command does nothing. +If \fIindex\fR is a short distance out of view, the command +adjusts the view just enough to make \fIindex\fR visible at the +edge of the window. +If \fIindex\fR is far out of view, then the command centers +\fIindex\fR in the window. +.TP +\fIpathName \fBtag \fIoption \fR?\fIarg arg ...\fR? +This command is used to manipulate tags. The exact behavior of the +command depends on the \fIoption\fR argument that follows the +\fBtag\fR argument. The following forms of the command are currently +supported: +.RS +.TP +\fIpathName \fBtag add \fItagName index1 \fR?\fIindex2 index1 index2 ...\fR? +Associate the tag \fItagName\fR with all of the characters starting +with \fIindex1\fR and ending just before +\fIindex2\fR (the character at \fIindex2\fR isn't tagged). +A single command may contain any number of \fIindex1\fR\-\fIindex2\fR +pairs. +If the last \fIindex2\fR is omitted then the single character at +\fIindex1\fR is tagged. +If there are no characters in the specified range (e.g. \fIindex1\fR +is past the end of the file or \fIindex2\fR is less than or equal +to \fIindex1\fR) then the command has no effect. +.TP +\fIpathName \fBtag bind \fItagName\fR ?\fIsequence\fR? ?\fIscript\fR? +This command associates \fIscript\fR with the tag given by +\fItagName\fR. +Whenever the event sequence given by \fIsequence\fR occurs for a +character that has been tagged with \fItagName\fR, +the script will be invoked. +This widget command is similar to the \fBbind\fR command except that +it operates on characters in a text rather than entire widgets. +See the \fBbind\fR manual entry for complete details +on the syntax of \fIsequence\fR and the substitutions performed +on \fIscript\fR before invoking it. +If all arguments are specified then a new binding is created, replacing +any existing binding for the same \fIsequence\fR and \fItagName\fR +(if the first character of \fIscript\fR is ``+'' then \fIscript\fR +augments an existing binding rather than replacing it). +In this case the return value is an empty string. +If \fIscript\fR is omitted then the command returns the \fIscript\fR +associated with \fItagName\fR and \fIsequence\fR (an error occurs +if there is no such binding). +If both \fIscript\fR and \fIsequence\fR are omitted then the command +returns a list of all the sequences for which bindings have been +defined for \fItagName\fR. +.RS +.PP +The only events for which bindings may be specified are those related +to the mouse and keyboard, such as \fBEnter\fR, \fBLeave\fR, +\fBButtonPress\fR, \fBMotion\fR, and \fBKeyPress\fR. +Event bindings for a text widget use the \fBcurrent\fR mark +described under MARKS above. +An \fBEnter\fR event triggers for a tag when the tag first +becomes present on the current character, and a \fBLeave\fR +event triggers for a tag when it ceases to be present on +the current character. +\fBEnter\fR and \fBLeave\fR events can happen either because the +\fBcurrent\fR mark moved or because the character at that +position changed. +Note that these events are different than \fBEnter\fR and \fBLeave\fR +events for windows. +Mouse and keyboard events are directed to the current character. +.PP +It is possible for the current character to have multiple tags, +and for each of them to have a binding for a particular event +sequence. +When this occurs, one binding is invoked for each tag, in order +from lowest-priority to highest priority. +If there are multiple matching bindings for a single tag, then +the most specific binding is chosen (see the manual entry for +the \fBbind\fR command for details). +\fBcontinue\fR and \fBbreak\fR commands within binding scripts +are processed in the same way as for bindings created with +the \fBbind\fR command. +.PP +If bindings are created for the widget as a whole using the +\fBbind\fR command, then those bindings will supplement the +tag bindings. +The tag bindings will be invoked first, followed by bindings +for the window as a whole. +.RE +.TP +\fIpathName \fBtag cget\fR \fItagName option\fR +This command returns the current value of the option named \fIoption\fR +associated with the tag given by \fItagName\fR. +\fIOption\fR may have any of the values accepted by the \fBtag configure\fR +widget command. +.TP +\fIpathName \fBtag configure \fItagName\fR ?\fIoption\fR? ?\fIvalue\fR? ?\fIoption value ...\fR? +This command is similar to the \fBconfigure\fR widget command except +that it modifies options associated with the tag given by \fItagName\fR +instead of modifying options for the overall text widget. +If no \fIoption\fR is specified, the command returns a list describing +all of the available options for \fItagName\fR (see \fBTk_ConfigureInfo\fR +for information on the format of this list). +If \fIoption\fR is specified with no \fIvalue\fR, then the command returns +a list describing the one named option (this list will be identical to +the corresponding sublist of the value returned if no \fIoption\fR +is specified). +If one or more \fIoption\-value\fR pairs are specified, then the command +modifies the given option(s) to have the given value(s) in \fItagName\fR; +in this case the command returns an empty string. +See TAGS above for details on the options available for tags. +.TP +\fIpathName \fBtag delete \fItagName \fR?\fItagName ...\fR? +Deletes all tag information for each of the \fItagName\fR +arguments. +The command removes the tags from all characters in the file +and also deletes any other information associated with the tags, +such as bindings and display information. +The command returns an empty string. +.TP +\fIpathName\fB tag lower \fItagName \fR?\fIbelowThis\fR? +Changes the priority of tag \fItagName\fR so that it is just lower +in priority than the tag whose name is \fIbelowThis\fR. +If \fIbelowThis\fR is omitted, then \fItagName\fR's priority +is changed to make it lowest priority of all tags. +.TP +\fIpathName \fBtag names \fR?\fIindex\fR? +Returns a list whose elements are the names of all the tags that +are active at the character position given by \fIindex\fR. +If \fIindex\fR is omitted, then the return value will describe +all of the tags that exist for the text (this includes all tags +that have been named in a ``\fIpathName \fBtag\fR'' widget +command but haven't been deleted by a ``\fIpathName \fBtag delete\fR'' +widget command, even if no characters are currently marked with +the tag). +The list will be sorted in order from lowest priority to highest +priority. +.TP +\fIpathName \fBtag nextrange \fItagName index1 \fR?\fIindex2\fR? +This command searches the text for a range of characters tagged +with \fItagName\fR where the first character of the range is +no earlier than the character at \fIindex1\fR and no later than +the character just before \fIindex2\fR (a range starting at +\fIindex2\fR will not be considered). +If several matching ranges exist, the first one is chosen. +The command's return value is a list containing +two elements, which are the index of the first character of the +range and the index of the character just after the last one in +the range. +If no matching range is found then the return value is an +empty string. +If \fIindex2\fR is not given then it defaults to the end of the text. +.TP +\fIpathName \fBtag prevrange \fItagName index1 \fR?\fIindex2\fR? +This command searches the text for a range of characters tagged +with \fItagName\fR where the first character of the range is +before the character at \fIindex1\fR and no earlier than +the character at \fIindex2\fR (a range starting at +\fIindex2\fR will be considered). +If several matching ranges exist, the one closest to \fIindex1\fR is chosen. +The command's return value is a list containing +two elements, which are the index of the first character of the +range and the index of the character just after the last one in +the range. +If no matching range is found then the return value is an +empty string. +If \fIindex2\fR is not given then it defaults to the beginning of the text. +.TP +\fIpathName\fB tag raise \fItagName \fR?\fIaboveThis\fR? +Changes the priority of tag \fItagName\fR so that it is just higher +in priority than the tag whose name is \fIaboveThis\fR. +If \fIaboveThis\fR is omitted, then \fItagName\fR's priority +is changed to make it highest priority of all tags. +.TP +\fIpathName \fBtag ranges \fItagName\fR +Returns a list describing all of the ranges of text that have been +tagged with \fItagName\fR. +The first two elements of the list describe the first tagged range +in the text, the next two elements describe the second range, and +so on. +The first element of each pair contains the index of the first +character of the range, and the second element of the pair contains +the index of the character just after the last one in the +range. +If there are no characters tagged with \fItag\fR then an +empty string is returned. +.TP +\fIpathName \fBtag remove \fItagName index1 \fR?\fIindex2 index1 index2 ...\fR? +Remove the tag \fItagName\fR from all of the characters starting +at \fIindex1\fR and ending just before +\fIindex2\fR (the character at \fIindex2\fR isn't affected). +A single command may contain any number of \fIindex1\fR\-\fIindex2\fR +pairs. +If the last \fIindex2\fR is omitted then the single character at +\fIindex1\fR is tagged. +If there are no characters in the specified range (e.g. \fIindex1\fR +is past the end of the file or \fIindex2\fR is less than or equal +to \fIindex1\fR) then the command has no effect. +This command returns an empty string. +.RE +.TP +\fIpathName \fBwindow \fIoption \fR?\fIarg arg ...\fR? +This command is used to manipulate embedded windows. +The behavior of the command depends on the \fIoption\fR argument +that follows the \fBtag\fR argument. +The following forms of the command are currently supported: +.RS +.TP +\fIpathName \fBwindow cget\fR \fIindex option\fR +Returns the value of a configuration option for an embedded window. +\fIIndex\fR identifies the embedded window, and \fIoption\fR +specifies a particular configuration option, which must be one of +the ones listed in the section EMBEDDED WINDOWS. +.TP +\fIpathName \fBwindow configure \fIindex\fR ?\fIoption value ...\fR? +Query or modify the configuration options for an embedded window. +If no \fIoption\fR is specified, returns a list describing all of +the available options for the embedded window at \fIindex\fR +(see \fBTk_ConfigureInfo\fR for information on the format of this list). +If \fIoption\fR is specified with no \fIvalue\fR, then the command +returns a list describing the one named option (this list will be +identical to the corresponding sublist of the value returned if no +\fIoption\fR is specified). +If one or more \fIoption\-value\fR pairs are specified, then the command +modifies the given option(s) to have the given value(s); in +this case the command returns an empty string. +See EMBEDDED WINDOWS for information on the options that +are supported. +.TP +\fIpathName \fBwindow create \fIindex\fR ?\fIoption value ...\fR? +This command creates a new window annotation, which will appear +in the text at the position given by \fIindex\fR. +Any number of \fIoption\-value\fR pairs may be specified to +configure the annotation. +See EMBEDDED WINDOWS for information on the options that +are supported. +Returns an empty string. +.TP +\fIpathName \fBwindow names\fR +Returns a list whose elements are the names of all windows currently +embedded in \fIwindow\fR. +.RE +.TP +\fIpathName \fBxview \fIoption args\fR +This command is used to query and change the horizontal position of the +text in the widget's window. It can take any of the following +forms: +.RS +.TP +\fIpathName \fBxview\fR +Returns a list containing two elements. +Each element is a real fraction between 0 and 1; together they describe +the portion of the document's horizontal span that is visible in +the window. +For example, if the first element is .2 and the second element is .6, +20% of the text is off-screen to the left, the middle 40% is visible +in the window, and 40% of the text is off-screen to the right. +The fractions refer only to the lines that are actually visible in the +window: if the lines in the window are all very short, so that they +are entirely visible, the returned fractions will be 0 and 1, +even if there are other lines in the text that are +much wider than the window. +These are the same values passed to scrollbars via the \fB\-xscrollcommand\fR +option. +.TP +\fIpathName \fBxview moveto\fI fraction\fR +Adjusts the view in the window so that \fIfraction\fR of the horizontal +span of the text is off-screen to the left. +\fIFraction\fR is a fraction between 0 and 1. +.TP +\fIpathName \fBxview scroll \fInumber what\fR +This command shifts the view in the window left or right according to +\fInumber\fR and \fIwhat\fR. +\fINumber\fR must be an integer. +\fIWhat\fR must be either \fBunits\fR or \fBpages\fR or an abbreviation +of one of these. +If \fIwhat\fR is \fBunits\fR, the view adjusts left or right by +\fInumber\fR average-width characters on the display; if it is +\fBpages\fR then the view adjusts by \fInumber\fR screenfuls. +If \fInumber\fR is negative then characters farther to the left +become visible; if it is positive then characters farther to the right +become visible. +.RE +.TP +\fIpathName \fByview \fI?args\fR? +This command is used to query and change the vertical position of the +text in the widget's window. +It can take any of the following forms: +.RS +.TP +\fIpathName \fByview\fR +Returns a list containing two elements, both of which are real fractions +between 0 and 1. +The first element gives the position of the first character in the +top line in the window, relative to the text as a whole (0.5 means +it is halfway through the text, for example). +The second element gives the position of the character just after +the last one in the bottom line of the window, +relative to the text as a whole. +These are the same values passed to scrollbars via the \fB\-yscrollcommand\fR +option. +.TP +\fIpathName \fByview moveto\fI fraction\fR +Adjusts the view in the window so that the character given by \fIfraction\fR +appears on the top line of the window. +\fIFraction\fR is a fraction between 0 and 1; 0 indicates the first +character in the text, 0.33 indicates the character one-third the +way through the text, and so on. +.TP +\fIpathName \fByview scroll \fInumber what\fR +This command adjust the view in the window up or down according to +\fInumber\fR and \fIwhat\fR. +\fINumber\fR must be an integer. +\fIWhat\fR must be either \fBunits\fR or \fBpages\fR. +If \fIwhat\fR is \fBunits\fR, the view adjusts up or down by +\fInumber\fR lines on the display; if it is \fBpages\fR then +the view adjusts by \fInumber\fR screenfuls. +If \fInumber\fR is negative then earlier positions in the text +become visible; if it is positive then later positions in the text +become visible. +.TP +\fIpathName \fByview \fR?\fB\-pickplace\fR? \fIindex\fR +Changes the view in the widget's window to make \fIindex\fR visible. +If the \fB\-pickplace\fR option isn't specified then \fIindex\fR will +appear at the top of the window. +If \fB\-pickplace\fR is specified then the widget chooses where +\fIindex\fR appears in the window: +.RS +.IP [1] +If \fIindex\fR is already visible somewhere in the window then the +command does nothing. +.IP [2] +If \fIindex\fR is only a few lines off-screen above the window then +it will be positioned at the top of the window. +.IP [3] +If \fIindex\fR is only a few lines off-screen below the window then +it will be positioned at the bottom of the window. +.IP [4] +Otherwise, \fIindex\fR will be centered in the window. +.LP +The \fB\-pickplace\fR option has been obsoleted by the \fBsee\fR widget +command (\fBsee\fR handles both x- and y-motion to make a location +visible, whereas \fB\-pickplace\fR only handles motion in y). +.RE +.TP +\fIpathName \fByview \fInumber\fR +This command makes the first character on the line after +the one given by \fInumber\fR visible at the top of the window. +\fINumber\fR must be an integer. +This command used to be used for scrolling, but now it is obsolete. +.RE + +.SH BINDINGS +.PP +Tk automatically creates class bindings for texts that give them +the following default behavior. +In the descriptions below, ``word'' refers to a contiguous group +of letters, digits, or ``_'' characters, or any single character +other than these. +.IP [1] +Clicking mouse button 1 positions the insertion cursor +just before the character underneath the mouse cursor, sets the +input focus to this widget, and clears any selection in the widget. +Dragging with mouse button 1 strokes out a selection between +the insertion cursor and the character under the mouse. +.IP [2] +Double-clicking with mouse button 1 selects the word under the mouse +and positions the insertion cursor at the beginning of the word. +Dragging after a double click will stroke out a selection consisting +of whole words. +.IP [3] +Triple-clicking with mouse button 1 selects the line under the mouse +and positions the insertion cursor at the beginning of the line. +Dragging after a triple click will stroke out a selection consisting +of whole lines. +.IP [4] +The ends of the selection can be adjusted by dragging with mouse +button 1 while the Shift key is down; this will adjust the end +of the selection that was nearest to the mouse cursor when button +1 was pressed. +If the button is double-clicked before dragging then the selection +will be adjusted in units of whole words; if it is triple-clicked +then the selection will be adjusted in units of whole lines. +.IP [5] +Clicking mouse button 1 with the Control key down will reposition the +insertion cursor without affecting the selection. +.IP [6] +If any normal printing characters are typed, they are +inserted at the point of the insertion cursor. +.IP [7] +The view in the widget can be adjusted by dragging with mouse button 2. +If mouse button 2 is clicked without moving the mouse, the selection +is copied into the text at the position of the mouse cursor. +The Insert key also inserts the selection, but at the position of +the insertion cursor. +.IP [8] +If the mouse is dragged out of the widget +while button 1 is pressed, the entry will automatically scroll to +make more text visible (if there is more text off-screen on the side +where the mouse left the window). +.IP [9] +The Left and Right keys move the insertion cursor one character to the +left or right; they also clear any selection in the text. +If Left or Right is typed with the Shift key down, then the insertion +cursor moves and the selection is extended to include the new character. +Control-Left and Control-Right move the insertion cursor by words, and +Control-Shift-Left and Control-Shift-Right move the insertion cursor +by words and also extend the selection. +Control-b and Control-f behave the same as Left and Right, respectively. +Meta-b and Meta-f behave the same as Control-Left and Control-Right, +respectively. +.IP [10] +The Up and Down keys move the insertion cursor one line up or +down and clear any selection in the text. +If Up or Right is typed with the Shift key down, then the insertion +cursor moves and the selection is extended to include the new character. +Control-Up and Control-Down move the insertion cursor by paragraphs (groups +of lines separated by blank lines), and +Control-Shift-Up and Control-Shift-Down move the insertion cursor +by paragraphs and also extend the selection. +Control-p and Control-n behave the same as Up and Down, respectively. +.IP [11] +The Next and Prior keys move the insertion cursor forward or backwards +by one screenful and clear any selection in the text. +If the Shift key is held down while Next or Prior is typed, then +the selection is extended to include the new character. +Control-v moves the view down one screenful without moving the +insertion cursor or adjusting the selection. +.IP [12] +Control-Next and Control-Prior scroll the view right or left by one page +without moving the insertion cursor or affecting the selection. +.IP [13] +Home and Control-a move the insertion cursor to the +beginning of its line and clear any selection in the widget. +Shift-Home moves the insertion cursor to the beginning of the line +and also extends the selection to that point. +.IP [14] +End and Control-e move the insertion cursor to the +end of the line and clear any selection in the widget. +Shift-End moves the cursor to the end of the line and extends the selection +to that point. +.IP [15] +Control-Home and Meta-< move the insertion cursor to the beginning of +the text and clear any selection in the widget. +Control-Shift-Home moves the insertion cursor to the beginning of the text +and also extends the selection to that point. +.IP [16] +Control-End and Meta-> move the insertion cursor to the end of the +text and clear any selection in the widget. +Control-Shift-End moves the cursor to the end of the text and extends +the selection to that point. +.IP [17] +The Select key and Control-Space set the selection anchor to the position +of the insertion cursor. They don't affect the current selection. +Shift-Select and Control-Shift-Space adjust the selection to the +current position of the insertion cursor, selecting from the anchor +to the insertion cursor if there was not any selection previously. +.IP [18] +Control-/ selects the entire contents of the widget. +.IP [19] +Control-\e clears any selection in the widget. +.IP [20] +The F16 key (labelled Copy on many Sun workstations) or Meta-w +copies the selection in the widget to the clipboard, if there is a selection. +.IP [21] +The F20 key (labelled Cut on many Sun workstations) or Control-w +copies the selection in the widget to the clipboard and deletes +the selection. +If there is no selection in the widget then these keys have no effect. +.IP [22] +The F18 key (labelled Paste on many Sun workstations) or Control-y +inserts the contents of the clipboard at the position of the +insertion cursor. +.IP [23] +The Delete key deletes the selection, if there is one in the widget. +If there is no selection, it deletes the character to the right of +the insertion cursor. +.IP [24] +Backspace and Control-h delete the selection, if there is one +in the widget. +If there is no selection, they delete the character to the left of +the insertion cursor. +.IP [25] +Control-d deletes the character to the right of the insertion cursor. +.IP [26] +Meta-d deletes the word to the right of the insertion cursor. +.IP [27] +Control-k deletes from the insertion cursor to the end of its line; +if the insertion cursor is already at the end of a line, then +Control-k deletes the newline character. +.IP [28] +Control-o opens a new line by inserting a newline character in +front of the insertion cursor without moving the insertion cursor. +.IP [29] +Meta-backspace and Meta-Delete delete the word to the left of the +insertion cursor. +.IP [30] +Control-x deletes whatever is selected in the text widget. +.IP [31] +Control-t reverses the order of the two characters to the right of +the insertion cursor. +.PP +If the widget is disabled using the \fB\-state\fR option, then its +view can still be adjusted and text can still be selected, +but no insertion cursor will be displayed and no text modifications will +take place. +.PP +The behavior of texts can be changed by defining new bindings for +individual widgets or by redefining the class bindings. + +.SH "PERFORMANCE ISSUES" +.PP +Text widgets should run efficiently under a variety +of conditions. The text widget uses about 2-3 bytes of +main memory for each byte of text, so texts containing a megabyte +or more should be practical on most workstations. +Text is represented internally with a modified B-tree structure +that makes operations relatively efficient even with large texts. +Tags are included in the B-tree structure in a way that allows +tags to span large ranges or have many disjoint smaller ranges +without loss of efficiency. +Marks are also implemented in a way that allows large numbers of +marks. +In most cases it is fine to have large numbers of unique tags, +or a tag that has many distinct ranges. +.PP +One performance problem can arise if you have hundreds or thousands +of different tags that all have the following characteristics: +the first and last ranges of each tag are near the beginning and +end of the text, respectively, +or a single tag range covers most of the text widget. +The cost of adding and deleting tags like this is proportional +to the number of other tags with the same properties. +In contrast, there is no problem with having thousands of distinct +tags if their overall ranges are localized and spread uniformly throughout +the text. +.PP +Very long text lines can be expensive, +especially if they have many marks and tags within them. +.PP +The display line with the insert cursor is redrawn each time the +cursor blinks, which causes a steady stream of graphics traffic. +Set the \fBinsertOffTime\fP attribute to 0 avoid this. +.SH KEYWORDS +text, widget diff --git a/tk4.2/doc/tk.n b/tk4.2/doc/tk.n new file mode 100644 index 0000000..70347aa --- /dev/null +++ b/tk4.2/doc/tk.n @@ -0,0 +1,48 @@ +'\" +'\" Copyright (c) 1992 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) tk.n 1.13 96/08/27 13:21:24 +'\" +.so man.macros +.TH tk n 4.0 Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +tk \- Manipulate Tk internal state +.SH SYNOPSIS +\fBtk\fR \fIoption \fR?\fIarg arg ...\fR? +.BE + +.SH DESCRIPTION +.PP +The \fBtk\fR command provides access to miscellaneous +elements of Tk's internal state. +Most of the information manipulated by this command pertains to the +application as a whole, or to a screen or display, rather than to a +particular window. +The command can take any of a number of different forms +depending on the \fIoption\fR argument. The legal forms are: +.TP +\fBtk appname ?\fInewName\fR? +If \fInewName\fR isn't specified, this command returns the name +of the application (the name that may be used in \fBsend\fR +commands to communicate with the application). +If \fInewName\fR is specified, then the name of the application +is changed to \fInewName\fR. +If the given name is already in use, then a suffix of the form +``\fB #2\fR'' or ``\fB #3\fR'' is appended in order to make the name unique. +The command's result is the name actually chosen. +\fInewName\fR should not start with a capital letter. +This will interfere with option processing, since names starting with +capitals are assumed to be classes; as a result, Tk may not +be able to find some options for the application. +If sends have been disabled by deleting the \fBsend\fR command, +this command will reenable them and recreate the \fBsend\fR +command. + +.SH KEYWORDS +application name, send diff --git a/tk4.2/doc/tk4.0.ps b/tk4.2/doc/tk4.0.ps new file mode 100644 index 0000000..d79642d --- /dev/null +++ b/tk4.2/doc/tk4.0.ps @@ -0,0 +1,4602 @@ +%! +%%BoundingBox: (atend) +%%Pages: (atend) +%%DocumentFonts: (atend) +%%EndComments +%%BeginProlog +% +% FrameMaker postscript_prolog 3.0, for use with FrameMaker 3.0 +% This postscript_prolog file is Copyright (c) 1986-1991 Frame Technology +% Corporation. All rights reserved. This postscript_prolog file may be +% freely copied and distributed in conjunction with documents created using +% FrameMaker. +% NOTE +% This file fixes the problem with NeWS printers dithering color output. +% Any questions should be sent to mickey@magickingdom.eng.sun.com +% +% Known Problems: +% Due to bugs in Transcript, the 'PS-Adobe-' is omitted from line 1 +/FMversion (3.0) def +% Set up Color vs. Black-and-White + +/FMPrintInColor { % once-thru loop gimmick + % See if we're a NeWSprint printer + /currentcanvas where { + pop systemdict /separationdict known + exit + } if +% originally had the following, which should always be false: +% /currentcanvas where { +% pop currentcanvas /Color known { +% currentcanvas /Color get +% exit +% } if +% } if + systemdict /colorimage known + systemdict /currentcolortransfer known and +exit } loop def + +% Uncomment the following line to force b&w on color printer +% /FMPrintInColor false def +/FrameDict 195 dict def +systemdict /errordict known not {/errordict 10 dict def + errordict /rangecheck {stop} put} if +% The readline in 23.0 doesn't recognize cr's as nl's on AppleTalk +FrameDict /tmprangecheck errordict /rangecheck get put +errordict /rangecheck {FrameDict /bug true put} put +FrameDict /bug false put +mark +% Some PS machines read past the CR, so keep the following 3 lines together! +currentfile 5 string readline +00 +0000000000 +cleartomark +errordict /rangecheck FrameDict /tmprangecheck get put +FrameDict /bug get { + /readline { + /gstring exch def + /gfile exch def + /gindex 0 def + { + gfile read pop + dup 10 eq {exit} if + dup 13 eq {exit} if + gstring exch gindex exch put + /gindex gindex 1 add def + } loop + pop + gstring 0 gindex getinterval true + } def + } if +/FMVERSION { + FMversion ne { + /Times-Roman findfont 18 scalefont setfont + 100 100 moveto + (FrameMaker version does not match postscript_prolog!) + dup = + show showpage + } if + } def +/FMLOCAL { + FrameDict begin + 0 def + end + } def + /gstring FMLOCAL + /gfile FMLOCAL + /gindex FMLOCAL + /orgxfer FMLOCAL + /orgproc FMLOCAL + /organgle FMLOCAL + /orgfreq FMLOCAL + /yscale FMLOCAL + /xscale FMLOCAL + /manualfeed FMLOCAL + /paperheight FMLOCAL + /paperwidth FMLOCAL +/FMDOCUMENT { + array /FMfonts exch def + /#copies exch def + FrameDict begin + 0 ne dup {setmanualfeed} if + /manualfeed exch def + /paperheight exch def + /paperwidth exch def + /yscale exch def + /xscale exch def + currenttransfer cvlit /orgxfer exch def + currentscreen cvlit /orgproc exch def + /organgle exch def /orgfreq exch def + setpapername + manualfeed {true} {papersize} ifelse + {manualpapersize} {false} ifelse + {desperatepapersize} if + end + } def + /pagesave FMLOCAL + /orgmatrix FMLOCAL + /landscape FMLOCAL +/FMBEGINPAGE { + FrameDict begin + /pagesave save def + 3.86 setmiterlimit + /landscape exch 0 ne def + landscape { + 90 rotate 0 exch neg translate pop + } + {pop pop} + ifelse + xscale yscale scale + /orgmatrix matrix def + gsave + } def +/FMENDPAGE { + grestore + pagesave restore + end + showpage + } def +/FMFONTDEFINE { + FrameDict begin + findfont + ReEncode + 1 index exch + definefont + FMfonts 3 1 roll + put + end + } def +/FMFILLS { + FrameDict begin + array /fillvals exch def + end + } def +/FMFILL { + FrameDict begin + fillvals 3 1 roll put + end + } def +/FMNORMALIZEGRAPHICS { + newpath + 0.0 0.0 moveto + 1 setlinewidth + 0 setlinecap + 0 0 0 sethsbcolor + 0 setgray + } bind def + /fx FMLOCAL + /fy FMLOCAL + /fh FMLOCAL + /fw FMLOCAL + /llx FMLOCAL + /lly FMLOCAL + /urx FMLOCAL + /ury FMLOCAL +/FMBEGINEPSF { + end + /FMEPSF save def + /showpage {} def + FMNORMALIZEGRAPHICS + [/fy /fx /fh /fw /ury /urx /lly /llx] {exch def} forall + fx fy translate + rotate + fw urx llx sub div fh ury lly sub div scale + llx neg lly neg translate + } bind def +/FMENDEPSF { + FMEPSF restore + FrameDict begin + } bind def +FrameDict begin +/setmanualfeed { +%%BeginFeature *ManualFeed True + statusdict /manualfeed true put +%%EndFeature + } def +/max {2 copy lt {exch} if pop} bind def +/min {2 copy gt {exch} if pop} bind def +/inch {72 mul} def +/pagedimen { + paperheight sub abs 16 lt exch + paperwidth sub abs 16 lt and + {/papername exch def} {pop} ifelse + } def + /papersizedict FMLOCAL +/setpapername { + /papersizedict 14 dict def + papersizedict begin + /papername /unknown def + /Letter 8.5 inch 11.0 inch pagedimen + /LetterSmall 7.68 inch 10.16 inch pagedimen + /Tabloid 11.0 inch 17.0 inch pagedimen + /Ledger 17.0 inch 11.0 inch pagedimen + /Legal 8.5 inch 14.0 inch pagedimen + /Statement 5.5 inch 8.5 inch pagedimen + /Executive 7.5 inch 10.0 inch pagedimen + /A3 11.69 inch 16.5 inch pagedimen + /A4 8.26 inch 11.69 inch pagedimen + /A4Small 7.47 inch 10.85 inch pagedimen + /B4 10.125 inch 14.33 inch pagedimen + /B5 7.16 inch 10.125 inch pagedimen + end + } def +/papersize { + papersizedict begin + /Letter {lettertray letter} def + /LetterSmall {lettertray lettersmall} def + /Tabloid {11x17tray 11x17} def + /Ledger {ledgertray ledger} def + /Legal {legaltray legal} def + /Statement {statementtray statement} def + /Executive {executivetray executive} def + /A3 {a3tray a3} def + /A4 {a4tray a4} def + /A4Small {a4tray a4small} def + /B4 {b4tray b4} def + /B5 {b5tray b5} def + /unknown {unknown} def + papersizedict dup papername known {papername} {/unknown} ifelse get + end + /FMdicttop countdictstack 1 add def + statusdict begin stopped end + countdictstack -1 FMdicttop {pop end} for + } def +/manualpapersize { + papersizedict begin + /Letter {letter} def + /LetterSmall {lettersmall} def + /Tabloid {11x17} def + /Ledger {ledger} def + /Legal {legal} def + /Statement {statement} def + /Executive {executive} def + /A3 {a3} def + /A4 {a4} def + /A4Small {a4small} def + /B4 {b4} def + /B5 {b5} def + /unknown {unknown} def + papersizedict dup papername known {papername} {/unknown} ifelse get + end + stopped + } def +/desperatepapersize { + statusdict /setpageparams known + { + paperwidth paperheight 0 1 + statusdict begin + {setpageparams} stopped pop + end + } if + } def +/savematrix { + orgmatrix currentmatrix pop + } bind def +/restorematrix { + orgmatrix setmatrix + } bind def +/dmatrix matrix def +/dpi 72 0 dmatrix defaultmatrix dtransform + dup mul exch dup mul add sqrt def +/freq dpi 18.75 div 8 div round dup 0 eq {pop 1} if 8 mul dpi exch div def +/sangle 1 0 dmatrix defaultmatrix dtransform exch atan def +/DiacriticEncoding [ +/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef +/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef +/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef +/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef +/.notdef /.notdef /.notdef /.notdef /space /exclam /quotedbl +/numbersign /dollar /percent /ampersand /quotesingle /parenleft +/parenright /asterisk /plus /comma /hyphen /period /slash /zero /one +/two /three /four /five /six /seven /eight /nine /colon /semicolon +/less /equal /greater /question /at /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 /bracketleft /backslash +/bracketright /asciicircum /underscore /grave /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 /braceleft /bar +/braceright /asciitilde /.notdef /Adieresis /Aring /Ccedilla /Eacute +/Ntilde /Odieresis /Udieresis /aacute /agrave /acircumflex /adieresis +/atilde /aring /ccedilla /eacute /egrave /ecircumflex /edieresis +/iacute /igrave /icircumflex /idieresis /ntilde /oacute /ograve +/ocircumflex /odieresis /otilde /uacute /ugrave /ucircumflex +/udieresis /dagger /.notdef /cent /sterling /section /bullet +/paragraph /germandbls /registered /copyright /trademark /acute +/dieresis /.notdef /AE /Oslash /.notdef /.notdef /.notdef /.notdef +/yen /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef +/ordfeminine /ordmasculine /.notdef /ae /oslash /questiondown +/exclamdown /logicalnot /.notdef /florin /.notdef /.notdef +/guillemotleft /guillemotright /ellipsis /.notdef /Agrave /Atilde +/Otilde /OE /oe /endash /emdash /quotedblleft /quotedblright +/quoteleft /quoteright /.notdef /.notdef /ydieresis /Ydieresis +/fraction /currency /guilsinglleft /guilsinglright /fi /fl /daggerdbl +/periodcentered /quotesinglbase /quotedblbase /perthousand +/Acircumflex /Ecircumflex /Aacute /Edieresis /Egrave /Iacute +/Icircumflex /Idieresis /Igrave /Oacute /Ocircumflex /.notdef /Ograve +/Uacute /Ucircumflex /Ugrave /dotlessi /circumflex /tilde /macron +/breve /dotaccent /ring /cedilla /hungarumlaut /ogonek /caron +] def +/ReEncode { + dup + length + dict begin + { + 1 index /FID ne + {def} + {pop pop} ifelse + } forall + 0 eq {/Encoding DiacriticEncoding def} if + currentdict + end + } bind def +/graymode true def + /bwidth FMLOCAL + /bpside FMLOCAL + /bstring FMLOCAL + /onbits FMLOCAL + /offbits FMLOCAL + /xindex FMLOCAL + /yindex FMLOCAL + /x FMLOCAL + /y FMLOCAL +/setpattern { + /bwidth exch def + /bpside exch def + /bstring exch def + /onbits 0 def /offbits 0 def + freq sangle landscape {90 add} if + {/y exch def + /x exch def + /xindex x 1 add 2 div bpside mul cvi def + /yindex y 1 add 2 div bpside mul cvi def + bstring yindex bwidth mul xindex 8 idiv add get + 1 7 xindex 8 mod sub bitshift and 0 ne + {/onbits onbits 1 add def 1} + {/offbits offbits 1 add def 0} + ifelse + } + setscreen + {} settransfer + offbits offbits onbits add div FMsetgray + /graymode false def + } bind def +/grayness { + FMsetgray + graymode not { + /graymode true def + orgxfer cvx settransfer + orgfreq organgle orgproc cvx setscreen + } if + } bind def + /HUE FMLOCAL + /SAT FMLOCAL + /BRIGHT FMLOCAL + /Colors FMLOCAL +FMPrintInColor + + { + /HUE 0 def + /SAT 0 def + /BRIGHT 0 def + % array of arrays Hue and Sat values for the separations [HUE BRIGHT] + /Colors + [[0 0 ] % black + [0 0 ] % white + [0.00 1.0] % red + [0.37 1.0] % green + [0.60 1.0] % blue + [0.50 1.0] % cyan + [0.83 1.0] % magenta + [0.16 1.0] % comment / yellow + ] def + + /BEGINBITMAPCOLOR { + BITMAPCOLOR} def + /BEGINBITMAPCOLORc { + BITMAPCOLORc} def + /BEGINBITMAPTRUECOLOR { + BITMAPTRUECOLOR } def + /BEGINBITMAPTRUECOLORc { + BITMAPTRUECOLORc } def + /K { + Colors exch get dup + 0 get /HUE exch store + 1 get /BRIGHT exch store + HUE 0 eq BRIGHT 0 eq and + {1.0 SAT sub setgray} + {HUE SAT BRIGHT sethsbcolor} + ifelse + } def + /FMsetgray { + /SAT exch 1.0 exch sub store + HUE 0 eq BRIGHT 0 eq and + {1.0 SAT sub setgray} + {HUE SAT BRIGHT sethsbcolor} + ifelse + } bind def + } + + { + /BEGINBITMAPCOLOR { + BITMAPGRAY} def + /BEGINBITMAPCOLORc { + BITMAPGRAYc} def + /BEGINBITMAPTRUECOLOR { + BITMAPTRUEGRAY } def + /BEGINBITMAPTRUECOLORc { + BITMAPTRUEGRAYc } def + /FMsetgray {setgray} bind def + /K { + pop + } def + } +ifelse +/normalize { + transform round exch round exch itransform + } bind def +/dnormalize { + dtransform round exch round exch idtransform + } bind def +/lnormalize { + 0 dtransform exch cvi 2 idiv 2 mul 1 add exch idtransform pop + } bind def +/H { + lnormalize setlinewidth + } bind def +/Z { + setlinecap + } bind def + /fillvals FMLOCAL +/X { + fillvals exch get + dup type /stringtype eq + {8 1 setpattern} + {grayness} + ifelse + } bind def +/V { + gsave eofill grestore + } bind def +/N { + stroke + } bind def +/M {newpath moveto} bind def +/E {lineto} bind def +/D {curveto} bind def +/O {closepath} bind def + /n FMLOCAL +/L { + /n exch def + newpath + normalize + moveto + 2 1 n {pop normalize lineto} for + } bind def +/Y { + L + closepath + } bind def + /x1 FMLOCAL + /x2 FMLOCAL + /y1 FMLOCAL + /y2 FMLOCAL + /rad FMLOCAL +/R { + /y2 exch def + /x2 exch def + /y1 exch def + /x1 exch def + x1 y1 + x2 y1 + x2 y2 + x1 y2 + 4 Y + } bind def +/RR { + /rad exch def + normalize + /y2 exch def + /x2 exch def + normalize + /y1 exch def + /x1 exch def + newpath + x1 y1 rad add moveto + x1 y2 x2 y2 rad arcto + x2 y2 x2 y1 rad arcto + x2 y1 x1 y1 rad arcto + x1 y1 x1 y2 rad arcto + closepath + 16 {pop} repeat + } bind def +/C { + grestore + gsave + R + clip + } bind def + /FMpointsize FMLOCAL +/F { + FMfonts exch get + FMpointsize scalefont + setfont + } bind def +/Q { + /FMpointsize exch def + F + } bind def +/T { + moveto show + } bind def +/RF { + rotate + 0 ne {-1 1 scale} if + } bind def +/TF { + gsave + moveto + RF + show + grestore + } bind def +/P { + moveto + 0 32 3 2 roll widthshow + } bind def +/PF { + gsave + moveto + RF + 0 32 3 2 roll widthshow + grestore + } bind def +/S { + moveto + 0 exch ashow + } bind def +/SF { + gsave + moveto + RF + 0 exch ashow + grestore + } bind def +/B { + moveto + 0 32 4 2 roll 0 exch awidthshow + } bind def +/BF { + gsave + moveto + RF + 0 32 4 2 roll 0 exch awidthshow + grestore + } bind def +/G { + gsave + newpath + normalize translate 0.0 0.0 moveto + dnormalize scale + 0.0 0.0 1.0 5 3 roll arc + closepath fill + grestore + } bind def +/A { + gsave + savematrix + newpath + 2 index 2 div add exch 3 index 2 div sub exch + normalize 2 index 2 div sub exch 3 index 2 div add exch + translate + scale + 0.0 0.0 1.0 5 3 roll arc + restorematrix + stroke + grestore + } bind def + /x FMLOCAL + /y FMLOCAL + /w FMLOCAL + /h FMLOCAL + /xx FMLOCAL + /yy FMLOCAL + /ww FMLOCAL + /hh FMLOCAL + /FMsaveobject FMLOCAL + /FMoptop FMLOCAL + /FMdicttop FMLOCAL +/BEGINPRINTCODE { + /FMdicttop countdictstack 1 add def + /FMoptop count 4 sub def + /FMsaveobject save def + userdict begin + /showpage {} def + FMNORMALIZEGRAPHICS + 3 index neg 3 index neg translate + } bind def +/ENDPRINTCODE { + count -1 FMoptop {pop pop} for + countdictstack -1 FMdicttop {pop end} for + FMsaveobject restore + } bind def +/gn { + 0 + { 46 mul + cf read pop + 32 sub + dup 46 lt {exit} if + 46 sub add + } loop + add + } bind def + /str FMLOCAL +/cfs { + /str sl string def + 0 1 sl 1 sub {str exch val put} for + str def + } bind def +/ic [ + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0223 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0223 + 0 + {0 hx} {1 hx} {2 hx} {3 hx} {4 hx} {5 hx} {6 hx} {7 hx} {8 hx} {9 hx} + {10 hx} {11 hx} {12 hx} {13 hx} {14 hx} {15 hx} {16 hx} {17 hx} {18 hx} + {19 hx} {gn hx} {0} {1} {2} {3} {4} {5} {6} {7} {8} {9} {10} {11} {12} + {13} {14} {15} {16} {17} {18} {19} {gn} {0 wh} {1 wh} {2 wh} {3 wh} + {4 wh} {5 wh} {6 wh} {7 wh} {8 wh} {9 wh} {10 wh} {11 wh} {12 wh} + {13 wh} {14 wh} {gn wh} {0 bl} {1 bl} {2 bl} {3 bl} {4 bl} {5 bl} {6 bl} + {7 bl} {8 bl} {9 bl} {10 bl} {11 bl} {12 bl} {13 bl} {14 bl} {gn bl} + {0 fl} {1 fl} {2 fl} {3 fl} {4 fl} {5 fl} {6 fl} {7 fl} {8 fl} {9 fl} + {10 fl} {11 fl} {12 fl} {13 fl} {14 fl} {gn fl} + ] def + /sl FMLOCAL + /val FMLOCAL + /ws FMLOCAL + /im FMLOCAL + /bs FMLOCAL + /cs FMLOCAL + /len FMLOCAL + /pos FMLOCAL +/ms { + /sl exch def + /val 255 def + /ws cfs + /im cfs + /val 0 def + /bs cfs + /cs cfs + } bind def +400 ms +/ip { + is + 0 + cf cs readline pop + { ic exch get exec + add + } forall + pop + + } bind def +/wh { + /len exch def + /pos exch def + ws 0 len getinterval im pos len getinterval copy pop + pos len + } bind def +/bl { + /len exch def + /pos exch def + bs 0 len getinterval im pos len getinterval copy pop + pos len + } bind def +/s1 1 string def +/fl { + /len exch def + /pos exch def + /val cf s1 readhexstring pop 0 get def + pos 1 pos len add 1 sub {im exch val put} for + pos len + } bind def +/hx { + 3 copy getinterval + cf exch readhexstring pop pop + } bind def + /h FMLOCAL + /w FMLOCAL + /d FMLOCAL + /lb FMLOCAL + /bitmapsave FMLOCAL + /is FMLOCAL + /cf FMLOCAL +/wbytes { + dup + 8 eq {pop} {1 eq {7 add 8 idiv} {3 add 4 idiv} ifelse} ifelse + } bind def +/BEGINBITMAPBWc { + 1 {} COMMONBITMAPc + } bind def +/BEGINBITMAPGRAYc { + 8 {} COMMONBITMAPc + } bind def +/BEGINBITMAP2BITc { + 2 {} COMMONBITMAPc + } bind def +/COMMONBITMAPc { + /r exch def + /d exch def + gsave + translate rotate scale /h exch def /w exch def + /lb w d wbytes def + sl lb lt {lb ms} if + /bitmapsave save def + r + /is im 0 lb getinterval def + ws 0 lb getinterval is copy pop + /cf currentfile def + w h d [w 0 0 h neg 0 h] + {ip} image + bitmapsave restore + grestore + } bind def +/BEGINBITMAPBW { + 1 {} COMMONBITMAP + } bind def +/BEGINBITMAPGRAY { + 8 {} COMMONBITMAP + } bind def +/BEGINBITMAP2BIT { + 2 {} COMMONBITMAP + } bind def +/COMMONBITMAP { + /r exch def + /d exch def + gsave + translate rotate scale /h exch def /w exch def + /bitmapsave save def + r + /is w d wbytes string def + /cf currentfile def + w h d [w 0 0 h neg 0 h] + {cf is readhexstring pop} image + bitmapsave restore + grestore + } bind def + /proc1 FMLOCAL + /proc2 FMLOCAL + /newproc FMLOCAL +/Fmcc { + /proc2 exch cvlit def + /proc1 exch cvlit def + /newproc proc1 length proc2 length add array def + newproc 0 proc1 putinterval + newproc proc1 length proc2 putinterval + newproc cvx +} bind def +/ngrayt 256 array def +/nredt 256 array def +/nbluet 256 array def +/ngreent 256 array def + /gryt FMLOCAL + /blut FMLOCAL + /grnt FMLOCAL + /redt FMLOCAL + /indx FMLOCAL + /cynu FMLOCAL + /magu FMLOCAL + /yelu FMLOCAL + /k FMLOCAL + /u FMLOCAL +/colorsetup { + currentcolortransfer + /gryt exch def + /blut exch def + /grnt exch def + /redt exch def + 0 1 255 { + /indx exch def + /cynu 1 red indx get 255 div sub def + /magu 1 green indx get 255 div sub def + /yelu 1 blue indx get 255 div sub def + /k cynu magu min yelu min def + /u k currentundercolorremoval exec def + nredt indx 1 0 cynu u sub max sub redt exec put + ngreent indx 1 0 magu u sub max sub grnt exec put + nbluet indx 1 0 yelu u sub max sub blut exec put + ngrayt indx 1 k currentblackgeneration exec sub gryt exec put + } for + {255 mul cvi nredt exch get} + {255 mul cvi ngreent exch get} + {255 mul cvi nbluet exch get} + {255 mul cvi ngrayt exch get} + setcolortransfer + {pop 0} setundercolorremoval + {} setblackgeneration + } bind def + /tran FMLOCAL +/fakecolorsetup { + /tran 256 string def + 0 1 255 {/indx exch def + tran indx + red indx get 77 mul + green indx get 151 mul + blue indx get 28 mul + add add 256 idiv put} for + currenttransfer + {255 mul cvi tran exch get 255.0 div} + exch Fmcc settransfer +} bind def +/BITMAPCOLOR { + /d 8 def + gsave + translate rotate scale /h exch def /w exch def + /bitmapsave save def + colorsetup + /is w d wbytes string def + /cf currentfile def + w h d [w 0 0 h neg 0 h] + {cf is readhexstring pop} {is} {is} true 3 colorimage + bitmapsave restore + grestore + } bind def +/BITMAPCOLORc { + /d 8 def + gsave + translate rotate scale /h exch def /w exch def + /lb w d wbytes def + sl lb lt {lb ms} if + /bitmapsave save def + colorsetup + /is im 0 lb getinterval def + ws 0 lb getinterval is copy pop + /cf currentfile def + w h d [w 0 0 h neg 0 h] + {ip} {is} {is} true 3 colorimage + bitmapsave restore + grestore + } bind def +/BITMAPTRUECOLORc { + gsave + translate rotate scale /h exch def /w exch def + /bitmapsave save def + + /is w string def + + ws 0 w getinterval is copy pop + /cf currentfile def + w h 8 [w 0 0 h neg 0 h] + {ip} {gip} {bip} true 3 colorimage + bitmapsave restore + grestore + } bind def +/BITMAPTRUECOLOR { + gsave + translate rotate scale /h exch def /w exch def + /bitmapsave save def + /is w string def + /gis w string def + /bis w string def + /cf currentfile def + w h 8 [w 0 0 h neg 0 h] + { cf is readhexstring pop } + { cf gis readhexstring pop } + { cf bis readhexstring pop } + true 3 colorimage + bitmapsave restore + grestore + } bind def +/BITMAPTRUEGRAYc { + gsave + translate rotate scale /h exch def /w exch def + /bitmapsave save def + + /is w string def + + ws 0 w getinterval is copy pop + /cf currentfile def + w h 8 [w 0 0 h neg 0 h] + {ip gip bip w gray} image + bitmapsave restore + grestore + } bind def +/ww FMLOCAL +/r FMLOCAL +/g FMLOCAL +/b FMLOCAL +/i FMLOCAL +/gray { + /ww exch def + /b exch def + /g exch def + /r exch def + 0 1 ww 1 sub { /i exch def r i get .299 mul g i get .587 mul + b i get .114 mul add add r i 3 -1 roll floor cvi put } for + r + } bind def +/BITMAPTRUEGRAY { + gsave + translate rotate scale /h exch def /w exch def + /bitmapsave save def + /is w string def + /gis w string def + /bis w string def + /cf currentfile def + w h 8 [w 0 0 h neg 0 h] + { cf is readhexstring pop + cf gis readhexstring pop + cf bis readhexstring pop w gray} image + bitmapsave restore + grestore + } bind def +/BITMAPGRAY { + 8 {fakecolorsetup} COMMONBITMAP + } bind def +/BITMAPGRAYc { + 8 {fakecolorsetup} COMMONBITMAPc + } bind def +/ENDBITMAP { + } bind def +end + /ALDsave FMLOCAL + /ALDmatrix matrix def ALDmatrix currentmatrix pop +/StartALD { + /ALDsave save def + savematrix + ALDmatrix setmatrix + } bind def +/InALD { + restorematrix + } bind def +/DoneALD { + ALDsave restore + } bind def +%%EndProlog +%%BeginSetup +(3.0) FMVERSION +1 1 612 792 0 1 13 FMDOCUMENT +0 0 /Helvetica-Bold FMFONTDEFINE +1 0 /Times-Bold FMFONTDEFINE +2 0 /Times-Italic FMFONTDEFINE +3 0 /Times-Roman FMFONTDEFINE +4 0 /Helvetica FMFONTDEFINE +5 0 /Courier FMFONTDEFINE +6 0 /Courier-Oblique FMFONTDEFINE +32 FMFILLS +0 0 FMFILL +1 0.1 FMFILL +2 0.3 FMFILL +3 0.5 FMFILL +4 0.7 FMFILL +5 0.9 FMFILL +6 0.97 FMFILL +7 1 FMFILL +8 <0f1e3c78f0e1c387> FMFILL +9 <0f87c3e1f0783c1e> FMFILL +10 FMFILL +11 FMFILL +12 <8142241818244281> FMFILL +13 <03060c183060c081> FMFILL +14 <8040201008040201> FMFILL +16 1 FMFILL +17 0.9 FMFILL +18 0.7 FMFILL +19 0.5 FMFILL +20 0.3 FMFILL +21 0.1 FMFILL +22 0.03 FMFILL +23 0 FMFILL +24 FMFILL +25 FMFILL +26 <3333333333333333> FMFILL +27 <0000ffff0000ffff> FMFILL +28 <7ebddbe7e7dbbd7e> FMFILL +29 FMFILL +30 <7fbfdfeff7fbfdfe> FMFILL +%%EndSetup +%%Page: "1" 1 +%%BeginPaperSize: Letter +%%EndPaperSize +612 792 0 FMBEGINPAGE +98.1 675 512.1 675 2 L +7 X +0 K +V +2 H +0 Z +0 X +N +98.1 450 512.1 450 2 L +7 X +V +2 Z +0 X +N +98.1 108 512.1 126 R +7 X +V +0 10 Q +0 X +(1) 506.54 119.33 T +1 24 Q +-0.48 (Tk4.0 Overview and Porting Guide) 152.1 605 S +2 12 Q +(John Ouster) 152.1 563 T +(hout) 210.84 563 T +98.1 135 512.1 423 R +7 X +V +3 10 Q +0 X +(Tk version 4.0 is a major new release with many improvements, new features, and bug) 152.1 416.33 T +(\336xes. This document provides an introduction to the new features and describes the most) 152.1 404.33 T +-0.18 (common problems you are likely to encounter when porting scripts from Tk 3.6, the previ-) 152.1 392.33 P +(ous release. This is) 152.1 380.33 T +2 F +(not) 230.66 380.33 T +3 F +( an introduction to Tk: I assume that you are already familiar with) 243.43 380.33 T +(Tk 3.6 as described in the book) 152.1 368.33 T +2 F +(T) 279.79 368.33 T +(cl and the Tk T) 284.43 368.33 T +(oolkit) 343.48 368.33 T +3 F +(.) 366.24 368.33 T +-0.26 (The good news about Tk 4.0 is that it has many improvements over Tk 3.6. Here are a) 170.1 356.33 P +(few of the most important new features:) 152.1 344.33 T +3 12 Q +(\245) 152.1 329.33 T +3 10 Q +(Tk 4.0 includes a general-purpose mechanism for manipulating color images \050Tk 3.6) 162.9 329.33 T +(supports only monochrome images\051.) 162.9 317.33 T +3 12 Q +(\245) 152.1 302.33 T +3 10 Q +-0.17 (The text widget in Tk 4.0 includes many new features such as tab stops, embedded win-) 162.9 302.33 P +(dows, horizontal scrolling, and many new formatting options.) 162.9 290.33 T +3 12 Q +(\245) 152.1 275.33 T +3 10 Q +(The binding mechanism in Tk 4.0 is much more powerful in Tk 3.6.) 162.9 275.33 T +3 12 Q +(\245) 152.1 260.33 T +3 10 Q +(Motif compliance is much better) 162.9 260.33 T +(. For example, there is now support for keyboard tra-) 292.82 260.33 T +(versal and focus highlights.) 162.9 248.33 T +3 12 Q +(\245) 152.1 233.33 T +3 10 Q +(Many widgets have been improved. For example, buttons and labels can display multi-) 162.9 233.33 T +(line justi\336ed text, and scales can handle real values.) 162.9 221.33 T +(The bad news about Tk 4.0 is that it contains several incompatibilities with Tk 3.6.) 170.1 206.33 T +(Ever since the \336rst release of Tk I have assumed that there would eventually be a major) 152.1 194.33 T +(new release of Tk with substantial incompatibilities. I knew that I wouldn\325) 152.1 182.33 T +(t be able to get) 450.06 182.33 T +(all of the features of Tk right the \336rst time; rather than live forever with all of my early) 152.1 170.33 T +(mistakes, I wanted to have a chance to correct them. Tk 4.0 is that correction. I apologize) 152.1 158.33 T +-0.05 (for the incompatibilities, but I hope they improve Tk enough to justify the dif) 152.1 146.33 P +-0.05 (\336culties you) 460.55 146.33 P +44.1 351 98.1 423 C +35.1 360 197.1 414 R +7 X +0 K +V +1 9 Q +0 X +(FIGURE 1) 35.1 408 T +(T) 35.1 387 T +(ABLE 1) 40.43 387 T +26.1 351 125.1 423 R +7 X +V +40.5 63 571.5 729 C +FMENDPAGE +%%EndPage: "1" 2 +%%Page: "2" 2 +612 792 0 FMBEGINPAGE +0 10 Q +0 X +0 K +(2) 98.1 668.33 T +4 F +(Tk4.0 Overview and Porting Guide) 359.34 668.33 T +98.1 660.6 512.1 660.6 2 L +0.25 H +0 Z +N +98.1 135 512.1 639 R +7 X +V +3 F +0 X +(encounter during porting. Tk 4.0 is a one-time correction: we will try very hard to avoid) 152.1 632.33 T +(substantial incompatibilities \050especially in Tk\325) 152.1 620.3 T +(s T) 337 620.3 T +(cl-level interfaces\051 in future releases.) 348.79 620.3 T +-0.4 (Sections 1-1) 170.1 608.3 P +-0.4 (1 cover the major areas of change in Tk 4.0: bindings, focus, text widgets,) 219.02 608.3 P +-0 (Motif compliance, other widget changes, images, color management, event handling, sup-) 152.1 596.26 P +(port for multiple displays, the) 152.1 584.23 T +5 F +(send) 273.14 584.23 T +3 F +( command, and the selection. Section 12 summarizes) 297.13 584.23 T +(several smaller changes. Section 13 lists all of the incompatibilities that af) 152.1 572.19 T +(fect T) 448.4 572.19 T +(cl scripts,) 471.29 572.19 T +-0.02 (along with suggestions for how to deal with them. The explanations here are not intended) 152.1 560.16 P +(to be comprehensive, but rather to introduce you to the issues; for complete information) 152.1 548.12 T +(on new or modi\336ed commands, refer to the reference documentation that comes with the) 152.1 536.09 T +(distribution.) 152.1 524.05 T +98.1 480.7 512.1 483.72 C +152.1 481.92 512.1 481.92 2 L +0.5 H +2 Z +0 X +0 K +N +98.1 482.21 143.1 482.21 2 L +0 Z +N +40.5 63 571.5 729 C +0 12 Q +0 X +0 K +(1) 134.63 487.72 T +(Bindings) 152.1 487.72 T +3 10 Q +-0.35 (The changes for Tk 4.0 that are most likely to af) 152.1 464.03 P +-0.35 (fect existing T) 341.31 464.03 P +-0.35 (cl scripts are those related to) 397.64 464.03 P +(bindings. The new binding mechanism in Tk 4.0 is much more powerful than that of Tk) 152.1 452 T +(3.6, particularly in the way it allows behaviors to be combined, but several incompatible) 152.1 439.96 T +(changes were required to implement the new features. These changes are likely to break) 152.1 427.93 T +(most Tk 3.6 scripts. Fortunately) 152.1 415.89 T +(, it is relatively easy to upgrade your bindings to work) 279.16 415.89 T +(under Tk 4.0.) 152.1 403.86 T +-0.27 (The basic mechanism for bindings is the same as in Tk 3.6. A binding associates a T) 170.1 391.86 P +-0.27 (cl) 502.65 391.86 P +(script with a particular event \050or sequence of events\051 occurring in one or more windows;) 152.1 379.82 T +-0.11 (the script will be invoked automatically whenever the event sequence occurs in any of the) 152.1 367.79 P +-0.13 (speci\336ed windows. The Tk 4.0 binding mechanism has three major feature changes. First,) 152.1 355.75 P +(there is a more general mechanism for specifying the relationship between windows and) 152.1 343.72 T +(bindings, called) 152.1 331.68 T +2 F +(binding tags) 217.89 331.68 T +3 F +(. Second, the con\337ict resolution mechanism \050which is) 267.6 331.68 T +(invoked when more than one binding matches an event\051 has been changed to allow more) 152.1 319.65 T +(than one binding script to execute for a single event. Third, the) 152.1 307.61 T +5 F +(Any) 405.81 307.61 T +3 F +( modi\336er is now) 423.8 307.61 T +(implicit in all binding patterns. These changes are discussed separately in the subsections) 152.1 295.58 T +(that follow) 152.1 283.54 T +(.) 195.04 283.54 T +-0.16 (Overall, the main ef) 170.1 271.54 P +-0.16 (fect of Tk 4.0\325) 249.37 271.54 P +-0.16 (s binding changes is that it allows more bindings to) 306.06 271.54 P +(trigger than Tk 3.6 does. Feedback from the T) 152.1 259.51 T +(cl/Tk community about the Tk 3.6 binding) 335.71 259.51 T +(mechanism indicated that it was too conservative about triggering bindings. This caused) 152.1 247.47 T +(the system to lose behaviors relatively easily and made the binding structure fragile. It) 152.1 235.44 T +-0.35 (appears to be easier to deal with too many binding invocations than too few) 152.1 223.4 P +-0.35 (, so Tk 4.0 tries) 449.17 223.4 P +(to err in this direction.) 152.1 211.37 T +0 F +(1.1) 127.41 181.37 T +(Binding tags) 152.1 181.37 T +3 F +(In Tk 3.6 you specify the window\050s\051 for a binding in one of three ways:) 152.1 165.37 T +3 12 Q +(\245) 152.1 150.37 T +3 10 Q +(Y) 162.9 150.37 T +(ou give the name of a window) 169.12 150.37 T +(, such as) 289.49 150.37 T +5 F +(.a.b.c) 326.13 150.37 T +3 F +(, in which case the binding applies) 362.11 150.37 T +(only to that window) 162.9 138.33 T +(.) 242.49 138.33 T +FMENDPAGE +%%EndPage: "2" 3 +%%Page: "3" 3 +612 792 0 FMBEGINPAGE +4 10 Q +0 X +0 K +(1 Bindings) 98.1 668.33 T +0 F +(3) 506.54 668.33 T +98.1 660.6 512.1 660.6 2 L +0.25 H +0 Z +N +98.1 135 512.1 639 R +7 X +V +3 12 Q +0 X +(\245) 152.1 632.33 T +3 10 Q +-0.06 (Y) 162.9 632.33 P +-0.06 (ou give the name of a class, such as) 169.12 632.33 P +5 F +-0.15 (Button) 313.45 632.33 P +3 F +-0.06 (, in which case the binding applies to all) 349.43 632.33 P +(the windows of that class.) 162.9 620.33 T +3 12 Q +(\245) 152.1 605.33 T +3 10 Q +(Y) 162.9 605.33 T +(ou specify) 169.12 605.33 T +5 F +(all) 212.97 605.33 T +3 F +(, in which case the binding applies to all windows.) 230.96 605.33 T +-0.3 (In Tk4.0 you specify the window\050s\051 using a more general mechanism called a) 170.1 590.33 P +2 F +-0.3 (binding) 479.35 590.33 P +(tag) 152.1 578.33 T +3 F +(. A binding tag may be an arbitrary string, but if it starts with a \322.\323 then it must be the) 164.87 578.33 T +(name of a window) 152.1 566.33 T +(. If you specify a class name or) 225.56 566.33 T +5 F +(all) 352.4 566.33 T +3 F +( as a binding tag, it will usually) 370.39 566.33 T +-0.1 (have the same ef) 152.1 554.33 P +-0.1 (fect as in Tk 3.6, but you may also specify other strings that were not per-) 218.51 554.33 P +(mitted in Tk 3.6.) 152.1 542.33 T +-0.07 (Each window in Tk 4.0 has a list of binding tags. When an event occurs in a window) 170.1 530.33 P +-0.07 (,) 507.17 530.33 P +-0.19 (Tk fetches the window\325) 152.1 518.33 P +-0.19 (s binding tags and matches the event against all of the bindings for) 245.62 518.33 P +-0.09 (any of the tags. By default, the binding tags for a window consist of the window name, its) 152.1 506.33 P +-0.14 (class name, the name of its nearest toplevel ancestor) 152.1 494.33 P +-0.14 (, and) 359.61 494.33 P +5 F +-0.33 (all) 381.26 494.33 P +3 F +-0.14 (. For example, a button win-) 399.25 494.33 P +(dow named) 152.1 482.33 T +5 F +(.b) 200.95 482.33 T +3 F +( will have the tags) 212.95 482.33 T +5 9 Q +(.b Button . all) 179.1 468 T +3 10 Q +(by default and all of the following bindings will apply to the window:) 152.1 454.33 T +5 9 Q +(bind .b {identify "press here to exit"}) 179.1 440 T +(bind Button {%W invoke}) 179.1 430 T +(bind all {help %W}) 179.1 420 T +3 10 Q +(So far) 152.1 406.33 T +(, this mechanism produces the same behavior as in Tk 3.6 except that bindings cre-) 175.85 406.33 T +(ated for a toplevel also apply to its descendants \050see Section 1.5 for more on this issue\051.) 152.1 394.33 T +(Y) 170.1 382.33 T +(ou can use the) 176.32 382.33 T +5 F +(bindtags) 235.71 382.33 T +3 F +( command to change the binding tags for a window or) 283.69 382.33 T +(their order) 152.1 370.33 T +(. For example, the command) 193.46 370.33 T +5 9 Q +(bindtags .b {.b MyButton all}) 179.1 356 T +3 10 Q +(will change the binding tags for) 152.1 342.33 T +5 F +(.b) 281.46 342.33 T +3 F +( to the three values in the list. This provides a simple) 293.45 342.33 T +(way to make radical changes the behavior of a window) 152.1 330.33 T +(. After the above command is) 371.55 330.33 T +(invoked none of the) 152.1 318.33 T +5 F +(Button) 234.26 318.33 T +3 F +( class bindings will apply to) 270.24 318.33 T +5 F +(.b) 384.63 318.33 T +3 F +(. Instead, bindings for) 396.63 318.33 T +5 F +-0.81 (MyButton) 152.1 306.33 P +3 F +-0.34 ( will apply; this might give the button a totally dif) 200.07 306.33 P +-0.34 (ferent set of behaviors than a) 395.88 306.33 P +(normal button. In addition, the) 152.1 294.33 T +5 F +(bindtags) 276.75 294.33 T +3 F +( command removes the \322.\323 tag, so bindings on) 324.72 294.33 T +(\322.\323 will not apply to) 152.1 282.33 T +5 F +(.b) 234.27 282.33 T +3 F +(.) 246.27 282.33 T +(Y) 170.1 270.33 T +(ou can also place additional tags on a window with the) 176.32 270.33 T +5 F +(bindtags) 397.55 270.33 T +3 F +( command to) 445.53 270.33 T +(combine a number of behaviors. For example,) 152.1 258.33 T +5 9 Q +(bindtags .b {.b MyButton Button . all}) 179.1 244 T +3 10 Q +(gives) 152.1 230.33 T +5 F +(.b) 175.7 230.33 T +3 F +( the behaviors of) 187.69 230.33 T +5 F +(MyButton) 257.08 230.33 T +3 F +( bindings as well as those speci\336ed by) 305.06 230.33 T +5 F +(Button) 459.96 230.33 T +3 F +(bindings.) 152.1 218.33 T +(Overall, binding tags are similar to the tag mechanisms already used internally by) 170.1 206.33 T +(canvas and text widgets in Tk 3.6, except that binding tags apply to windows instead of) 152.1 194.33 T +(graphical objects or textual characters.) 152.1 182.33 T +FMENDPAGE +%%EndPage: "3" 4 +%%Page: "4" 4 +612 792 0 FMBEGINPAGE +0 10 Q +0 X +0 K +(4) 98.1 668.33 T +4 F +(Tk4.0 Overview and Porting Guide) 359.34 668.33 T +98.1 660.6 512.1 660.6 2 L +0.25 H +0 Z +N +98.1 135 512.1 639 R +7 X +V +0 F +0 X +(1.2) 127.41 632.33 T +(Con\337ict resolution) 152.1 632.33 T +3 F +(It is possible for several bindings to match a particular event. In Tk 3.6 at most one event) 152.1 616.33 T +(is actually allowed to trigger: a set of con\337ict resolution rules determines the winner) 152.1 604.22 T +(. In) 488.27 604.22 T +(general, a more speci\336c binding takes precedence over a less speci\336c binding. For exam-) 152.1 592.11 T +-0.27 (ple, any binding for a speci\336c widget takes precedence over any class or) 152.1 580 P +5 F +-0.66 (all) 439.96 580 P +3 F +-0.27 ( binding, and) 457.95 580 P +(a binding on) 152.1 567.89 T +5 F +() 204.57 567.89 T +3 F +( takes precedence over a binding on) 270.54 567.89 T +5 F +(.) 416.24 567.89 T +3 F +-0.26 (The mechanism for con\337ict resolution is similar in Tk 4.0 except that one binding can) 170.1 555.89 P +-0.35 (trigger for) 152.1 543.78 P +2 F +-0.35 (each) 194.7 543.78 P +3 F +-0.35 ( binding tag on the window where the event occurs. The bindings trigger in) 213.57 543.78 P +(the order of the tags. Thus if button) 152.1 531.67 T +5 F +(.b) 296.17 531.67 T +3 F +( has the default binding tags, one binding for) 308.16 531.67 T +5 F +(.b) 489.71 531.67 T +3 F +(can trigger) 152.1 519.56 T +(, followed by one for) 194.72 519.56 T +5 F +(Button) 281.32 519.56 T +3 F +(, followed by one for \322) 317.3 519.56 T +5 F +(.) 408.34 519.56 T +3 F +(\323, followed by one for) 414.34 519.56 T +5 F +(all) 152.1 507.44 T +3 F +(. If there are no matching bindings for a given tag then none will trigger) 170.09 507.44 T +(, and if there) 456.98 507.44 T +(are several matching bindings for a given tag then a single one is chosen using the same) 152.1 495.33 T +(rules as in Tk 3.6.) 152.1 483.22 T +(The philosophy behind binding tags in Tk 4.0 is that each binding tag corresponds to) 170.1 471.22 T +(an independent behavior) 152.1 459.11 T +(, so bindings with dif) 249.96 459.11 T +(ferent tags should usually be additive. Sup-) 334.46 459.11 T +(pose you de\336ned the following binding:) 152.1 447 T +5 9 Q +(bind .b {puts "press here to exit"}) 179.1 432.67 T +3 10 Q +(This binding will add to the behavior de\336ned by the Button class binding for) 152.1 419 T +5 F +() 460.81 419 T +3 F +(.) 502.79 419 T +(In Tk 3.6, the widget-speci\336c binding will replace the class binding, which will break the) 152.1 406.89 T +(behavior of the button so that it no longer has normal button behavior) 152.1 394.78 T +(.) 429.71 394.78 T +(Sometimes there need to be interactions between binding tags. For example, you) 170.1 382.78 T +(might wish to keep most of the default button behavior for) 152.1 370.67 T +5 F +(.b) 388.34 370.67 T +3 F +( but replace the default) 400.33 370.67 T +(behavior for) 152.1 358.56 T +5 F +() 203.72 358.56 T +3 F +( with some other behavior) 293.67 358.56 T +(. T) 397.49 358.56 T +(o allow bindings to be) 407.9 358.56 T +-0.17 (overridden, Tk 4.0 allows the) 152.1 346.44 P +5 F +-0.41 (break) 271.44 346.44 P +3 F +-0.17 ( command to be invoked from inside a binding. This) 301.43 346.44 P +(causes all remaining binding tags for that binding to be skipped. Consider the following) 152.1 334.33 T +(binding:) 152.1 322.22 T +5 9 Q +(bind .b {myRelease .b; break}) 179.1 307.89 T +3 10 Q +-0.21 (This will cause the) 152.1 294.22 P +5 F +-0.5 (myRelease) 228.99 294.22 P +3 F +-0.21 ( procedure to be invoked, then the) 282.96 294.22 P +5 F +-0.5 (break) 420.28 294.22 P +3 F +-0.21 ( command will) 450.26 294.22 P +-0.37 (cause the class binding for the event to be skipped \050assuming that the widget name appears) 152.1 282.11 P +(before its class in the binding tags for) 152.1 270 T +5 F +(.b) 304.78 270 T +3 F +(\051, along with any bindings for other tags.) 316.77 270 T +2 F +(Note:) 119.09 254 T +-0.07 (Y) 152.1 254 P +-0.07 (ou cannot invoke) 156.74 254 P +6 F +-0.17 (break) 227.31 254 P +2 F +-0.07 ( fr) 257.29 254 P +-0.07 (om within the) 266.02 254 P +6 F +-0.17 (myRelease) 322.73 254 P +2 F +-0.07 ( pr) 376.7 254 P +-0.07 (ocedur) 387.64 254 P +-0.07 (e in the above example:) 415.03 254 P +-0.02 (this will generate a T) 152.1 242.89 P +-0.02 (cl err) 236.05 242.89 P +-0.02 (or) 257.59 242.89 P +-0.02 (. However) 265.37 242.89 P +-0.02 (, you can invoke the command \322) 305.31 242.89 P +6 F +-0.05 (return -code) 434.25 242.89 P +(break) 152.1 231.78 T +2 F +(\323 in the pr) 182.08 231.78 T +(ocedur) 223.64 231.78 T +(e to achieve the same effect as the) 251.03 231.78 T +6 F +(break) 389.25 231.78 T +2 F +( in the binding script.) 419.23 231.78 T +0 F +(1.3) 127.41 202.78 T +(Implicit Any) 152.1 202.78 T +3 F +-0.13 (In Tk 3.6 extraneous modi\336ers prevent a binding from matching an event. For example, if) 152.1 186.78 P +(a binding is de\336ned for) 152.1 174.67 T +5 F +() 247.32 174.67 T +3 F +( and the mouse button is pressed with the) 307.29 174.67 T +5 F +(Num-) 474.68 174.67 T +(Lock) 152.1 162.56 T +3 F +( key down, then the binding will not match. If you want a binding to trigger even) 176.09 162.56 T +(when extraneous modi\336ers are present, you must specify the) 152.1 150.45 T +5 F +(Any) 396.37 150.45 T +3 F +( modi\336er) 414.36 150.45 T +(, as in) 450.33 150.45 T +5 F +() 152.1 138.33 T +3 F +(.) 206.07 138.33 T +FMENDPAGE +%%EndPage: "4" 5 +%%Page: "5" 5 +612 792 0 FMBEGINPAGE +4 10 Q +0 X +0 K +(1 Bindings) 98.1 668.33 T +0 F +(5) 506.54 668.33 T +98.1 660.6 512.1 660.6 2 L +0.25 H +0 Z +N +98.1 135 512.1 639 R +7 X +V +3 F +0 X +-0.06 (In Tk 4.0, all bindings have the) 170.1 632.33 P +5 F +-0.15 (Any) 297.08 632.33 P +3 F +-0.06 ( modi\336er present implicitly) 315.08 632.33 P +-0.06 (. The) 423.35 632.33 P +5 F +-0.15 (Any) 446.26 632.33 P +3 F +-0.06 ( modi\336er is) 464.25 632.33 P +(still allowed for compatibility) 152.1 620.33 T +(, but it has no meaning. Thus a binding for) 270.55 620.33 T +5 F +() 443.23 620.33 T +3 F +(will match a button press event even if) 152.1 608.33 T +5 F +(NumLock) 309.21 608.33 T +3 F +(,) 351.19 608.33 T +5 F +(Shift) 356.19 608.33 T +3 F +(,) 386.17 608.33 T +5 F +(Control) 391.17 608.33 T +3 F +(, or any combina-) 433.15 608.33 T +(tion of them. If you wish for a binding not to trigger when a modi\336er is present, you can) 152.1 596.33 T +(just de\336ne an empty binding for that modi\336er combination. For example,) 152.1 584.33 T +5 9 Q +(bind .b {# this script is a no-op}) 179.1 570 T +3 10 Q +(creates a binding that will trigger on mouse button presses when the) 152.1 556.33 T +5 F +(Control) 426.36 556.33 T +3 F +( key is) 468.34 556.33 T +-0.22 (down. If there is also a) 152.1 544.33 P +5 F +-0.52 () 244.35 544.33 P +3 F +-0.22 ( binding for) 334.3 544.33 P +5 F +-0.52 (.b) 383.35 544.33 P +3 F +-0.22 (, it will no longer be invoked) 395.34 544.33 P +-0.02 (if the) 152.1 532.33 P +5 F +-0.05 (Control) 175.37 532.33 P +3 F +-0.02 ( key is down, due to the con\337ict resolution rules. The script for the above) 217.35 532.33 P +(binding is just a T) 152.1 520.33 T +(cl comment, so it has no ef) 223.59 520.33 T +(fect when it is invoked. Alternatively) 330.84 520.33 T +(, you) 478.98 520.33 T +(could use) 152.1 508.33 T +5 F +(%s) 192.63 508.33 T +3 F +( in the binding script to extract the modi\336er state, then test to see that only) 204.62 508.33 T +(desired modi\336ers are present.) 152.1 496.33 T +0 F +(1.4) 127.41 466.33 T +(Porting problems: widget bindings vs. class bindings) 152.1 466.33 T +3 F +-0.38 (Y) 152.1 450.33 P +-0.38 (ou are likely to encounter two problems with bindings when you port Tk 3.6 scripts to Tk) 158.32 450.33 P +-0.18 (4.0: widget bindings vs. class bindings, and events on top-level windows. This section dis-) 152.1 438.33 P +(cusses the \336rst problem and the following section discusses the second problem.) 152.1 426.33 T +(In Tk 3.6, if a widget-speci\336c binding matches an event then no class binding will) 170.1 414.33 T +-0.15 (trigger for the event; in Tk 4.0 both bindings will trigger) 152.1 402.33 P +-0.15 (. Because of this change, you will) 375.75 402.33 P +-0.09 (need to modify most of your widget-speci\336c bindings in one of two ways. If a widget-spe-) 152.1 390.33 P +(ci\336c binding in Tk 3.6 was intended to supplement the class binding, this could only be) 152.1 378.33 T +(done by duplicating the code of the class binding in the widget binding script. This dupli-) 152.1 366.33 T +-0.02 (cated code is no longer necessary in Tk 4.0 and will probably interfere with the new class) 152.1 354.33 P +(bindings in Tk 4.0; you should remove the duplicated class code, leaving only the widget-) 152.1 342.33 T +(speci\336c code in the binding script. If a widget-speci\336c binding in Tk 3.6 was intended to) 152.1 330.33 T +-0.17 (override the class binding, this will no longer occur by default in Tk 4.0; you should add a) 152.1 318.33 P +5 F +-0.54 (break) 152.1 306.33 P +3 F +-0.22 ( command at the end of the binding script to prevent the class binding from trigger-) 182.08 306.33 P +(ing. If a widget binding in Tk 3.6 didn\325) 152.1 294.33 T +(t con\337ict with a class binding, then you will not) 308.49 294.33 T +(need to modify it for Tk 4.0. For example, a widget binding for) 152.1 282.33 T +5 F +() 407.49 282.33 T +3 F +( in a text widget) 443.47 282.33 T +(would not need to be modi\336ed, since it doesn\325) 152.1 270.33 T +(t con\337ict with a class binding.) 336.53 270.33 T +0 F +(1.5) 127.41 240.33 T +(Porting problems: events on top-levels) 152.1 240.33 T +3 F +-0.26 (The second binding problem you are likely to encounter in porting Tk 3.6 scripts to Tk 4.0) 152.1 224.33 P +(is that in Tk 4.0 a binding on a toplevel will match events on any of the internal windows) 152.1 212.33 T +(within that top-level. For example, suppose you have a binding created as follows:) 152.1 200.33 T +5 9 Q +(toplevel .t) 179.1 186 T +(button .t.b1 ...) 179.1 176 T +(button .t.b2 ...) 179.1 166 T +(bind .t action) 179.1 156 T +FMENDPAGE +%%EndPage: "5" 6 +%%Page: "6" 6 +612 792 0 FMBEGINPAGE +0 10 Q +0 X +0 K +(6) 98.1 668.33 T +4 F +(Tk4.0 Overview and Porting Guide) 359.34 668.33 T +98.1 660.6 512.1 660.6 2 L +0.25 H +0 Z +N +98.1 135 512.1 639 R +7 X +V +3 F +0 X +-0.27 (This binding will trigger not only when the mouse enters) 152.1 632.33 P +5 F +-0.64 (.t) 379.29 632.33 P +3 F +-0.27 (, but also when it enters either) 391.28 632.33 P +5 F +(.t.b1) 152.1 620.33 T +3 F +( or) 182.08 620.33 T +5 F +(.t.b2) 195.41 620.33 T +3 F +(. This is because the binding tags for a window include its nearest) 225.39 620.33 T +(ancestor toplevel by default. The toplevel is present in the binding tags to make it easy to) 152.1 608.33 T +(set up accelerator keys that apply in all the windows of a panel. For example,) 152.1 596.33 T +5 9 Q +(bind .t {controlAProc %W}) 179.1 582 T +3 10 Q +(will cause) 152.1 568.33 T +5 F +(controlAProc) 194.85 568.33 T +3 F +( to be invoked whenever) 266.81 568.33 T +5 F +(Control-a) 367.56 568.33 T +3 F +( is typed in any of the) 421.53 568.33 T +-0.12 (windows in) 152.1 556.33 P +5 F +-0.29 (.t) 200.72 556.33 P +3 F +-0.12 (. The procedure will receive the name of the focus window as its ar) 212.71 556.33 P +-0.12 (gument.) 479.62 556.33 P +(Unfortunately) 170.1 544.33 T +(, if you have created bindings on toplevel windows in your Tk 3.6) 225.52 544.33 T +-0.16 (scripts, they probably expect to trigger only for events in the toplevel, so the bindings will) 152.1 532.33 P +(misbehave under Tk 4.0. Fortunately you can reproduce the behavior of Tk 3.6 by using) 152.1 520.33 T +(the) 152.1 508.33 T +5 F +(%W) 166.81 508.33 T +3 F +( substitution in the binding script. For example, to ensure that) 178.8 508.33 T +5 F +(action) 427.28 508.33 T +3 F +( is invoked) 463.26 508.33 T +(only for) 152.1 496.33 T +5 F +(Enter) 186.52 496.33 T +3 F +( events in a toplevel window itself, create the following binding in place) 216.51 496.33 T +(of the one above:) 152.1 484.33 T +5 9 Q +(bind .t {) 179.1 470 T +(if {"%W" == ".t"} {) 200.63 460 T +(action) 222.23 450 T +(}) 200.63 440 T +(}) 179.1 430 T +3 10 Q +-0.01 (When an) 152.1 416.33 P +5 F +-0.03 (Enter) 190.38 416.33 P +3 F +-0.01 ( event occurs in a descendant of) 220.36 416.33 P +5 F +-0.03 (.t) 350.45 416.33 P +3 F +-0.01 ( such as) 362.45 416.33 P +5 F +-0.03 (.t.x) 396.56 416.33 P +3 F +-0.01 (, a binding for) 420.54 416.33 P +5 F +-0.03 (Enter) 479.63 416.33 P +3 F +(in) 152.1 404.33 T +5 F +(.t.x) 162.37 404.33 T +3 F +( will trigger \336rst, if there is one. Then the above binding will trigger) 186.36 404.33 T +(. Since) 457.58 404.33 T +5 F +(%W) 487.29 404.33 T +3 F +(will be substituted with) 152.1 392.33 T +5 F +(.t.x) 248.17 392.33 T +3 F +(, the) 272.15 392.33 T +5 F +(if) 291.86 392.33 T +3 F +( condition will not be satis\336ed and the binding will) 303.86 392.33 T +(not do anything.) 152.1 380.33 T +-0.14 ( An alternative solution is to remove the toplevel window from the binding tags of all) 170.1 368.33 P +-0.12 (its internal windows. However) 152.1 356.33 P +-0.12 (, this means that you won\325) 274.03 356.33 P +-0.12 (t be able to take advantage of the) 378.73 356.33 P +(tag to create key bindings that apply everywhere within the toplevel.) 152.1 344.33 T +0 F +(1.6) 127.41 314.33 T +(Internal bindings in canvases and texts) 152.1 314.33 T +3 F +(The same changes in con\337ict resolution described in Section 1.2 also apply to bindings) 152.1 298.33 T +-0.05 (created internally for the items of a canvas or the tags of a text widget. If a canvas item or) 152.1 286.33 P +-0.29 (character of text has multiple tags, then one binding can trigger for each tag on each event.) 152.1 274.33 P +-0.32 (The bindings trigger in the priority order of the tags. Similar porting problems are likely to) 152.1 262.33 P +-0.19 (occur as described in Section 1.4; if a binding for one tag needs to override that of another) 152.1 250.33 P +(tag, you\325ll need to add a) 152.1 238.33 T +5 F +(break) 251.2 238.33 T +3 F +( command under Tk 4.0; if a binding for one tag dupli-) 281.18 238.33 T +-0.28 (cated the code from another tag\325) 152.1 226.33 P +-0.28 (s binding, so that they will compose in Tk 3.6, you\325ll have) 279.76 226.33 P +(to remove the duplicated code in Tk 4.0.) 152.1 214.33 T +FMENDPAGE +%%EndPage: "6" 7 +%%Page: "7" 7 +612 792 0 FMBEGINPAGE +4 10 Q +0 X +0 K +(2 Focus management) 98.1 668.33 T +0 F +(7) 506.54 668.33 T +98.1 660.6 512.1 660.6 2 L +0.25 H +0 Z +N +98.1 135 512.1 639 R +7 X +V +98.1 623.98 512.1 627 C +152.1 625.2 512.1 625.2 2 L +0.5 H +2 Z +0 X +0 K +N +98.1 625.49 143.1 625.49 2 L +0 Z +N +40.5 63 571.5 729 C +0 12 Q +0 X +0 K +(2) 134.63 631 T +(Focus management) 152.1 631 T +3 10 Q +(The input focus is another area where Tk 4.0 contains major changes. Fortunately) 152.1 607.31 T +(, the) 477.87 607.31 T +-0.09 (focus changes should not require as many modi\336cations to your Tk 3.6 scripts as the bind-) 152.1 595.31 P +(ing changes.) 152.1 583.31 T +0 F +(2.1) 127.41 553.31 T +(One focus window per toplevel) 152.1 553.31 T +3 F +(Tk 3.6 only keeps track of a single focus window for each application, and this results in) 152.1 537.31 T +(two problems. First, it doesn\325) 152.1 525.31 T +(t allow an application to use multiple displays since this) 269.64 525.31 T +-0.16 (could result in multiple simultaneous focus windows, one on each display) 152.1 513.31 P +-0.16 (. Second, the Tk) 444.99 513.31 P +(3.6 model doesn\325) 152.1 501.31 T +(t work very well for applications that have multiple toplevels: when the) 221.04 501.31 T +(mouse moves from one toplevel to another) 152.1 489.31 T +(, the focus window should switch to whatever) 322.7 489.31 T +-0.24 (window had the focus the last time the mouse was in the new toplevel, but Tk 3.6 does not) 152.1 477.31 P +(remember this information.) 152.1 465.31 T +(Tk 4.0 corrects both of these problems. It remembers one focus window for each) 170.1 453.31 T +(toplevel, which can be queried with the) 152.1 441.31 T +5 F +(focus -lastfor) 311.98 441.31 T +3 F +( command. When the win-) 395.94 441.31 T +(dow manager gives the focus to a toplevel window \050because the mouse entered the win-) 152.1 429.31 T +(dow or because you clicked on the window) 152.1 417.31 T +(, depending on the focus model being used by) 324.38 417.31 T +(the window manager\051, Tk passes the focus on to the remembered window) 152.1 405.31 T +(. Several win-) 446.23 405.31 T +(dows in an application can have the focus at the same time, one on each display the appli-) 152.1 393.31 T +(cation is using. When asking for the current focus window in the) 152.1 381.31 T +5 F +(focus) 413.31 381.31 T +3 F +( command, you) 443.29 381.31 T +(can use the) 152.1 369.31 T +5 F +(-displayof) 199 369.31 T +3 F +( switch to specify a particular display) 258.97 369.31 T +(.) 407.66 369.31 T +(When you set the focus to a window with the) 170.1 357.31 T +5 F +(focus) 353.31 357.31 T +3 F +( command, Tk remembers that) 383.29 357.31 T +(window as the most recent focus window for its toplevel. In addition, if the application) 152.1 345.31 T +(currently has the focus for the window\325) 152.1 333.31 T +(s display) 309.2 333.31 T +(, Tk moves the focus to the speci\336ed win-) 343.82 333.31 T +-0.35 (dow; this can be used, for example to move the focus to a dialog when the dialog is posted,) 152.1 321.31 P +(or to perform keyboard traversal among the toplevels of an application. If the application) 152.1 309.31 T +(doesn\325) 152.1 297.31 T +(t currently have the focus for the display) 178.57 297.31 T +(, then Tk will not normally take the focus) 339.74 297.31 T +(from its current owner) 152.1 285.31 T +(. However) 241.2 285.31 T +(, you can specify the) 282.43 285.31 T +5 F +(-force) 367.36 285.31 T +3 F +( ar) 403.34 285.31 T +(gument to) 413.43 285.31 T +5 F +(focus) 456.18 285.31 T +3 F +( to) 486.17 285.31 T +(insist that Tk grab the focus for this application \050in general this is probably not a good) 152.1 273.31 T +(idea, since it may clash with the window manager) 152.1 261.31 T +(\325) 352.05 261.31 T +(s focus policy\051.) 354.83 261.31 T +0 F +(2.2) 127.41 231.31 T +(Keyboard traversal) 152.1 231.31 T +3 F +-0.38 (Tk 4.0 has a much more complete implementation of keyboard traversal than Tk 3.6. In Tk) 152.1 215.31 P +(3.6 there is built-in support only for keyboard traversal of menus. In Tk 4.0 keyboard tra-) 152.1 203.31 T +(versal is implemented for all widgets. Y) 152.1 191.31 T +(ou can type) 311.27 191.31 T +5 F +(Tab) 359.85 191.31 T +3 F +( to move the focus among the) 377.84 191.31 T +-0.4 (windows within a toplevel and) 152.1 179.31 P +5 F +-0.95 (Shift+Tab) 275.31 179.31 P +3 F +-0.4 ( to move in the reverse direction. The order of) 329.28 179.31 P +-0.11 (traversal is de\336ned by the stacking order of widgets, with the lowest widget \336rst in the tra-) 152.1 167.31 P +(versal order) 152.1 155.31 T +(. All Tk widgets now provide a) 199 155.31 T +5 F +(-takefocus) 326.14 155.31 T +3 F +( option, which determines) 386.11 155.31 T +FMENDPAGE +%%EndPage: "7" 8 +%%Page: "8" 8 +612 792 0 FMBEGINPAGE +0 10 Q +0 X +0 K +(8) 98.1 668.33 T +4 F +(Tk4.0 Overview and Porting Guide) 359.34 668.33 T +98.1 660.6 512.1 660.6 2 L +0.25 H +0 Z +N +98.1 135 512.1 639 R +7 X +V +3 F +0 X +(whether the window should accept the focus during traversal or be skipped. This option) 152.1 632.33 T +(has several features; see the) 152.1 620.33 T +5 F +(options.n) 265.61 620.33 T +3 F +( manual entry for details.) 319.58 620.33 T +(All of the Tk widgets provide a traversal highlight ring as required by Motif. The) 170.1 608.33 T +(highlight ring turns dark when the widget has the input focus. Its size and colors are con-) 152.1 596.33 T +(trolled by the) 152.1 584.33 T +5 F +(-highlightthickness) 207.9 584.33 T +3 F +(,) 321.84 584.33 T +5 F +(-highlightbackground) 326.83 584.33 T +3 F +(, and) 446.77 584.33 T +5 F +(-) 152.1 572.33 T +(highlightcolor) 158.1 572.33 T +3 F +( options. Y) 242.05 572.33 T +(ou may notice that widgets appear to have extra space) 285.2 572.33 T +(around them in Tk 4.0; this is due to the traversal highlight ring, which is normally the) 152.1 560.33 T +(same color as the background for widgets.) 152.1 548.33 T +0 F +(2.3) 127.41 518.33 T +(Support for focus-follows-mouse) 152.1 518.33 T +3 F +(Both Tk 3.6 and Tk 4.0 use an) 152.1 502.33 T +2 F +(explicit focus model) 275.91 502.33 T +3 F +( within a toplevel. This means that) 355.86 502.33 T +(moving the mouse among the windows of a toplevel does not normally move the focus;) 152.1 490.33 T +-0.06 (you have to click or perform some other action \050such as pressing) 152.1 478.33 P +5 F +-0.15 (Tab) 412.26 478.33 P +3 F +-0.06 (\051 to move the focus.) 430.25 478.33 P +(Tk 3.6 has no support for an) 152.1 466.33 T +2 F +(implicit focus model) 267.58 466.33 T +3 F +( where the window under the mouse) 348.64 466.33 T +(always has the focus. In Tk 4.0 you can invoke the library procedure) 152.1 454.33 T +5 F +(tk_focusFol-) 428.83 454.33 T +(lowsMouse) 152.1 442.33 T +3 F +( to switch to an implicit focus model; in this mode whenever the mouse) 206.07 442.33 T +(enters a new window the focus will switch to that window) 152.1 430.33 T +(.) 384.07 430.33 T +0 F +(2.4) 127.41 400.33 T +(No default focus window) 152.1 400.33 T +(, no \322none\323 focus.) 269.45 400.33 T +3 F +-0.16 (Tk 3.6 has the notion of a default focus window) 152.1 384.33 P +-0.16 (, which receives the focus if the focus win-) 341.56 384.33 P +(dow is deleted. It is also possible for an application to abandon the input focus by setting) 152.1 372.33 T +(the focus to) 152.1 360.33 T +5 F +(none) 201.23 360.33 T +3 F +(. In Tk 4.0 both of these features have been eliminated. There is no) 225.22 360.33 T +(default focus window) 152.1 348.33 T +(, and the focus can never be explicitly abandoned. If the focus win-) 238.05 348.33 T +(dow is destroyed, Tk resets the input focus to the toplevel containing the old focus win-) 152.1 336.33 T +(dow) 152.1 324.33 T +(. If the toplevel is destroyed, the window manager will reclaim the focus and move it) 168.66 324.33 T +(elsewhere.) 152.1 312.33 T +-0.18 (If you really want to abandon the focus in Tk 4.0 so that keyboard events are ignored,) 170.1 300.33 P +(you can create a dummy window with no key bindings \050set its binding tags to an empty) 152.1 288.33 T +(string to be sure\051, make sure that is never mapped, and give it the input focus.) 152.1 276.33 T +0 F +(2.5) 127.41 246.33 T +(Better focus events) 152.1 246.33 T +3 F +-0.13 (Tk 3.6 has a quirky event model for) 152.1 230.33 P +5 F +-0.32 (FocusIn) 296.77 230.33 P +3 F +-0.13 ( and) 338.75 230.33 P +5 F +-0.32 (FocusOut) 357.92 230.33 P +3 F +-0.13 ( events: when the window) 405.89 230.33 P +-0.23 (manager gives the focus to a toplevel, Tk generates a) 152.1 218.33 P +5 F +-0.55 (FocusIn) 364.36 218.33 P +3 F +-0.23 ( event for the toplevel and) 406.33 218.33 P +(another) 152.1 206.33 T +5 F +(FocusIn) 184.57 206.33 T +3 F +( event for the focus window) 226.55 206.33 T +(, but no events for any other windows.) 337.76 206.33 T +(When the window manager moves the focus somewhere else,) 152.1 194.33 T +5 F +(FocusOut) 400.79 194.33 T +3 F +( events are gen-) 448.77 194.33 T +-0 (erated for these same two windows. In Tk 4.0,) 152.1 182.33 P +5 F +-0 (FocusIn) 339.73 182.33 P +3 F +-0 ( and) 381.71 182.33 P +5 F +-0 (FocusOut) 401.13 182.33 P +3 F +-0 ( events are gen-) 449.11 182.33 P +-0.26 (erated in the same way as) 152.1 170.33 P +5 F +-0.63 (Enter) 255.43 170.33 P +3 F +-0.26 ( and) 285.41 170.33 P +5 F +-0.63 (Leave) 304.31 170.33 P +3 F +-0.26 ( events: when the focus arrives, a) 334.29 170.33 P +5 F +-0.63 (FocusIn) 467.89 170.33 P +3 F +-0.05 (event is generated for each window from the toplevel down to the focus window) 152.1 158.33 P +-0.05 (, with dif-) 472.5 158.33 P +FMENDPAGE +%%EndPage: "8" 9 +%%Page: "9" 9 +612 792 0 FMBEGINPAGE +4 10 Q +0 X +0 K +(3 T) 98.1 668.33 T +(ext widgets) 111.43 668.33 T +0 F +(9) 506.54 668.33 T +98.1 660.6 512.1 660.6 2 L +0.25 H +0 Z +N +98.1 135 512.1 639 R +7 X +V +3 F +0 X +-0.33 (ferent detail \336elds for dif) 152.1 632.33 P +-0.33 (ferent windows \050see Xlib documentation for information on these) 250.53 632.33 P +(values\051. The reverse happens when the focus leaves a window) 152.1 620.33 T +(.) 399.57 620.33 T +0 F +(2.6) 127.41 590.33 T +(Porting issues) 152.1 590.33 T +3 F +(If you didn\325) 152.1 574.33 T +(t have any special focus-related code in Tk 3.6, then you shouldn\325) 199.66 574.33 T +(t need to) 462.9 574.33 T +(make any changes for 4.0; things will just work better) 152.1 562.33 T +(. If you wrote code in Tk 3.6 to get) 366.96 562.33 T +(around the weaknesses with its focus mechanism, then you should remove most or all of) 152.1 550.33 T +(that code. For example, if you implemented keyboard traversal yourself, or if you built) 152.1 538.33 T +(your own mechanism to remember a separate focus window for each toplevel and give it) 152.1 526.33 T +(the input focus whenever the toplevel gets the focus, you can simply remove this code,) 152.1 514.33 T +-0.33 (since Tk 4.0 performs these functions for you. If you wrote code that depends on the weird) 152.1 502.33 P +-0.03 (event model in Tk 3.6, that code will need to be rewritten for Tk 4.0. The Tk 4.0 model is) 152.1 490.33 P +(general enough to duplicate any ef) 152.1 478.33 T +(fects that were possible in Tk 3.6.) 289.86 478.33 T +98.1 434.98 512.1 438 C +152.1 436.2 512.1 436.2 2 L +0.5 H +2 Z +0 X +0 K +N +98.1 436.49 143.1 436.49 2 L +0 Z +N +40.5 63 571.5 729 C +0 12 Q +0 X +0 K +(3) 134.63 442 T +(T) 152.1 442 T +(ext widgets) 158.54 442 T +3 10 Q +(T) 152.1 418.31 T +(ext widgets have under) 157.51 418.31 T +(gone a major overhaul for Tk 4.0 and they have improved in) 249.76 418.31 T +(many ways. The changes to text widgets are almost entirely upward-compatible from Tk) 152.1 406.31 T +(3.6.) 152.1 394.31 T +0 F +(3.1) 127.41 364.31 T +(Embedded windows.) 152.1 364.31 T +3 F +(Tk 3.6 supported two kinds of annotations in texts: marks and tags. In Tk 4.0 a third kind) 152.1 348.31 T +-0.04 (of annotation is available: an embedded window) 152.1 336.31 P +-0.04 (. This allows you to embed other widgets) 344.99 336.31 P +(inside a text widget, mixed in with the text. The text widget acts as a geometry manager) 152.1 324.31 T +(for these windows, laying them out and wrapping them just as if each embedded window) 152.1 312.31 T +(were a single character in the text. Y) 152.1 300.31 T +(ou can even have texts with nothing in them but) 297.64 300.31 T +(embedded windows. The) 152.1 288.31 T +5 F +(window) 254.8 288.31 T +3 F +( widget command for text widgets provides several) 290.78 288.31 T +(options to manage embedded windows.) 152.1 276.31 T +0 F +(3.2) 127.41 246.31 T +(More options for tags.) 152.1 246.31 T +3 F +(In Tk 4.0 tags support many new options providing additional control over how informa-) 152.1 230.31 T +(tion is displayed. Here is a summary of the new options:) 152.1 218.31 T +3 12 Q +(\245) 152.1 203.31 T +3 10 Q +(Y) 162.9 203.31 T +(ou can now specify tab stops with the) 169.12 203.31 T +5 F +(-tabs) 321.79 203.31 T +3 F +( option. Each tab stop can use left, cen-) 351.78 203.31 T +(ter) 162.9 191.31 T +(, right, or numeric justi\336cation. T) 173.04 191.31 T +(ab stops can also be speci\336ed for the widget as a) 305.6 191.31 T +(whole.) 162.9 179.31 T +3 12 Q +(\245) 152.1 164.31 T +3 10 Q +(Y) 162.9 164.31 T +(ou can specify justi\336cation \050left, center or right\051 with the) 169.12 164.31 T +5 F +(-justify) 398.12 164.31 T +3 F +( option.) 446.09 164.31 T +FMENDPAGE +%%EndPage: "9" 10 +%%Page: "10" 10 +612 792 0 FMBEGINPAGE +0 10 Q +0 X +0 K +(10) 98.1 668.33 T +4 F +(Tk4.0 Overview and Porting Guide) 359.34 668.33 T +98.1 660.6 512.1 660.6 2 L +0.25 H +0 Z +N +98.1 135 512.1 639 R +7 X +V +3 12 Q +0 X +(\245) 152.1 632.33 T +3 10 Q +(Y) 162.9 632.33 T +(ou can now specify line spacing with three options,) 169.12 632.33 T +5 F +(-spacing1) 376.75 632.33 T +3 F +(,) 430.72 632.33 T +5 F +(-spacing2) 435.72 632.33 T +3 F +(, and) 489.69 632.33 T +5 F +(-) 162.9 620.2 T +(spacing3) 168.9 620.2 T +3 F +(, which control the spacing above a line, between wrapped lines, and) 216.87 620.2 T +(below a line.) 162.9 608.06 T +3 12 Q +(\245) 152.1 593.06 T +3 10 Q +(Y) 162.9 593.06 T +(ou can now specify mar) 169.12 593.06 T +(gins with the) 264.41 593.06 T +5 F +(-lmargin1) 318.55 593.06 T +3 F +(,) 372.52 593.06 T +5 F +(-lmargin2) 377.52 593.06 T +3 F +(, and) 431.49 593.06 T +5 F +(-rmargin) 453.42 593.06 T +3 F +(options.) 162.9 580.92 T +3 12 Q +(\245) 152.1 565.92 T +3 10 Q +-0.25 (Y) 162.9 565.92 P +-0.25 (ou can now adjust the vertical position of text \050e.g. for superscripts or subscripts\051 with) 169.12 565.92 P +(the) 162.9 553.79 T +5 F +(-offset) 177.61 553.79 T +3 F +( option.) 219.59 553.79 T +3 12 Q +(\245) 152.1 538.79 T +3 10 Q +-0.03 (Y) 162.9 538.79 P +-0.03 (ou can now specify the wrapping style \050word wrapping, character wrapping, or none\051) 169.12 538.79 P +(with the) 162.9 526.65 T +5 F +(-wrap) 197.88 526.65 T +3 F +( option.) 227.86 526.65 T +3 12 Q +(\245) 152.1 511.65 T +3 10 Q +(Y) 162.9 511.65 T +(ou can now request overstriking with the) 169.12 511.65 T +5 F +(-overstrike) 334.83 511.65 T +3 F +( option.) 400.8 511.65 T +0 F +(3.3) 127.41 481.65 T +(Bindings) 152.1 481.65 T +3 F +-0.19 (The default bindings for text widgets have been completely rewritten in Tk 4.0. They now) 152.1 465.65 P +(support almost all of the Motif behavior \050everything except add mode and secondary) 152.1 453.52 T +-0.36 (selections\051. They also include a substantial subset of the Emacs bindings for cursor motion) 152.1 441.38 P +(and basic editing. The) 152.1 429.24 T +5 F +(tk_strictMotif) 242.87 429.24 T +3 F +( variable disables the Emacs bindings.) 326.82 429.24 T +0 F +(3.4) 127.41 399.24 T +(Miscellaneous new features) 152.1 399.24 T +3 F +(In addition to the major changes described above, text widgets also include the following) 152.1 383.24 T +(new features:) 152.1 371.11 T +1 F +(Horizontal scr) 162.9 356.11 T +(olling) 224.07 356.11 T +3 F +(. T) 247.95 356.11 T +(ext widgets can now be scrolled horizontally as well as verti-) 258.36 356.11 T +(cally) 162.9 343.97 T +(, using the) 181.68 343.97 T +5 F +(-) 225.55 343.97 T +(xscrollcommand) 231.54 343.97 T +3 F +( option and the) 315.5 343.97 T +5 F +(xview) 377.68 343.97 T +3 F +( widget command.) 407.67 343.97 T +1 F +(Sear) 162.9 328.97 T +(ching) 182.15 328.97 T +3 F +(. T) 205.48 328.97 T +(ext widgets have a new) 215.88 328.97 T +5 F +(search) 311.64 328.97 T +3 F +( widget command, which provides ef) 347.62 328.97 T +(\336-) 495.67 328.97 T +-0.19 (cient searching of text widgets using either exact matching, glob-style matching, or reg-) 162.9 316.83 P +(ular expressions. Y) 162.9 304.7 T +(ou can search forwards or backwards.) 238.79 304.7 T +1 F +(Mark gravity) 162.9 289.7 T +3 F +(. In Tk 3.6 marks always had \322right gravity\323, which means they stick to) 219.71 289.7 T +(the character on the right side of the mark; if you insert at the position of a mark, the) 162.9 277.56 T +-0.1 (new character goes before the mark. In Tk 4.0 you can specify whether marks have left) 162.9 265.42 P +(or right gravity) 162.9 253.29 T +(.) 222.77 253.29 T +1 F +(Scr) 162.9 238.29 T +(een information) 177.15 238.29 T +3 F +(. In Tk 4.0 there are two new widget commands for text widgets) 245.16 238.29 T +(that return information about the screen layout. The) 162.9 226.15 T +5 F +(dlineinfo) 371.92 226.15 T +3 F +( widget command) 425.89 226.15 T +(returns the bounding box of a display line \050all the information displayed on one line of) 162.9 214.02 T +(the window) 162.9 201.88 T +(, which may be either a whole line of text or a partial line if wrapping has) 209.16 201.88 T +(occurred\051. The) 162.9 189.74 T +5 F +(bbox) 224.23 189.74 T +3 F +( widget command returns the screen area occupied by a single) 248.21 189.74 T +(character) 162.9 177.61 T +(.) 198.97 177.61 T +1 F +(Extended insert command) 162.9 162.61 T +3 F +(. The) 275.06 162.61 T +5 F +(insert) 298.1 162.61 T +3 F +( widget command now supports an addi-) 334.08 162.61 T +-0.32 (tional ar) 162.9 150.47 P +-0.32 (gument giving a list of tags to apply to the new characters. Y) 195.43 150.47 P +-0.32 (ou can also include) 434 150.47 P +(several text and tag ar) 162.9 138.33 T +(guments in a single) 250.42 138.33 T +5 F +(insert) 330.38 138.33 T +3 F +( command.) 366.36 138.33 T +FMENDPAGE +%%EndPage: "10" 11 +%%Page: "11" 11 +612 792 0 FMBEGINPAGE +4 10 Q +0 X +0 K +(4 Better Motif compliance) 98.1 668.33 T +0 F +(1) 501.54 668.33 T +(1) 506.54 668.33 T +98.1 660.6 512.1 660.6 2 L +0.25 H +0 Z +N +98.1 135 512.1 639 R +7 X +V +1 F +0 X +(See command) 162.9 632.33 T +3 F +(. There is a new) 222.03 632.33 T +5 F +(see) 288.08 632.33 T +3 F +( widget command, which adjusts the view in the) 306.07 632.33 T +(widget if needed to ensure that a particular character is visible in the window) 162.9 620.29 T +(.) 470.07 620.29 T +0 F +(3.5) 127.41 590.29 T +(Porting issues: tag stickiness, change in end) 152.1 590.29 T +3 F +(There are two changes in text widgets that may require modi\336cations to Tk 3.6 scripts.) 152.1 574.29 T +-0.06 (The \336rst change has to do with tag stickiness. In Tk 3.6, tags are sticky to the right: if you) 152.1 562.24 P +(insert new text just after a tagged range, the new text acquires the tags of the preceding) 152.1 550.19 T +(character) 152.1 538.14 T +(. If you insert text before a tagged range in Tk 3.6, the new characters do not) 188.17 538.14 T +-0.34 (acquire the tags of the range. In Tk 4.0, tags are not sticky on either side: new text acquires) 152.1 526.09 P +(a tag from surrounding characters only if the tag is present on both sides of the insertion) 152.1 514.05 T +(position. The sticky behavior in Tk 3.6 was rarely useful and special code was often) 152.1 502 T +(needed to work around it. Y) 152.1 489.95 T +(ou should be able to eliminate this code in Tk 4.0.) 263.24 489.95 T +(The second incompatible change in text widgets is that the index) 170.1 477.95 T +5 F +(end) 431.32 477.95 T +3 F +( now refers to) 449.31 477.95 T +-0.14 (the position just after the \336nal newline in the text, whereas in Tk 3.6 it referred to the posi-) 152.1 465.9 P +-0.1 (tion just before the \336nal newline. This makes it possible to apply tags to the \336nal newline,) 152.1 453.86 P +(which was not possible in Tk 3.6, but you may need to modify your scripts if you depend) 152.1 441.81 T +(on the old position of) 152.1 429.76 T +5 F +(end) 240.11 429.76 T +3 F +(.) 258.1 429.76 T +98.1 386.4 512.1 389.43 C +152.1 387.63 512.1 387.63 2 L +0.5 H +2 Z +0 X +0 K +N +98.1 387.92 143.1 387.92 2 L +0 Z +N +40.5 63 571.5 729 C +0 12 Q +0 X +0 K +(4) 134.63 393.43 T +(Better Motif compliance) 152.1 393.43 T +3 10 Q +(All of the widgets have been modi\336ed in Tk 4.0 to improve their Motif compliance. This) 152.1 369.74 T +-0.3 (was done by adding features that were missing and reworking the bindings to comply with) 152.1 357.69 P +(Motif conventions. I believe that the widgets are now completely Motif compliant except) 152.1 345.64 T +(for the following missing features:) 152.1 333.6 T +3 12 Q +(\245) 152.1 318.6 T +3 10 Q +(There is no support for secondary selections.) 162.9 318.6 T +3 12 Q +(\245) 152.1 303.6 T +3 10 Q +(There is no support for \322add mode\323 in widgets such as texts and listboxes.) 162.9 303.6 T +3 12 Q +(\245) 152.1 288.6 T +3 10 Q +(There is no support for drag and drop.) 162.9 288.6 T +-0.02 (Please let me know if you \336nd any other discrepancies between the Tk widgets and Motif) 152.1 273.59 P +(widgets. W) 152.1 261.55 T +(e plan to eliminate the remaining incompatibilities over the next year or two.) 196.82 261.55 T +98.1 218.19 512.1 221.21 C +152.1 219.41 512.1 219.41 2 L +0.5 H +2 Z +0 X +0 K +N +98.1 219.7 143.1 219.7 2 L +0 Z +N +40.5 63 571.5 729 C +0 12 Q +0 X +0 K +(5) 134.63 225.21 T +(W) 152.1 225.21 T +(idget changes) 163.31 225.21 T +3 10 Q +-0.07 (All of the Tk 4.0 widgets have been improved over their 3.6 counterparts, mostly in small) 152.1 201.52 P +-0.23 (and backwards compatible ways. Here is a summary of the widget improvements; see Sec-) 152.1 189.48 P +(tion 13 for information about incompatible changes.) 152.1 177.43 T +3 12 Q +(\245) 152.1 162.43 T +3 10 Q +(All widgets now have a) 162.9 162.43 T +5 F +(cget) 259.78 162.43 T +3 F +( command, which provides an easier way to retrieve the) 283.76 162.43 T +(value of a con\336guration option. In other situations where con\336guration options are) 162.9 150.38 T +(used, such as for menu entries or text tags, a) 162.9 138.33 T +5 F +(cget) 342.21 138.33 T +3 F +( command is also available.) 366.2 138.33 T +FMENDPAGE +%%EndPage: "11" 12 +%%Page: "12" 12 +612 792 0 FMBEGINPAGE +0 10 Q +0 X +0 K +(12) 98.1 668.33 T +4 F +(Tk4.0 Overview and Porting Guide) 359.34 668.33 T +98.1 660.6 512.1 660.6 2 L +0.25 H +0 Z +N +98.1 135 512.1 639 R +7 X +V +3 12 Q +0 X +(\245) 152.1 632.33 T +3 10 Q +-0.22 (All widgets now have) 162.9 632.33 P +5 F +-0.53 (-highlightthickness) 251.96 632.33 P +3 F +-0.22 (,) 365.9 632.33 P +5 F +-0.53 (-highlightbackground) 370.68 632.33 P +3 F +-0.22 (, and) 490.61 632.33 P +5 F +(-) 162.9 620.33 T +(highlightcolor) 168.9 620.33 T +3 F +( options for displaying a highlight ring when the widget \050or one) 252.85 620.33 T +(of its descendants\051 has the input focus.) 162.9 608.33 T +3 12 Q +(\245) 152.1 593.33 T +3 10 Q +(Entry widgets now support justi\336cation and provide a) 162.9 593.33 T +5 F +(-show) 379.99 593.33 T +3 F +( option for \050not\051 display-) 409.97 593.33 T +(ing passwords. They will autosize to \336t their text if) 162.9 581.33 T +5 F +(-width 0) 369.17 581.33 T +3 F +( is speci\336ed.) 417.14 581.33 T +3 12 Q +(\245) 152.1 566.33 T +3 10 Q +-0.16 (The label/button family of widgets now supports multiline text and justi\336cation, includ-) 162.9 566.33 P +(ing new options) 162.9 554.33 T +5 F +(-wraplength) 229.25 554.33 T +3 F +( and) 295.22 554.33 T +5 F +(-justify) 314.65 554.33 T +3 F +(. These features make the message) 361.97 554.33 T +-0.04 (widget obsolete. There is also a new) 162.9 542.33 P +5 F +-0.1 (-underline) 310.27 542.33 P +3 F +-0.04 ( option for highlighting a character) 370.23 542.33 P +(for keyboard traversal.) 162.9 530.33 T +3 12 Q +(\245) 152.1 515.33 T +3 10 Q +-0.23 (Listboxes now support all of the Motif selection modes, including single selection, mul-) 162.9 515.33 P +(tiple selection, and multiple disjoint selections, via the) 162.9 503.33 T +5 F +(-selectmode) 382.78 503.33 T +3 F +( option. They) 448.74 503.33 T +(will autosize to \336t their contents if) 162.9 491.33 T +5 F +(-width 0) 302.54 491.33 T +3 F +( or) 350.52 491.33 T +5 F +(-height 0) 363.84 491.33 T +3 F +( is speci\336ed. There are) 417.81 491.33 T +(new) 162.9 479.33 T +5 F +(see) 182.05 479.33 T +3 F +(,) 200.04 479.33 T +5 F +(bbox) 205.04 479.33 T +3 F +(, and) 229.02 479.33 T +5 F +(activate) 250.95 479.33 T +3 F +( widget commands.) 298.92 479.33 T +3 12 Q +(\245) 152.1 464.33 T +3 10 Q +(Canvas polygons now support) 162.9 464.33 T +5 F +(-outline) 286.16 464.33 T +3 F +( and) 334.14 464.33 T +5 F +(-width) 353.57 464.33 T +3 F +( options for drawing outlines.) 389.55 464.33 T +3 12 Q +(\245) 152.1 449.33 T +3 10 Q +-0.03 (Scale widgets now support real values as well as integers \050see the) 162.9 449.33 P +5 F +-0.08 (-resolution) 426.77 449.33 P +3 F +-0.03 ( and) 492.73 449.33 P +5 F +-0.54 (-digits) 162.9 437.33 P +3 F +-0.22 ( options\051, and they have a) 204.88 437.33 P +5 F +-0.54 (-variable) 308.73 437.33 P +3 F +-0.22 ( option to link to a T) 362.7 437.33 P +-0.22 (cl variable. They) 442.83 437.33 P +-0.28 (have two new widget commands,) 162.9 425.33 P +5 F +-0.67 (coords) 297.52 425.33 P +3 F +-0.28 ( and) 333.5 425.33 P +5 F +-0.67 (identify) 352.37 425.33 P +3 F +-0.28 (, and their bindings are now) 399.69 425.33 P +(de\336ned in T) 162.9 413.33 T +(cl rather than being hardwired in C code as in Tk 3.6.) 210.5 413.33 T +3 12 Q +(\245) 152.1 398.33 T +3 10 Q +(Scrollbar widgets now have a new interface to the controlling widget, which provides) 162.9 398.33 T +-0.04 (more \337exibility than the old style \050but the old style is still supported for compatibility\051.) 162.9 386.33 P +(There is a new option) 162.9 374.33 T +5 F +(-jump) 252 374.33 T +3 F +( to prevent continuous updates while dragging the slider) 281.98 374.33 T +(,) 505.88 374.33 T +-0.24 (and a new option) 162.9 362.33 P +5 F +-0.59 (-elementborderwidth) 232.98 362.33 P +3 F +-0.24 ( to control the border width of the arrows) 346.92 362.33 P +(and slider separately from the widget\325) 162.9 350.33 T +(s outer border) 314.18 350.33 T +(. There are four new widget com-) 369.14 350.33 T +(mands,) 162.9 338.33 T +5 F +(activate) 193.99 338.33 T +3 F +(,) 241.97 338.33 T +5 F +(delta) 246.96 338.33 T +3 F +(,) 276.95 338.33 T +5 F +(fraction) 281.95 338.33 T +3 F +(, and) 329.92 338.33 T +5 F +(identify) 351.85 338.33 T +3 F +(, and the default bindings) 399.17 338.33 T +(are now de\336ned in T) 162.9 326.33 T +(cl rather than being hardwired in C code as in Tk 3.6.) 244.91 326.33 T +3 12 Q +(\245) 152.1 311.33 T +3 10 Q +-0.13 (Menu entries now have several new con\336guration options such as) 162.9 311.33 P +5 F +-0.31 (-foreground) 426.97 311.33 P +3 F +-0.13 ( and) 492.93 311.33 P +5 F +-0.41 (-) 162.9 299.33 P +-0.41 (indicatoron) 168.9 299.33 P +3 F +-0.17 (, and tear) 234.86 299.33 P +-0.17 (-of) 271.23 299.33 P +-0.17 (f menus have been reimplemented to be more Motif-like.) 282.7 299.33 P +(New menu entries can be created in the middle of a menu using the) 162.9 287.33 T +5 F +(insert) 434.36 287.33 T +3 F +( widget) 470.34 287.33 T +(command, and there is a) 162.9 275.33 T +5 F +(type) 262.83 275.33 T +3 F +( widget command that returns the type of a menu entry) 286.81 275.33 T +(.) 505.45 275.33 T +3 12 Q +(\245) 152.1 260.33 T +3 10 Q +(Menubuttons now have a) 162.9 260.33 T +5 F +(-indicatoron) 266.16 260.33 T +3 F +( option for displaying an option menu indi-) 338.12 260.33 T +-0.38 (cator) 162.9 248.33 P +-0.38 (. There is now support for option menus via the) 182.33 248.33 P +5 F +-0.91 (tk_optionMenu) 370.9 248.33 P +3 F +-0.38 ( procedure, and) 448.86 248.33 P +(popups are simpli\336ed with the) 162.9 236.33 T +5 F +(tk_popup) 286.44 236.33 T +3 F +( procedure.) 334.42 236.33 T +3 12 Q +(\245) 152.1 221.33 T +3 10 Q +-0.03 (The variable) 162.9 221.33 P +5 F +-0.07 (tk_strictMotif) 215.57 221.33 P +3 F +-0.03 ( is used in more places to enforce even stricter Motif) 299.53 221.33 P +(compliance.) 162.9 209.33 T +FMENDPAGE +%%EndPage: "12" 13 +%%Page: "13" 13 +612 792 0 FMBEGINPAGE +4 10 Q +0 X +0 K +(6 Images) 98.1 668.33 T +0 F +(13) 500.99 668.33 T +98.1 660.6 512.1 660.6 2 L +0.25 H +0 Z +N +98.1 135 512.1 639 R +7 X +V +98.1 623.98 512.1 627 C +152.1 625.2 512.1 625.2 2 L +0.5 H +2 Z +0 X +0 K +N +98.1 625.49 143.1 625.49 2 L +0 Z +N +40.5 63 571.5 729 C +0 12 Q +0 X +0 K +(6) 134.63 631 T +(Images) 152.1 631 T +3 10 Q +(Tk 4.0 contains a general-purpose image mechanism for displaying color pictures and) 152.1 607.31 T +(other complex objects. There is a new command,) 152.1 595.26 T +5 F +(image) 350.84 595.26 T +3 F +(, which may be used to create) 380.82 595.26 T +(image objects. For example, the command) 152.1 583.21 T +5 9 Q +(image create photo myFace -f) 179.1 568.88 T +(ile picture.ppm) 330.09 568.88 T +3 10 Q +(creates a new image named) 152.1 555.21 T +5 F +(myFace) 264.5 555.21 T +3 F +(. The image is of type) 300.48 555.21 T +5 F +(photo) 390.14 555.21 T +3 F +( \050a full-color represen-) 420.12 555.21 T +(tation that dithers on monochrome or color) 152.1 543.17 T +(-mapped displays\051 and the source data for the) 323.46 543.17 T +(image is in the \336le named) 152.1 531.12 T +5 F +(picture.ppm) 257.59 531.12 T +3 F +(. Once an image has been created, it can be) 323.56 531.12 T +-0.15 (used in many dif) 152.1 519.07 P +-0.15 (ferent places by specifying a) 218.37 519.07 P +5 F +-0.36 (-image) 334.46 519.07 P +3 F +-0.15 ( option. For example, the command) 370.44 519.07 P +5 9 Q +(label .l -image myFace) 179.1 504.74 T +3 10 Q +(will create a label widget that displays the image, and if) 152.1 491.07 T +5 F +(.c) 377.5 491.07 T +3 F +( is a canvas widget the com-) 389.49 491.07 T +(mand) 152.1 479.02 T +5 9 Q +(.c create image 400 200 -image myFace) 179.1 464.69 T +3 10 Q +(will create an image item in the canvas that displays) 152.1 451.02 T +5 F +(myFace) 363.06 451.02 T +3 F +(.) 399.04 451.02 T +(The image mechanism provides a great deal of \337exibility:) 170.1 439.02 T +3 12 Q +(\245) 152.1 424.02 T +3 10 Q +-0.18 (Once an image has been de\336ned, it can be used in many dif) 162.9 424.02 P +-0.18 (ferent places, even on dif) 397.84 424.02 P +-0.18 (fer-) 497.68 424.02 P +(ent displays.) 162.9 411.98 T +3 12 Q +(\245) 152.1 396.98 T +3 10 Q +(Images provide image commands, analogous to widget commands, that can be used to) 162.9 396.98 T +(manipulate the image; any changes in an image are automatically re\337ected in all of its) 162.9 384.93 T +(instances.) 162.9 372.88 T +3 12 Q +(\245) 152.1 357.88 T +3 10 Q +-0.21 (There can be many dif) 162.9 357.88 P +-0.21 (ferent types of images. Tk 4.0 has two built-in types,) 251.78 357.88 P +5 F +-0.51 (photo) 463.11 357.88 P +3 F +-0.21 ( and) 493.1 357.88 P +5 F +(bitmap) 162.9 345.83 T +3 F +(. Other image types can be de\336ned in C as extensions \050see the documentation) 198.88 345.83 T +-0.16 (for the) 162.9 333.79 P +5 F +-0.39 (Tk_CreateImageType) 191.44 333.79 P +3 F +-0.16 ( library procedure\051. The photo image type was imple-) 299.38 333.79 P +(mented by Paul Mackerras, based on his earlier photo widget.) 162.9 321.74 T +3 12 Q +(\245) 152.1 306.74 T +3 10 Q +(W) 162.9 306.74 T +(ithin the photo image type, there can be many dif) 171.93 306.74 T +(ferent \336le formats. In Tk 4.0, only) 368.29 306.74 T +-0.11 (PPM, PGM, and GIF formats are built-in, but other formats can be added as extensions) 162.9 294.69 P +(\050see the documentation for the) 162.9 282.64 T +5 F +(Tk_CreatePhotoImageFormat) 286.97 282.64 T +3 F +( library proce-) 436.89 282.64 T +(dure\051. Readers for XPM, TIFF) 162.9 270.59 T +(, and others are available from the T) 284.23 270.59 T +(cl community) 428.41 270.59 T +(.) 483.01 270.59 T +98.1 227.24 512.1 230.26 C +152.1 228.46 512.1 228.46 2 L +0.5 H +2 Z +0 X +0 K +N +98.1 228.75 143.1 228.75 2 L +0 Z +N +40.5 63 571.5 729 C +0 12 Q +0 X +0 K +(7) 134.63 234.26 T +(Color management) 152.1 234.26 T +3 10 Q +(Tk 3.6 suf) 152.1 210.57 T +(fers from a relatively weak mechanism for managing colors. It uses only the) 192.73 210.57 T +(default colormap for a screen, and if all the entries in that colormap \336ll up then Tk) 152.1 198.52 T +(switches to monochrome mode and \322rounds\323 all future colors to black or white. This) 152.1 186.48 T +(approach is becoming increasingly unpleasant because of applications such as Frame and) 152.1 174.43 T +(W) 152.1 162.38 T +(eb browsers that use up all the entries in the default colormap.) 160.74 162.38 T +(Tk 4.0 has a much more powerful color management mechanism. If a colormap \336lls) 170.1 150.38 T +(up, Tk allocates future colors by picking the closest match from the available colors, so) 152.1 138.33 T +FMENDPAGE +%%EndPage: "13" 14 +%%Page: "14" 14 +612 792 0 FMBEGINPAGE +0 10 Q +0 X +0 K +(14) 98.1 668.33 T +4 F +(Tk4.0 Overview and Porting Guide) 359.34 668.33 T +98.1 660.6 512.1 660.6 2 L +0.25 H +0 Z +N +98.1 135 512.1 639 R +7 X +V +3 F +0 X +(that it need not revert to monochrome mode. Tk also manages colors better by delaying) 152.1 632.33 T +-0.3 (color allocation until colors are actually needed; in many cases, such as 3D borders, colors) 152.1 620.33 P +(are never needed. When colors are scarce Tk changes the way it displays beveled borders) 152.1 608.33 T +-0.38 (so that it uses stippling instead of additional colors for the light and dark shadows. Y) 152.1 596.33 P +-0.38 (ou can) 484.01 596.33 P +(\336nd out whether a colormap has \336lled up using the new command) 152.1 584.33 T +5 F +(winfo colormap-) 418.59 584.33 T +(full) 152.1 572.33 T +3 F +(.) 176.09 572.33 T +-0.26 (Tk 4.0 also allows you to allocate new colormaps for toplevel and frame widgets with) 170.1 560.33 P +(the) 152.1 548.33 T +5 F +(-colormap) 166.81 548.33 T +3 F +( option, and you change the visual type in these widgets \050with the) 220.78 548.33 T +5 F +(-) 152.1 536.33 T +(visual) 158.1 536.33 T +3 F +( option\051 to take advantage of visuals other than the default visual for a screen.) 194.08 536.33 T +(New commands) 152.1 524.33 T +5 F +(winfo visualsavailable) 219.27 524.33 T +3 F +( and) 351.2 524.33 T +5 F +(wm colormapwindows) 370.63 524.33 T +3 F +( have) 478.57 524.33 T +(been added to help manage colormaps and visuals.) 152.1 512.33 T +(The default color scheme in Tk 4.0 has changed from a tan palette \050\322bisque\323\051 to a) 170.1 500.33 T +(gray palette, which seems to becoming standard for Motif. There is a new T) 152.1 488.33 T +(cl procedure) 454.78 488.33 T +5 F +-0.36 (tk_setPalette) 152.1 476.33 P +3 F +-0.15 ( that changes the palette of an application on the \337y) 230.06 476.33 P +-0.15 (, and there is also a) 433.89 476.33 P +(procedure) 152.1 464.33 T +5 F +(tk_bisque) 194.56 464.33 T +3 F +( to restore the palette to the old bisque colors.) 248.53 464.33 T +(The Tk 3.6 color model mechanism is no longer necessary so it has been removed in) 170.1 452.33 T +(Tk 4.0. If you want to \336nd out whether a screen is monochrome or color) 152.1 440.33 T +(, you cannot use) 440.38 440.33 T +(the) 152.1 428.33 T +5 F +(tk colormodel) 166.81 428.33 T +3 F +( command anymore; use) 244.77 428.33 T +5 F +(winfo depth) 345.25 428.33 T +3 F +( instead.) 411.22 428.33 T +98.1 384.98 512.1 388 C +152.1 386.2 512.1 386.2 2 L +0.5 H +2 Z +0 X +0 K +N +98.1 386.49 143.1 386.49 2 L +0 Z +N +40.5 63 571.5 729 C +0 12 Q +0 X +0 K +(8) 134.63 392 T +(Event handling: \336leevent and after) 152.1 392 T +3 10 Q +(Tk 4.0 contains several improvements in the area of event handling besides those already) 152.1 368.31 T +(mentioned for bindings:) 152.1 356.31 T +3 12 Q +(\245) 152.1 341.31 T +3 10 Q +(There is a new command) 162.9 341.31 T +5 F +(f) 265.87 341.31 T +(ileevent) 271.87 341.31 T +3 F +( for performing event-driven I/O to and from) 319.84 341.31 T +-0.12 (\336les. The) 162.9 329.31 P +5 F +-0.29 (f) 202.35 329.31 P +-0.29 (ileevent) 208.35 329.31 P +3 F +-0.12 ( command is modelled very closely after Mark Diekhans\325) 256.33 329.31 P +5 F +-0.29 (add-) 488.11 329.31 P +(input) 162.9 317.31 T +3 F +( extension, which has been used widely with Tk 3.6.) 192.88 317.31 T +3 12 Q +(\245) 152.1 302.31 T +3 10 Q +-0.34 (The) 162.9 302.31 P +5 F +-0.82 (after) 180.6 302.31 P +3 F +-0.34 ( command has two new options,) 210.58 302.31 P +5 F +-0.82 (idle) 339.82 302.31 P +3 F +-0.34 ( and) 363.81 302.31 P +5 F +-0.82 (cancel) 382.55 302.31 P +3 F +-0.34 (.) 418.53 302.31 P +5 F +-0.82 (After idle) 423.19 302.31 P +3 F +-0.34 ( can be) 482.33 302.31 P +-0.2 (used to schedule a script as an \322idle handler\323, which means it runs the next time that Tk) 162.9 290.31 P +(enters the event loop and \336nds no work to do.) 162.9 278.31 T +5 F +(After cancel) 348.06 278.31 T +3 F +( may be used to delete) 420.02 278.31 T +(a previously-scheduled) 162.9 266.31 T +5 F +(after) 257.83 266.31 T +3 F +( script, so that it will no longer be invoked.) 287.81 266.31 T +98.1 222.95 512.1 225.98 C +152.1 224.18 512.1 224.18 2 L +0.5 H +2 Z +0 X +0 K +N +98.1 224.46 143.1 224.46 2 L +0 Z +N +40.5 63 571.5 729 C +0 12 Q +0 X +0 K +(9) 134.63 229.98 T +(Multiple displays) 152.1 229.98 T +3 10 Q +(Although Tk has always allowed a single application to open windows on several dis-) 152.1 206.29 T +(plays, the support for multiple displays is weak in Tk 3.6. For example, many of the bind-) 152.1 194.29 T +(ings break if users work simultaneously in windows on dif) 152.1 182.29 T +(ferent displays, and) 385.94 182.29 T +(mechanisms like the selection and the input focus have insuf) 152.1 170.29 T +(\336cient support for multiple) 394.26 170.29 T +(displays.) 152.1 158.29 T +FMENDPAGE +%%EndPage: "14" 15 +%%Page: "15" 15 +612 792 0 FMBEGINPAGE +4 10 Q +0 X +0 K +(10 The send command) 98.1 668.33 T +0 F +(15) 500.99 668.33 T +98.1 660.6 512.1 660.6 2 L +0.25 H +0 Z +N +98.1 135 512.1 639 R +7 X +V +3 F +0 X +-0.33 (Tk 4.0 contains numerous modi\336cations to improve the handling of multiple displays.) 170.1 632.33 P +-0.18 (Several commands, such as) 152.1 620.24 P +5 F +-0.44 (selection) 263.78 620.24 P +3 F +-0.18 (,) 317.76 620.24 P +5 F +-0.44 (send) 322.57 620.24 P +3 F +-0.18 (, and) 346.55 620.24 P +5 F +-0.44 (focus) 368.12 620.24 P +3 F +-0.18 (, have a new) 398.1 620.24 P +5 F +-0.44 (-displayof) 449.82 620.24 P +3 F +(ar) 152.1 608.15 T +(gument so that you can select a particular display) 159.69 608.15 T +(. In addition, the bindings have been) 356.12 608.15 T +(reworked to handle interactions occurring simultaneously on dif) 152.1 596.05 T +(ferent displays. W) 408.13 596.05 T +(ith Tk) 480.73 596.05 T +(4.0 it should be possible to create applications that really use multiple displays gracefully) 152.1 583.96 T +(.) 508.44 583.96 T +98.1 540.6 512.1 543.63 C +152.1 541.83 512.1 541.83 2 L +0.5 H +2 Z +0 X +0 K +N +98.1 542.12 143.1 542.12 2 L +0 Z +N +40.5 63 571.5 729 C +0 12 Q +0 X +0 K +(10) 127.96 547.63 T +(The send command) 152.1 547.63 T +3 10 Q +-0.2 (The) 152.1 523.94 P +5 F +-0.48 (send) 169.94 523.94 P +3 F +-0.2 ( command has been completely overhauled for Tk 4.0 to eliminate several prob-) 193.93 523.94 P +(lems in Tk 3.6 and add a number of new features:) 152.1 511.85 T +3 12 Q +(\245) 152.1 496.85 T +3 10 Q +(Tk 3.6 aborts a) 162.9 496.85 T +5 F +(send) 225.36 496.85 T +3 F +( command if no response is received within 5 seconds; this made) 249.34 496.85 T +(it very dif) 162.9 484.75 T +(\336cult to invoke long-running commands. Tk 4.0 eliminates the timeout and) 202.14 484.75 T +(uses a dif) 162.9 472.66 T +(ferent mechanism to tell if the tar) 200.47 472.66 T +(get application has crashed.) 333.53 472.66 T +3 12 Q +(\245) 152.1 457.66 T +3 10 Q +-0.36 (The) 162.9 457.66 P +5 F +-0.87 (winfo interps) 180.58 457.66 P +3 F +-0.36 ( command no longer returns the names of applications that have) 257.66 457.66 P +(exited or crashed.) 162.9 445.57 T +3 12 Q +(\245) 152.1 430.57 T +3 10 Q +(Asynchronous sends are possible using the) 162.9 430.57 T +5 F +(-async) 336.67 430.57 T +3 F +( switch.) 372.65 430.57 T +3 12 Q +(\245) 152.1 415.57 T +3 10 Q +(Commands can be sent to displays other than that of the root window) 162.9 415.57 T +(, using the) 439.3 415.57 T +5 F +(-) 162.9 403.47 T +(displayof) 168.9 403.47 T +3 F +( switch.) 222.87 403.47 T +3 12 Q +(\245) 152.1 388.47 T +3 10 Q +(W) 162.9 388.47 T +(indow server security is now checked on each) 171.93 388.47 T +5 F +(send) 357.89 388.47 T +3 F +(, so Tk 4.0 deals better with) 381.88 388.47 T +(changes in the security of the server) 162.9 376.38 T +(.) 306.12 376.38 T +3 12 Q +(\245) 152.1 361.38 T +3 10 Q +(More complete error information \050including the) 162.9 361.38 T +5 F +(errorCode) 356.09 361.38 T +3 F +( and) 410.06 361.38 T +5 F +(errorInfo) 429.49 361.38 T +3 F +( vari-) 483.46 361.38 T +(ables\051 is propagated back to the sender after errors.) 162.9 349.29 T +3 12 Q +(\245) 152.1 334.29 T +3 10 Q +(Y) 162.9 334.29 T +(ou can query and change the name of an application with the) 169.12 334.29 T +5 F +(tk appname) 414.48 334.29 T +3 F +( com-) 474.45 334.29 T +(mand.) 162.9 322.19 T +(Unfortunately the improvements to the Tk 4.0) 152.1 307.19 T +5 F +(send) 338.65 307.19 T +3 F +( mechanism required substantial) 362.63 307.19 T +(changes to the transport protocol for sends; this makes it impossible for Tk 4.0 applica-) 152.1 295.1 T +(tions to communicate with Tk 3.6 applications via) 152.1 283.01 T +5 F +(send) 355.04 283.01 T +3 F +(. The new transport protocol is) 379.02 283.01 T +(more \337exible than the old protocol, so it should be possible to make protocol improve-) 152.1 270.91 T +(ments in an upward-compatible way) 152.1 258.82 T +(.) 296.9 258.82 T +98.1 215.47 512.1 218.49 C +152.1 216.69 512.1 216.69 2 L +0.5 H +2 Z +0 X +0 K +N +98.1 216.98 143.1 216.98 2 L +0 Z +N +40.5 63 571.5 729 C +0 12 Q +0 X +0 K +(1) 128.62 222.49 T +(1) 134.63 222.49 T +(The selection and clipboard) 152.1 222.49 T +3 10 Q +(In Tk 3.6 the selection mechanism can deal only with the display of the root window and) 152.1 198.8 T +-0.13 (with the primary selection; there is no support for multiple displays, secondary selections,) 152.1 186.71 P +(or the clipboard. Tk 4.0 eliminates all of these shortcomings. The) 152.1 174.61 T +5 F +(-displayof) 415.82 174.61 T +3 F +( option) 475.78 174.61 T +-0.12 (can be used to specify a particular display in the selection command, and there is now full) 152.1 162.52 P +(access to all of the X selection types. Tk 4.0 also includes a new) 152.1 150.43 T +5 F +(clipboard) 411.36 150.43 T +3 F +( command) 465.33 150.43 T +(for manipulating the clipboard.) 152.1 138.33 T +FMENDPAGE +%%EndPage: "15" 16 +%%Page: "16" 16 +612 792 0 FMBEGINPAGE +0 10 Q +0 X +0 K +(16) 98.1 668.33 T +4 F +(Tk4.0 Overview and Porting Guide) 359.34 668.33 T +98.1 660.6 512.1 660.6 2 L +0.25 H +0 Z +N +98.1 135 512.1 639 R +7 X +V +98.1 623.98 512.1 627 C +152.1 625.2 512.1 625.2 2 L +0.5 H +2 Z +0 X +0 K +N +98.1 625.49 143.1 625.49 2 L +0 Z +N +40.5 63 571.5 729 C +0 12 Q +0 X +0 K +(12) 127.96 631 T +(Miscellaneous changes) 152.1 631 T +3 10 Q +(Here is a quick summary of the remaining changes in Tk 4.0:) 152.1 607.31 T +3 12 Q +(\245) 152.1 592.31 T +3 10 Q +-0.17 (The) 162.9 592.31 P +5 F +-0.42 (wish) 180.76 592.31 P +3 F +-0.17 ( application has been modi\336ed so that the) 204.75 592.31 P +5 F +-0.42 (-f) 371.58 592.31 P +-0.42 (ile) 383.57 592.31 P +3 F +-0.17 ( switch is no longer needed) 401.56 592.31 P +(or recommended. This makes) 162.9 580.31 T +5 F +(wish) 283.64 580.31 T +3 F +( just like) 307.63 580.31 T +5 F +(tclsh) 344.56 580.31 T +3 F +(, where you specify the script \336le) 374.54 580.31 T +(as the \336rst ar) 162.9 568.31 T +(gument to the program, e.g.) 214.07 568.31 T +5 F +(wish foo.tcl) 327.33 568.31 T +3 F +(. The) 399.29 568.31 T +5 F +(-f) 422.33 568.31 T +(ile) 434.32 568.31 T +3 F +( switch is still) 452.31 568.31 T +(permitted for backward compatibility) 162.9 556.31 T +(, but its use is deprecated.) 311.87 556.31 T +3 12 Q +(\245) 152.1 541.31 T +5 10 Q +(Wish) 162.9 541.31 T +3 F +( now sets the application\325) 186.89 541.31 T +(s class from the application name \050what appears in the) 288.49 541.31 T +-0.37 (title bar of the window by default\051, rather than always using) 162.9 529.31 P +5 F +-0.88 (Tk) 400.9 529.31 P +3 F +-0.37 ( as the class as in Tk 3.6.) 412.89 529.31 P +(This makes application-speci\336c options easier to use.) 162.9 517.31 T +3 12 Q +(\245) 152.1 502.31 T +3 10 Q +(T) 162.9 502.31 T +(oplevel windows are now resizable by default, whereas in Tk 3.6 they were not. Y) 168.31 502.31 T +(ou) 496.22 502.31 T +(can use the) 162.9 490.31 T +5 F +(wm resizable) 209.8 490.31 T +3 F +( command to make windows non-reiszable.) 281.77 490.31 T +3 12 Q +(\245) 152.1 475.31 T +3 10 Q +(Tk 4.0 patches around an Xlib bug whereby long-running applications tended to reach) 162.9 475.31 T +(the end of the space of X resource ids, wrap around to 0 again, and then crash. Tk now) 162.9 463.31 T +(reuses resource identi\336ers so that wrap-around should never occur) 162.9 451.31 T +(.) 427.14 451.31 T +3 12 Q +(\245) 152.1 436.31 T +3 10 Q +-0.13 (There is a new) 162.9 436.31 P +5 F +-0.31 (winfo manager) 223.43 436.31 P +3 F +-0.13 ( command that tells which geometry manager is con-) 301.08 436.31 P +(trolling a particular widget.) 162.9 424.31 T +3 12 Q +(\245) 152.1 409.31 T +3 10 Q +(There is a new) 162.9 409.31 T +5 F +(bell) 223.96 409.31 T +3 F +( command that does what its name suggests.) 247.94 409.31 T +3 12 Q +(\245) 152.1 394.31 T +3 10 Q +(There are new) 162.9 394.31 T +5 F +(winfo pointerx) 222.56 394.31 T +3 F +(,) 306.51 394.31 T +5 F +(winfo pointery) 311.51 394.31 T +3 F +(, and) 394.81 394.31 T +5 F +(winfo pointerxy) 416.74 394.31 T +3 F +(commands that can be used to query the position of the mouse pointer) 162.9 382.31 T +(.) 442.17 382.31 T +98.1 338.95 512.1 341.98 C +152.1 340.18 512.1 340.18 2 L +0.5 H +2 Z +0 X +0 K +N +98.1 340.46 143.1 340.46 2 L +0 Z +N +40.5 63 571.5 729 C +0 12 Q +0 X +0 K +(13) 127.96 345.98 T +(Summary of Incompatibilites) 152.1 345.98 T +3 10 Q +-0.24 (This section lists all of the incompatible changes in Tk 4.0 that may require changes in T) 152.1 322.29 P +-0.24 (cl) 502.62 322.29 P +-0.22 (scripts written for T) 152.1 310.29 P +-0.22 (cl 3.6. Each incompatibility is described in terms of the problem it pro-) 230.42 310.29 P +(duces when you run your Tk 3.6 script under Tk 4.0 and a possible work-around. Only) 152.1 298.29 T +(T) 152.1 286.29 T +(cl-level incompatibilities are covered here. For incompatible changes at the C level, see) 157.51 286.29 T +(the) 152.1 274.29 T +5 F +(README) 166.81 274.29 T +3 F +( and) 202.79 274.29 T +5 F +(changes) 222.22 274.29 T +3 F +( \336les in the distribution. The problems and solutions are) 264.2 274.29 T +(roughly in order of importance, with the most important problems \336rst.) 152.1 262.29 T +1 F +(Pr) 152.1 247.29 T +(oblem #1:) 162.46 247.29 T +3 F +(When you change the background color of a widget, a small ring in the) 206.88 247.29 T +(default background color remains around the edge of the widget.) 152.1 235.29 T +2 F +(Solution:) 170.1 223.29 T +3 F +(This is the focus traversal highlight, whose color is speci\336ed separately) 209.25 223.29 T +(from) 170.1 211.29 T +5 F +(-background) 192.03 211.29 T +3 F +(; use the) 257.99 211.29 T +5 F +(-highlightbackground) 293.8 211.29 T +3 F +( option to change the) 413.74 211.29 T +(color of the highlight. Or) 170.1 199.29 T +(, you can set) 269.92 199.29 T +5 F +(-highlightthickness) 322.38 199.29 T +3 F +( to 0 to eliminate) 436.31 199.29 T +(the traversal highlight altogether) 170.1 187.29 T +(.) 299.74 187.29 T +1 F +(Pr) 152.1 172.29 T +(oblem #2:) 162.46 172.29 T +3 F +(Bindings de\336ned for a widget no longer replace the corresponding class) 206.88 172.29 T +(bindings, so unwanted class bindings get invoked in addition to the widget bindings.) 152.1 160.29 T +FMENDPAGE +%%EndPage: "16" 17 +%%Page: "17" 17 +612 792 0 FMBEGINPAGE +4 10 Q +0 X +0 K +(13 Summary of Incompatibilites) 98.1 668.33 T +0 F +(17) 500.99 668.33 T +98.1 660.6 512.1 660.6 2 L +0.25 H +0 Z +N +98.1 135 512.1 639 R +7 X +V +2 F +0 X +(Solution:) 170.1 632.33 T +3 F +(Add a) 209.25 632.33 T +5 F +(break) 235.89 632.33 T +3 F +( command at the end of the widget binding, or rework the) 265.88 632.33 T +(widget binding so that it\325) 170.1 620.33 T +(s OK for the class binding to execute.) 270.05 620.33 T +1 F +(Pr) 152.1 605.33 T +(oblem #3:) 162.46 605.33 T +3 F +(Bindings on toplevel windows are invoked when events occur for internal) 206.88 605.33 T +(windows inside the toplevels.) 152.1 593.33 T +2 F +(Solution:) 170.1 581.33 T +3 F +(Use the) 209.25 581.33 T +5 F +(%W) 242 581.33 T +3 F +( substitution to extract the name of the window where the event) 253.99 581.33 T +(actually occurred, and only execute the rest of the binding script if this matches the) 170.1 569.33 T +(name of the toplevel.) 170.1 557.33 T +1 F +-0.15 (Pr) 152.1 542.33 P +-0.15 (oblem #4:) 162.46 542.33 P +3 F +-0.15 (The) 206.58 542.33 P +5 F +-0.37 (-command) 224.46 542.33 P +3 F +-0.15 ( option for a cascade menu entry is no longer invoked when) 272.44 542.33 P +(the submenu is posted.) 152.1 530.33 T +2 F +(Solution:) 170.1 518.33 T +3 F +(Use the) 209.25 518.33 T +5 F +(-postcommand) 242 518.33 T +3 F +( option for the submenu instead.) 313.96 518.33 T +1 F +(Pr) 152.1 503.33 T +(oblem #5:) 162.46 503.33 T +3 F +(The) 206.88 503.33 T +5 F +(-geometry) 224.92 503.33 T +3 F +( option is no longer supported by listboxes, frames, and) 278.89 503.33 T +(toplevels.) 152.1 491.33 T +2 F +(Solution:) 170.1 479.33 T +3 F +(Use the) 209.25 479.33 T +5 F +(-width) 242 479.33 T +3 F +( and) 277.98 479.33 T +5 F +(-height) 297.41 479.33 T +3 F +( options instead.) 339.39 479.33 T +1 F +(Pr) 152.1 464.33 T +(oblem #6:) 162.46 464.33 T +3 F +(The procedure) 206.88 464.33 T +5 F +(tk_listboxSingleSelect) 267.38 464.33 T +3 F +( no longer exists.) 399.3 464.33 T +2 F +(Solution:) 170.1 452.33 T +3 F +(Use the) 209.25 452.33 T +5 F +(-selectmode) 242 452.33 T +3 F +( option on the listbox instead.) 307.96 452.33 T +1 F +(Pr) 152.1 437.33 T +(oblem #7:) 162.46 437.33 T +3 F +(Canvases no longer have a) 206.88 437.33 T +5 F +(-scrollincrement) 315.96 437.33 T +3 F +( option.) 411.91 437.33 T +2 F +(Solution:) 170.1 425.33 T +3 F +(Use the new) 209.25 425.33 T +5 F +(-xscrollincrement) 261.15 425.33 T +3 F +( and) 363.09 425.33 T +5 F +(-yscrollincrement) 382.52 425.33 T +3 F +(options instead.) 170.1 413.33 T +1 F +(Pr) 152.1 398.33 T +(oblem #8:) 162.46 398.33 T +3 F +(The) 206.88 398.33 T +5 F +(tk colormodel) 224.92 398.33 T +3 F +( command no longer exists.) 302.88 398.33 T +2 F +-0.28 (Solution:) 170.1 386.33 P +3 F +-0.28 (T) 208.97 386.33 P +-0.28 (o \336nd out whether a window is monochrome or color) 214.37 386.33 P +-0.28 (, use) 424.34 386.33 P +5 F +-0.68 (winfo depth) 444.6 386.33 P +3 F +(to extract the window\325) 170.1 374.33 T +(s depth; a depth of 1 means monochrome.) 259.76 374.33 T +1 F +-0.08 (Pr) 152.1 359.33 P +-0.08 (oblem #9:) 162.46 359.33 P +3 F +-0.08 (The class of Tk applications is no longer) 206.72 359.33 P +5 F +-0.19 (Tk) 370.97 359.33 P +3 F +-0.08 (, so options speci\336ed for the) 382.96 359.33 P +5 F +-0.19 (Tk) 497.69 359.33 P +3 F +(class in your) 152.1 347.33 T +5 F +(.Xdefaults) 205.12 347.33 T +3 F +( \336le are no longer used.) 265.09 347.33 T +2 F +(Solution:) 170.1 335.33 T +3 F +(Modify your) 209.25 335.33 T +5 F +(.Xdefaults) 262.55 335.33 T +3 F +( \336le \050and any T) 322.52 335.33 T +(cl code that sets options\051 to) 382.88 335.33 T +(specify the name of the application \050with the \336rst letter capitalized\051 as the class) 170.1 323.33 T +(instead of) 170.1 311.33 T +5 F +(Tk) 211.74 311.33 T +3 F +(.) 223.73 311.33 T +1 F +-0.15 (Pr) 152.1 296.33 P +-0.15 (oblem #10:) 162.46 296.33 P +3 F +-0.15 (When text is added to a text widget just after a tagged area, the new text no) 211.57 296.33 P +(longer receives the tag.) 152.1 284.33 T +2 F +-0.1 (Solution:) 170.1 272.33 P +3 F +-0.1 (Explicitly tag the new text with the desired tags. If you want the tags on the) 209.15 272.33 P +-0.08 (new text to be the same as those at some other point in the text, you can use the) 170.1 260.33 P +5 F +-0.2 (tag) 488.31 260.33 P +(names) 170.1 248.33 T +3 F +( widget command to query existing tags.) 200.08 248.33 T +1 F +(Pr) 152.1 233.33 T +(oblem #1) 162.46 233.33 T +(1:) 200.5 233.33 T +3 F +(W) 211.33 233.33 T +(idgets appear lar) 220.36 233.33 T +(ger than they did in Tk 3.6.) 286.24 233.33 T +2 F +(Solution:) 170.1 221.33 T +3 F +(There are two issues here. The \336rst is that all widgets now have a focus tra-) 209.25 221.33 T +-0.24 (versal highlight ring that turns dark when the widget has the focus; this is required for) 170.1 209.33 P +(Motif compliance but you can eliminate it by specifying a 0 value for the) 170.1 197.33 T +5 F +( -high-) 462.4 197.33 T +(lightthickness) 170.1 185.33 T +3 F +( option. The second issue is that the default padding for buttons) 254.05 185.33 T +-0.17 (and menubuttons has been increased to match the sizes of Motif widgets. If you don\325) 170.1 173.33 P +-0.17 (t) 506.99 173.33 P +(mind being dif) 170.1 161.33 T +(ferent from Motif, you can set the) 228.78 161.33 T +5 F +(-padx) 366.45 161.33 T +3 F +( and) 396.44 161.33 T +5 F +(-) 415.86 161.33 T +(pady) 421.86 161.33 T +3 F +( options back to) 445.85 161.33 T +FMENDPAGE +%%EndPage: "17" 18 +%%Page: "18" 18 +612 792 0 FMBEGINPAGE +0 10 Q +0 X +0 K +(18) 98.1 668.33 T +4 F +(Tk4.0 Overview and Porting Guide) 359.34 668.33 T +98.1 660.6 512.1 660.6 2 L +0.25 H +0 Z +N +98.1 135 512.1 639 R +7 X +V +3 F +0 X +(their Tk 3.6 values \050use the) 170.1 632.33 T +5 F +(conf) 281.41 632.33 T +(igure) 305.4 632.33 T +3 F +( widget command in Tk 3.6 to see what the) 335.38 632.33 T +(old values were\051.) 170.1 620.33 T +1 F +(Pr) 152.1 605.33 T +(oblem #12:) 162.46 605.33 T +3 F +(Listboxes now return the selection as a string with newlines separating the) 211.88 605.33 T +(values, rather than a T) 152.1 593.33 T +(cl, list.) 240.49 593.33 T +2 F +(Solution:) 170.1 581.33 T +3 F +(Modify your code to handle the new format. Y) 209.25 581.33 T +(ou can convert the selection) 395.06 581.33 T +(back into the old list format with a script like the following:) 170.1 569.33 T +5 9 Q +(split [selection get] \134n) 179.1 555 T +1 10 Q +(Pr) 152.1 541.33 T +(oblem #13:) 162.46 541.33 T +3 F +(Tk 4.0 applications cannot) 211.88 541.33 T +5 F +(send) 320.42 541.33 T +3 F +( to or be sent from Tk 3.6 applications.) 344.4 541.33 T +2 F +(Solution:) 170.1 529.33 T +3 F +(The only solution is to upgrade all your applications to Tk 4.0.) 209.25 529.33 T +1 F +-0.17 (Pr) 152.1 514.33 P +-0.17 (oblem #14:) 162.46 514.33 P +3 F +-0.17 (In texts,) 211.54 514.33 P +5 F +-0.4 (end) 245.91 514.33 P +3 F +-0.17 ( now refers to a position just after the \336nal newline, instead of) 263.9 514.33 P +(the \336nal newline.) 152.1 502.33 T +2 F +-0.08 (Solution:) 170.1 490.33 P +3 F +-0.08 (If you wish to refer to the \336nal newline, use the index) 209.17 490.33 P +5 F +-0.19 (end-1char) 424.98 490.33 P +3 F +-0.08 ( instead) 478.95 490.33 P +(of) 170.1 478.33 T +5 F +(end) 180.92 478.33 T +3 F +(.) 198.91 478.33 T +1 F +(Pr) 152.1 463.33 T +(oblem #15:) 162.46 463.33 T +3 F +(In entry widgets,) 211.88 463.33 T +5 F +(sel.last) 281.83 463.33 T +3 F +( now refers to the character just after the last) 329.8 463.33 T +(selected one, rather than the last selected one. The second index for the) 152.1 451.33 T +5 F +(delete) 438.81 451.33 T +3 F +( widget) 474.79 451.33 T +(command has changed in the same way) 152.1 439.33 T +(.) 309.66 439.33 T +2 F +(Solution:) 170.1 427.33 T +3 F +(Add one to the values used in your scripts.) 209.25 427.33 T +1 F +(Pr) 152.1 412.33 T +(oblem #16:) 162.46 412.33 T +3 F +(Because) 211.88 412.33 T +5 F +(Any) 247.68 412.33 T +3 F +( is implicit in all bindings, bindings trigger when extra modi-) 265.67 412.33 T +(\336ers are present, whereas they didn\325) 152.1 400.33 T +(t trigger in Tk 3.6.) 296.24 400.33 T +2 F +(Solution:) 170.1 388.33 T +3 F +(In most cases it\325) 209.25 388.33 T +(s probably \336ne to ignore the extra modi\336ers. If you really) 273.93 388.33 T +-0.12 (don\325) 170.1 376.33 P +-0.12 (t want any actions to be taken when extra modi\336ers are present, create additional) 188.24 376.33 P +(bindings for the cases with extra modi\336ers, and specify a single blank character \050or) 170.1 364.33 T +(any script that does nothing\051 as the script for those bindings. Alternatively) 170.1 352.33 T +(, you can) 465.93 352.33 T +(use the) 170.1 340.33 T +5 F +(%s) 200.63 340.33 T +3 F +( substitution to extract the mouse and modi\336er state in the event binding,) 212.63 340.33 T +(then you can test this value for modi\336ers you do or don\325) 170.1 328.33 T +(t want.) 394.5 328.33 T +1 F +(Pr) 152.1 313.33 T +(oblem #17:) 162.46 313.33 T +3 F +(In scrollbars there is no longer a) 211.88 313.33 T +5 F +(-foreground) 343.17 313.33 T +3 F +( or) 409.13 313.33 T +5 F +(-activefore-) 422.45 313.33 T +(ground) 152.1 301.33 T +3 F +( option, and) 188.08 301.33 T +5 F +(-background) 238.05 301.33 T +3 F +( has a dif) 304.02 301.33 T +(ferent meaning.) 340.2 301.33 T +2 F +-0.4 (Solution:) 170.1 289.33 P +3 F +-0.4 (Use) 208.85 289.33 P +5 F +-0.96 (-troughcolor) 226.49 289.33 P +3 F +-0.4 ( everywhere that you used) 298.45 289.33 P +5 F +-0.96 (-background) 403.87 289.33 P +3 F +-0.4 ( in Tk 3.6,) 469.83 289.33 P +5 F +(-background) 170.1 277.33 T +3 F +( everywhere you used to use) 236.06 277.33 T +5 F +(-foreground) 352.08 277.33 T +3 F +(, and) 418.04 277.33 T +5 F +(-activeback-) 439.97 277.33 T +(ground) 170.1 265.33 T +3 F +( everywhere you used to use) 206.08 265.33 T +5 F +(-activeforeground) 322.1 265.33 T +3 F +(.) 424.04 265.33 T +1 F +(Pr) 152.1 250.33 T +(oblem #18:) 162.46 250.33 T +3 F +(Options for colors seem to have changed in scale widgets.) 211.88 250.33 T +2 F +(Solution:) 170.1 238.33 T +3 F +(Use) 209.25 238.33 T +5 F +(-background) 227.29 238.33 T +3 F +( where you used to use) 293.25 238.33 T +5 F +(-sliderforeground) 387.07 238.33 T +3 F +(,) 489.02 238.33 T +5 F +(-) 170.1 226.33 T +(troughcolor) 176.1 226.33 T +3 F +( where you used to use) 242.06 226.33 T +5 F +(-background) 335.88 226.33 T +3 F +(, and) 401.84 226.33 T +5 F +( -activeback-) 421.27 226.33 T +(ground) 170.1 214.33 T +3 F +( everywhere you used to use) 206.08 214.33 T +5 F +(-activeforeground) 322.1 214.33 T +3 F +(.) 424.04 214.33 T +1 F +(Pr) 152.1 199.33 T +(oblem #19:) 162.46 199.33 T +3 F +(Scale widgets no longer accept hexadecimal or octal numbers in the) 211.88 199.33 T +5 F +(set) 485.84 199.33 T +3 F +(command or the) 152.1 187.33 T +5 F +(-from) 219.55 187.33 T +3 F +( and) 249.54 187.33 T +5 F +(-to) 268.97 187.33 T +3 F +( options.) 286.96 187.33 T +2 F +(Solution:) 170.1 175.33 T +3 F +(Use) 209.25 175.33 T +5 F +(format) 227.29 175.33 T +3 F +( or) 263.27 175.33 T +5 F +(expr) 276.59 175.33 T +3 F +( to convert the values to decimal.) 300.58 175.33 T +1 F +(Pr) 152.1 160.33 T +(oblem #20:) 162.46 160.33 T +3 F +(In checkbuttons, radiobuttons, and menu entries, the) 211.88 160.33 T +5 F +(-selector) 423.4 160.33 T +3 F +( option) 477.37 160.33 T +(no longer exists.) 152.1 148.33 T +FMENDPAGE +%%EndPage: "18" 19 +%%Page: "19" 19 +612 792 0 FMBEGINPAGE +4 10 Q +0 X +0 K +(13 Summary of Incompatibilites) 98.1 668.33 T +0 F +(19) 500.99 668.33 T +98.1 660.6 512.1 660.6 2 L +0.25 H +0 Z +N +98.1 135 512.1 639 R +7 X +V +2 F +0 X +(Solution:) 170.1 632.33 T +3 F +(Use) 209.25 632.33 T +5 F +(-selectcolor) 227.29 632.33 T +3 F +( instead of) 299.25 632.33 T +5 F +(-select) 343.39 632.33 T +3 F +(. T) 385.36 632.33 T +(o specify that no indicator) 395.77 632.33 T +(should be drawn at all, use the) 170.1 620.33 T +5 F +(-indicatoron) 293.9 620.33 T +3 F +( option instead of setting) 365.86 620.33 T +5 F +(-select) 467.2 620.33 T +3 F +(to an empty string.) 170.1 608.33 T +1 F +-0.12 (Pr) 152.1 593.33 P +-0.12 (oblem #21:) 162.46 593.33 P +3 F +-0.12 (The indices of menu entries have changed, and operations on menu entry 0) 211.64 593.33 P +(no longer work.) 152.1 581.33 T +2 F +(Solution:) 170.1 569.33 T +3 F +(This is because menus now have a tearof) 209.25 569.33 T +(f entry at the top by default, and) 372.55 569.33 T +(this occupies entry 0, so your \336rst entry is now entry 1. Y) 170.1 557.33 T +(ou can either set the) 398.95 557.33 T +5 F +(-) 170.1 545.33 T +(tearoff) 176.1 545.33 T +3 F +( option to 0 to eliminate the tearof) 218.07 545.33 T +(f entry or add 1 to all the indices you) 354.2 545.33 T +(use in your scripts.) 170.1 533.33 T +1 F +-0.22 (Pr) 152.1 518.33 P +-0.22 (oblem #22:) 162.46 518.33 P +3 F +-0.22 (The) 211.44 518.33 P +5 F +-0.53 (enable) 229.26 518.33 P +3 F +-0.22 ( and) 265.24 518.33 P +5 F +-0.53 (disable) 284.23 518.33 P +3 F +-0.22 ( widget commands are no longer supported by) 326.21 518.33 P +(menus.) 152.1 506.33 T +2 F +(Solution:) 170.1 494.33 T +3 F +(Use the) 209.25 494.33 T +5 F +(-state) 242 494.33 T +3 F +( con\336guration option instead.) 277.98 494.33 T +1 F +(Pr) 152.1 479.33 T +(oblem #23:) 162.46 479.33 T +3 F +(The) 211.88 479.33 T +5 F +(activate) 229.92 479.33 T +3 F +( and) 277.89 479.33 T +5 F +(deactivate) 297.32 479.33 T +3 F +( widget commands are no longer sup-) 357.29 479.33 T +(ported by buttons, checkbuttons, radiobuttons, and menus.) 152.1 467.33 T +2 F +(Solution:) 170.1 455.33 T +3 F +(Use the) 209.25 455.33 T +5 F +(-state) 242 455.33 T +3 F +( con\336guration option instead.) 277.98 455.33 T +1 F +(Pr) 152.1 440.33 T +(oblem #24:) 162.46 440.33 T +3 F +(Canvas arc items no longer use the) 211.88 440.33 T +5 F +(-f) 353.72 440.33 T +(ill) 365.71 440.33 T +3 F +( and) 383.7 440.33 T +5 F +(-stipple) 403.13 440.33 T +3 F +( options for) 451.11 440.33 T +(drawing when the) 152.1 428.33 T +5 F +(-style) 226.21 428.33 T +3 F +( option is) 262.19 428.33 T +5 F +(arc) 301.9 428.33 T +3 F +(.) 319.89 428.33 T +2 F +(Solution:) 170.1 416.33 T +3 F +(Use the) 209.25 416.33 T +5 F +(-outline) 242 416.33 T +3 F +( and) 289.97 416.33 T +5 F +(-outlinestipple) 309.4 416.33 T +3 F +( options instead.) 399.35 416.33 T +1 F +-0.29 (Pr) 152.1 401.33 P +-0.29 (oblem #25:) 162.46 401.33 P +3 F +-0.29 (The variable) 211.29 401.33 P +5 F +-0.7 (tkVersion) 263.43 401.33 P +3 F +-0.29 ( no longer exists \050it has been obsolete for several) 317.4 401.33 P +(releases\051.) 152.1 389.33 T +2 F +(Solution:) 170.1 377.33 T +3 F +(Use) 209.25 377.33 T +5 F +(tk_version) 227.29 377.33 T +3 F +( instead.) 287.26 377.33 T +1 F +(Pr) 152.1 362.33 T +(oblem #26:) 162.46 362.33 T +3 F +(The syntax of the) 211.88 362.33 T +5 F +(scan) 284.05 362.33 T +3 F +( widget commands for texts has changed.) 308.03 362.33 T +2 F +(Solution:) 170.1 350.33 T +3 F +(Modify your code to use the new syntax.) 209.25 350.33 T +1 F +(Pr) 152.1 335.33 T +(oblem #27:) 162.46 335.33 T +5 F +(wish) 211.88 335.33 T +3 F +( no longer recognizes the) 235.86 335.33 T +5 F +(-help) 338.84 335.33 T +3 F +( option.) 368.82 335.33 T +2 F +(Solution:) 170.1 323.33 T +3 F +(Implement this option yourself in your) 209.25 323.33 T +5 F +(wish) 366.38 323.33 T +3 F +( scripts.) 390.37 323.33 T +1 F +(Pr) 152.1 308.33 T +(oblem #28:) 162.46 308.33 T +3 F +(Tk 4.0 always prints real numbers such as canvas coordinates with a deci-) 211.88 308.33 T +(mal point. This can cause syntax errors if you later use them in situations where integers) 152.1 296.33 T +(are expected.) 152.1 284.33 T +2 F +(Solution:) 170.1 272.33 T +3 F +(Change your code so that real numbers work OK, or use the) 209.25 272.33 T +5 F +(expr) 451.57 272.33 T +3 F +( com-) 475.55 272.33 T +(mand \050with the) 170.1 260.33 T +5 F +(round) 233.12 260.33 T +3 F +( function\051 to convert the numbers to integers.) 263.1 260.33 T +1 F +(Pr) 152.1 245.33 T +(oblem #29:) 162.46 245.33 T +3 F +(The) 211.88 245.33 T +5 F +(pack info) 229.92 245.33 T +3 F +( command returns dif) 283.89 245.33 T +(ferent information, and) 369.48 245.33 T +5 F +(pack) 464.41 245.33 T +(newinfo) 152.1 233.33 T +3 F +( no longer exists.) 194.08 233.33 T +2 F +(Solution:) 170.1 221.33 T +3 F +(Use) 209.25 221.33 T +5 F +(pack info) 227.29 221.33 T +3 F +( where you used to use) 281.26 221.33 T +5 F +(pack newinfo) 375.08 221.33 T +3 F +(.) 447.04 221.33 T +5 F +(Pack info) 452.04 221.33 T +3 F +(was obsolete, so it has been eliminated.) 170.1 209.33 T +1 F +(Pr) 152.1 194.33 T +(oblem #30:) 162.46 194.33 T +3 F +(The) 211.88 194.33 T +5 F +(view) 229.92 194.33 T +3 F +( widget command for entries no longer exists, nor does the) 253.9 194.33 T +5 F +(-) 152.1 182.33 T +(scrollcommand) 158.1 182.33 T +3 F +( option.) 236.05 182.33 T +2 F +-0.29 (Solution:) 170.1 170.33 P +3 F +-0.29 (Use) 208.96 170.33 P +5 F +-0.69 (xview) 226.71 170.33 P +3 F +-0.29 ( where you used to use) 256.7 170.33 P +5 F +-0.69 (view) 348.8 170.33 P +3 F +-0.29 (; use) 372.78 170.33 P +5 F +-0.69 (-xscrollcommand) 393.31 170.33 P +3 F +-0.29 ( where) 483.26 170.33 P +(you used to use) 170.1 158.33 T +5 F +(-scrollcommand) 234.51 158.33 T +3 F +(.) 318.46 158.33 T +FMENDPAGE +%%EndPage: "19" 20 +%%Page: "20" 20 +612 792 0 FMBEGINPAGE +0 10 Q +0 X +0 K +(20) 98.1 668.33 T +4 F +(Tk4.0 Overview and Porting Guide) 359.34 668.33 T +98.1 660.6 512.1 660.6 2 L +0.25 H +0 Z +N +98.1 135 512.1 639 R +7 X +V +1 F +0 X +(Pr) 152.1 632.33 T +(oblem #31:) 162.46 632.33 T +3 F +(The) 211.88 632.33 T +5 F +(-padx) 229.92 632.33 T +3 F +( and) 259.9 632.33 T +5 F +(-pady) 279.33 632.33 T +3 F +( options are ignored for the button family of wid-) 309.31 632.33 T +(gets if a bitmap or image is being displayed: the padding is always 0.) 152.1 620.02 T +2 F +-0.27 (Solution:) 170.1 608.02 P +3 F +-0.27 (Pack the button inside a frame, with extra padding in the frame. Or) 208.98 608.02 P +-0.27 (, redo the) 472.94 608.02 P +(image or bitmap to incorporate padding into it.) 170.1 595.71 T +1 F +(Pr) 152.1 580.71 T +(oblem #32:) 162.46 580.71 T +3 F +(In radiobuttons, the) 211.88 580.71 T +5 F +(-value) 292.38 580.71 T +3 F +( option no longer defaults to the name of the) 328.36 580.71 T +(widget; it defaults to an empty string.) 152.1 568.4 T +2 F +(Solution:) 170.1 556.4 T +3 F +(Specify the widget\325) 209.25 556.4 T +(s name explicitly as the value of the option.) 286.98 556.4 T +1 F +(Pr) 152.1 541.4 T +(oblem #33:) 162.46 541.4 T +3 F +(The) 211.88 541.4 T +5 F +(-menu) 229.92 541.4 T +3 F +( option for menubuttons and cascade menu entries may refer) 259.9 541.4 T +(only to a child of the menubutton or menu.) 152.1 529.08 T +2 F +(Solution:) 170.1 517.08 T +3 F +(Rename menus to meet this requirement.) 209.25 517.08 T +1 F +(Pr) 152.1 502.08 T +(oblem #34:) 162.46 502.08 T +3 F +(The interpretation of) 211.88 502.08 T +5 F +(@y) 297.09 502.08 T +3 F +( in menus has changed: it never returns) 309.08 502.08 T +5 F +(none) 467.86 502.08 T +3 F +(,) 491.84 502.08 T +(even if the y-coordinate is outside the menu \050it returns the index of the closest entry\051.) 152.1 489.77 T +2 F +(Solution:) 170.1 477.77 T +3 F +(If you care about this distinction, check the y-coordinate explicitly to see if) 209.25 477.77 T +-0.17 (it is less than 0 or greater than or equal to the window\325) 170.1 465.46 P +-0.17 (s height \050use) 385.7 465.46 P +5 F +-0.41 (winfo height) 438.21 465.46 P +3 F +(to get the height\051.) 170.1 453.15 T +1 F +-0.13 (Pr) 152.1 438.15 P +-0.13 (oblem #35:) 162.46 438.15 P +3 F +-0.13 (The) 211.62 438.15 P +5 F +-0.3 (invoke) 229.54 438.15 P +3 F +-0.13 ( and) 265.52 438.15 P +5 F +-0.3 (activate) 284.7 438.15 P +3 F +-0.13 ( widget commands for menus no longer post) 332.67 438.15 P +(cascaded submenus.) 152.1 425.83 T +2 F +(Solution:) 170.1 413.83 T +3 F +(Use the) 209.25 413.83 T +5 F +(postcascade) 242 413.83 T +3 F +( widget command to post submenus.) 307.96 413.83 T +1 F +(Pr) 152.1 398.83 T +(oblem #36:) 162.46 398.83 T +3 F +(The selection tar) 211.88 398.83 T +(gets) 278.31 398.83 T +5 F +(APPLICATION) 296.91 398.83 T +3 F +( and) 362.87 398.83 T +5 F +(WINDOW_NAME) 382.3 398.83 T +3 F +( are no longer) 448.27 398.83 T +(supported.) 152.1 386.52 T +2 F +(Solution:) 170.1 374.52 T +3 F +(Use tar) 209.25 374.52 T +(gets) 237.65 374.52 T +5 F +(TK_APPLICATION) 256.25 374.52 T +3 F +( and) 340.21 374.52 T +5 F +(TK_WINDOW) 359.64 374.52 T +3 F +( instead.) 413.61 374.52 T +1 F +(Pr) 152.1 359.52 T +(oblem #37:) 162.46 359.52 T +3 F +(There is no longer a default focus.) 211.88 359.52 T +2 F +(Solution:) 170.1 347.52 T +3 F +(None: modify your code not to depend on this feature.) 209.25 347.52 T +1 F +(Pr) 152.1 332.52 T +(oblem #38:) 162.46 332.52 T +3 F +(The) 211.88 332.52 T +5 F +(focus) 229.92 332.52 T +3 F +( command now returns an empty string to indicate that the) 259.9 332.52 T +(application doesn\325) 152.1 320.21 T +(t have the input focus, instead of) 225.48 320.21 T +5 F +(none) 358.17 320.21 T +3 F +(.) 382.15 320.21 T +2 F +(Solution:) 170.1 308.21 T +3 F +(Modify your code to check for an empty string instead of) 209.25 308.21 T +5 F +(none) 440.47 308.21 T +3 F +(.) 464.46 308.21 T +1 F +(Pr) 152.1 293.21 T +(oblem #39:) 162.46 293.21 T +5 F +(FocusIn) 211.88 293.21 T +3 F +( and) 253.85 293.21 T +5 F +(FocusOut) 273.28 293.21 T +3 F +( events are delivered to more windows than) 321.26 293.21 T +(they used to be.) 152.1 280.9 T +2 F +-0.02 (Solution:) 170.1 268.9 P +3 F +-0.02 (Modify your code to use the new set of events. The old event set was some-) 209.23 268.9 P +(what bizarre, and the new set matches more closely what happens elsewhere, such as) 170.1 256.58 T +(with) 170.1 244.27 T +5 F +(Enter) 190.37 244.27 T +3 F +( and) 220.35 244.27 T +5 F +(Leave) 239.78 244.27 T +3 F +( events.) 269.77 244.27 T +1 F +-0.28 (Pr) 152.1 229.27 P +-0.28 (oblem #40:) 162.46 229.27 P +5 F +-0.67 (wm maxsize) 211.32 229.27 P +3 F +-0.28 ( and) 270.62 229.27 P +5 F +-0.67 (wm minsize) 289.49 229.27 P +3 F +-0.28 ( no longer accept empty ar) 348.79 229.27 P +-0.28 (guments. This) 453.52 229.27 P +(means that you cannot use these commands to make windows non-resizable.) 152.1 216.96 T +2 F +(Solution:) 170.1 204.96 T +3 F +(Use the) 209.25 204.96 T +5 F +(wm resizable) 242 204.96 T +3 F +( command to make windows resizable.) 313.96 204.96 T +1 F +(Pr) 152.1 189.96 T +(oblem #41:) 162.46 189.96 T +3 F +(In the placer) 211.88 189.96 T +(, if you specify both) 261.43 189.96 T +5 F +(-x) 344.15 189.96 T +3 F +( and) 356.15 189.96 T +5 F +(-relx) 375.58 189.96 T +3 F +( then they add, instead of) 405.56 189.96 T +(the most recent speci\336cation replacing the earlier one. Ditto for) 152.1 177.65 T +5 F +(-y) 407.74 177.65 T +3 F +( and) 419.73 177.65 T +5 F +(-rely) 439.16 177.65 T +3 F +(,) 468.5 177.65 T +5 F +(-width) 473.49 177.65 T +3 F +(and) 152.1 165.33 T +5 F +(-relwidth) 169.03 165.33 T +3 F +(, and) 223 165.33 T +5 F +(-height) 244.93 165.33 T +3 F +( and) 286.91 165.33 T +5 F +(-relheight) 306.33 165.33 T +3 F +(.) 366.3 165.33 T +2 F +(Solution:) 170.1 153.33 T +3 F +(If you no longer want one of these options to be used, set it to 0 explicitly) 209.25 153.33 T +(.) 503.14 153.33 T +1 F +(Pr) 152.1 138.33 T +(oblem #42:) 162.46 138.33 T +3 F +(The command \322) 211.88 138.33 T +5 F +(focus none) 276.27 138.33 T +3 F +(\323 doesn\325) 336.24 138.33 T +(t work in Tk 4.0.) 369.64 138.33 T +FMENDPAGE +%%EndPage: "20" 21 +%%Page: "21" 21 +612 792 0 FMBEGINPAGE +4 10 Q +0 X +0 K +(13 Summary of Incompatibilites) 98.1 668.33 T +0 F +(21) 500.99 668.33 T +98.1 660.6 512.1 660.6 2 L +0.25 H +0 Z +N +98.1 135 512.1 639 R +7 X +V +2 F +0 X +(Solution:) 170.1 632.33 T +3 F +(Create a dummy widget that is never mapped and set the focus to that wid-) 209.25 632.33 T +(get.) 170.1 620.33 T +1 F +(Pr) 152.1 605.33 T +(oblem #43:) 162.46 605.33 T +5 F +(%D) 211.88 605.33 T +3 F +( substitutions are no longer supported in bindings, nor are the event) 223.87 605.33 T +(types) 152.1 593.33 T +5 F +(CirculateRequest) 175.7 593.33 T +3 F +(,) 271.64 593.33 T +5 F +(Conf) 276.64 593.33 T +(igureRequest) 300.63 593.33 T +3 F +(,) 372.59 593.33 T +5 F +(MapRequest) 377.59 593.33 T +3 F +(, and) 437.55 593.33 T +5 F +(Resiz-) 459.48 593.33 T +(eRequest) 152.1 581.33 T +3 F +(.) 200.07 581.33 T +2 F +-0.25 (Solution:) 170.1 569.33 P +3 F +-0.25 (Use the name of the display instead of %D to identify a display; you can get) 209 569.33 P +(the display name with the) 170.1 557.33 T +5 F +(winfo screen) 275.31 557.33 T +3 F +( command. The desupported event types) 347.27 557.33 T +(never really worked anyway) 170.1 545.33 T +(, so there should be no code that depends on them.) 282.96 545.33 T +1 F +(Pr) 152.1 530.33 T +(oblem #44:) 162.46 530.33 T +5 F +(%) 211.88 530.33 T +3 F +( binding substitutions that return window identi\336ers, such as) 217.87 530.33 T +5 F +(%a) 461.63 530.33 T +3 F +( and) 473.62 530.33 T +5 F +(%S) 493.05 530.33 T +3 F +(,) 505.05 530.33 T +(now produce hexadecimal results instead of decimal.) 152.1 518.33 T +2 F +(Solution:) 170.1 506.33 T +3 F +(Use the) 209.25 506.33 T +5 F +(format) 242 506.33 T +3 F +( command to turn them back to decimal.) 277.98 506.33 T +1 F +(Pr) 152.1 491.33 T +(oblem #45:) 162.46 491.33 T +5 F +(Enter) 211.88 491.33 T +3 F +(,) 241.46 491.33 T +5 F +(Leave) 246.46 491.33 T +3 F +(,) 276.44 491.33 T +5 F +(FocusIn) 281.44 491.33 T +3 F +(, and) 323.42 491.33 T +5 F +(FocusOut) 345.34 491.33 T +3 F +( events with detail) 393.32 491.33 T +5 F +(Notify-) 468.83 491.33 T +(Inferior) 152.1 479.33 T +3 F +( are now ignored by the binding mechanism, so they\325re not visible to T) 200.07 479.33 T +(cl) 483.08 479.33 T +(scripts.) 152.1 467.33 T +2 F +-0.13 (Solution:) 170.1 455.33 P +3 F +-0.13 (In most cases, T) 209.12 455.33 P +-0.13 (cl scripts work better if these bindings are ignored. Y) 273 455.33 P +-0.13 (ou can) 483.49 455.33 P +(still use C code to access these events if you really need them. Or) 170.1 443.33 T +(, create bindings on) 431.18 443.33 T +-0.33 (the inferior windows and use) 170.1 431.33 P +5 F +-0.8 (NotifyAncestor) 286.96 431.33 P +3 F +-0.33 ( bindings on the children instead of) 370.91 431.33 P +5 F +(NotifyInferior) 170.1 419.33 T +3 F +( bindings on the parent.) 254.05 419.33 T +FMENDPAGE +%%EndPage: "21" 22 +%%Page: "22" 22 +612 792 0 FMBEGINPAGE +0 10 Q +0 X +0 K +(22) 98.1 668.33 T +4 F +(Tk4.0 Overview and Porting Guide) 359.34 668.33 T +98.1 660.6 512.1 660.6 2 L +0.25 H +0 Z +N +98.1 135 512.1 639 R +7 X +V +FMENDPAGE +%%EndPage: "22" 23 +%%Trailer +%%BoundingBox: 0 0 612 792 +%%Pages: 22 1 +%%DocumentFonts: Helvetica-Bold +%%+ Times-Bold +%%+ Times-Italic +%%+ Times-Roman +%%+ Helvetica +%%+ Courier +%%+ Courier-Oblique diff --git a/tk4.2/doc/tkerror.n b/tk4.2/doc/tkerror.n new file mode 100644 index 0000000..5fc6983 --- /dev/null +++ b/tk4.2/doc/tkerror.n @@ -0,0 +1,31 @@ +'\" +'\" Copyright (c) 1990-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) tkerror.n 1.16 96/08/28 18:07:31 +'\" +.so man.macros +.TH tkerror n 4.1 Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +tkerror \- Command invoked to process background errors +.SH SYNOPSIS +\fBtkerror \fImessage\fR +.BE + +.SH DESCRIPTION +.PP +Note: as of Tk 4.1 the \fBtkerror\fR command has been renamed to +\fBbgerror\fR because the event loop (which is what usually invokes +it) is now part of Tcl. The changes are backward compatible, so that +old uses of \fBtkerror\fR should still work, but you should modify +your scripts to use \fBbgerror\fR instead of \fBtkerror\fR. +Documentation for \fBbgerror\fR is available as part of Tcl's +documentation. + +.SH KEYWORDS +background error, reporting diff --git a/tk3.6/doc/tkvars.n b/tk4.2/doc/tkvars.n similarity index 52% rename from tk3.6/doc/tkvars.n rename to tk4.2/doc/tkvars.n index 31f51f3..947d574 100644 --- a/tk3.6/doc/tkvars.n +++ b/tk4.2/doc/tkvars.n @@ -1,27 +1,14 @@ '\" -'\" Copyright (c) 1990 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1990-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) tkvars.n 1.22 96/08/27 13:21:38 '\" -'\" $Header: /user6/ouster/wish/man/RCS/tkvars.n,v 1.9 93/06/18 14:06:51 ouster Exp $ SPRITE (Berkeley) -'/" .so man.macros -.HS tkvars tk 3.3 +.TH tkvars n 4.1 Tk "Tk Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -34,27 +21,32 @@ The following Tcl variables are either set or used by Tk at various times in its execution: .TP 15 \fBtk_library\fR -Tk sets this variable hold the name of a directory containing a library +This variable holds the file name for a directory containing a library of Tcl scripts related to Tk. These scripts include an initialization file that is normally processed whenever a Tk application starts up, plus other files containing procedures that implement default behaviors for widgets. -.VS -The value of this variable is taken from the TK_LIBRARY environment -variable, if one exists, or else from a default value compiled into -Tk. -.VE +The initial value of \fBtcl_library\fR is set when Tk is added to +an interpreter; this is done by searching several different directories +until one is found that contains an appropriate Tk startup script. +If the \fBTK_LIBRARY\fR environment variable exists, then +the directory it names is checked first. +If \fBTK_LIBRARY\fR isn't set or doesn't refer to an appropriate +directory, then Tk checks several other directories based on a +compiled-in default location, the location of the Tcl library directory, +the location of the binary containing the application, and the current +working directory. +The variable can be modified by an application to switch to a different +library. .TP \fBtk_patchLevel\fR -.VS Contains a decimal integer giving the current patch level for Tk. The patch level is incremented for each new release or patch, and it uniquely identifies an official version of Tk. -.VE .TP -\fBtk_priv\fR +\fBtkPriv\fR This variable is an array containing several pieces of information -that are private to Tk. The elements of \fBtk_priv\fR are used by +that are private to Tk. The elements of \fBtkPriv\fR are used by Tk library procedures and default bindings. They should not be accessed by any code outside Tk. .TP @@ -75,10 +67,6 @@ any Tk release that includes changes that are not backward compatible work with the new release). The minor version number increases with each new release of Tk, except that it resets to zero whenever the major version number changes. -.TP 15 -\fBtkVersion\fR -Has the same value as \fBtk_version\fR. This variable is obsolete and -will be deleted soon. .SH KEYWORDS variables, version diff --git a/tk3.6/doc/tkwait.n b/tk4.2/doc/tkwait.n similarity index 58% rename from tk3.6/doc/tkwait.n rename to tk4.2/doc/tkwait.n index b243677..6446768 100644 --- a/tk3.6/doc/tkwait.n +++ b/tk4.2/doc/tkwait.n @@ -1,38 +1,23 @@ '\" '\" Copyright (c) 1992 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) tkwait.n 1.13 96/07/31 08:19:23 '\" -'\" $Header: /user6/ouster/wish/man/RCS/tkwait.n,v 1.5 93/10/18 08:32:09 ouster Exp $ SPRITE (Berkeley) -'/" .so man.macros -.HS tkwait tk +.TH tkwait n "" Tk "Tk Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tkwait \- Wait for variable to change or window to be destroyed .SH SYNOPSIS \fBtkwait variable \fIname\fR -.br +.sp \fBtkwait visibility \fIname\fR -.VS -.VE -.br +.sp \fBtkwait window \fIname\fR .BE @@ -45,13 +30,11 @@ If the first argument is \fBvariable\fR (or any abbreviation of it) then the second argument is the name of a global variable and the command waits for that variable to be modified. If the first argument is \fBvisibility\fR (or any abbreviation -.VS of it) then the second argument is the name of a window and the \fBtkwait\fR command waits for a change in its visibility state (as indicated by the arrival of a VisibilityNotify event). This form is typically used to wait for a newly-created window to appear on the screen before taking some action. -.VE If the first argument is \fBwindow\fR (or any abbreviation of it) then the second argument is the name of a window and the \fBtkwait\fR command waits for that window to be destroyed. @@ -61,6 +44,8 @@ with a dialog box before using the result of that interaction. While the \fBtkwait\fR command is waiting it processes events in the normal fashion, so the application will continue to respond to user interactions. +If an event handler invokes \fBtkwait\fR again, the nested call +to \fBtkwait\fR must complete before the outer call can complete. .SH KEYWORDS variable, visibility, wait, window diff --git a/tk4.2/doc/toplevel.n b/tk4.2/doc/toplevel.n new file mode 100644 index 0000000..be45c1a --- /dev/null +++ b/tk4.2/doc/toplevel.n @@ -0,0 +1,132 @@ +'\" +'\" Copyright (c) 1990-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) toplevel.n 1.24 96/08/27 13:21:54 +'\" +.so man.macros +.TH toplevel n 4.0 Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +toplevel \- Create and manipulate toplevel widgets +.SH SYNOPSIS +\fBtoplevel\fI \fIpathName \fR?\fIoptions\fR? +.SO +\-borderwidth \-highlightbackground \-highlightthickness \-takefocus +\-cursor \-highlightcolor \-relief +.SE +.SH "WIDGET-SPECIFIC OPTIONS" +.OP \-background background Background +This option is the same as the standard \fBbackground\fR option +except that its value may also be specified as an empty string. +In this case, the widget will display no background or border, and +no colors will be consumed from its colormap for its background +and border. +.OP \-class class Class +Specifies a class for the window. +This class will be used when querying the option database for +the window's other options, and it will also be used later for +other purposes such as bindings. +The \fBclass\fR option may not be changed with the \fBconfigure\fR +widget command. +.OP \-colormap colormap Colormap +Specifies a colormap to use for the window. +The value may be either \fBnew\fR, in which case a new colormap is +created for the window and its children, or the name of another +window (which must be on the same screen and have the same visual +as \fIpathName\fR), in which case the new window will use the colormap +from the specified window. +If the \fBcolormap\fR option is not specified, the new window +uses the default colormap of its screen. +This option may not be changed with the \fBconfigure\fR +widget command. +.OP \-height height Height +Specifies the desired height for the window in any of the forms +acceptable to \fBTk_GetPixels\fR. +If this option is less than or equal to zero then the window will +not request any size at all. +.OP \-screen "" "" +Specifies the screen on which to place the new window. +Any valid screen name may be used, even one associated with a +different display. +Defaults to the same screen as its parent. +This option is special in that it may not be specified via the option +database, and it may not be modified with the \fBconfigure\fR +widget command. +.OP \-visual visual Visual +Specifies visual information for the new window in any of the +forms accepted by \fBTk_GetVisual\fR. +If this option is not specified, the new window will use the default +visual for its screen. +The \fBvisual\fR option may not be modified with the \fBconfigure\fR +widget command. +.OP \-width width Width +Specifies the desired width for the window in any of the forms +acceptable to \fBTk_GetPixels\fR. +If this option is less than or equal to zero then the window will +not request any size at all. +.BE + +.SH DESCRIPTION +.PP +The \fBtoplevel\fR command creates a new toplevel widget (given +by the \fIpathName\fR argument). Additional +options, described above, may be specified on the command line +or in the option database +to configure aspects of the toplevel such as its background color +and relief. The \fBtoplevel\fR command returns the +path name of the new window. +.PP +A toplevel is similar to a frame except that it is created as a +top-level window: its X parent is the root window of a screen +rather than the logical parent from its path name. The primary +purpose of a toplevel is to serve as a container for dialog boxes +and other collections of widgets. The only visible features +of a toplevel are its background color and an optional 3-D border +to make the toplevel appear raised or sunken. + +.SH "WIDGET COMMAND" +.PP +The \fBtoplevel\fR command creates a new Tcl command whose +name is the same as the path name of the toplevel's window. This +command may be used to invoke various +operations on the widget. It has the following general form: +.CS +\fIpathName option \fR?\fIarg arg ...\fR? +.CE +\fIPathName\fR is the name of the command, which is the same as +the toplevel widget's path name. \fIOption\fR and the \fIarg\fRs +determine the exact behavior of the command. The following +commands are possible for toplevel widgets: +.TP +\fIpathName \fBcget\fR \fIoption\fR +Returns the current value of the configuration option given +by \fIoption\fR. +\fIOption\fR may have any of the values accepted by the \fBtoplevel\fR +command. +.TP +\fIpathName \fBconfigure\fR ?\fIoption\fR? ?\fIvalue option value ...\fR? +Query or modify the configuration options of the widget. +If no \fIoption\fR is specified, returns a list describing all of +the available options for \fIpathName\fR (see \fBTk_ConfigureInfo\fR for +information on the format of this list). If \fIoption\fR is specified +with no \fIvalue\fR, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no \fIoption\fR is specified). If +one or more \fIoption\-value\fR pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +\fIOption\fR may have any of the values accepted by the \fBtoplevel\fR +command. + +.SH BINDINGS +.PP +When a new toplevel is created, it has no default event bindings: +toplevels are not intended to be interactive. + +.SH KEYWORDS +toplevel, widget diff --git a/tk3.6/doc/winfo.n b/tk4.2/doc/winfo.n similarity index 63% rename from tk3.6/doc/winfo.n rename to tk4.2/doc/winfo.n index 9da3bc9..9510b8b 100644 --- a/tk3.6/doc/winfo.n +++ b/tk4.2/doc/winfo.n @@ -1,27 +1,14 @@ '\" -'\" Copyright (c) 1990 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1990-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) winfo.n 1.42 96/08/27 13:21:53 '\" -'\" $Header: /user6/ouster/wish/man/RCS/winfo.n,v 1.24 93/07/09 09:56:06 ouster Exp $ SPRITE (Berkeley) -'/" .so man.macros -.HS winfo tk +.TH winfo n 4.0 Tk "Tk Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -36,22 +23,26 @@ The \fBwinfo\fR command is used to retrieve information about windows managed by Tk. It can take any of a number of different forms, depending on the \fIoption\fR argument. The legal forms are: .TP -\fBwinfo atom \fIname\fR -.VS +\fBwinfo atom \fR?\fB\-displayof \fIwindow\fR? \fIname\fR Returns a decimal string giving the integer identifier for the atom whose name is \fIname\fR. If no atom exists with the name \fIname\fR then a new one is created. +If the \fB\-displayof\fR option is given then the atom is looked +up on the display of \fIwindow\fR; otherwise it is looked up on +the display of the application's main window. .TP -\fBwinfo atomname \fIid\fR +\fBwinfo atomname \fR?\fB\-displayof \fIwindow\fR? \fIid\fR Returns the textual name for the atom whose integer identifier is \fIid\fR. +If the \fB\-displayof\fR option is given then the identifier is looked +up on the display of \fIwindow\fR; otherwise it is looked up on +the display of the application's main window. This command is the inverse of the \fBwinfo atom\fR command. -Generates an error if no such atom exists. +It generates an error if no such atom exists. .TP \fBwinfo cells \fIwindow\fR Returns a decimal string giving the number of cells in the color map for \fIwindow\fR. -.VE .TP \fBwinfo children \fIwindow\fR Returns a list containing the path names of all the children @@ -61,14 +52,23 @@ of their logical parents. \fBwinfo class \fIwindow\fR Returns the class name for \fIwindow\fR. .TP -\fBwinfo containing \fIrootX rootY\fR -.VS +\fBwinfo colormapfull \fIwindow\fR +Returns 1 if the colormap for \fIwindow\fR is known to be full, 0 +otherwise. The colormap for a window is ``known'' to be full if the last +attempt to allocate a new color on that window failed and this +application hasn't freed any colors in the colormap since the +failed allocation. +.TP +\fBwinfo containing \fR?\fB\-displayof \fIwindow\fR? \fIrootX rootY\fR Returns the path name for the window containing the point given by \fIrootX\fR and \fIrootY\fR. \fIRootX\fR and \fIrootY\fR are specified in screen units (i.e. any form acceptable to \fBTk_GetPixels\fR) in the coordinate system of the root window (if a virtual-root window manager is in use then the coordinate system of the virtual root window is used). +If the \fB\-displayof\fR option is given then the coordinates refer +to the screen containing \fIwindow\fR; otherwise they refer to the +screen of the application's main window. If no window in this application contains the point then an empty string is returned. In selecting the containing window, children are given higher priority @@ -90,7 +90,6 @@ in \fIwindow\fR corresponding to the distance given by \fInumber\fR. to \fBTk_GetScreenMM\fR, such as ``2.0c'' or ``1i''. The return value may be fractional; for an integer value, use \fBwinfo pixels\fR. -.VE .TP \fBwinfo geometry \fIwindow\fR Returns the geometry for \fIwindow\fR, in the form @@ -110,39 +109,74 @@ instead of its actual height. \fBwinfo id \fIwindow\fR Returns a hexadecimal string indicating the X identifier for \fIwindow\fR. .TP -\fBwinfo interps\fR +\fBwinfo interps \fR?\fB\-displayof \fIwindow\fR? Returns a list whose members are the names of all Tcl interpreters -(e.g. all Tk-based applications) currently registered for the -display of the invoking application. +(e.g. all Tk-based applications) currently registered for a particular display. +If the \fB\-displayof\fR option is given then the return value refers +to the display of \fIwindow\fR; otherwise it refers to +the display of the application's main window. .TP \fBwinfo ismapped \fIwindow\fR Returns \fB1\fR if \fIwindow\fR is currently mapped, \fB0\fR otherwise. .TP +\fBwinfo manager \fIwindow\fR +Returns the name of the geometry manager currently +responsible for \fIwindow\fR, or an empty string if \fIwindow\fR +isn't managed by any geometry manager. +The name is usually the name of the Tcl command for the geometry +manager, such as \fBpack\fR or \fBplace\fR. +If the geometry manager is a widget, such as canvases or text, the +name is the widget's class command, such as \fBcanvas\fR. +.TP \fBwinfo name \fIwindow\fR Returns \fIwindow\fR's name (i.e. its name within its parent, as opposed to its full path name). -.VS The command \fBwinfo name .\fR will return the name of the application. -.VE .TP \fBwinfo parent \fIwindow\fR Returns the path name of \fIwindow\fR's parent, or an empty string if \fIwindow\fR is the main window of the application. .TP -\fBwinfo pathname \fIid\fR +\fBwinfo pathname \fR?\fB\-displayof \fIwindow\fR? \fIid\fR Returns the path name of the window whose X identifier is \fIid\fR. \fIId\fR must be a decimal, hexadecimal, or octal integer and must correspond to a window in the invoking application. +If the \fB\-displayof\fR option is given then the identifier is looked +up on the display of \fIwindow\fR; otherwise it is looked up on +the display of the application's main window. .TP \fBwinfo pixels \fIwindow\fR \fInumber\fR -.VS Returns the number of pixels in \fIwindow\fR corresponding to the distance given by \fInumber\fR. \fINumber\fR may be specified in any of the forms acceptable to \fBTk_GetPixels\fR, such as ``2.0c'' or ``1i''. The result is rounded to the nearest integer value; for a fractional result, use \fBwinfo fpixels\fR. -.VE +.TP +\fBwinfo pointerx \fIwindow\fR +If the mouse pointer is on the same screen as \fIwindow\fR, returns the +pointer's x coordinate, measured in pixels in the screen's root window. +If a virtual root window is in use on the screen, the position is +measured in the virtual root. +If the mouse pointer isn't on the same screen as \fIwindow\fR then +-1 is returned. +.TP +\fBwinfo pointerxy \fIwindow\fR +If the mouse pointer is on the same screen as \fIwindow\fR, returns a list +with two elements, which are the pointer's x and y coordinates measured +in pixels in the screen's root window. +If a virtual root window is in use on the screen, the position +is computed in the virtual root. +If the mouse pointer isn't on the same screen as \fIwindow\fR then +both of the returned coordinates are -1. +.TP +\fBwinfo pointery \fIwindow\fR +If the mouse pointer is on the same screen as \fIwindow\fR, returns the +pointer's y coordinate, measured in pixels in the screen's root window. +If a virtual root window is in use on the screen, the position +is computed in the virtual root. +If the mouse pointer isn't on the same screen as \fIwindow\fR then +-1 is returned. .TP \fBwinfo reqheight \fIwindow\fR Returns a decimal string giving \fIwindow\fR's requested height, @@ -155,13 +189,11 @@ in pixels. This is the value used by \fIwindow\fR's geometry manager to compute its geometry. .TP \fBwinfo rgb \fIwindow color\fR -.VS Returns a list containing three decimal values, which are the red, green, and blue intensities that correspond to \fIcolor\fR in the window given by \fIwindow\fR. \fIColor\fR may be specified in any of the forms acceptable for a color option. -.VE .TP \fBwinfo rootx \fIwindow\fR Returns a decimal string giving the x-coordinate, in the root @@ -180,7 +212,6 @@ Returns the name of the screen associated with \fIwindow\fR, in the form \fIdisplayName\fR.\fIscreenIndex\fR. .TP \fBwinfo screencells \fIwindow\fR -.VS Returns a decimal string giving the number of cells in the default color map for \fIwindow\fR's screen. .TP @@ -202,7 +233,7 @@ in millimeters. .TP \fBwinfo screenvisual \fIwindow\fR Returns one of the following strings to indicate the default visual -type for \fIwindow\fR's screen: \fBdirectcolor\fR, \fBgrayscale\fR, +class for \fIwindow\fR's screen: \fBdirectcolor\fR, \fBgrayscale\fR, \fBpseudocolor\fR, \fBstaticcolor\fR, \fBstaticgray\fR, or \fBtruecolor\fR. .TP @@ -210,15 +241,42 @@ type for \fIwindow\fR's screen: \fBdirectcolor\fR, \fBgrayscale\fR, Returns a decimal string giving the width of \fIwindow\fR's screen, in pixels. .TP +\fBwinfo server \fIwindow\fR +Returns a string containing information about the server for +\fIwindow\fR's display. The exact format of this string may vary +from platform to platform. For X servers the string +has the form ``\fBX\fImajor\fBR\fIminor vendor vendorVersion\fR'' +where \fImajor\fR and \fIminor\fR are the version and revision +numbers provided by the server (e.g., \fBX11R5\fR), \fIvendor\fR +is the name of the vendor for the server, and \fIvendorRelease\fR +is an integer release number provided by the server. +.TP \fBwinfo toplevel \fIwindow\fR Returns the path name of the top-level window containing \fIwindow\fR. .TP +\fBwinfo viewable \fIwindow\fR +Returns 1 if \fIwindow\fR and all of its ancestors up through the +nearest toplevel window are mapped. Returns 0 if any of these +windows are not mapped. +.TP \fBwinfo visual \fIwindow\fR Returns one of the following strings to indicate the visual -type for \fIwindow\fR: \fBdirectcolor\fR, \fBgrayscale\fR, +class for \fIwindow\fR: \fBdirectcolor\fR, \fBgrayscale\fR, \fBpseudocolor\fR, \fBstaticcolor\fR, \fBstaticgray\fR, or \fBtruecolor\fR. .TP +\fBwinfo visualid \fIwindow\fR +Returns the X identifier for the visual for \fIwindow\fR. +.TP +\fBwinfo visualsavailable \fIwindow\fR ?\fBincludeids\fR? +Returns a list whose elements describe the visuals available for +\fIwindow\fR's screen. +Each element consists of a visual class followed by an integer depth. +The class has the same form as returned by \fBwinfo visual\fR. +The depth gives the number of bits per pixel in the visual. +In addition, if the \fBincludeids\fR argument is provided, then the +depth is followed by the X identifier for the visual. +.TP \fBwinfo vrootheight \fIwindow\fR Returns the height of the virtual root window associated with \fIwindow\fR if there is one; otherwise returns the height of \fIwindow\fR's screen. @@ -238,7 +296,6 @@ Returns the y-offset of the virtual root window associated with \fIwindow\fR, relative to the root window of its screen. This is normally either zero or negative. Returns 0 if there is no virtual root window for \fIwindow\fR. -.VE .TP \fBwinfo width \fIwindow\fR Returns a decimal string giving \fIwindow\fR's width in pixels. diff --git a/tk4.2/doc/wish.1 b/tk4.2/doc/wish.1 new file mode 100644 index 0000000..9083ea9 --- /dev/null +++ b/tk4.2/doc/wish.1 @@ -0,0 +1,178 @@ +'\" +'\" Copyright (c) 1991-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) wish.1 1.27 96/08/27 13:21:23 +'\" +.so man.macros +.TH wish 1 4.1 Tk "Tk Applications" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +wish \- Simple windowing shell +.SH SYNOPSIS +\fBwish\fR ?\fIfileName arg arg ...\fR? +.SH OPTIONS +.IP "\fB\-colormap \fBnew\fR" 20 +Specifies that the window should have a new private colormap instead of +using the default colormap for the screen. +.IP "\fB\-display \fIdisplay\fR" 20 +Display (and screen) on which to display window. +.IP "\fB\-geometry \fIgeometry\fR" 20 +Initial geometry to use for window. If this option is specified, its +value is stored in the \fBgeometry\fR global variable of the application's +Tcl interpreter. +.IP "\fB\-name \fIname\fR" 20 +Use \fIname\fR as the title to be displayed in the window, and +as the name of the interpreter for \fBsend\fR commands. +.IP "\fB\-sync\fR" 20 +Execute all X server commands synchronously, so that errors +are reported immediately. This will result in much slower +execution, but it is useful for debugging. +.IP "\fB\-visual \fIvisual\fR" 20 +Specifies the visual to use for the window. +\fIVisual\fR may have any of the forms supported by the \fBTk_GetVisual\fR +procedure. +.IP "\fB\-\|\-\fR" 20 +Pass all remaining arguments through to the script's \fBargv\fR +variable without interpreting them. +This provides a mechanism for passing arguments such as \fB\-name\fR +to a script instead of having \fBwish\fR interpret them. +.BE + +.SH DESCRIPTION +.PP +\fBWish\fR is a simple program consisting of the Tcl command +language, the Tk toolkit, and a main program that reads commands +from standard input or from a file. +It creates a main window and then processes Tcl commands. +If \fBwish\fR is invoked with no arguments, or with a first argument +that starts with ``\-'', then it reads Tcl commands interactively from +standard input. +It will continue processing commands until all windows have been +deleted or until end-of-file is reached on standard input. +If there exists a file \fB.wishrc\fR in the home directory of +the user, \fBwish\fR evaluates the file as a Tcl script +just before reading the first command from standard input. +.PP +If \fBwish\fR is invoked with an initial \fIfileName\fR argument, then +\fIfileName\fR is treated as the name of a script file. +\fBWish\fR will evaluate the script in \fIfileName\fR (which +presumably creates a user interface), then it will respond to events +until all windows have been deleted. +Commands will not be read from standard input. +There is no automatic evaluation of \fB.wishrc\fR in this +case, but the script file can always \fBsource\fR it if desired. + +.SH "OPTIONS" +.PP +\fBWish\fR automatically processes all of the command-line options +described in the \fBOPTIONS\fR summary above. +Any other command-line arguments besides these are passed through +to the application using the \fBargc\fR and \fBargv\fR variables +described later. + +.SH "APPLICATION NAME AND CLASS" +.PP +The name of the application, which is used for purposes such as +\fBsend\fR commands, is taken from the \fB\-name\fR option, +if it is specified; otherwise it is taken from \fIfileName\fR, +if it is specified, or from the command name by which +\fBwish\fR was invoked. In the last two cases, if the name contains a ``/'' +character, then only the characters after the last slash are used +as the application name. +.PP +The class of the application, which is used for purposes such as +specifying options with a \fBRESOURCE_MANAGER\fR property or .Xdefaults +file, is the same as its name except that the first letter is +capitalized. + +.SH "VARIABLES" +.PP +\fBWish\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 options described above. +.TP 15 +\fBargv\fR +Contains a Tcl list whose elements are the \fIarg\fR arguments +that follow a \fB\-\|\-\fR option or don't match any of the +options described in OPTIONS above, in order, or an empty string +if there are no such arguments. +.TP 15 +\fBargv0\fR +Contains \fIfileName\fR if it was specified. +Otherwise, contains the name by which \fBwish\fR was invoked. +.TP 15 +\fBgeometry\fR +If the \fB\-geometry\fR option is specified, \fBwish\fR copies its +value into this variable. If the variable still exists after +\fIfileName\fR has been evaluated, \fBwish\fR uses the value of +the variable in a \fBwm geometry\fR command to set the main +window's geometry. +.TP 15 +\fBtcl_interactive\fR +Contains 1 if \fBwish\fR is reading commands interactively (\fIfileName\fR +was not specified and standard input is a terminal-like +device), 0 otherwise. + +.SH "SCRIPT FILES" +.PP +If you create a Tcl script in a file whose first line is +.CS +\fB#!/usr/local/bin/wish\fR +.CE +then you can invoke the script file directly from your shell if +you mark it as executable. +This assumes that \fBwish\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. +Many UNIX systems do not allow the \fB#!\fR line to exceed about +30 characters in length, so be sure that the \fBwish\fR executable +can be accessed with a short file name. +.PP +An even better approach is to start your script files with the +following three lines: +.CS +\fB#!/bin/sh +# the next line restarts using wish \e +exec wish "$0" "$@"\fR +.CE +This approach has three advantages over the approach in the previous +paragraph. First, the location of the \fBwish\fR binary doesn't have +to be hard-wired into the script: it can be anywhere in your shell +search path. Second, it gets around the 30-character file name limit +in the previous approach. +Third, this approach will work even if \fBwish\fR is +itself a shell script (this is done on some systems in order to +handle multiple architectures or operating systems: the \fBwish\fR +script selects one of several binaries to run). The three lines +cause both \fBsh\fR and \fBwish\fR to process the script, but the +\fBexec\fR is only executed by \fBsh\fR. +\fBsh\fR processes the script first; it treats the second +line as a comment and executes the third line. +The \fBexec\fR statement cause the shell to stop processing and +instead to start up \fBwish\fR to reprocess the entire script. +When \fBwish\fR starts up, it treats all three lines as comments, +since the backslash at the end of the second line causes the third +line to be treated as part of the comment on the second line. + +.SH PROMPTS +.PP +When \fBwish\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 \fBwish\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 +shell, toolkit diff --git a/tk3.6/doc/wm.n b/tk4.2/doc/wm.n similarity index 75% rename from tk3.6/doc/wm.n rename to tk4.2/doc/wm.n index da5d996..f89ec79 100644 --- a/tk3.6/doc/wm.n +++ b/tk4.2/doc/wm.n @@ -1,27 +1,14 @@ '\" -'\" Copyright (c) 1991 The Regents of the University of California. -'\" All rights reserved. +'\" Copyright (c) 1991-1994 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" -'\" 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. +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) wm.n 1.36 96/10/09 16:16:09 '\" -'\" $Header: /user6/ouster/wish/man/RCS/wm.n,v 1.18 93/09/20 15:22:57 ouster Exp $ SPRITE (Berkeley) -'/" .so man.macros -.HS wm tk +.TH wm n 4.0 Tk "Tk Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -59,7 +46,6 @@ of \fIminNumer\fR, \fIminDenom\fR, \fImaxNumer\fR, and \fImaxDenom\fR returned). .TP \fBwm client \fIwindow\fR ?\fIname\fR? -.VS If \fIname\fR is specified, this command stores \fIname\fR (which should be the name of the host on which the application is executing) in \fIwindow\fR's @@ -71,6 +57,32 @@ set in a \fBwm client\fR command for \fIwindow\fR. If \fIname\fR is specified as an empty string, the command deletes the \fBWM_CLIENT_MACHINE\fR property from \fIwindow\fR. .TP +\fBwm colormapwindows \fIwindow\fR ?\fIwindowList\fR? +This command is used to manipulate the \fBWM_COLORMAP_WINDOWS\fR +property, which provides information to the window managers about +windows that have private colormaps. +If \fIwindowList\fR isn't specified, the command returns a list +whose elements are the names of the windows in the \fBWM_COLORMAP_WINDOWS\fR +property. +If \fIwindowList\fR is specified, it consists of a list of window +path names; the command overwrites the \fBWM_COLORMAP_WINDOWS\fR +property with the given windows and returns an empty string. +The \fBWM_COLORMAP_WINDOWS\fR property should normally contain a +list of the internal windows within \fIwindow\fR whose colormaps differ +from their parents. +The order of the windows in the property indicates a priority order: +the window manager will attempt to install as many colormaps as possible +from the head of this list when \fIwindow\fR gets the colormap focus. +If \fIwindow\fR is not included among the windows in \fIwindowList\fR, +Tk implicitly adds it at the end of the \fBWM_COLORMAP_WINDOWS\fR +property, so that its colormap is lowest in priority. +If \fBwm colormapwindows\fR is not invoked, Tk will automatically set +the property for each top-level window to all the internal windows +whose colormaps differ from their parents, followed by the top-level +itself; the order of the internal windows is undefined. +See the ICCCM documentation for more information on the +\fBWM_COLORMAP_WINDOWS\fR property. +.TP \fBwm command \fIwindow\fR ?\fIvalue\fR? If \fIvalue\fR is specified, this command stores \fIvalue\fR in \fIwindow\fR's \fBWM_COMMAND\fR property for use by the window manager or @@ -81,7 +93,6 @@ If \fIvalue\fR isn't specified then the command returns the last value set in a \fBwm command\fR command for \fIwindow\fR. If \fIvalue\fR is specified as an empty string, the command deletes the \fBWM_COMMAND\fR property from \fIwindow\fR. -.VE .TP \fBwm deiconify \fIwindow\fR Arrange for \fIwindow\fR to be displayed in normal (non-iconified) form. @@ -104,17 +115,15 @@ should give the focus to \fIwindow\fR at appropriate times. However, once the focus has been given to \fIwindow\fR or one of its descendants, the application may re-assign the focus among \fIwindow\fR's descendants. The focus model defaults to \fBpassive\fR, and Tk's \fBfocus\fR command -assumes a passive model of focussing. +assumes a passive model of focusing. .TP \fBwm frame \fIwindow\fR -.VS If \fIwindow\fR has been reparented by the window manager into a decorative frame, the command returns the X window identifier for the outermost frame that contains \fIwindow\fR (the window whose parent is the root or virtual root). If \fIwindow\fR hasn't been reparented by the window manager then the command returns the X window identifier for \fIwindow\fR. -.VE .TP \fBwm geometry \fIwindow\fR ?\fInewGeometry\fR? If \fInewGeometry\fR is specified, then the geometry of \fIwindow\fR @@ -238,56 +247,52 @@ hints (if no hints are in effect then an empty string is returned). \fBwm iconwindow \fIwindow\fR ?\fIpathName\fR? If \fIpathName\fR is specified, it is the path name for a window to use as icon for \fIwindow\fR: when \fIwindow\fR is iconified then -\fIpathName\fR should be mapped to serve as icon, and when \fIwindow\fR +\fIpathName\fR will be mapped to serve as icon, and when \fIwindow\fR is de-iconified then \fIpathName\fR will be unmapped again. If \fIpathName\fR is specified as an empty string then any existing icon window association for \fIwindow\fR will be cancelled. If the \fIpathName\fR argument is specified then an empty string is returned. Otherwise the command returns the path name of the current icon window for \fIwindow\fR, or an empty string if there -is no icon window currently specified for \fIwindow\fR. Note: -not all window managers support the notion of an icon window. +is no icon window currently specified for \fIwindow\fR. +Button press events are disabled for \fIwindow\fR as long as it is +an icon window; this is needed in order to allow window managers +to ``own'' those events. +Note: not all window managers support the notion of an icon window. .TP \fBwm maxsize \fIwindow\fR ?\fIwidth height\fR? -If \fIwidth\fR and \fIheight\fR are specified, then \fIwindow\fR -becomes resizable and \fIwidth\fR and \fIheight\fR give its -maximum permissible dimensions. +If \fIwidth\fR and \fIheight\fR are specified, they give +the maximum permissible dimensions for \fIwindow\fR. For gridded windows the dimensions are specified in grid units; otherwise they are specified in pixel units. -During manual sizing, the window manager -should restrict the window's dimensions to be less than or -equal to \fIwidth\fR and \fIheight\fR. -If \fIwidth\fR and \fIheight\fR are specified as empty strings, -then the maximum size option is cancelled for \fIwindow\fR. +The window manager will restrict the window's dimensions to be +less than or equal to \fIwidth\fR and \fIheight\fR. If \fIwidth\fR and \fIheight\fR are specified, then the command returns an empty string. Otherwise it returns a Tcl list with two elements, which are the -maximum width and height currently in effect; if no maximum -dimensions are in effect for \fIwindow\fR then an empty -string is returned. See the sections on geometry management -below for more information. +maximum width and height currently in effect. +The maximum size defaults to the size of the screen. +If resizing has been disabled with the \fBwm resizable\fR command, +then this command has no effect. +See the sections on geometry management below for more information. .TP \fBwm minsize \fIwindow\fR ?\fIwidth height\fR? -If \fIwidth\fR and \fIheight\fR are specified, then \fIwindow\fR -becomes resizable and \fIwidth\fR and \fIheight\fR give its -minimum permissible dimensions. +If \fIwidth\fR and \fIheight\fR are specified, they give the +minimum permissible dimensions for \fIwindow\fR. For gridded windows the dimensions are specified in grid units; otherwise they are specified in pixel units. -During manual sizing, the window manager -should restrict the window's dimensions to be greater than or -equal to \fIwidth\fR and \fIheight\fR. -If \fIwidth\fR and \fIheight\fR are specified as empty strings, -then the minimum size option is cancelled for \fIwindow\fR. +The window manager will restrict the window's dimensions to be +greater than or equal to \fIwidth\fR and \fIheight\fR. If \fIwidth\fR and \fIheight\fR are specified, then the command returns an empty string. Otherwise it returns a Tcl list with two elements, which are the -minimum width and height currently in effect; if no minimum -dimensions are in effect for \fIwindow\fR then an empty -string is returned. See the sections on geometry management -below for more information. +minimum width and height currently in effect. +The minimum size defaults to one pixel in each dimension. +If resizing has been disabled with the \fBwm resizable\fR command, +then this command has no effect. +See the sections on geometry management below for more information. .TP \fBwm overrideredirect \fIwindow\fR ?\fIboolean\fR? -.VS If \fIboolean\fR is specified, it must have a proper boolean form and the override-redirect flag for \fIwindow\fR is set to that value. If \fIboolean\fR is not specified then \fB1\fR or \fB0\fR is @@ -298,7 +303,6 @@ it to be ignored by the window manager; among other things, this means that the window will not be reparented from the root window into a decorative frame and the user will not be able to manipulate the window using the normal window manager mechanisms. -.VE .TP \fBwm positionfrom \fIwindow\fR ?\fIwho\fR? If \fIwho\fR is specified, it must be either \fBprogram\fR or @@ -315,7 +319,6 @@ Otherwise it returns \fBuser\fR or \fBwindow\fR to indicate the source of the window's current position, or an empty string if no source has been specified yet. Most window managers interpret ``no source'' as equivalent to \fBprogram\fR. -.VS Tk will automatically set the position source to \fBuser\fR when a \fBwm geometry\fR command is invoked, unless the source has been set explicitly to \fBprogram\fR. @@ -345,14 +348,28 @@ Lastly, if neither \fIname\fR nor \fIcommand\fR is specified, the command returns a list of all the protocols for which handlers are currently defined for \fIwindow\fR. .RS -.LP +.PP Tk always defines a protocol handler for \fBWM_DELETE_WINDOW\fR, even if you haven't asked for one with \fBwm protocol\fR. If a \fBWM_DELETE_WINDOW\fR message arrives when you haven't defined a handler, then Tk handles the message by destroying the window for which it was received. .RE -.VE +.TP +\fBwm resizable \fIwindow\fR ?\fIwidth height\fR? +This command controls whether or not the user may interactively +resize a top-level window. If \fIwidth\fR and \fIheight\fR are +specified, they are boolean values that determine whether the +width and height of \fIwindow\fR may be modified by the user. +In this case the command returns an empty string. +If \fIwidth\fR and \fIheight\fR are omitted then the command +returns a list with two 0/1 elements that indicate whether the +width and height of \fIwindow\fR are currently resizable. +By default, windows are resizable in both dimensions. +If resizing is disabled, then the window's size will be the size +from the most recent interactive resize or \fBwm geometry\fR +command. If there has been no such operation then +the window's natural size will be used. .TP \fBwm sizefrom \fIwindow\fR ?\fIwho\fR? If \fIwho\fR is specified, it must be either \fBprogram\fR or @@ -371,10 +388,13 @@ no source has been specified yet. Most window managers interpret ``no source'' as equivalent to \fBprogram\fR. .TP \fBwm state \fIwindow\fR -.VS Returns the current state of \fIwindow\fR: either \fBnormal\fR, -\fBiconic\fR, or \fBwithdrawn\fR. -.VE +\fBiconic\fR, \fBwithdrawn\fR, or \fBicon\fR. The difference +between \fBiconic\fR and \fBicon\fR is that \fBiconic\fR refers +to a window that has been iconified (e.g., with the \fBwm iconify\fR +command) while \fBicon\fR refers to a window whose only purpose is +to serve as the icon for some other window (via the \fBwm iconwindow\fR +command). .TP \fBwm title \fIwindow\fR ?\fIstring\fR? If \fIstring\fR is specified, then it will be passed to the window @@ -400,88 +420,46 @@ empty string if \fIwindow\fR isn't currently a transient window. Arranges for \fIwindow\fR to be withdrawn from the screen. This causes the window to be unmapped and forgotten about by the window manager. If the window -.VS has never been mapped, then this command causes the window to be mapped in the withdrawn state. Not all window managers appear to know how to handle windows that are mapped in the withdrawn state. -.VE Note: it sometimes seems to be necessary to withdraw a window and then re-map it (e.g. with \fBwm deiconify\fR) to get some window managers to pay attention to changes in window attributes such as group. -.SH "SOURCES OF GEOMETRY INFORMATION" +.SH "GEOMETRY MANAGEMENT" .PP -Size-related information for top-level windows -can come from three sources. -First, geometry requests come from the widgets that are descendants -of a top-level window. -Each widget requests a particular size for itself -by calling \fBTk_GeometryRequest\fR. This information is passed to -geometry managers, which then request large enough sizes for parent -windows so that they can layout the children properly. -Geometry information passes upwards through the window hierarchy -until eventually a particular size is requested for each top-level -window. -These requests are called \fIinternal requests\fR in the discussion -below. -The second source of width and height information is through the -\fBwm geometry\fR command. Third, the user can -request a particular size for a window using the -interactive facilities of the window manager. -The second and third types of geometry requests are called -\fIexternal requests\fR in the discussion below; Tk treats -these two kinds of requests identically. - -.SH "UNGRIDDED GEOMETRY MANAGEMENT" +By default a top-level window appears on the screen in its +\fInatural size\fR, which is the one determined internally by its +widgets and geometry managers. +If the natural size of a top-level window changes, then the window's size +changes to match. +A top-level window can be given a size other than its natural size in two ways. +First, the user can resize the window manually using the facilities +of the window manager, such as resize handles. +Second, the application can request a particular size for a +top-level window using the \fBwm geometry\fR command. +These two cases are handled identically by Tk; in either case, +the requested size overrides the natural size. +You can return the window to its natural by invoking \fBwm geometry\fR +with an empty \fIgeometry\fR string. .PP -Tk allows the geometry of a top-level window to be managed in -either of two general ways: ungridded or gridded. -The ungridded form occurs if no \fBwm grid\fR command -has been issued for a top-level window. -Ungridded management has several variants. -In the simplest variant of ungridded windows, -no \fBwm geometry\fR, \fBwm minsize\fR, or \fBwm maxsize\fR -commands have been invoked either. -In this case, the window's size is -determined totally by the internal requests emanating from the -widgets inside the window: Tk will ask the window manager not to -permit the user to resize the window interactively. -.PP -If a \fBwm geometry\fR command is invoked on an ungridded window, -then the size in that command overrides any size requested by the -window's widgets; from now on, the window's size will be determined -entirely by the most recent information from \fBwm geometry\fR -commands. To go back to using the size requested by the window's -widgets, issue a \fBwm geometry\fR command with an empty \fIgeometry\fR -string. -.PP -To enable interactive resizing of an ungridded window, one or both -of the \fBwm maxsize\fR -and \fBwm minsize\fR commands must be issued. -The information from these commands will be passed to the window -manager, and size changes within the specified range will be permitted. -For ungridded windows the limits refer to the top-level window's -dimensions in pixels. -If only a \fBwm maxsize\fR command is issued then the minimum -dimensions default to 1; if only a \fBwm minsize\fR command is -.VS -issued then the maximum dimensions default to the size of the display. -.VE -If the size of a window is changed interactively, it has the same -effect as if \fBwm geometry\fR had been invoked: from now on, internal -geometry requests will be ignored. -To return to internal control over the window's size, issue a -\fBwm geometry\fR command with an empty \fIgeometry\fR argument. -If a window has been manually resized or moved, the \fBwm geometry\fR -command will return the geometry that was requested interactively. +Normally a top-level window can have any size from one pixel in each +dimension up to the size of its screen. +However, you can use the \fBwm minsize\fR and \fBwm maxsize\fR commands +to limit the range of allowable sizes. +The range set by \fBwm minsize\fR and \fBwm maxsize\fR applies to +all forms of resizing, including the window's natural size as +well as manual resizes and the \fBwm geometry\fR command. +You can also use the command \fBwm resizable\fR to completely +disable interactive resizing in one or both dimensions. .SH "GRIDDED GEOMETRY MANAGEMENT" .PP -The second style of geometry management is called \fIgridded\fR. -This approach occurs when one of the widgets of an application -supports a range of useful sizes. +Gridded geometry management occurs when one of the widgets of an +application supports a range of useful sizes. This occurs, for example, in a text editor where the scrollbars, menus, and other adornments are fixed in size but the edit widget can support any number of lines of text or characters per line. @@ -509,23 +487,11 @@ To return to non-gridded geometry management, invoke When gridded geometry management is enabled then all the dimensions specified in \fBwm minsize\fR, \fBwm maxsize\fR, and \fBwm geometry\fR commands are treated as grid units rather than pixel units. -Interactive resizing is automatically enabled, and it will be -carried out in even numbers of grid units rather than pixels. -By default there are no limits on the minimum or maximum dimensions -of a gridded window. -As with ungridded windows, interactive resizing has exactly the -same effect as invoking the \fBwm geometry\fR command. -For gridded windows, internally- and externally-requested dimensions -work together: the externally-specified width and height determine -the size of the window in grid units, and the information from the -last \fBwm grid\fR command maps from grid units to pixel units. +Interactive resizing is also carried out in even numbers of grid units +rather than pixels. .SH BUGS .PP -The window manager interactions seem too complicated, especially -for managing geometry. Suggestions on how to simplify this would -be greatly appreciated. -.PP Most existing window managers appear to have bugs that affect the operation of the \fBwm\fR command. For example, some changes won't take effect if the window is already active: the window will have diff --git a/tk4.2/generic/README b/tk4.2/generic/README new file mode 100644 index 0000000..572cc93 --- /dev/null +++ b/tk4.2/generic/README @@ -0,0 +1,5 @@ +This directory contains Tk source files that work on all the platforms +where Tk runs (e.g. UNIX, PCs, and Macintoshes). Platform-specific +sources are in the directories ../unix, ../win, and ../mac. + +SCCS ID: @(#) README 1.1 95/09/11 14:02:45 diff --git a/tk4.2/generic/default.h b/tk4.2/generic/default.h new file mode 100644 index 0000000..91a19f6 --- /dev/null +++ b/tk4.2/generic/default.h @@ -0,0 +1,29 @@ +/* + * default.h -- + * + * This file defines the defaults for all options for all of + * the Tk widgets. + * + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) default.h 1.4 96/02/07 17:33:39 + */ + +#ifndef _DEFAULT +#define _DEFAULT + +#if defined(__WIN32__) || defined(_WIN32) +# include "tkWinDefault.h" +#else +# if defined(MAC_TCL) +# include "tkMacDefault.h" +# else +# include "tkUnixDefault.h" +# endif +#endif + +#endif /* _DEFAULT */ diff --git a/tk3.6/ks_names.h b/tk4.2/generic/ks_names.h similarity index 100% rename from tk3.6/ks_names.h rename to tk4.2/generic/ks_names.h diff --git a/tk4.2/generic/tk.h b/tk4.2/generic/tk.h new file mode 100644 index 0000000..d856454 --- /dev/null +++ b/tk4.2/generic/tk.h @@ -0,0 +1,1402 @@ +/* + * tk.h -- + * + * Declarations for Tk-related things that are visible + * outside of the Tk module itself. + * + * Copyright (c) 1989-1994 The Regents of the University of California. + * Copyright (c) 1994 The Australian National University. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tk.h 1.193 96/10/02 17:21:08 + */ + +#ifndef _TK +#define _TK + +/* + * When version numbers change here, must also go into the following files + * and update the version numbers: + * + * library/tk.tcl + * unix/configure.in + * unix/Makefile.in + * win/makefile.bc + * win/makefile.vc + * + * The release level should be 0 for alpha, 1 for beta, and 2 for + * final/patch. The release serial value is the number that follows the + * "a", "b", or "p" in the patch level; for example, if the patch level + * is 4.3b2, TK_RELEASE_SERIAL is 2. It restarts at 1 whenever the + * release level is changed, except for the final release, which should + * be 0. + */ + +#define TK_MAJOR_VERSION 4 +#define TK_MINOR_VERSION 2 +#define TK_RELEASE_LEVEL 2 +#define TK_RELEASE_SERIAL 0 + +#define TK_VERSION "4.2" +#define TK_PATCH_LEVEL "4.2" + +/* + * A special definition used to allow this header file to be included + * in resource files. + */ + +#ifndef RESOURCE_INCLUDED + +/* + * The following definitions set up the proper options for Macintosh + * compilers. We use this method because there is no autoconf equivalent. + */ + +#ifdef MAC_TCL +# ifndef REDO_KEYSYM_LOOKUP +# define REDO_KEYSYM_LOOKUP +# endif +#endif + +#ifndef _TCL +# include +#endif +#ifndef _XLIB_H +# ifdef MAC_TCL +# include +# include +# else +# include +# endif +#endif +#ifdef __STDC__ +# include +#endif + +/* + * Decide whether or not to use input methods. + */ + +#ifdef XNQueryInputStyle +#define TK_USE_INPUT_METHODS +#endif + +/* + * Dummy types that are used by clients: + */ + +typedef struct Tk_BindingTable_ *Tk_BindingTable; +typedef struct Tk_Canvas_ *Tk_Canvas; +typedef struct Tk_Cursor_ *Tk_Cursor; +typedef struct Tk_ErrorHandler_ *Tk_ErrorHandler; +typedef struct Tk_Image__ *Tk_Image; +typedef struct Tk_ImageMaster_ *Tk_ImageMaster; +typedef struct Tk_Window_ *Tk_Window; +typedef struct Tk_3DBorder_ *Tk_3DBorder; + +/* + * Additional types exported to clients. + */ + +typedef char *Tk_Uid; + +/* + * Structure used to specify how to handle argv options. + */ + +typedef struct { + char *key; /* The key string that flags the option in the + * argv array. */ + int type; /* Indicates option type; see below. */ + char *src; /* Value to be used in setting dst; usage + * depends on type. */ + char *dst; /* Address of value to be modified; usage + * depends on type. */ + char *help; /* Documentation message describing this option. */ +} Tk_ArgvInfo; + +/* + * Legal values for the type field of a Tk_ArgvInfo: see the user + * documentation for details. + */ + +#define TK_ARGV_CONSTANT 15 +#define TK_ARGV_INT 16 +#define TK_ARGV_STRING 17 +#define TK_ARGV_UID 18 +#define TK_ARGV_REST 19 +#define TK_ARGV_FLOAT 20 +#define TK_ARGV_FUNC 21 +#define TK_ARGV_GENFUNC 22 +#define TK_ARGV_HELP 23 +#define TK_ARGV_CONST_OPTION 24 +#define TK_ARGV_OPTION_VALUE 25 +#define TK_ARGV_OPTION_NAME_VALUE 26 +#define TK_ARGV_END 27 + +/* + * Flag bits for passing to Tk_ParseArgv: + */ + +#define TK_ARGV_NO_DEFAULTS 0x1 +#define TK_ARGV_NO_LEFTOVERS 0x2 +#define TK_ARGV_NO_ABBREV 0x4 +#define TK_ARGV_DONT_SKIP_FIRST_ARG 0x8 + +/* + * Structure used to describe application-specific configuration + * options: indicates procedures to call to parse an option and + * to return a text string describing an option. + */ + +typedef int (Tk_OptionParseProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, Tk_Window tkwin, char *value, char *widgRec, + int offset)); +typedef char *(Tk_OptionPrintProc) _ANSI_ARGS_((ClientData clientData, + Tk_Window tkwin, char *widgRec, int offset, + Tcl_FreeProc **freeProcPtr)); + +typedef struct Tk_CustomOption { + Tk_OptionParseProc *parseProc; /* Procedure to call to parse an + * option and store it in converted + * form. */ + Tk_OptionPrintProc *printProc; /* Procedure to return a printable + * string describing an existing + * option. */ + ClientData clientData; /* Arbitrary one-word value used by + * option parser: passed to + * parseProc and printProc. */ +} Tk_CustomOption; + +/* + * Structure used to specify information for Tk_ConfigureWidget. Each + * structure gives complete information for one option, including + * how the option is specified on the command line, where it appears + * in the option database, etc. + */ + +typedef struct Tk_ConfigSpec { + int type; /* Type of option, such as TK_CONFIG_COLOR; + * see definitions below. Last option in + * table must have type TK_CONFIG_END. */ + char *argvName; /* Switch used to specify option in argv. + * NULL means this spec is part of a group. */ + char *dbName; /* Name for option in option database. */ + char *dbClass; /* Class for option in database. */ + char *defValue; /* Default value for option if not + * specified in command line or database. */ + int offset; /* Where in widget record to store value; + * use Tk_Offset macro to generate values + * for this. */ + int specFlags; /* Any combination of the values defined + * below; other bits are used internally + * by tkConfig.c. */ + Tk_CustomOption *customPtr; /* If type is TK_CONFIG_CUSTOM then this is + * a pointer to info about how to parse and + * print the option. Otherwise it is + * irrelevant. */ +} Tk_ConfigSpec; + +/* + * Type values for Tk_ConfigSpec structures. See the user + * documentation for details. + */ + +#define TK_CONFIG_BOOLEAN 1 +#define TK_CONFIG_INT 2 +#define TK_CONFIG_DOUBLE 3 +#define TK_CONFIG_STRING 4 +#define TK_CONFIG_UID 5 +#define TK_CONFIG_COLOR 6 +#define TK_CONFIG_FONT 7 +#define TK_CONFIG_BITMAP 8 +#define TK_CONFIG_BORDER 9 +#define TK_CONFIG_RELIEF 10 +#define TK_CONFIG_CURSOR 11 +#define TK_CONFIG_ACTIVE_CURSOR 12 +#define TK_CONFIG_JUSTIFY 13 +#define TK_CONFIG_ANCHOR 14 +#define TK_CONFIG_SYNONYM 15 +#define TK_CONFIG_CAP_STYLE 16 +#define TK_CONFIG_JOIN_STYLE 17 +#define TK_CONFIG_PIXELS 18 +#define TK_CONFIG_MM 19 +#define TK_CONFIG_WINDOW 20 +#define TK_CONFIG_CUSTOM 21 +#define TK_CONFIG_END 22 + +/* + * Macro to use to fill in "offset" fields of Tk_ConfigInfos. + * Computes number of bytes from beginning of structure to a + * given field. + */ + +#ifdef offsetof +#define Tk_Offset(type, field) ((int) offsetof(type, field)) +#else +#define Tk_Offset(type, field) ((int) ((char *) &((type *) 0)->field)) +#endif + +/* + * Possible values for flags argument to Tk_ConfigureWidget: + */ + +#define TK_CONFIG_ARGV_ONLY 1 + +/* + * Possible flag values for Tk_ConfigInfo structures. Any bits at + * or above TK_CONFIG_USER_BIT may be used by clients for selecting + * certain entries. Before changing any values here, coordinate with + * tkConfig.c (internal-use-only flags are defined there). + */ + +#define TK_CONFIG_COLOR_ONLY 1 +#define TK_CONFIG_MONO_ONLY 2 +#define TK_CONFIG_NULL_OK 4 +#define TK_CONFIG_DONT_SET_DEFAULT 8 +#define TK_CONFIG_OPTION_SPECIFIED 0x10 +#define TK_CONFIG_USER_BIT 0x100 + +/* + * Enumerated type for describing actions to be taken in response + * to a restrictProc established by Tk_RestrictEvents. + */ + +typedef enum { + TK_DEFER_EVENT, TK_PROCESS_EVENT, TK_DISCARD_EVENT +} Tk_RestrictAction; + +/* + * Priority levels to pass to Tk_AddOption: + */ + +#define TK_WIDGET_DEFAULT_PRIO 20 +#define TK_STARTUP_FILE_PRIO 40 +#define TK_USER_DEFAULT_PRIO 60 +#define TK_INTERACTIVE_PRIO 80 +#define TK_MAX_PRIO 100 + +/* + * Relief values returned by Tk_GetRelief: + */ + +#define TK_RELIEF_RAISED 1 +#define TK_RELIEF_FLAT 2 +#define TK_RELIEF_SUNKEN 4 +#define TK_RELIEF_GROOVE 8 +#define TK_RELIEF_RIDGE 16 + +/* + * "Which" argument values for Tk_3DBorderGC: + */ + +#define TK_3D_FLAT_GC 1 +#define TK_3D_LIGHT_GC 2 +#define TK_3D_DARK_GC 3 + +/* + * Special EnterNotify/LeaveNotify "mode" for use in events + * generated by tkShare.c. Pick a high enough value that it's + * unlikely to conflict with existing values (like NotifyNormal) + * or any new values defined in the future. + */ + +#define TK_NOTIFY_SHARE 20 + +/* + * Enumerated type for describing a point by which to anchor something: + */ + +typedef enum { + TK_ANCHOR_N, TK_ANCHOR_NE, TK_ANCHOR_E, TK_ANCHOR_SE, + TK_ANCHOR_S, TK_ANCHOR_SW, TK_ANCHOR_W, TK_ANCHOR_NW, + TK_ANCHOR_CENTER +} Tk_Anchor; + +/* + * Enumerated type for describing a style of justification: + */ + +typedef enum { + TK_JUSTIFY_LEFT, TK_JUSTIFY_RIGHT, TK_JUSTIFY_CENTER +} Tk_Justify; + +/* + * Each geometry manager (the packer, the placer, etc.) is represented + * by a structure of the following form, which indicates procedures + * to invoke in the geometry manager to carry out certain functions. + */ + +typedef void (Tk_GeomRequestProc) _ANSI_ARGS_((ClientData clientData, + Tk_Window tkwin)); +typedef void (Tk_GeomLostSlaveProc) _ANSI_ARGS_((ClientData clientData, + Tk_Window tkwin)); + +typedef struct Tk_GeomMgr { + char *name; /* Name of the geometry manager (command + * used to invoke it, or name of widget + * class that allows embedded widgets). */ + Tk_GeomRequestProc *requestProc; + /* Procedure to invoke when a slave's + * requested geometry changes. */ + Tk_GeomLostSlaveProc *lostSlaveProc; + /* Procedure to invoke when a slave is + * taken away from one geometry manager + * by another. NULL means geometry manager + * doesn't care when slaves are lost. */ +} Tk_GeomMgr; + +/* + * Result values returned by Tk_GetScrollInfo: + */ + +#define TK_SCROLL_MOVETO 1 +#define TK_SCROLL_PAGES 2 +#define TK_SCROLL_UNITS 3 +#define TK_SCROLL_ERROR 4 + +/*--------------------------------------------------------------------------- + * + * Extensions to the X event set + * + *--------------------------------------------------------------------------- + */ + +#define VirtualEvent (LASTEvent) +#define ActivateNotify (LASTEvent + 1) +#define DeactivateNotify (LASTEvent + 2) +#define TK_LASTEVENT (LASTEvent + 3) + +#define VirtualEventMask (1L << 30) +#define ActivateMask (1L << 29) + + +/* + * A virtual event shares most of its fields with the XKeyEvent and + * XButtonEvent structures. 99% of the time a virtual event will be + * an abstraction of a key or button event, so this structure provides + * the most information to the user. The only difference is the changing + * of the detail field for a virtual event so that it holds the name of the + * virtual event being triggered. + */ + +typedef struct { + int type; + unsigned long serial; /* # of last request processed by server */ + Bool send_event; /* True if this came from a SendEvent request */ + Display *display; /* Display the event was read from */ + Window event; /* Window on which event was requested. */ + Window root; /* root window that the event occured on */ + Window subwindow; /* child window */ + Time time; /* milliseconds */ + int x, y; /* pointer x, y coordinates in event window */ + int x_root, y_root; /* coordinates relative to root */ + unsigned int state; /* key or button mask */ + Tk_Uid name; /* Name of virtual event. */ + Bool same_screen; /* same screen flag */ +} XVirtualEvent; + +typedef struct { + int type; + unsigned long serial; /* # of last request processed by server */ + Bool send_event; /* True if this came from a SendEvent request */ + Display *display; /* Display the event was read from */ + Window window; /* Window in which event occurred. */ +} XActivateDeactivateEvent; +typedef XActivateDeactivateEvent XActivateEvent; +typedef XActivateDeactivateEvent XDeactivateEvent; + +/* + *-------------------------------------------------------------- + * + * Macros for querying Tk_Window structures. See the + * manual entries for documentation. + * + *-------------------------------------------------------------- + */ + +#define Tk_Display(tkwin) (((Tk_FakeWin *) (tkwin))->display) +#define Tk_ScreenNumber(tkwin) (((Tk_FakeWin *) (tkwin))->screenNum) +#define Tk_Screen(tkwin) (ScreenOfDisplay(Tk_Display(tkwin), \ + Tk_ScreenNumber(tkwin))) +#define Tk_Depth(tkwin) (((Tk_FakeWin *) (tkwin))->depth) +#define Tk_Visual(tkwin) (((Tk_FakeWin *) (tkwin))->visual) +#define Tk_WindowId(tkwin) (((Tk_FakeWin *) (tkwin))->window) +#define Tk_PathName(tkwin) (((Tk_FakeWin *) (tkwin))->pathName) +#define Tk_Name(tkwin) (((Tk_FakeWin *) (tkwin))->nameUid) +#define Tk_Class(tkwin) (((Tk_FakeWin *) (tkwin))->classUid) +#define Tk_X(tkwin) (((Tk_FakeWin *) (tkwin))->changes.x) +#define Tk_Y(tkwin) (((Tk_FakeWin *) (tkwin))->changes.y) +#define Tk_Width(tkwin) (((Tk_FakeWin *) (tkwin))->changes.width) +#define Tk_Height(tkwin) \ + (((Tk_FakeWin *) (tkwin))->changes.height) +#define Tk_Changes(tkwin) (&((Tk_FakeWin *) (tkwin))->changes) +#define Tk_Attributes(tkwin) (&((Tk_FakeWin *) (tkwin))->atts) +#define Tk_IsMapped(tkwin) \ + (((Tk_FakeWin *) (tkwin))->flags & TK_MAPPED) +#define Tk_IsTopLevel(tkwin) \ + (((Tk_FakeWin *) (tkwin))->flags & TK_TOP_LEVEL) +#define Tk_ReqWidth(tkwin) (((Tk_FakeWin *) (tkwin))->reqWidth) +#define Tk_ReqHeight(tkwin) (((Tk_FakeWin *) (tkwin))->reqHeight) +#define Tk_InternalBorderWidth(tkwin) \ + (((Tk_FakeWin *) (tkwin))->internalBorderWidth) +#define Tk_Parent(tkwin) (((Tk_FakeWin *) (tkwin))->parentPtr) +#define Tk_Colormap(tkwin) (((Tk_FakeWin *) (tkwin))->atts.colormap) + +/* + * The structure below is needed by the macros above so that they can + * access the fields of a Tk_Window. The fields not needed by the macros + * are declared as "dummyX". The structure has its own type in order to + * prevent applications from accessing Tk_Window fields except using + * official macros. WARNING!! The structure definition must be kept + * consistent with the TkWindow structure in tkInt.h. If you change one, + * then change the other. See the declaration in tkInt.h for + * documentation on what the fields are used for internally. + */ + +typedef struct Tk_FakeWin { + Display *display; + char *dummy1; + int screenNum; + Visual *visual; + int depth; + Window window; + char *dummy2; + char *dummy3; + Tk_Window parentPtr; + char *dummy4; + char *dummy5; + char *pathName; + Tk_Uid nameUid; + Tk_Uid classUid; + XWindowChanges changes; + unsigned int dummy6; + XSetWindowAttributes atts; + unsigned long dummy7; + unsigned int flags; + char *dummy8; +#ifdef TK_USE_INPUT_METHODS + XIC dummy9; +#endif /* TK_USE_INPUT_METHODS */ + ClientData *dummy10; + int dummy11; + int dummy12; + char *dummy13; + char *dummy14; + ClientData dummy15; + int reqWidth, reqHeight; + int internalBorderWidth; + char *dummy16; + char *dummy17; +} Tk_FakeWin; + +/* + * Flag values for TkWindow (and Tk_FakeWin) structures are: + * + * TK_MAPPED: 1 means window is currently mapped, + * 0 means unmapped. + * TK_TOP_LEVEL: 1 means this is a top-level window (it + * was or will be created as a child of + * a root window). + * TK_ALREADY_DEAD: 1 means the window is in the process of + * being destroyed already. + * TK_NEED_CONFIG_NOTIFY: 1 means that the window has been reconfigured + * before it was made to exist. At the time of + * making it exist a ConfigureNotify event needs + * to be generated. + * TK_GRAB_FLAG: Used to manage grabs. See tkGrab.c for + * details. + * TK_CHECKED_IC: 1 means we've already tried to get an input + * context for this window; if the ic field + * is NULL it means that there isn't a context + * for the field. + * TK_PARENT_DESTROYED: 1 means that the window's parent has already + * been destroyed or is in the process of being + * destroyed. + * TK_WM_COLORMAP_WINDOW: 1 means that this window has at some time + * appeared in the WM_COLORMAP_WINDOWS property + * for its toplevel, so we have to remove it + * from that property if the window is + * deleted and the toplevel isn't. + */ + +#define TK_MAPPED 1 +#define TK_TOP_LEVEL 2 +#define TK_ALREADY_DEAD 4 +#define TK_NEED_CONFIG_NOTIFY 8 +#define TK_GRAB_FLAG 0x10 +#define TK_CHECKED_IC 0x20 +#define TK_PARENT_DESTROYED 0x40 +#define TK_WM_COLORMAP_WINDOW 0x80 + +/* + *-------------------------------------------------------------- + * + * Procedure prototypes and structures used for defining new canvas + * items: + * + *-------------------------------------------------------------- + */ + +/* + * For each item in a canvas widget there exists one record with + * the following structure. Each actual item is represented by + * a record with the following stuff at its beginning, plus additional + * type-specific stuff after that. + */ + +#define TK_TAG_SPACE 3 + +typedef struct Tk_Item { + int id; /* Unique identifier for this item + * (also serves as first tag for + * item). */ + struct Tk_Item *nextPtr; /* Next in display list of all + * items in this canvas. Later items + * in list are drawn on top of earlier + * ones. */ + Tk_Uid staticTagSpace[TK_TAG_SPACE];/* Built-in space for limited # of + * tags. */ + Tk_Uid *tagPtr; /* Pointer to array of tags. Usually + * points to staticTagSpace, but + * may point to malloc-ed space if + * there are lots of tags. */ + int tagSpace; /* Total amount of tag space available + * at tagPtr. */ + int numTags; /* Number of tag slots actually used + * at *tagPtr. */ + struct Tk_ItemType *typePtr; /* Table of procedures that implement + * this type of item. */ + int x1, y1, x2, y2; /* Bounding box for item, in integer + * canvas units. Set by item-specific + * code and guaranteed to contain every + * pixel drawn in item. Item area + * includes x1 and y1 but not x2 + * and y2. */ + + /* + *------------------------------------------------------------------ + * Starting here is additional type-specific stuff; see the + * declarations for individual types to see what is part of + * each type. The actual space below is determined by the + * "itemInfoSize" of the type's Tk_ItemType record. + *------------------------------------------------------------------ + */ +} Tk_Item; + +/* + * Records of the following type are used to describe a type of + * item (e.g. lines, circles, etc.) that can form part of a + * canvas widget. + */ + +typedef int Tk_ItemCreateProc _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int argc, + char **argv)); +typedef int Tk_ItemConfigureProc _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int argc, + char **argv, int flags)); +typedef int Tk_ItemCoordProc _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int argc, + char **argv)); +typedef void Tk_ItemDeleteProc _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, Display *display)); +typedef void Tk_ItemDisplayProc _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, Display *display, Drawable dst, + int x, int y, int width, int height)); +typedef double Tk_ItemPointProc _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double *pointPtr)); +typedef int Tk_ItemAreaProc _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double *rectPtr)); +typedef int Tk_ItemPostscriptProc _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int prepass)); +typedef void Tk_ItemScaleProc _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double originX, double originY, + double scaleX, double scaleY)); +typedef void Tk_ItemTranslateProc _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double deltaX, double deltaY)); +typedef int Tk_ItemIndexProc _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, char *indexString, + int *indexPtr)); +typedef void Tk_ItemCursorProc _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, int index)); +typedef int Tk_ItemSelectionProc _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, int offset, char *buffer, + int maxBytes)); +typedef void Tk_ItemInsertProc _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, int beforeThis, char *string)); +typedef void Tk_ItemDCharsProc _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, int first, int last)); + +typedef struct Tk_ItemType { + char *name; /* The name of this type of item, such + * as "line". */ + int itemSize; /* Total amount of space needed for + * item's record. */ + Tk_ItemCreateProc *createProc; /* Procedure to create a new item of + * this type. */ + Tk_ConfigSpec *configSpecs; /* Pointer to array of configuration + * specs for this type. Used for + * returning configuration info. */ + Tk_ItemConfigureProc *configProc; /* Procedure to call to change + * configuration options. */ + Tk_ItemCoordProc *coordProc; /* Procedure to call to get and set + * the item's coordinates. */ + Tk_ItemDeleteProc *deleteProc; /* Procedure to delete existing item of + * this type. */ + Tk_ItemDisplayProc *displayProc; /* Procedure to display items of + * this type. */ + int alwaysRedraw; /* Non-zero means displayProc should + * be called even when the item has + * been moved off-screen. */ + Tk_ItemPointProc *pointProc; /* Computes distance from item to + * a given point. */ + Tk_ItemAreaProc *areaProc; /* Computes whether item is inside, + * outside, or overlapping an area. */ + Tk_ItemPostscriptProc *postscriptProc; + /* Procedure to write a Postscript + * description for items of this + * type. */ + Tk_ItemScaleProc *scaleProc; /* Procedure to rescale items of + * this type. */ + Tk_ItemTranslateProc *translateProc;/* Procedure to translate items of + * this type. */ + Tk_ItemIndexProc *indexProc; /* Procedure to determine index of + * indicated character. NULL if + * item doesn't support indexing. */ + Tk_ItemCursorProc *icursorProc; /* Procedure to set insert cursor pos. + * to just before a given position. */ + Tk_ItemSelectionProc *selectionProc;/* Procedure to return selection (in + * STRING format) when it is in this + * item. */ + Tk_ItemInsertProc *insertProc; /* Procedure to insert something into + * an item. */ + Tk_ItemDCharsProc *dCharsProc; /* Procedure to delete characters + * from an item. */ + struct Tk_ItemType *nextPtr; /* Used to link types together into + * a list. */ +} Tk_ItemType; + +/* + * The following structure provides information about the selection and + * the insertion cursor. It is needed by only a few items, such as + * those that display text. It is shared by the generic canvas code + * and the item-specific code, but most of the fields should be written + * only by the canvas generic code. + */ + +typedef struct Tk_CanvasTextInfo { + Tk_3DBorder selBorder; /* Border and background for selected + * characters. Read-only to items.*/ + int selBorderWidth; /* Width of border around selection. + * Read-only to items. */ + XColor *selFgColorPtr; /* Foreground color for selected text. + * Read-only to items. */ + Tk_Item *selItemPtr; /* Pointer to selected item. NULL means + * selection isn't in this canvas. + * Writable by items. */ + int selectFirst; /* Index of first selected character. + * Writable by items. */ + int selectLast; /* Index of last selected character. + * Writable by items. */ + Tk_Item *anchorItemPtr; /* Item corresponding to "selectAnchor": + * not necessarily selItemPtr. Read-only + * to items. */ + int selectAnchor; /* Fixed end of selection (i.e. "select to" + * operation will use this as one end of the + * selection). Writable by items. */ + Tk_3DBorder insertBorder; /* Used to draw vertical bar for insertion + * cursor. Read-only to items. */ + int insertWidth; /* Total width of insertion cursor. Read-only + * to items. */ + int insertBorderWidth; /* Width of 3-D border around insert cursor. + * Read-only to items. */ + Tk_Item *focusItemPtr; /* Item that currently has the input focus, + * or NULL if no such item. Read-only to + * items. */ + int gotFocus; /* Non-zero means that the canvas widget has + * the input focus. Read-only to items.*/ + int cursorOn; /* Non-zero means that an insertion cursor + * should be displayed in focusItemPtr. + * Read-only to items.*/ +} Tk_CanvasTextInfo; + +/* + *-------------------------------------------------------------- + * + * Procedure prototypes and structures used for managing images: + * + *-------------------------------------------------------------- + */ + +typedef struct Tk_ImageType Tk_ImageType; +typedef int (Tk_ImageCreateProc) _ANSI_ARGS_((Tcl_Interp *interp, + char *name, int argc, char **argv, Tk_ImageType *typePtr, + Tk_ImageMaster master, ClientData *masterDataPtr)); +typedef ClientData (Tk_ImageGetProc) _ANSI_ARGS_((Tk_Window tkwin, + ClientData masterData)); +typedef void (Tk_ImageDisplayProc) _ANSI_ARGS_((ClientData instanceData, + Display *display, Drawable drawable, int imageX, int imageY, + int width, int height, int drawableX, int drawableY)); +typedef void (Tk_ImageFreeProc) _ANSI_ARGS_((ClientData instanceData, + Display *display)); +typedef void (Tk_ImageDeleteProc) _ANSI_ARGS_((ClientData masterData)); +typedef void (Tk_ImageChangedProc) _ANSI_ARGS_((ClientData clientData, + int x, int y, int width, int height, int imageWidth, + int imageHeight)); + +/* + * The following structure represents a particular type of image + * (bitmap, xpm image, etc.). It provides information common to + * all images of that type, such as the type name and a collection + * of procedures in the image manager that respond to various + * events. Each image manager is represented by one of these + * structures. + */ + +struct Tk_ImageType { + char *name; /* Name of image type. */ + Tk_ImageCreateProc *createProc; + /* Procedure to call to create a new image + * of this type. */ + Tk_ImageGetProc *getProc; /* Procedure to call the first time + * Tk_GetImage is called in a new way + * (new visual or screen). */ + Tk_ImageDisplayProc *displayProc; + /* Call to draw image, in response to + * Tk_RedrawImage calls. */ + Tk_ImageFreeProc *freeProc; /* Procedure to call whenever Tk_FreeImage + * is called to release an instance of an + * image. */ + Tk_ImageDeleteProc *deleteProc; + /* Procedure to call to delete image. It + * will not be called until after freeProc + * has been called for each instance of the + * image. */ + struct Tk_ImageType *nextPtr; + /* Next in list of all image types currently + * known. Filled in by Tk, not by image + * manager. */ +}; + +/* + *-------------------------------------------------------------- + * + * Additional definitions used to manage images of type "photo". + * + *-------------------------------------------------------------- + */ + +/* + * The following type is used to identify a particular photo image + * to be manipulated: + */ + +typedef void *Tk_PhotoHandle; + +/* + * The following structure describes a block of pixels in memory: + */ + +typedef struct Tk_PhotoImageBlock { + unsigned char *pixelPtr; /* Pointer to the first pixel. */ + int width; /* Width of block, in pixels. */ + int height; /* Height of block, in pixels. */ + int pitch; /* Address difference between corresponding + * pixels in successive lines. */ + int pixelSize; /* Address difference between successive + * pixels in the same line. */ + int offset[3]; /* Address differences between the red, green + * and blue components of the pixel and the + * pixel as a whole. */ +} Tk_PhotoImageBlock; + +/* + * Procedure prototypes and structures used in reading and + * writing photo images: + */ + +typedef struct Tk_PhotoImageFormat Tk_PhotoImageFormat; +typedef int (Tk_ImageFileMatchProc) _ANSI_ARGS_((FILE *f, char *fileName, + char *formatString, int *widthPtr, int *heightPtr)); +typedef int (Tk_ImageStringMatchProc) _ANSI_ARGS_((char *string, + char *formatString, int *widthPtr, int *heightPtr)); +typedef int (Tk_ImageFileReadProc) _ANSI_ARGS_((Tcl_Interp *interp, + FILE *f, char *fileName, char *formatString, Tk_PhotoHandle imageHandle, + int destX, int destY, int width, int height, int srcX, int srcY)); +typedef int (Tk_ImageStringReadProc) _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char *formatString, Tk_PhotoHandle imageHandle, + int destX, int destY, int width, int height, int srcX, int srcY)); +typedef int (Tk_ImageFileWriteProc) _ANSI_ARGS_((Tcl_Interp *interp, + char *fileName, char *formatString, Tk_PhotoImageBlock *blockPtr)); +typedef int (Tk_ImageStringWriteProc) _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_DString *dataPtr, char *formatString, + Tk_PhotoImageBlock *blockPtr)); + +/* + * The following structure represents a particular file format for + * storing images (e.g., PPM, GIF, JPEG, etc.). It provides information + * to allow image files of that format to be recognized and read into + * a photo image. + */ + +struct Tk_PhotoImageFormat { + char *name; /* Name of image file format */ + Tk_ImageFileMatchProc *fileMatchProc; + /* Procedure to call to determine whether + * an image file matches this format. */ + Tk_ImageStringMatchProc *stringMatchProc; + /* Procedure to call to determine whether + * the data in a string matches this format. */ + Tk_ImageFileReadProc *fileReadProc; + /* Procedure to call to read data from + * an image file into a photo image. */ + Tk_ImageStringReadProc *stringReadProc; + /* Procedure to call to read data from + * a string into a photo image. */ + Tk_ImageFileWriteProc *fileWriteProc; + /* Procedure to call to write data from + * a photo image to a file. */ + Tk_ImageStringWriteProc *stringWriteProc; + /* Procedure to call to obtain a string + * representation of the data in a photo + * image.*/ + struct Tk_PhotoImageFormat *nextPtr; + /* Next in list of all photo image formats + * currently known. Filled in by Tk, not + * by image format handler. */ +}; + +/* + *-------------------------------------------------------------- + * + * The definitions below provide backward compatibility for + * functions and types related to event handling that used to + * be in Tk but have moved to Tcl. + * + *-------------------------------------------------------------- + */ + +#define TK_READABLE TCL_READABLE +#define TK_WRITABLE TCL_WRITABLE +#define TK_EXCEPTION TCL_EXCEPTION + +#define TK_DONT_WAIT TCL_DONT_WAIT +#define TK_X_EVENTS TCL_WINDOW_EVENTS +#define TK_WINDOW_EVENTS TCL_WINDOW_EVENTS +#define TK_FILE_EVENTS TCL_FILE_EVENTS +#define TK_TIMER_EVENTS TCL_TIMER_EVENTS +#define TK_IDLE_EVENTS TCL_IDLE_EVENTS +#define TK_ALL_EVENTS TCL_ALL_EVENTS + +#define Tk_IdleProc Tcl_IdleProc +#define Tk_FileProc Tcl_FileProc +#define Tk_TimerProc Tcl_TimerProc +#define Tk_TimerToken Tcl_TimerToken + +#define Tk_BackgroundError Tcl_BackgroundError +#define Tk_CancelIdleCall Tcl_CancelIdleCall +#define Tk_CreateFileHandler(file,mask,proc,data) \ + Tcl_CreateFileHandler(Tcl_GetFile((ClientData) (file), TCL_UNIX_FD), \ + (mask), (proc), (data)) +#define Tk_CreateTimerHandler Tcl_CreateTimerHandler +#define Tk_DeleteFileHandler(file) \ + Tcl_DeleteFileHandler(Tcl_GetFile((ClientData) (file), TCL_UNIX_FD)) +#define Tk_DeleteTimerHandler Tcl_DeleteTimerHandler +#define Tk_DoOneEvent Tcl_DoOneEvent +#define Tk_DoWhenIdle Tcl_DoWhenIdle +#define Tk_Sleep Tcl_Sleep + +/* Additional stuff that has moved to Tcl: */ + +#define Tk_AfterCmd Tcl_AfterCmd +#define Tk_EventuallyFree Tcl_EventuallyFree +#define Tk_FreeProc Tcl_FreeProc +#define Tk_Preserve Tcl_Preserve +#define Tk_Release Tcl_Release + +/* + *-------------------------------------------------------------- + * + * Additional procedure types defined by Tk. + * + *-------------------------------------------------------------- + */ + +typedef int (Tk_ErrorProc) _ANSI_ARGS_((ClientData clientData, + XErrorEvent *errEventPtr)); +typedef void (Tk_EventProc) _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +typedef int (Tk_GenericProc) _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +typedef int (Tk_GetSelProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *portion)); +typedef void (Tk_LostSelProc) _ANSI_ARGS_((ClientData clientData)); +typedef Tk_RestrictAction (Tk_RestrictProc) _ANSI_ARGS_(( + ClientData clientData, XEvent *eventPtr)); +typedef int (Tk_SelectionProc) _ANSI_ARGS_((ClientData clientData, + int offset, char *buffer, int maxBytes)); + +/* + *-------------------------------------------------------------- + * + * Exported procedures and variables. + * + *-------------------------------------------------------------- + */ + +EXTERN XColor * Tk_3DBorderColor _ANSI_ARGS_((Tk_3DBorder border)); +EXTERN GC Tk_3DBorderGC _ANSI_ARGS_((Tk_Window tkwin, + Tk_3DBorder border, int which)); +EXTERN void Tk_3DHorizontalBevel _ANSI_ARGS_((Tk_Window tkwin, + Drawable drawable, Tk_3DBorder border, int x, + int y, int width, int height, int leftIn, + int rightIn, int topBevel, int relief)); +EXTERN void Tk_3DVerticalBevel _ANSI_ARGS_((Tk_Window tkwin, + Drawable drawable, Tk_3DBorder border, int x, + int y, int width, int height, int leftBevel, + int relief)); +EXTERN void Tk_AddOption _ANSI_ARGS_((Tk_Window tkwin, char *name, + char *value, int priority)); +EXTERN void Tk_BindEvent _ANSI_ARGS_((Tk_BindingTable bindingTable, + XEvent *eventPtr, Tk_Window tkwin, int numObjects, + ClientData *objectPtr)); +EXTERN void Tk_CanvasDrawableCoords _ANSI_ARGS_((Tk_Canvas canvas, + double x, double y, short *drawableXPtr, + short *drawableYPtr)); +EXTERN void Tk_CanvasEventuallyRedraw _ANSI_ARGS_(( + Tk_Canvas canvas, int x1, int y1, int x2, + int y2)); +EXTERN int Tk_CanvasGetCoord _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, char *string, + double *doublePtr)); +EXTERN Tk_CanvasTextInfo *Tk_CanvasGetTextInfo _ANSI_ARGS_((Tk_Canvas canvas)); +EXTERN int Tk_CanvasPsBitmap _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Pixmap bitmap, int x, int y, + int width, int height)); +EXTERN int Tk_CanvasPsColor _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, XColor *colorPtr)); +EXTERN int Tk_CanvasPsFont _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, XFontStruct *fontStructPtr)); +EXTERN void Tk_CanvasPsPath _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, double *coordPtr, int numPoints)); +EXTERN int Tk_CanvasPsStipple _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Pixmap bitmap)); +EXTERN double Tk_CanvasPsY _ANSI_ARGS_((Tk_Canvas canvas, double y)); +EXTERN void Tk_CanvasSetStippleOrigin _ANSI_ARGS_(( + Tk_Canvas canvas, GC gc)); +EXTERN int Tk_CanvasTagsParseProc _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp, + Tk_Window tkwin, char *value, char *widgRec, + int offset)); +EXTERN char * Tk_CanvasTagsPrintProc _ANSI_ARGS_(( + ClientData clientData, Tk_Window tkwin, + char *widgRec, int offset, + Tcl_FreeProc **freeProcPtr)); +EXTERN Tk_Window Tk_CanvasTkwin _ANSI_ARGS_((Tk_Canvas canvas)); +EXTERN void Tk_CanvasWindowCoords _ANSI_ARGS_((Tk_Canvas canvas, + double x, double y, short *screenXPtr, + short *screenYPtr)); +EXTERN void Tk_ChangeWindowAttributes _ANSI_ARGS_((Tk_Window tkwin, + unsigned long valueMask, + XSetWindowAttributes *attsPtr)); +EXTERN void Tk_ClearSelection _ANSI_ARGS_((Tk_Window tkwin, + Atom selection)); +EXTERN int Tk_ClipboardAppend _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, Atom target, Atom format, + char* buffer)); +EXTERN int Tk_ClipboardClear _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin)); +EXTERN int Tk_ConfigureInfo _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, Tk_ConfigSpec *specs, + char *widgRec, char *argvName, int flags)); +EXTERN int Tk_ConfigureValue _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, Tk_ConfigSpec *specs, + char *widgRec, char *argvName, int flags)); +EXTERN int Tk_ConfigureWidget _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, Tk_ConfigSpec *specs, + int argc, char **argv, char *widgRec, + int flags)); +EXTERN void Tk_ConfigureWindow _ANSI_ARGS_((Tk_Window tkwin, + unsigned int valueMask, XWindowChanges *valuePtr)); +EXTERN Tk_Window Tk_CoordsToWindow _ANSI_ARGS_((int rootX, int rootY, + Tk_Window tkwin)); +EXTERN unsigned long Tk_CreateBinding _ANSI_ARGS_((Tcl_Interp *interp, + Tk_BindingTable bindingTable, ClientData object, + char *eventString, char *command, int append)); +EXTERN Tk_BindingTable Tk_CreateBindingTable _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN Tk_ErrorHandler Tk_CreateErrorHandler _ANSI_ARGS_((Display *display, + int errNum, int request, int minorCode, + Tk_ErrorProc *errorProc, ClientData clientData)); +EXTERN void Tk_CreateEventHandler _ANSI_ARGS_((Tk_Window token, + unsigned long mask, Tk_EventProc *proc, + ClientData clientData)); +EXTERN void Tk_CreateGenericHandler _ANSI_ARGS_(( + Tk_GenericProc *proc, ClientData clientData)); +EXTERN void Tk_CreateImageType _ANSI_ARGS_(( + Tk_ImageType *typePtr)); +EXTERN void Tk_CreateItemType _ANSI_ARGS_((Tk_ItemType *typePtr)); +EXTERN void Tk_CreatePhotoImageFormat _ANSI_ARGS_(( + Tk_PhotoImageFormat *formatPtr)); +EXTERN void Tk_CreateSelHandler _ANSI_ARGS_((Tk_Window tkwin, + Atom selection, Atom target, + Tk_SelectionProc *proc, ClientData clientData, + Atom format)); +EXTERN Tk_Window Tk_CreateWindow _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window parent, char *name, char *screenName)); +EXTERN Tk_Window Tk_CreateWindowFromPath _ANSI_ARGS_(( + Tcl_Interp *interp, Tk_Window tkwin, + char *pathName, char *screenName)); +EXTERN int Tk_DefineBitmap _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Uid name, char *source, int width, + int height)); +EXTERN void Tk_DefineCursor _ANSI_ARGS_((Tk_Window window, + Tk_Cursor cursor)); +EXTERN void Tk_DeleteAllBindings _ANSI_ARGS_(( + Tk_BindingTable bindingTable, ClientData object)); +EXTERN int Tk_DeleteBinding _ANSI_ARGS_((Tcl_Interp *interp, + Tk_BindingTable bindingTable, ClientData object, + char *eventString)); +EXTERN void Tk_DeleteBindingTable _ANSI_ARGS_(( + Tk_BindingTable bindingTable)); +EXTERN void Tk_DeleteErrorHandler _ANSI_ARGS_(( + Tk_ErrorHandler handler)); +EXTERN void Tk_DeleteEventHandler _ANSI_ARGS_((Tk_Window token, + unsigned long mask, Tk_EventProc *proc, + ClientData clientData)); +EXTERN void Tk_DeleteGenericHandler _ANSI_ARGS_(( + Tk_GenericProc *proc, ClientData clientData)); +EXTERN void Tk_DeleteImage _ANSI_ARGS_((Tcl_Interp *interp, + char *name)); +EXTERN void Tk_DeleteSelHandler _ANSI_ARGS_((Tk_Window tkwin, + Atom selection, Atom target)); +EXTERN void Tk_DestroyWindow _ANSI_ARGS_((Tk_Window tkwin)); +EXTERN char * Tk_DisplayName _ANSI_ARGS_((Tk_Window tkwin)); +EXTERN void Tk_Draw3DPolygon _ANSI_ARGS_((Tk_Window tkwin, + Drawable drawable, Tk_3DBorder border, + XPoint *pointPtr, int numPoints, int borderWidth, + int leftRelief)); +EXTERN void Tk_Draw3DRectangle _ANSI_ARGS_((Tk_Window tkwin, + Drawable drawable, Tk_3DBorder border, int x, + int y, int width, int height, int borderWidth, + int relief)); +EXTERN void Tk_DrawFocusHighlight _ANSI_ARGS_((Tk_Window tkwin, + GC gc, int width, Drawable drawable)); +EXTERN void Tk_Fill3DPolygon _ANSI_ARGS_((Tk_Window tkwin, + Drawable drawable, Tk_3DBorder border, + XPoint *pointPtr, int numPoints, int borderWidth, + int leftRelief)); +EXTERN void Tk_Fill3DRectangle _ANSI_ARGS_((Tk_Window tkwin, + Drawable drawable, Tk_3DBorder border, int x, + int y, int width, int height, int borderWidth, + int relief)); +EXTERN Tk_PhotoHandle Tk_FindPhoto _ANSI_ARGS_((char *imageName)); +EXTERN void Tk_Free3DBorder _ANSI_ARGS_((Tk_3DBorder border)); +EXTERN void Tk_FreeBitmap _ANSI_ARGS_((Display *display, + Pixmap bitmap)); +EXTERN void Tk_FreeColor _ANSI_ARGS_((XColor *colorPtr)); +EXTERN void Tk_FreeColormap _ANSI_ARGS_((Display *display, + Colormap colormap)); +EXTERN void Tk_FreeCursor _ANSI_ARGS_((Display *display, + Tk_Cursor cursor)); +EXTERN void Tk_FreeFontStruct _ANSI_ARGS_(( + XFontStruct *fontStructPtr)); +EXTERN void Tk_FreeGC _ANSI_ARGS_((Display *display, GC gc)); +EXTERN void Tk_FreeImage _ANSI_ARGS_((Tk_Image image)); +EXTERN void Tk_FreeOptions _ANSI_ARGS_((Tk_ConfigSpec *specs, + char *widgRec, Display *display, int needFlags)); +EXTERN void Tk_FreePixmap _ANSI_ARGS_((Display *display, + Pixmap pixmap)); +EXTERN void Tk_FreeXId _ANSI_ARGS_((Display *display, XID xid)); +EXTERN GC Tk_GCForColor _ANSI_ARGS_((XColor *colorPtr, + Drawable drawable)); +EXTERN void Tk_GeometryRequest _ANSI_ARGS_((Tk_Window tkwin, + int reqWidth, int reqHeight)); +EXTERN Tk_3DBorder Tk_Get3DBorder _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, Tk_Uid colorName)); +EXTERN void Tk_GetAllBindings _ANSI_ARGS_((Tcl_Interp *interp, + Tk_BindingTable bindingTable, ClientData object)); +EXTERN int Tk_GetAnchor _ANSI_ARGS_((Tcl_Interp *interp, + char *string, Tk_Anchor *anchorPtr)); +EXTERN char * Tk_GetAtomName _ANSI_ARGS_((Tk_Window tkwin, + Atom atom)); +EXTERN char * Tk_GetBinding _ANSI_ARGS_((Tcl_Interp *interp, + Tk_BindingTable bindingTable, ClientData object, + char *eventString)); +EXTERN Pixmap Tk_GetBitmap _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, Tk_Uid string)); +EXTERN Pixmap Tk_GetBitmapFromData _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, char *source, + int width, int height)); +EXTERN int Tk_GetCapStyle _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int *capPtr)); +EXTERN XColor * Tk_GetColor _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, Tk_Uid name)); +EXTERN XColor * Tk_GetColorByValue _ANSI_ARGS_((Tk_Window tkwin, + XColor *colorPtr)); +EXTERN Colormap Tk_GetColormap _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, char *string)); +EXTERN Tk_Cursor Tk_GetCursor _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, Tk_Uid string)); +EXTERN Tk_Cursor Tk_GetCursorFromData _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, char *source, char *mask, + int width, int height, int xHot, int yHot, + Tk_Uid fg, Tk_Uid bg)); +EXTERN XFontStruct * Tk_GetFontStruct _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, Tk_Uid name)); +EXTERN GC Tk_GetGC _ANSI_ARGS_((Tk_Window tkwin, + unsigned long valueMask, XGCValues *valuePtr)); +EXTERN Tk_Image Tk_GetImage _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, char *name, + Tk_ImageChangedProc *changeProc, + ClientData clientData)); +EXTERN Tk_ItemType * Tk_GetItemTypes _ANSI_ARGS_((void)); +EXTERN int Tk_GetJoinStyle _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int *joinPtr)); +EXTERN int Tk_GetJustify _ANSI_ARGS_((Tcl_Interp *interp, + char *string, Tk_Justify *justifyPtr)); +EXTERN int Tk_GetNumMainWindows _ANSI_ARGS_((void)); +EXTERN Tk_Uid Tk_GetOption _ANSI_ARGS_((Tk_Window tkwin, char *name, + char *className)); +EXTERN int Tk_GetPixels _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, char *string, int *intPtr)); +EXTERN Pixmap Tk_GetPixmap _ANSI_ARGS_((Display *display, Drawable d, + int width, int height, int depth)); +EXTERN int Tk_GetRelief _ANSI_ARGS_((Tcl_Interp *interp, + char *name, int *reliefPtr)); +EXTERN void Tk_GetRootCoords _ANSI_ARGS_ ((Tk_Window tkwin, + int *xPtr, int *yPtr)); +EXTERN int Tk_GetScrollInfo _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv, double *dblPtr, + int *intPtr)); +EXTERN int Tk_GetScreenMM _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, char *string, double *doublePtr)); +EXTERN int Tk_GetSelection _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, Atom selection, Atom target, + Tk_GetSelProc *proc, ClientData clientData)); +EXTERN Tk_Uid Tk_GetUid _ANSI_ARGS_((char *string)); +EXTERN Visual * Tk_GetVisual _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, char *string, int *depthPtr, + Colormap *colormapPtr)); +EXTERN void Tk_GetVRootGeometry _ANSI_ARGS_((Tk_Window tkwin, + int *xPtr, int *yPtr, int *widthPtr, + int *heightPtr)); +EXTERN int Tk_Grab _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, int grabGlobal)); +EXTERN void Tk_HandleEvent _ANSI_ARGS_((XEvent *eventPtr)); +EXTERN Tk_Window Tk_IdToWindow _ANSI_ARGS_((Display *display, + Window window)); +EXTERN void Tk_ImageChanged _ANSI_ARGS_(( + Tk_ImageMaster master, int x, int y, + int width, int height, int imageWidth, + int imageHeight)); +EXTERN int Tk_Init _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN Atom Tk_InternAtom _ANSI_ARGS_((Tk_Window tkwin, + char *name)); +EXTERN void Tk_Main _ANSI_ARGS_((int argc, char **argv, + Tcl_AppInitProc *appInitProc)); +EXTERN void Tk_MainLoop _ANSI_ARGS_((void)); +EXTERN void Tk_MaintainGeometry _ANSI_ARGS_((Tk_Window slave, + Tk_Window master, int x, int y, int width, + int height)); +EXTERN Tk_Window Tk_MainWindow _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN void Tk_MakeWindowExist _ANSI_ARGS_((Tk_Window tkwin)); +EXTERN void Tk_ManageGeometry _ANSI_ARGS_((Tk_Window tkwin, + Tk_GeomMgr *mgrPtr, ClientData clientData)); +EXTERN void Tk_MapWindow _ANSI_ARGS_((Tk_Window tkwin)); +EXTERN void Tk_MoveResizeWindow _ANSI_ARGS_((Tk_Window tkwin, + int x, int y, int width, int height)); +EXTERN void Tk_MoveWindow _ANSI_ARGS_((Tk_Window tkwin, int x, + int y)); +EXTERN void Tk_MoveToplevelWindow _ANSI_ARGS_((Tk_Window tkwin, + int x, int y)); +EXTERN char * Tk_NameOf3DBorder _ANSI_ARGS_((Tk_3DBorder border)); +EXTERN char * Tk_NameOfAnchor _ANSI_ARGS_((Tk_Anchor anchor)); +EXTERN char * Tk_NameOfBitmap _ANSI_ARGS_((Display *display, + Pixmap bitmap)); +EXTERN char * Tk_NameOfCapStyle _ANSI_ARGS_((int cap)); +EXTERN char * Tk_NameOfColor _ANSI_ARGS_((XColor *colorPtr)); +EXTERN char * Tk_NameOfCursor _ANSI_ARGS_((Display *display, + Tk_Cursor cursor)); +EXTERN char * Tk_NameOfFontStruct _ANSI_ARGS_(( + XFontStruct *fontStructPtr)); +EXTERN char * Tk_NameOfImage _ANSI_ARGS_(( + Tk_ImageMaster imageMaster)); +EXTERN char * Tk_NameOfJoinStyle _ANSI_ARGS_((int join)); +EXTERN char * Tk_NameOfJustify _ANSI_ARGS_((Tk_Justify justify)); +EXTERN char * Tk_NameOfRelief _ANSI_ARGS_((int relief)); +EXTERN Tk_Window Tk_NameToWindow _ANSI_ARGS_((Tcl_Interp *interp, + char *pathName, Tk_Window tkwin)); +EXTERN void Tk_OwnSelection _ANSI_ARGS_((Tk_Window tkwin, + Atom selection, Tk_LostSelProc *proc, + ClientData clientData)); +EXTERN int Tk_ParseArgv _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, int *argcPtr, char **argv, + Tk_ArgvInfo *argTable, int flags)); +EXTERN void Tk_PhotoPutBlock _ANSI_ARGS_((Tk_PhotoHandle handle, + Tk_PhotoImageBlock *blockPtr, int x, int y, + int width, int height)); +EXTERN void Tk_PhotoPutZoomedBlock _ANSI_ARGS_(( + Tk_PhotoHandle handle, + Tk_PhotoImageBlock *blockPtr, int x, int y, + int width, int height, int zoomX, int zoomY, + int subsampleX, int subsampleY)); +EXTERN int Tk_PhotoGetImage _ANSI_ARGS_((Tk_PhotoHandle handle, + Tk_PhotoImageBlock *blockPtr)); +EXTERN void Tk_PhotoBlank _ANSI_ARGS_((Tk_PhotoHandle handle)); +EXTERN void Tk_PhotoExpand _ANSI_ARGS_((Tk_PhotoHandle handle, + int width, int height )); +EXTERN void Tk_PhotoGetSize _ANSI_ARGS_((Tk_PhotoHandle handle, + int *widthPtr, int *heightPtr)); +EXTERN void Tk_PhotoSetSize _ANSI_ARGS_((Tk_PhotoHandle handle, + int width, int height)); +EXTERN void Tk_PreserveColormap _ANSI_ARGS_((Display *display, + Colormap colormap)); +EXTERN void Tk_QueueWindowEvent _ANSI_ARGS_((XEvent *eventPtr, + Tcl_QueuePosition position)); +EXTERN void Tk_RedrawImage _ANSI_ARGS_((Tk_Image image, int imageX, + int imageY, int width, int height, + Drawable drawable, int drawableX, int drawableY)); +EXTERN void Tk_ResizeWindow _ANSI_ARGS_((Tk_Window tkwin, + int width, int height)); +EXTERN int Tk_RestackWindow _ANSI_ARGS_((Tk_Window tkwin, + int aboveBelow, Tk_Window other)); +EXTERN Tk_RestrictProc *Tk_RestrictEvents _ANSI_ARGS_((Tk_RestrictProc *proc, + ClientData arg, ClientData *prevArgPtr)); +EXTERN char * Tk_SetAppName _ANSI_ARGS_((Tk_Window tkwin, + char *name)); +EXTERN void Tk_SetBackgroundFromBorder _ANSI_ARGS_(( + Tk_Window tkwin, Tk_3DBorder border)); +EXTERN void Tk_SetClass _ANSI_ARGS_((Tk_Window tkwin, + char *className)); +EXTERN void Tk_SetGrid _ANSI_ARGS_((Tk_Window tkwin, + int reqWidth, int reqHeight, int gridWidth, + int gridHeight)); +EXTERN void Tk_SetInternalBorder _ANSI_ARGS_((Tk_Window tkwin, + int width)); +EXTERN void Tk_SetWindowBackground _ANSI_ARGS_((Tk_Window tkwin, + unsigned long pixel)); +EXTERN void Tk_SetWindowBackgroundPixmap _ANSI_ARGS_(( + Tk_Window tkwin, Pixmap pixmap)); +EXTERN void Tk_SetWindowBorder _ANSI_ARGS_((Tk_Window tkwin, + unsigned long pixel)); +EXTERN void Tk_SetWindowBorderWidth _ANSI_ARGS_((Tk_Window tkwin, + int width)); +EXTERN void Tk_SetWindowBorderPixmap _ANSI_ARGS_((Tk_Window tkwin, + Pixmap pixmap)); +EXTERN void Tk_SetWindowColormap _ANSI_ARGS_((Tk_Window tkwin, + Colormap colormap)); +EXTERN int Tk_SetWindowVisual _ANSI_ARGS_((Tk_Window tkwin, + Visual *visual, int depth, + Colormap colormap)); +EXTERN void Tk_SizeOfBitmap _ANSI_ARGS_((Display *display, + Pixmap bitmap, int *widthPtr, + int *heightPtr)); +EXTERN void Tk_SizeOfImage _ANSI_ARGS_((Tk_Image image, + int *widthPtr, int *heightPtr)); +EXTERN int Tk_StrictMotif _ANSI_ARGS_((Tk_Window tkwin)); +EXTERN void Tk_UndefineCursor _ANSI_ARGS_((Tk_Window window)); +EXTERN void Tk_Ungrab _ANSI_ARGS_((Tk_Window tkwin)); +EXTERN void Tk_UnmaintainGeometry _ANSI_ARGS_((Tk_Window slave, + Tk_Window master)); +EXTERN void Tk_UnmapWindow _ANSI_ARGS_((Tk_Window tkwin)); +EXTERN void Tk_UnsetGrid _ANSI_ARGS_((Tk_Window tkwin)); + +/* + * Tcl commands exported by Tk: + */ + +EXTERN int Tk_AfterCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_BellCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_BindCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_BindtagsCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_ButtonCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_CanvasCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_CheckbuttonCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_ClipboardCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_ChooseColorCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_ChooseFontCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_DestroyCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_EntryCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_EventCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_FileeventCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_FrameCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_FocusCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_GetOpenFileCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_GetSaveFileCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_GrabCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_GridCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_ImageCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_LabelCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_ListboxCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_LowerCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_MenuCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_MenubuttonCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_MessageBoxCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_MessageCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_OptionCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_PackCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_PlaceCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_RadiobuttonCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_RaiseCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_ScaleCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_ScrollbarCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_SelectionCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_SendCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_TextCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_TkCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_TkwaitCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_ToplevelCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_UpdateCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_WinfoCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_WmCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +#endif /* RESOURCE_INCLUDED */ +#endif /* _TK */ diff --git a/tk3.6/tk3d.c b/tk4.2/generic/tk3d.c similarity index 59% rename from tk3.6/tk3d.c rename to tk4.2/generic/tk3d.c index 00a85c4..5eae8a4 100644 --- a/tk3.6/tk3d.c +++ b/tk4.2/generic/tk3d.c @@ -4,33 +4,17 @@ * This module provides procedures to draw borders in * the three-dimensional Motif style. * - * Copyright (c) 1990-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tk3d.c 1.53 96/06/27 08:15:35 */ -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tk3d.c,v 1.36 93/06/16 17:15:59 ouster Exp $ SPRITE (Berkeley)"; -#endif - -#include "tkConfig.h" -#include "tk.h" +#include "tkPort.h" +#include "tkInt.h" /* * One of the following data structures is allocated for @@ -40,28 +24,37 @@ static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tk3d.c,v 1.36 93/06/16 17 */ typedef struct { - Display *display; /* Display for which the resources - * below are allocated. */ + Screen *screen; /* Screen on which the border will be used. */ + Visual *visual; /* Visual for all windows and pixmaps using + * the border. */ + int depth; /* Number of bits per pixel of drawables where + * the border will be used. */ + Colormap colormap; /* Colormap out of which pixels are + * allocated. */ int refCount; /* Number of different users of * this border. */ XColor *bgColorPtr; /* Background color (intensity * between lightColorPtr and * darkColorPtr). */ - XColor *lightColorPtr; /* Color used for lighter areas of - * border (must free this when - * deleting structure). */ - XColor *darkColorPtr; /* Color for darker areas (must - * free when deleting structure). */ + XColor *darkColorPtr; /* Color for darker areas (must free when + * deleting structure). NULL means shadows + * haven't been allocated yet.*/ + XColor *lightColorPtr; /* Color used for lighter areas of border + * (must free this when deleting structure). + * NULL means shadows haven't been allocated + * yet. */ Pixmap shadow; /* Stipple pattern to use for drawing - * lighter-shadow-ed areas. Only used on - * monochrome displays; on color displays - * this is None. */ - GC lightGC; /* Used to draw lighter parts of - * the border. */ - GC darkGC; /* Used to draw darker parts of the - * border. */ + * shadows areas. Used for displays with + * <= 64 colors or where colormap has filled + * up. */ GC bgGC; /* Used (if necessary) to draw areas in * the background color. */ + GC darkGC; /* Used to draw darker parts of the + * border. None means the shadow colors + * haven't been allocated yet.*/ + GC lightGC; /* Used to draw lighter parts of + * the border. None means the shadow colors + * haven't been allocated yet. */ Tcl_HashEntry *hashPtr; /* Entry in borderTable (needed in * order to delete structure). */ } Border; @@ -94,6 +87,8 @@ static int initialized = 0; /* 0 means static structures haven't */ static void BorderInit _ANSI_ARGS_((void)); +static void GetShadows _ANSI_ARGS_((Border *borderPtr, + Tk_Window tkwin)); static int Intersect _ANSI_ARGS_((XPoint *a1Ptr, XPoint *a2Ptr, XPoint *b1Ptr, XPoint *b2Ptr, XPoint *iPtr)); static void ShiftLine _ANSI_ARGS_((XPoint *p1Ptr, XPoint *p2Ptr, @@ -123,13 +118,10 @@ static void ShiftLine _ANSI_ARGS_((XPoint *p1Ptr, XPoint *p2Ptr, */ Tk_3DBorder -Tk_Get3DBorder(interp, tkwin, colormap, colorName) +Tk_Get3DBorder(interp, tkwin, colorName) Tcl_Interp *interp; /* Place to store an error message. */ - Tk_Window tkwin; /* Token for window in which - * border will be drawn. */ - Colormap colormap; /* Colormap to use for allocating border - * colors. None means use current colormap - * for tkwin. */ + Tk_Window tkwin; /* Token for window in which border will + * be drawn. */ Tk_Uid colorName; /* String giving name of color * for window background. */ { @@ -137,9 +129,7 @@ Tk_Get3DBorder(interp, tkwin, colormap, colorName) Tcl_HashEntry *hashPtr; register Border *borderPtr; int new; - unsigned long light, dark; XGCValues gcValues; - unsigned long mask; if (!initialized) { BorderInit(); @@ -151,10 +141,7 @@ Tk_Get3DBorder(interp, tkwin, colormap, colorName) */ key.colorName = colorName; - if (colormap == None) { - colormap = Tk_Colormap(tkwin); - } - key.colormap = colormap; + key.colormap = Tk_Colormap(tkwin); key.screen = Tk_Screen(tkwin); hashPtr = Tcl_CreateHashEntry(&borderTable, (char *) &key, &new); @@ -168,99 +155,31 @@ Tk_Get3DBorder(interp, tkwin, colormap, colorName) */ borderPtr = (Border *) ckalloc(sizeof(Border)); - borderPtr->display = Tk_Display(tkwin); + borderPtr->screen = Tk_Screen(tkwin); + borderPtr->visual = Tk_Visual(tkwin); + borderPtr->depth = Tk_Depth(tkwin); + borderPtr->colormap = key.colormap; borderPtr->refCount = 1; borderPtr->bgColorPtr = NULL; - borderPtr->lightColorPtr = NULL; borderPtr->darkColorPtr = NULL; + borderPtr->lightColorPtr = NULL; borderPtr->shadow = None; - borderPtr->lightGC = None; - borderPtr->darkGC = None; borderPtr->bgGC = None; + borderPtr->darkGC = None; + borderPtr->lightGC = None; borderPtr->hashPtr = hashPtr; Tcl_SetHashValue(hashPtr, borderPtr); /* - * Figure out what colors and GC's to use for the light - * and dark areas and set up the graphics contexts. - * Monochrome displays get handled differently than - * color displays. + * Create the information for displaying the background color, + * but delay the allocation of shadows until they are actually + * needed for drawing. */ - borderPtr->bgColorPtr = Tk_GetColor(interp, tkwin, - key.colormap, colorName); + borderPtr->bgColorPtr = Tk_GetColor(interp, tkwin, colorName); if (borderPtr->bgColorPtr == NULL) { goto error; } - if (Tk_GetColorModel(tkwin) == TK_COLOR) { - XColor lightColor, darkColor; - int tmp; - - /* - * Color display. Compute the colors for the illuminated - * and shaded portions of the border. - */ - - tmp = (14 * (int) borderPtr->bgColorPtr->red)/10; - if (tmp > MAX_INTENSITY) { - tmp = MAX_INTENSITY; - } - lightColor.red = tmp; - tmp = (14 * (int) borderPtr->bgColorPtr->green)/10; - if (tmp > MAX_INTENSITY) { - tmp = MAX_INTENSITY; - } - lightColor.green = tmp; - tmp = (14 * (int) borderPtr->bgColorPtr->blue)/10; - if (tmp > MAX_INTENSITY) { - tmp = MAX_INTENSITY; - } - lightColor.blue = tmp; - darkColor.red = (60 * (int) borderPtr->bgColorPtr->red)/100; - darkColor.green = (60 * (int) borderPtr->bgColorPtr->green)/100; - darkColor.blue = (60 * (int) borderPtr->bgColorPtr->blue)/100; - borderPtr->lightColorPtr = Tk_GetColorByValue(interp, tkwin, - key.colormap, &lightColor); - if (borderPtr->lightColorPtr == NULL) { - goto error; - } - borderPtr->darkColorPtr = Tk_GetColorByValue(interp, tkwin, - key.colormap, &darkColor); - if (borderPtr->darkColorPtr == NULL) { - goto error; - } - light = borderPtr->lightColorPtr->pixel; - dark = borderPtr->darkColorPtr->pixel; - } else { - /* - * Monochrome display. - */ - - light = borderPtr->bgColorPtr->pixel; - if (light == WhitePixelOfScreen(Tk_Screen(tkwin))) { - dark = BlackPixelOfScreen(Tk_Screen(tkwin)); - } else { - dark = WhitePixelOfScreen(Tk_Screen(tkwin)); - } - borderPtr->shadow = Tk_GetBitmap(interp, tkwin, - Tk_GetUid("gray50")); - if (borderPtr->shadow == None) { - goto error; - } - } - gcValues.foreground = light; - gcValues.background = dark; - mask = GCForeground|GCBackground; - if (borderPtr->shadow != None) { - gcValues.stipple = borderPtr->shadow; - gcValues.fill_style = FillOpaqueStippled; - mask |= GCStipple|GCFillStyle; - } - borderPtr->lightGC = Tk_GetGC(tkwin, mask, &gcValues); - gcValues.foreground = dark; - gcValues.background = light; - borderPtr->darkGC = Tk_GetGC(tkwin, GCForeground|GCBackground, - &gcValues); gcValues.foreground = borderPtr->bgColorPtr->pixel; borderPtr->bgGC = Tk_GetGC(tkwin, GCForeground, &gcValues); } @@ -271,6 +190,210 @@ Tk_Get3DBorder(interp, tkwin, colormap, colorName) return NULL; } +/* + *-------------------------------------------------------------- + * + * Tk_3DVerticalBevel -- + * + * This procedure draws a vertical bevel along one side of + * an object. The bevel is always rectangular in shape: + * ||| + * ||| + * ||| + * ||| + * ||| + * ||| + * An appropriate shadow color is chosen for the bevel based + * on the leftBevel and relief arguments. Normally this + * procedure is called first, then Tk_3DHorizontalBevel is + * called next to draw neat corners. + * + * Results: + * None. + * + * Side effects: + * Graphics are drawn in drawable. + * + *-------------------------------------------------------------- + */ + +void +Tk_3DVerticalBevel(tkwin, drawable, border, x, y, width, height, + leftBevel, relief) + Tk_Window tkwin; /* Window for which border was allocated. */ + Drawable drawable; /* X window or pixmap in which to draw. */ + Tk_3DBorder border; /* Token for border to draw. */ + int x, y, width, height; /* Area of vertical bevel. */ + int leftBevel; /* Non-zero means this bevel forms the + * left side of the object; 0 means it + * forms the right side. */ + int relief; /* Kind of bevel to draw. For example, + * TK_RELIEF_RAISED means interior of + * object should appear higher than + * exterior. */ +{ + Border *borderPtr = (Border *) border; + GC left, right; + Display *display = Tk_Display(tkwin); + + if ((borderPtr->lightGC == None) && (relief != TK_RELIEF_FLAT)) { + GetShadows(borderPtr, tkwin); + } + if (relief == TK_RELIEF_RAISED) { + XFillRectangle(display, drawable, + (leftBevel) ? borderPtr->lightGC : borderPtr->darkGC, + x, y, (unsigned) width, (unsigned) height); + } else if (relief == TK_RELIEF_SUNKEN) { + XFillRectangle(display, drawable, + (leftBevel) ? borderPtr->darkGC : borderPtr->lightGC, + x, y, (unsigned) width, (unsigned) height); + } else if (relief == TK_RELIEF_RIDGE) { + int half; + + left = borderPtr->lightGC; + right = borderPtr->darkGC; + ridgeGroove: + half = width/2; + if (!leftBevel && (width & 1)) { + half++; + } + XFillRectangle(display, drawable, left, x, y, (unsigned) half, + (unsigned) height); + XFillRectangle(display, drawable, right, x+half, y, + (unsigned) (width-half), (unsigned) height); + } else if (relief == TK_RELIEF_GROOVE) { + left = borderPtr->darkGC; + right = borderPtr->lightGC; + goto ridgeGroove; + } else if (relief == TK_RELIEF_FLAT) { + XFillRectangle(display, drawable, borderPtr->bgGC, x, y, + (unsigned) width, (unsigned) height); + } +} + +/* + *-------------------------------------------------------------- + * + * Tk_3DHorizontalBevel -- + * + * This procedure draws a horizontal bevel along one side of + * an object. The bevel has mitered corners (depending on + * leftIn and rightIn arguments). + * + * Results: + * None. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +void +Tk_3DHorizontalBevel(tkwin, drawable, border, x, y, width, height, + leftIn, rightIn, topBevel, relief) + Tk_Window tkwin; /* Window for which border was allocated. */ + Drawable drawable; /* X window or pixmap in which to draw. */ + Tk_3DBorder border; /* Token for border to draw. */ + int x, y, width, height; /* Bounding box of area of bevel. Height + * gives width of border. */ + int leftIn, rightIn; /* Describes whether the left and right + * edges of the bevel angle in or out as + * they go down. For example, if "leftIn" + * is true, the left side of the bevel + * looks like this: + * ___________ + * __________ + * _________ + * ________ + */ + int topBevel; /* Non-zero means this bevel forms the + * top side of the object; 0 means it + * forms the bottom side. */ + int relief; /* Kind of bevel to draw. For example, + * TK_RELIEF_RAISED means interior of + * object should appear higher than + * exterior. */ +{ + Border *borderPtr = (Border *) border; + Display *display = Tk_Display(tkwin); + int bottom, halfway, x1, x2, x1Delta, x2Delta; + GC topGC = None, bottomGC = None; + /* Initializations needed only to prevent + * compiler warnings. */ + + if ((borderPtr->lightGC == None) && (relief != TK_RELIEF_FLAT)) { + GetShadows(borderPtr, tkwin); + } + + /* + * Compute a GC for the top half of the bevel and a GC for the + * bottom half (they're the same in many cases). + */ + + switch (relief) { + case TK_RELIEF_RAISED: + topGC = bottomGC = + (topBevel) ? borderPtr->lightGC : borderPtr->darkGC; + break; + case TK_RELIEF_SUNKEN: + topGC = bottomGC = + (topBevel) ? borderPtr->darkGC : borderPtr->lightGC; + break; + case TK_RELIEF_RIDGE: + topGC = borderPtr->lightGC; + bottomGC = borderPtr->darkGC; + break; + case TK_RELIEF_GROOVE: + topGC = borderPtr->darkGC; + bottomGC = borderPtr->lightGC; + break; + case TK_RELIEF_FLAT: + topGC = bottomGC = borderPtr->bgGC; + break; + } + + /* + * Compute various other geometry-related stuff. + */ + + x1 = x; + if (!leftIn) { + x1 += height; + } + x2 = x+width; + if (!rightIn) { + x2 -= height; + } + x1Delta = (leftIn) ? 1 : -1; + x2Delta = (rightIn) ? -1 : 1; + halfway = y + height/2; + if (!topBevel && (height & 1)) { + halfway++; + } + bottom = y + height; + + /* + * Draw one line for each y-coordinate covered by the bevel. + */ + + for ( ; y < bottom; y++) { + /* + * In some weird cases (such as large border widths for skinny + * rectangles) x1 can be >= x2. Don't draw the lines + * in these cases. + */ + + if (x1 < x2) { + XFillRectangle(display, drawable, + (y < halfway) ? topGC : bottomGC, x1, y, + (unsigned) (x2-x1), (unsigned) 1); + } + x1 += x1Delta; + x2 += x2Delta; + } +} + /* *-------------------------------------------------------------- * @@ -291,9 +414,9 @@ Tk_Get3DBorder(interp, tkwin, colormap, colorName) */ void -Tk_Draw3DRectangle(display, drawable, border, x, y, width, height, +Tk_Draw3DRectangle(tkwin, drawable, border, x, y, width, height, borderWidth, relief) - Display *display; /* X display in which to draw. */ + Tk_Window tkwin; /* Window for which border was allocated. */ Drawable drawable; /* X window or pixmap in which to draw. */ Tk_3DBorder border; /* Token for border to draw. */ int x, y, width, height; /* Outside area of region in @@ -303,58 +426,20 @@ Tk_Draw3DRectangle(display, drawable, border, x, y, width, height, int relief; /* Type of relief: TK_RELIEF_RAISED, * TK_RELIEF_SUNKEN, TK_RELIEF_GROOVE, etc. */ { - register Border *borderPtr = (Border *) border; - GC top, bottom; - XPoint points[7]; - - if ((width < 2*borderWidth) || (height < 2*borderWidth)) { - return; + if (width < 2*borderWidth) { + borderWidth = width/2; } - - /* - * Handle grooves and ridges with recursive calls. - */ - - if ((relief == TK_RELIEF_GROOVE) || (relief == TK_RELIEF_RIDGE)) { - int halfWidth, insideOffset; - - halfWidth = borderWidth/2; - insideOffset = borderWidth - halfWidth; - Tk_Draw3DRectangle(display, drawable, border, x, y, width, height, - halfWidth, (relief == TK_RELIEF_GROOVE) ? TK_RELIEF_SUNKEN - : TK_RELIEF_RAISED); - Tk_Draw3DRectangle(display, drawable, border, x + insideOffset, - y + insideOffset, width - insideOffset*2, - height - insideOffset*2, halfWidth, - (relief == TK_RELIEF_GROOVE) ? TK_RELIEF_RAISED - : TK_RELIEF_SUNKEN); - return; + if (height < 2*borderWidth) { + borderWidth = height/2; } - - if (relief == TK_RELIEF_RAISED) { - top = borderPtr->lightGC; - bottom = borderPtr->darkGC; - } else if (relief == TK_RELIEF_SUNKEN) { - top = borderPtr->darkGC; - bottom = borderPtr->lightGC; - } else { - top = bottom = borderPtr->bgGC; - } - XFillRectangle(display, drawable, bottom, x, y+height-borderWidth, - - (unsigned int) width, (unsigned int) borderWidth); - XFillRectangle(display, drawable, bottom, x+width-borderWidth, y, - (unsigned int) borderWidth, (unsigned int) height); - points[0].x = points[1].x = points[6].x = x; - points[0].y = points[6].y = y + height; - points[1].y = points[2].y = y; - points[2].x = x + width; - points[3].x = x + width - borderWidth; - points[3].y = points[4].y = y + borderWidth; - points[4].x = points[5].x = x + borderWidth; - points[5].y = y + height - borderWidth; - XFillPolygon(display, drawable, top, points, 7, Nonconvex, - CoordModeOrigin); + Tk_3DVerticalBevel(tkwin, drawable, border, x, y, borderWidth, height, + 1, relief); + Tk_3DVerticalBevel(tkwin, drawable, border, x+width-borderWidth, y, + borderWidth, height, 0, relief); + Tk_3DHorizontalBevel(tkwin, drawable, border, x, y, width, borderWidth, + 1, 1, 1, relief); + Tk_3DHorizontalBevel(tkwin, drawable, border, x, y+height-borderWidth, + width, borderWidth, 0, 0, 0, relief); } /* @@ -402,11 +487,57 @@ Tk_NameOf3DBorder(border) */ XColor * Tk_3DBorderColor(border) - Tk_3DBorder border; + Tk_3DBorder border; /* Border whose color is wanted. */ { return(((Border *) border)->bgColorPtr); } +/* + *-------------------------------------------------------------------- + * + * Tk_3DBorderGC -- + * + * Given a 3D border, returns one of the graphics contexts used to + * draw the border. + * + * Results: + * Returns the graphics context given by the "which" argument. + * + * Side effects: + * None. + * + *-------------------------------------------------------------------- + */ +GC +Tk_3DBorderGC(tkwin, border, which) + Tk_Window tkwin; /* Window for which border was allocated. */ + Tk_3DBorder border; /* Border whose GC is wanted. */ + int which; /* Selects one of the border's 3 GC's: + * TK_3D_FLAT_GC, TK_3D_LIGHT_GC, or + * TK_3D_DARK_GC. */ +{ + Border * borderPtr = (Border *) border; + + if ((borderPtr->lightGC == None) && (which != TK_3D_FLAT_GC)) { + GetShadows(borderPtr, tkwin); + } + if (which == TK_3D_FLAT_GC) { + return borderPtr->bgGC; + } else if (which == TK_3D_LIGHT_GC) { + return borderPtr->lightGC; + } else if (which == TK_3D_DARK_GC){ + return borderPtr->darkGC; + } + panic("bogus \"which\" value in Tk_3DBorderGC"); + + /* + * The code below will never be executed, but it's needed to + * keep compilers happy. + */ + + return (GC) None; +} + /* *-------------------------------------------------------------- * @@ -431,29 +562,30 @@ Tk_Free3DBorder(border) Tk_3DBorder border; /* Token for border to be released. */ { register Border *borderPtr = (Border *) border; + Display *display = DisplayOfScreen(borderPtr->screen); borderPtr->refCount--; if (borderPtr->refCount == 0) { if (borderPtr->bgColorPtr != NULL) { Tk_FreeColor(borderPtr->bgColorPtr); } - if (borderPtr->lightColorPtr != NULL) { - Tk_FreeColor(borderPtr->lightColorPtr); - } if (borderPtr->darkColorPtr != NULL) { Tk_FreeColor(borderPtr->darkColorPtr); } + if (borderPtr->lightColorPtr != NULL) { + Tk_FreeColor(borderPtr->lightColorPtr); + } if (borderPtr->shadow != None) { - Tk_FreeBitmap(borderPtr->display, borderPtr->shadow); - } - if (borderPtr->lightGC != None) { - Tk_FreeGC(borderPtr->display, borderPtr->lightGC); - } - if (borderPtr->darkGC != None) { - Tk_FreeGC(borderPtr->display, borderPtr->darkGC); + Tk_FreeBitmap(display, borderPtr->shadow); } if (borderPtr->bgGC != None) { - Tk_FreeGC(borderPtr->display, borderPtr->bgGC); + Tk_FreeGC(display, borderPtr->bgGC); + } + if (borderPtr->darkGC != None) { + Tk_FreeGC(display, borderPtr->darkGC); + } + if (borderPtr->lightGC != None) { + Tk_FreeGC(display, borderPtr->lightGC); } Tcl_DeleteHashEntry(borderPtr->hashPtr); ckfree((char *) borderPtr); @@ -513,7 +645,7 @@ Tk_GetRelief(interp, name, reliefPtr) int *reliefPtr; /* Where to store converted relief. */ { char c; - int length; + size_t length; c = name[0]; length = strlen(name); @@ -530,7 +662,7 @@ Tk_GetRelief(interp, name, reliefPtr) } else if ((c == 's') && (strncmp(name, "sunken", length) == 0)) { *reliefPtr = TK_RELIEF_SUNKEN; } else { - sprintf(interp->result, "bad relief type \"%.50s\": must be %s", + sprintf(interp->result, "bad relief type \"%.50s\": must be %s", name, "flat, groove, raised, ridge, or sunken"); return TCL_ERROR; } @@ -597,9 +729,9 @@ Tk_NameOfRelief(relief) */ void -Tk_Draw3DPolygon(display, drawable, border, pointPtr, numPoints, +Tk_Draw3DPolygon(tkwin, drawable, border, pointPtr, numPoints, borderWidth, leftRelief) - Display *display; /* X display in which to draw polygon. */ + Tk_Window tkwin; /* Window for which border was allocated. */ Drawable drawable; /* X window or pixmap in which to draw. */ Tk_3DBorder border; /* Token for border to draw. */ XPoint *pointPtr; /* Array of points describing @@ -620,6 +752,11 @@ Tk_Draw3DPolygon(display, drawable, border, pointPtr, numPoints, Border *borderPtr = (Border *) border; GC gc; int i, lightOnLeft, dx, dy, parallel, pointsSeen; + Display *display = Tk_Display(tkwin); + + if (borderPtr->lightGC == None) { + GetShadows(borderPtr, tkwin); + } /* * Handle grooves and ridges with recursive calls. @@ -629,10 +766,10 @@ Tk_Draw3DPolygon(display, drawable, border, pointPtr, numPoints, int halfWidth; halfWidth = borderWidth/2; - Tk_Draw3DPolygon(display, drawable, border, pointPtr, numPoints, + Tk_Draw3DPolygon(tkwin, drawable, border, pointPtr, numPoints, halfWidth, (leftRelief == TK_RELIEF_GROOVE) ? TK_RELIEF_RAISED : TK_RELIEF_SUNKEN); - Tk_Draw3DPolygon(display, drawable, border, pointPtr, numPoints, + Tk_Draw3DPolygon(tkwin, drawable, border, pointPtr, numPoints, -halfWidth, (leftRelief == TK_RELIEF_GROOVE) ? TK_RELIEF_SUNKEN : TK_RELIEF_RAISED); return; @@ -800,9 +937,9 @@ Tk_Draw3DPolygon(display, drawable, border, pointPtr, numPoints, */ void -Tk_Fill3DRectangle(display, drawable, border, x, y, width, +Tk_Fill3DRectangle(tkwin, drawable, border, x, y, width, height, borderWidth, relief) - Display *display; /* X display in which to draw rectangle. */ + Tk_Window tkwin; /* Window for which border was allocated. */ Drawable drawable; /* X window or pixmap in which to draw. */ Tk_3DBorder border; /* Token for border to draw. */ int x, y, width, height; /* Outside area of rectangular region. */ @@ -813,10 +950,10 @@ Tk_Fill3DRectangle(display, drawable, border, x, y, width, { register Border *borderPtr = (Border *) border; - XFillRectangle(display, drawable, borderPtr->bgGC, + XFillRectangle(Tk_Display(tkwin), drawable, borderPtr->bgGC, x, y, (unsigned int) width, (unsigned int) height); if (relief != TK_RELIEF_FLAT) { - Tk_Draw3DRectangle(display, drawable, border, x, y, width, + Tk_Draw3DRectangle(tkwin, drawable, border, x, y, width, height, borderWidth, relief); } } @@ -838,9 +975,9 @@ Tk_Fill3DRectangle(display, drawable, border, x, y, width, */ void -Tk_Fill3DPolygon(display, drawable, border, pointPtr, numPoints, +Tk_Fill3DPolygon(tkwin, drawable, border, pointPtr, numPoints, borderWidth, leftRelief) - Display *display; /* X display in which to draw polygon. */ + Tk_Window tkwin; /* Window for which border was allocated. */ Drawable drawable; /* X window or pixmap in which to draw. */ Tk_3DBorder border; /* Token for border to draw. */ XPoint *pointPtr; /* Array of points describing @@ -857,10 +994,10 @@ Tk_Fill3DPolygon(display, drawable, border, pointPtr, numPoints, { register Border *borderPtr = (Border *) border; - XFillPolygon(display, drawable, borderPtr->bgGC, + XFillPolygon(Tk_Display(tkwin), drawable, borderPtr->bgGC, pointPtr, numPoints, Complex, CoordModeOrigin); if (leftRelief != TK_RELIEF_FLAT) { - Tk_Draw3DPolygon(display, drawable, border, pointPtr, numPoints, + Tk_Draw3DPolygon(tkwin, drawable, border, pointPtr, numPoints, borderWidth, leftRelief); } } @@ -1047,3 +1184,145 @@ Intersect(a1Ptr, a2Ptr, b1Ptr, b2Ptr, iPtr) } return 0; } + +/* + *---------------------------------------------------------------------- + * + * GetShadows -- + * + * This procedure computes the shadow colors for a 3-D border + * and fills in the corresponding fields of the Border structure. + * It's called lazily, so that the colors aren't allocated until + * something is actually drawn with them. That way, if a border + * is only used for flat backgrounds the shadow colors will + * never be allocated. + * + * Results: + * None. + * + * Side effects: + * The lightGC and darkGC fields in borderPtr get filled in, + * if they weren't already. + * + *---------------------------------------------------------------------- + */ + +static void +GetShadows(borderPtr, tkwin) + Border *borderPtr; /* Information about border. */ + Tk_Window tkwin; /* Window where border will be used for + * drawing. */ +{ + XColor lightColor, darkColor; + int stressed, tmp1, tmp2; + XGCValues gcValues; + + if (borderPtr->lightGC != None) { + return; + } + stressed = TkCmapStressed(tkwin, borderPtr->colormap); + + /* + * First, handle the case of a color display with lots of colors. + * The shadow colors get computed using whichever formula results + * in the greatest change in color: + * 1. Lighter shadow is half-way to white, darker shadow is half + * way to dark. + * 2. Lighter shadow is 40% brighter than background, darker shadow + * is 40% darker than background. + */ + + if (!stressed && (Tk_Depth(tkwin) >= 6)) { + /* + * This is a color display with lots of colors. For the dark + * shadow, cut 40% from each of the background color components. + * For the light shadow, boost each component by 40% or half-way + * to white, whichever is greater (the first approach works + * better for unsaturated colors, the second for saturated ones). + */ + + darkColor.red = (60 * (int) borderPtr->bgColorPtr->red)/100; + darkColor.green = (60 * (int) borderPtr->bgColorPtr->green)/100; + darkColor.blue = (60 * (int) borderPtr->bgColorPtr->blue)/100; + borderPtr->darkColorPtr = Tk_GetColorByValue(tkwin, &darkColor); + gcValues.foreground = borderPtr->darkColorPtr->pixel; + borderPtr->darkGC = Tk_GetGC(tkwin, GCForeground, &gcValues); + + /* + * Compute the colors using integers, not using lightColor.red + * etc.: these are shorts and may have problems with integer + * overflow. + */ + + tmp1 = (14 * (int) borderPtr->bgColorPtr->red)/10; + if (tmp1 > MAX_INTENSITY) { + tmp1 = MAX_INTENSITY; + } + tmp2 = (MAX_INTENSITY + (int) borderPtr->bgColorPtr->red)/2; + lightColor.red = (tmp1 > tmp2) ? tmp1 : tmp2; + tmp1 = (14 * (int) borderPtr->bgColorPtr->green)/10; + if (tmp1 > MAX_INTENSITY) { + tmp1 = MAX_INTENSITY; + } + tmp2 = (MAX_INTENSITY + (int) borderPtr->bgColorPtr->green)/2; + lightColor.green = (tmp1 > tmp2) ? tmp1 : tmp2; + tmp1 = (14 * (int) borderPtr->bgColorPtr->blue)/10; + if (tmp1 > MAX_INTENSITY) { + tmp1 = MAX_INTENSITY; + } + tmp2 = (MAX_INTENSITY + (int) borderPtr->bgColorPtr->blue)/2; + lightColor.blue = (tmp1 > tmp2) ? tmp1 : tmp2; + borderPtr->lightColorPtr = Tk_GetColorByValue(tkwin, &lightColor); + gcValues.foreground = borderPtr->lightColorPtr->pixel; + borderPtr->lightGC = Tk_GetGC(tkwin, GCForeground, &gcValues); + return; + } + + if (borderPtr->shadow == None) { + borderPtr->shadow = Tk_GetBitmap((Tcl_Interp *) NULL, tkwin, + Tk_GetUid("gray50")); + if (borderPtr->shadow == None) { + panic("GetShadows couldn't allocate bitmap for border"); + } + } + if (borderPtr->visual->map_entries > 2) { + /* + * This isn't a monochrome display, but the colormap either + * ran out of entries or didn't have very many to begin with. + * Generate the light shadows with a white stipple and the + * dark shadows with a black stipple. + */ + + gcValues.foreground = borderPtr->bgColorPtr->pixel; + gcValues.background = BlackPixelOfScreen(borderPtr->screen); + gcValues.stipple = borderPtr->shadow; + gcValues.fill_style = FillOpaqueStippled; + borderPtr->darkGC = Tk_GetGC(tkwin, + GCForeground|GCBackground|GCStipple|GCFillStyle, &gcValues); + gcValues.background = WhitePixelOfScreen(borderPtr->screen); + borderPtr->lightGC = Tk_GetGC(tkwin, + GCForeground|GCBackground|GCStipple|GCFillStyle, &gcValues); + return; + } + + /* + * This is just a measly monochrome display, hardly even worth its + * existence on this earth. Make one shadow a 50% stipple and the + * other the opposite of the background. + */ + + gcValues.foreground = WhitePixelOfScreen(borderPtr->screen); + gcValues.background = BlackPixelOfScreen(borderPtr->screen); + gcValues.stipple = borderPtr->shadow; + gcValues.fill_style = FillOpaqueStippled; + borderPtr->lightGC = Tk_GetGC(tkwin, + GCForeground|GCBackground|GCStipple|GCFillStyle, &gcValues); + if (borderPtr->bgColorPtr->pixel + == WhitePixelOfScreen(borderPtr->screen)) { + gcValues.foreground = BlackPixelOfScreen(borderPtr->screen); + borderPtr->darkGC = Tk_GetGC(tkwin, GCForeground, &gcValues); + } else { + borderPtr->darkGC = borderPtr->lightGC; + borderPtr->lightGC = Tk_GetGC(tkwin, GCForeground, &gcValues); + } +} diff --git a/tk3.6/tkArgv.c b/tk4.2/generic/tkArgv.c similarity index 89% rename from tk3.6/tkArgv.c rename to tk4.2/generic/tkArgv.c index 87680fa..42aa9f0 100644 --- a/tk3.6/tkArgv.c +++ b/tk4.2/generic/tkArgv.c @@ -4,32 +4,16 @@ * This file contains a procedure that handles table-based * argv-argc parsing. * - * Copyright (c) 1990-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tkArgv.c 1.20 96/02/15 18:51:32 */ -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkArgv.c,v 1.15 93/06/16 17:16:19 ouster Exp $ SPRITE (Berkeley)"; -#endif - -#include "tkConfig.h" +#include "tkPort.h" #include "tk.h" /* @@ -104,7 +88,7 @@ Tk_ParseArgv(interp, tkwin, argcPtr, argv, argTable, flags) * argument should be copied (never greater * than srcIndex). */ int argc; /* # arguments in argv still to process. */ - int length; /* Number of characters in current argument. */ + size_t length; /* Number of characters in current argument. */ int i; if (flags & TK_ARGV_DONT_SKIP_FIRST_ARG) { @@ -119,8 +103,12 @@ Tk_ParseArgv(interp, tkwin, argcPtr, argv, argTable, flags) curArg = argv[srcIndex]; srcIndex++; argc--; - c = curArg[1]; length = strlen(curArg); + if (length > 0) { + c = curArg[1]; + } else { + c = 0; + } /* * Loop throught the argument descriptors searching for one with diff --git a/tk3.6/tkAtom.c b/tk4.2/generic/tkAtom.c similarity index 65% rename from tk3.6/tkAtom.c rename to tk4.2/generic/tkAtom.c index 8f3695c..9d35f6b 100644 --- a/tk3.6/tkAtom.c +++ b/tk4.2/generic/tkAtom.c @@ -7,34 +7,50 @@ * doesn't have to provide permanent storage for atom names, * for example). * - * Copyright (c) 1990-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tkAtom.c 1.13 96/02/15 18:51:34 */ -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkAtom.c,v 1.8 93/06/16 17:15:18 ouster Exp $ SPRITE (Berkeley)"; -#endif - -#include "tkConfig.h" +#include "tkPort.h" #include "tkInt.h" +/* + * The following are a list of the predefined atom strings. + * They should match those found in xatom.h + */ + +static char * atomNameArray[] = { + "PRIMARY", "SECONDARY", "ARC", + "ATOM", "BITMAP", "CARDINAL", + "COLORMAP", "CURSOR", "CUT_BUFFER0", + "CUT_BUFFER1", "CUT_BUFFER2", "CUT_BUFFER3", + "CUT_BUFFER4", "CUT_BUFFER5", "CUT_BUFFER6", + "CUT_BUFFER7", "DRAWABLE", "FONT", + "INTEGER", "PIXMAP", "POINT", + "RECTANGLE", "RESOURCE_MANAGER", "RGB_COLOR_MAP", + "RGB_BEST_MAP", "RGB_BLUE_MAP", "RGB_DEFAULT_MAP", + "RGB_GRAY_MAP", "RGB_GREEN_MAP", "RGB_RED_MAP", + "STRING", "VISUALID", "WINDOW", + "WM_COMMAND", "WM_HINTS", "WM_CLIENT_MACHINE", + "WM_ICON_NAME", "WM_ICON_SIZE", "WM_NAME", + "WM_NORMAL_HINTS", "WM_SIZE_HINTS", "WM_ZOOM_HINTS", + "MIN_SPACE", "NORM_SPACE", "MAX_SPACE", + "END_SPACE", "SUPERSCRIPT_X", "SUPERSCRIPT_Y", + "SUBSCRIPT_X", "SUBSCRIPT_Y", "UNDERLINE_POSITION", + "UNDERLINE_THICKNESS", "STRIKEOUT_ASCENT", "STRIKEOUT_DESCENT", + "ITALIC_ANGLE", "X_HEIGHT", "QUAD_WIDTH", + "WEIGHT", "POINT_SIZE", "RESOLUTION", + "COPYRIGHT", "NOTICE", "FONT_NAME", + "FAMILY_NAME", "FULL_NAME", "CAP_HEIGHT", + "WM_CLASS", "WM_TRANSIENT_FOR", + (char *) NULL +}; + /* * Forward references to procedures defined in this file: */ @@ -133,7 +149,7 @@ Tk_GetAtomName(tkwin, atom) int new, mustFree; handler= Tk_CreateErrorHandler(dispPtr->display, BadAtom, - -1, -1, (int (*)()) NULL, (ClientData) NULL); + -1, -1, (Tk_ErrorProc *) NULL, (ClientData) NULL); name = XGetAtomName(dispPtr->display, atom); mustFree = 1; if (name == NULL) { @@ -175,7 +191,27 @@ static void AtomInit(dispPtr) register TkDisplay *dispPtr; /* Display to initialize. */ { + Tcl_HashEntry *hPtr; + Atom atom; + dispPtr->atomInit = 1; Tcl_InitHashTable(&dispPtr->nameTable, TCL_STRING_KEYS); Tcl_InitHashTable(&dispPtr->atomTable, TCL_ONE_WORD_KEYS); + + for (atom = 1; atom <= XA_LAST_PREDEFINED; atom++) { + hPtr = Tcl_FindHashEntry(&dispPtr->atomTable, (char *) atom); + if (hPtr == NULL) { + char *name; + int new; + + name = atomNameArray[atom - 1]; + hPtr = Tcl_CreateHashEntry(&dispPtr->nameTable, (char *) name, + &new); + Tcl_SetHashValue(hPtr, atom); + name = Tcl_GetHashKey(&dispPtr->nameTable, hPtr); + hPtr = Tcl_CreateHashEntry(&dispPtr->atomTable, (char *) atom, + &new); + Tcl_SetHashValue(hPtr, name); + } + } } diff --git a/tk4.2/generic/tkBind.c b/tk4.2/generic/tkBind.c new file mode 100644 index 0000000..dbbc303 --- /dev/null +++ b/tk4.2/generic/tkBind.c @@ -0,0 +1,4108 @@ +/* + * tkBind.c -- + * + * This file provides procedures that associate Tcl commands + * with X events or sequences of X events. + * + * Copyright (c) 1989-1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkBind.c 1.121 96/10/14 11:36:31 + */ + +#include "tkPort.h" +#include "tkInt.h" + +/* + * File structure: + * + * Structure definitions and static variables. + * + * Init/Free this package. + * + * Tcl "bind" command (actually located in tkCmds.c). + * "bind" command implementation. + * "bind" implementation helpers. + * + * Tcl "event" command. + * "event" command implementation. + * "event" implementation helpers. + * + * Package-specific common helpers. + * + * Non-package-specific helpers. + */ + + +/* + * The following union is used to hold the detail information from an + * XEvent (including Tk's XVirtualEvent extension). + */ +typedef union { + KeySym keySym; /* KeySym that corresponds to xkey.keycode. */ + int button; /* Button that was pressed (xbutton.button). */ + Tk_Uid name; /* Tk_Uid of virtual event. */ + ClientData clientData; /* Used when type of Detail is unknown, and to + * ensure that all bytes of Detail are initialized + * when this structure is used in a hash key. */ +} Detail; + +/* + * The structure below represents a binding table. A binding table + * represents a domain in which event bindings may occur. It includes + * a space of objects relative to which events occur (usually windows, + * but not always), a history of recent events in the domain, and + * a set of mappings that associate particular Tcl commands with sequences + * of events in the domain. Multiple binding tables may exist at once, + * either because there are multiple applications open, or because there + * are multiple domains within an application with separate event + * bindings for each (for example, each canvas widget has a separate + * binding table for associating events with the items in the canvas). + * + * Note: it is probably a bad idea to reduce EVENT_BUFFER_SIZE much + * below 30. To see this, consider a triple mouse button click while + * the Shift key is down (and auto-repeating). There may be as many + * as 3 auto-repeat events after each mouse button press or release + * (see the first large comment block within Tk_BindEvent for more on + * this), for a total of 20 events to cover the three button presses + * and two intervening releases. If you reduce EVENT_BUFFER_SIZE too + * much, shift multi-clicks will be lost. + * + */ + +#define EVENT_BUFFER_SIZE 30 +typedef struct BindingTable { + XEvent eventRing[EVENT_BUFFER_SIZE];/* Circular queue of recent events + * (higher indices are for more recent + * events). */ + Detail detailRing[EVENT_BUFFER_SIZE];/* "Detail" information (keySym, + * button, Tk_Uid, or 0) for each + * entry in eventRing. */ + int curEvent; /* Index in eventRing of most recent + * event. Newer events have higher + * indices. */ + Tcl_HashTable patternTable; /* Used to map from an event to a + * list of patterns that may match that + * event. Keys are PatternTableKey + * structs, values are (PatSeq *). */ + Tcl_HashTable objectTable; /* Used to map from an object to a + * list of patterns associated with + * that object. Keys are ClientData, + * values are (PatSeq *). */ + Tcl_Interp *interp; /* Interpreter in which commands are + * executed. */ +} BindingTable; + +/* + * The following structure represents virtual event table. A virtual event + * table provides a way to map from platform-specific physical events such + * as button clicks or key presses to virtual events such as <>, + * <>, or <>. + * + * A virtual event is usually never part of the event stream, but instead is + * synthesized inline by matching low-level events. However, a virtual + * event may be generated by platform-specific code or by Tcl scripts. In + * that case, no lookup of the virtual event will need to be done using + * this table, because the virtual event is actually in the event stream. + */ + +typedef struct TkVirtualEventTable { + Tcl_HashTable patternTable; /* Used to map from a physical event to + * a list of patterns that may match that + * event. Keys PatternTableKey structs, + * values are (PatSeq *). */ + Tcl_HashTable virtualTable; /* Used to map a virtual event to the + * array of physical events that can + * trigger it. Keys are the Tk_Uid names + * of the virtual events, values are + * PhysicalsOwned structs. */ +} TkVirtualEventTable; + +/* + * The following structure is used as a key in a patternTable for both + * binding tables and a virtual event tables. + * + * In a binding table, the object field corresponds to the binding tag + * for the widget whose bindings are being accessed. + * + * In a virtual event table, the object field is always NULL. Virtual + * events are a global definiton and are not tied to a particular + * binding tag. + * + * The same key is used for both types of pattern tables so that the + * helper functions that traverse and match patterns will work for both + * binding tables and virtual event tables. + */ +typedef struct PatternTableKey { + ClientData object; /* For binding table, identifies the binding + * tag of the object (or class of objects) + * relative to which the event occurred. + * For virtual event table, always NULL. */ + int type; /* Type of event (from X). */ + Detail detail; /* Additional information, such as keysym, + * button, Tk_Uid, or 0 if nothing + * additional. */ +} PatternTableKey; + +/* + * The following structure defines a pattern, which is matched against X + * events as part of the process of converting X events into Tcl commands. + */ + +typedef struct Pattern { + int eventType; /* Type of X event, e.g. ButtonPress. */ + int needMods; /* Mask of modifiers that must be + * present (0 means no modifiers are + * required). */ + Detail detail; /* Additional information that must + * match event. Normally this is 0, + * meaning no additional information + * must match. For KeyPress and + * KeyRelease events, a keySym may + * be specified to select a + * particular keystroke (0 means any + * keystrokes). For button events, + * specifies a particular button (0 + * means any buttons are OK). For virtual + * events, specifies the Tk_Uid of the + * virtual event name (never 0). */ +} Pattern; + +/* + * The following structure defines a pattern sequence, which consists of one + * or more patterns. In order to trigger, a pattern sequence must match + * the most recent X events (first pattern to most recent event, next + * pattern to next event, and so on). It is used as the hash value in a + * patternTable for both binding tables and virtual event tables. + * + * In a binding table, it is the sequence of physical events that make up + * a binding for an object. + * + * In a virtual event table, it is the sequence of physical events that + * define a virtual event. + * + * The same structure is used for both types of pattern tables so that the + * helper functions that traverse and match patterns will work for both + * binding tables and virtual event tables. + */ + +typedef struct PatSeq { + int numPats; /* Number of patterns in sequence (usually + * 1). */ + char *command; /* Command to invoke when this pattern + * sequence matches (malloc-ed). */ + int flags; /* Miscellaneous flag values; see below for + * definitions. */ + struct PatSeq *nextSeqPtr; /* Next in list of all pattern sequences + * that have the same initial pattern. NULL + * means end of list. */ + Tcl_HashEntry *hPtr; /* Pointer to hash table entry for the + * initial pattern. This is the head of the + * list of which nextSeqPtr forms a part. */ + struct VirtualOwners *voPtr;/* In a binding table, always NULL. In a + * virtual event table, identifies the array + * of virtual events that can be triggered by + * this event. */ + struct PatSeq *nextObjPtr; /* In a binding table, next in list of all + * pattern sequences for the same object (NULL + * for end of list). Needed to implement + * Tk_DeleteAllBindings. In a virtual event + * table, always NULL. */ + Pattern pats[1]; /* Array of "numPats" patterns. Only one + * element is declared here but in actuality + * enough space will be allocated for "numPats" + * patterns. To match, pats[0] must match + * event n, pats[1] must match event n-1, etc. + */ +} PatSeq; + +/* + * Flag values for PatSeq structures: + * + * PAT_NEARBY 1 means that all of the events matching + * this sequence must occur with nearby X + * and Y mouse coordinates and close in time. + * This is typically used to restrict multiple + * button presses. + */ + +#define PAT_NEARBY 1 + +/* + * Constants that define how close together two events must be + * in milliseconds or pixels to meet the PAT_NEARBY constraint: + */ + +#define NEARBY_PIXELS 5 +#define NEARBY_MS 500 + + +/* + * The following structure keeps track of all the virtual events that are + * associated with a particular physical event. It is pointed to by the + * voPtr field in a PatSeq in the patternTable of a virtual event table. + */ + +typedef struct VirtualOwners { + int numOwners; /* Number of virtual events to trigger. */ + Tcl_HashEntry *owners[1]; /* Array of pointers to entries in + * virtualTable. Enough space will + * actually be allocated for numOwners + * hash entries. */ +} VirtualOwners; + +/* + * The following structure is used in the virtualTable of a virtual event + * table to associate a virtual event with all the physical events that can + * trigger it. + */ +typedef struct PhysicalsOwned { + int numOwned; /* Number of physical events owned. */ + PatSeq *patSeqs[1]; /* Array of pointers to physical event + * patterns. Enough space will actually + * be allocated to hold numOwned. */ +} PhysicalsOwned; + + +/* + * One of the following structures exists for each interpreter, + * associated with the key "tkBind". This structure keeps track + * of the current display and screen in the interpreter, so that + * a script can be invoked whenever the display/screen changes + * (the script does things like point tkPriv at a display-specific + * structure). + */ + +typedef struct ScreenInfo { + TkDisplay *curDispPtr; /* Display for last binding command invoked + * in this application. */ + int curScreenIndex; /* Index of screen for last binding command. */ + int bindingDepth; /* Number of active instances of Tk_BindEvent + * in this application. */ +} ScreenInfo; + +/* + * In X11R4 and earlier versions, XStringToKeysym is ridiculously + * slow. The data structure and hash table below, along with the + * code that uses them, implement a fast mapping from strings to + * keysyms. In X11R5 and later releases XStringToKeysym is plenty + * fast so this stuff isn't needed. The #define REDO_KEYSYM_LOOKUP + * is normally undefined, so that XStringToKeysym gets used. It + * can be set in the Makefile to enable the use of the hash table + * below. + */ + +#ifdef REDO_KEYSYM_LOOKUP +typedef struct { + char *name; /* Name of keysym. */ + KeySym value; /* Numeric identifier for keysym. */ +} KeySymInfo; +static KeySymInfo keyArray[] = { +#ifndef lint +#include "ks_names.h" +#endif + {(char *) NULL, 0} +}; +static Tcl_HashTable keySymTable; /* keyArray hashed by keysym value. */ +static Tcl_HashTable nameTable; /* keyArray hashed by keysym name. */ +#endif /* REDO_KEYSYM_LOOKUP */ + +static int initialized = 0; + +/* + * A hash table is kept to map from the string names of event + * modifiers to information about those modifiers. The structure + * for storing this information, and the hash table built at + * initialization time, are defined below. + */ + +typedef struct { + char *name; /* Name of modifier. */ + int mask; /* Button/modifier mask value, * such as Button1Mask. */ + int flags; /* Various flags; see below for + * definitions. */ +} ModInfo; + +/* + * Flags for ModInfo structures: + * + * DOUBLE - Non-zero means duplicate this event, + * e.g. for double-clicks. + * TRIPLE - Non-zero means triplicate this event, + * e.g. for triple-clicks. + */ + +#define DOUBLE 1 +#define TRIPLE 2 + +/* + * The following special modifier mask bits are defined, to indicate + * logical modifiers such as Meta and Alt that may float among the + * actual modifier bits. + */ + +#define META_MASK (AnyModifier<<1) +#define ALT_MASK (AnyModifier<<2) + +static ModInfo modArray[] = { + {"Control", ControlMask, 0}, + {"Shift", ShiftMask, 0}, + {"Lock", LockMask, 0}, + {"Meta", META_MASK, 0}, + {"M", META_MASK, 0}, + {"Alt", ALT_MASK, 0}, + {"B1", Button1Mask, 0}, + {"Button1", Button1Mask, 0}, + {"B2", Button2Mask, 0}, + {"Button2", Button2Mask, 0}, + {"B3", Button3Mask, 0}, + {"Button3", Button3Mask, 0}, + {"B4", Button4Mask, 0}, + {"Button4", Button4Mask, 0}, + {"B5", Button5Mask, 0}, + {"Button5", Button5Mask, 0}, + {"Mod1", Mod1Mask, 0}, + {"M1", Mod1Mask, 0}, + {"Command", Mod1Mask, 0}, + {"Mod2", Mod2Mask, 0}, + {"M2", Mod2Mask, 0}, + {"Option", Mod2Mask, 0}, + {"Mod3", Mod3Mask, 0}, + {"M3", Mod3Mask, 0}, + {"Mod4", Mod4Mask, 0}, + {"M4", Mod4Mask, 0}, + {"Mod5", Mod5Mask, 0}, + {"M5", Mod5Mask, 0}, + {"Double", 0, DOUBLE}, + {"Triple", 0, TRIPLE}, + {"Any", 0, 0}, /* Ignored: historical relic. */ + {NULL, 0, 0} +}; +static Tcl_HashTable modTable; + +/* + * This module also keeps a hash table mapping from event names + * to information about those events. The structure, an array + * to use to initialize the hash table, and the hash table are + * all defined below. + */ + +typedef struct { + char *name; /* Name of event. */ + int type; /* Event type for X, such as + * ButtonPress. */ + int eventMask; /* Mask bits (for XSelectInput) + * for this event type. */ +} EventInfo; + +/* + * Note: some of the masks below are an OR-ed combination of + * several masks. This is necessary because X doesn't report + * up events unless you also ask for down events. Also, X + * doesn't report button state in motion events unless you've + * asked about button events. + */ + +static EventInfo eventArray[] = { + {"Key", KeyPress, KeyPressMask}, + {"KeyPress", KeyPress, KeyPressMask}, + {"KeyRelease", KeyRelease, KeyPressMask|KeyReleaseMask}, + {"Button", ButtonPress, ButtonPressMask}, + {"ButtonPress", ButtonPress, ButtonPressMask}, + {"ButtonRelease", ButtonRelease, + ButtonPressMask|ButtonReleaseMask}, + {"Motion", MotionNotify, + ButtonPressMask|PointerMotionMask}, + {"Enter", EnterNotify, EnterWindowMask}, + {"Leave", LeaveNotify, LeaveWindowMask}, + {"FocusIn", FocusIn, FocusChangeMask}, + {"FocusOut", FocusOut, FocusChangeMask}, + {"Expose", Expose, ExposureMask}, + {"Visibility", VisibilityNotify, VisibilityChangeMask}, + {"Destroy", DestroyNotify, StructureNotifyMask}, + {"Unmap", UnmapNotify, StructureNotifyMask}, + {"Map", MapNotify, StructureNotifyMask}, + {"Reparent", ReparentNotify, StructureNotifyMask}, + {"Configure", ConfigureNotify, StructureNotifyMask}, + {"Gravity", GravityNotify, StructureNotifyMask}, + {"Circulate", CirculateNotify, StructureNotifyMask}, + {"Property", PropertyNotify, PropertyChangeMask}, + {"Colormap", ColormapNotify, ColormapChangeMask}, + {"Activate", ActivateNotify, ActivateMask}, + {"Deactivate", DeactivateNotify, ActivateMask}, + {(char *) NULL, 0, 0} +}; +static Tcl_HashTable eventTable; + +/* + * The defines and table below are used to classify events into + * various groups. The reason for this is that logically identical + * fields (e.g. "state") appear at different places in different + * types of events. The classification masks can be used to figure + * out quickly where to extract information from events. + */ + +#define KEY 0x1 +#define BUTTON 0x2 +#define MOTION 0x4 +#define CROSSING 0x8 +#define FOCUS 0x10 +#define EXPOSE 0x20 +#define VISIBILITY 0x40 +#define CREATE 0x80 +#define DESTROY 0x100 +#define UNMAP 0x200 +#define MAP 0x400 +#define REPARENT 0x800 +#define CONFIG 0x1000 +#define GRAVITY 0x2000 +#define CIRC 0x4000 +#define PROP 0x8000 +#define COLORMAP 0x10000 +#define VIRTUAL 0x20000 +#define ACTIVATE 0x40000 + +#define KEY_BUTTON_MOTION_VIRTUAL (KEY|BUTTON|MOTION|VIRTUAL) + +static int flagArray[TK_LASTEVENT] = { + /* Not used */ 0, + /* Not used */ 0, + /* KeyPress */ KEY, + /* KeyRelease */ KEY, + /* ButtonPress */ BUTTON, + /* ButtonRelease */ BUTTON, + /* MotionNotify */ MOTION, + /* EnterNotify */ CROSSING, + /* LeaveNotify */ CROSSING, + /* FocusIn */ FOCUS, + /* FocusOut */ FOCUS, + /* KeymapNotify */ 0, + /* Expose */ EXPOSE, + /* GraphicsExpose */ EXPOSE, + /* NoExpose */ 0, + /* VisibilityNotify */ VISIBILITY, + /* CreateNotify */ CREATE, + /* DestroyNotify */ DESTROY, + /* UnmapNotify */ UNMAP, + /* MapNotify */ MAP, + /* MapRequest */ 0, + /* ReparentNotify */ REPARENT, + /* ConfigureNotify */ CONFIG, + /* ConfigureRequest */ 0, + /* GravityNotify */ GRAVITY, + /* ResizeRequest */ 0, + /* CirculateNotify */ CIRC, + /* CirculateRequest */ 0, + /* PropertyNotify */ PROP, + /* SelectionClear */ 0, + /* SelectionRequest */ 0, + /* SelectionNotify */ 0, + /* ColormapNotify */ COLORMAP, + /* ClientMessage */ 0, + /* MappingNotify */ 0, + /* VirtualEvent */ VIRTUAL, + /* Activate */ ACTIVATE, + /* Deactivate */ ACTIVATE +}; + +/* + * The following tables are used as a two-way map between X's internal + * numeric values for fields in an XEvent and the strings used in Tcl. The + * tables are used both when constructing an XEvent from user input and + * when providing data from an XEvent to the user. + */ + +static TkStateMap notifyMode[] = { + {NotifyNormal, "NotifyNormal"}, + {NotifyGrab, "NotifyGrab"}, + {NotifyUngrab, "NotifyUngrab"}, + {NotifyWhileGrabbed, "NotifyWhileGrabbed"}, + {-1, NULL} +}; + +static TkStateMap notifyDetail[] = { + {NotifyAncestor, "NotifyAncestor"}, + {NotifyVirtual, "NotifyVirtual"}, + {NotifyInferior, "NotifyInferior"}, + {NotifyNonlinear, "NotifyNonlinear"}, + {NotifyNonlinearVirtual,"NotifyNonlinearVirtual"}, + {NotifyPointer, "NotifyPointer"}, + {NotifyPointerRoot, "NotifyPointerRoot"}, + {NotifyDetailNone, "NotifyDetailNone"}, + {-1, NULL} +}; + +static TkStateMap circPlace[] = { + {PlaceOnTop, "PlaceOnTop"}, + {PlaceOnBottom, "PlaceOnBottom"}, + {-1, NULL} +}; + +static TkStateMap visNotify[] = { + {VisibilityUnobscured, "VisibilityUnobscured"}, + {VisibilityPartiallyObscured, "VisibilityPartiallyObscured"}, + {VisibilityFullyObscured, "VisibilityFullyObscured"}, + {-1, NULL} +}; + +/* + * Prototypes for local procedures defined in this file: + */ + +static void ChangeScreen _ANSI_ARGS_((Tcl_Interp *interp, + char *dispName, int screenIndex)); +static int CreateVirtualEvent _ANSI_ARGS_((Tcl_Interp *interp, + TkVirtualEventTable *vetPtr, char *virtString, + char *eventString)); +static TkVirtualEventTable *CreateVirtualEventTable _ANSI_ARGS_((void)); +static int DeleteVirtualEvent _ANSI_ARGS_((Tcl_Interp *interp, + TkVirtualEventTable *vetPtr, char *virtString, + char *eventString)); +static void DeleteVirtualEventTable _ANSI_ARGS_(( + TkVirtualEventTable *vetPtr)); +static void ExpandPercents _ANSI_ARGS_((TkWindow *winPtr, + char *before, XEvent *eventPtr, KeySym keySym, + Tcl_DString *dsPtr)); +static PatSeq * FindSequence _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_HashTable *patternTablePtr, ClientData object, + char *eventString, int create, int allowVirtual, + unsigned long *maskPtr)); +static void FreeScreenInfo _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp)); +static void GetAllVirtualEvents _ANSI_ARGS_((Tcl_Interp *interp, + TkVirtualEventTable *vetPtr)); +static char * GetField _ANSI_ARGS_((char *p, char *copy, int size)); +static KeySym GetKeySym _ANSI_ARGS_((TkDisplay *dispPtr, + XEvent *eventPtr)); +static void GetPatternString _ANSI_ARGS_((PatSeq *psPtr, + Tcl_DString *dsPtr)); +static int GetVirtualEvent _ANSI_ARGS_((Tcl_Interp *interp, + TkVirtualEventTable *vetPtr, char *virtString)); +static Tk_Uid GetVirtualEventUid _ANSI_ARGS_((Tcl_Interp *interp, + char *virtString)); +static int HandleEventGenerate _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv)); +static void InitKeymapInfo _ANSI_ARGS_((TkDisplay *dispPtr)); +static PatSeq * MatchPatterns _ANSI_ARGS_((TkDisplay *dispPtr, + BindingTable *bindPtr, PatSeq *psPtr, + PatSeq *bestPtr, ClientData object, + char **bestCommandPtr)); +static int ParseEventDescription _ANSI_ARGS_((Tcl_Interp *interp, + char **eventStringPtr, Pattern *patPtr, + unsigned long *eventMaskPtr)); + + + +/* + *--------------------------------------------------------------------------- + * + * TkBindInit -- + * + * This procedure is called when an application is created. It + * initializes all the structures used by bindings and virtual + * events. + * + * Results: + * None. + * + * Side effects: + * Memory allocated. + * + *--------------------------------------------------------------------------- + */ + +void +TkBindInit(mainPtr) + TkMainInfo *mainPtr; /* The newly created application. */ +{ + if (sizeof(XEvent) < sizeof(XVirtualEvent)) { + panic("TkBindInit: virtual events can't be supported"); + } + mainPtr->bindingTable = Tk_CreateBindingTable(mainPtr->interp); + mainPtr->vetPtr = CreateVirtualEventTable(); +} + +/* + *--------------------------------------------------------------------------- + * + * TkBindFree -- + * + * This procedure is called when an application is deleted. It + * deletes all the structures used by bindings and virtual events. + * + * Results: + * None. + * + * Side effects: + * Memory freed. + * + *--------------------------------------------------------------------------- + */ + +void +TkBindFree(mainPtr) + TkMainInfo *mainPtr; /* The newly created application. */ +{ + Tk_DeleteBindingTable(mainPtr->bindingTable); + mainPtr->bindingTable = NULL; + + DeleteVirtualEventTable(mainPtr->vetPtr); + mainPtr->vetPtr = NULL; +} + +/* + *-------------------------------------------------------------- + * + * Tk_CreateBindingTable -- + * + * Set up a new domain in which event bindings may be created. + * + * Results: + * The return value is a token for the new table, which must + * be passed to procedures like Tk_CreatBinding. + * + * Side effects: + * Memory is allocated for the new table. + * + *-------------------------------------------------------------- + */ + +Tk_BindingTable +Tk_CreateBindingTable(interp) + Tcl_Interp *interp; /* Interpreter to associate with the binding + * table: commands are executed in this + * interpreter. */ +{ + BindingTable *bindPtr; + int i; + + /* + * If this is the first time a binding table has been created, + * initialize the global data structures. + */ + + if (!initialized) { + Tcl_HashEntry *hPtr; + ModInfo *modPtr; + EventInfo *eiPtr; + int dummy; + +#ifdef REDO_KEYSYM_LOOKUP + KeySymInfo *kPtr; + + Tcl_InitHashTable(&keySymTable, TCL_STRING_KEYS); + Tcl_InitHashTable(&nameTable, TCL_ONE_WORD_KEYS); + for (kPtr = keyArray; kPtr->name != NULL; kPtr++) { + hPtr = Tcl_CreateHashEntry(&keySymTable, kPtr->name, &dummy); + Tcl_SetHashValue(hPtr, kPtr->value); + hPtr = Tcl_CreateHashEntry(&nameTable, (char *) kPtr->value, + &dummy); + Tcl_SetHashValue(hPtr, kPtr->name); + } +#endif /* REDO_KEYSYM_LOOKUP */ + + initialized = 1; + + Tcl_InitHashTable(&modTable, TCL_STRING_KEYS); + for (modPtr = modArray; modPtr->name != NULL; modPtr++) { + hPtr = Tcl_CreateHashEntry(&modTable, modPtr->name, &dummy); + Tcl_SetHashValue(hPtr, modPtr); + } + + Tcl_InitHashTable(&eventTable, TCL_STRING_KEYS); + for (eiPtr = eventArray; eiPtr->name != NULL; eiPtr++) { + hPtr = Tcl_CreateHashEntry(&eventTable, eiPtr->name, &dummy); + Tcl_SetHashValue(hPtr, eiPtr); + } + } + + /* + * Create and initialize a new binding table. + */ + + bindPtr = (BindingTable *) ckalloc(sizeof(BindingTable)); + for (i = 0; i < EVENT_BUFFER_SIZE; i++) { + bindPtr->eventRing[i].type = -1; + } + bindPtr->curEvent = 0; + Tcl_InitHashTable(&bindPtr->patternTable, + sizeof(PatternTableKey)/sizeof(int)); + Tcl_InitHashTable(&bindPtr->objectTable, TCL_ONE_WORD_KEYS); + bindPtr->interp = interp; + return (Tk_BindingTable) bindPtr; +} + +/* + *-------------------------------------------------------------- + * + * Tk_DeleteBindingTable -- + * + * Destroy a binding table and free up all its memory. + * The caller should not use bindingTable again after + * this procedure returns. + * + * Results: + * None. + * + * Side effects: + * Memory is freed. + * + *-------------------------------------------------------------- + */ + +void +Tk_DeleteBindingTable(bindingTable) + Tk_BindingTable bindingTable; /* Token for the binding table to + * destroy. */ +{ + BindingTable *bindPtr = (BindingTable *) bindingTable; + PatSeq *psPtr, *nextPtr; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + + /* + * Find and delete all of the patterns associated with the binding + * table. + */ + + for (hPtr = Tcl_FirstHashEntry(&bindPtr->patternTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + for (psPtr = (PatSeq *) Tcl_GetHashValue(hPtr); + psPtr != NULL; psPtr = nextPtr) { + nextPtr = psPtr->nextSeqPtr; + ckfree((char *) psPtr->command); + ckfree((char *) psPtr); + } + } + + /* + * Clean up the rest of the information associated with the + * binding table. + */ + + Tcl_DeleteHashTable(&bindPtr->patternTable); + Tcl_DeleteHashTable(&bindPtr->objectTable); + ckfree((char *) bindPtr); +} + +/* + *-------------------------------------------------------------- + * + * Tk_CreateBinding -- + * + * Add a binding to a binding table, so that future calls to + * Tk_BindEvent may execute the command in the binding. + * + * Results: + * The return value is 0 if an error occurred while setting + * up the binding. In this case, an error message will be + * left in interp->result. If all went well then the return + * value is a mask of the event types that must be made + * available to Tk_BindEvent in order to properly detect when + * this binding triggers. This value can be used to determine + * what events to select for in a window, for example. + * + * Side effects: + * The new binding may cause future calls to Tk_BindEvent to + * behave differently than they did previously. + * + *-------------------------------------------------------------- + */ + +unsigned long +Tk_CreateBinding(interp, bindingTable, object, eventString, command, append) + Tcl_Interp *interp; /* Used for error reporting. */ + Tk_BindingTable bindingTable; /* Table in which to create binding. */ + ClientData object; /* Token for object with which binding + * is associated. */ + char *eventString; /* String describing event sequence + * that triggers binding. */ + char *command; /* Contains Tcl command to execute + * when binding triggers. */ + int append; /* 0 means replace any existing + * binding for eventString; 1 means + * append to that binding. */ +{ + BindingTable *bindPtr = (BindingTable *) bindingTable; + PatSeq *psPtr; + unsigned long eventMask; + + psPtr = FindSequence(interp, &bindPtr->patternTable, object, eventString, + 1, 1, &eventMask); + if (psPtr == NULL) { + return 0; + } + if (psPtr->command == NULL) { + int new; + Tcl_HashEntry *hPtr; + + /* + * This pattern sequence was just created. + * Link the pattern into the list associated with the object. + */ + + hPtr = Tcl_CreateHashEntry(&bindPtr->objectTable, (char *) object, + &new); + if (new) { + psPtr->nextObjPtr = NULL; + } else { + psPtr->nextObjPtr = (PatSeq *) Tcl_GetHashValue(hPtr); + } + Tcl_SetHashValue(hPtr, psPtr); + } + + if (append && (psPtr->command != NULL)) { + int length; + char *new; + + length = strlen(psPtr->command) + strlen(command) + 2; + new = (char *) ckalloc((unsigned) length); + sprintf(new, "%s\n%s", psPtr->command, command); + ckfree((char *) psPtr->command); + psPtr->command = new; + } else { + if (psPtr->command != NULL) { + ckfree((char *) psPtr->command); + } + psPtr->command = (char *) ckalloc((unsigned) (strlen(command) + 1)); + strcpy(psPtr->command, command); + } + return eventMask; +} + +/* + *-------------------------------------------------------------- + * + * Tk_DeleteBinding -- + * + * Remove an event binding from a binding table. + * + * Results: + * The result is a standard Tcl return value. If an error + * occurs then interp->result will contain an error message. + * + * Side effects: + * The binding given by object and eventString is removed + * from bindingTable. + * + *-------------------------------------------------------------- + */ + +int +Tk_DeleteBinding(interp, bindingTable, object, eventString) + Tcl_Interp *interp; /* Used for error reporting. */ + Tk_BindingTable bindingTable; /* Table in which to delete binding. */ + ClientData object; /* Token for object with which binding + * is associated. */ + char *eventString; /* String describing event sequence + * that triggers binding. */ +{ + BindingTable *bindPtr = (BindingTable *) bindingTable; + PatSeq *psPtr, *prevPtr; + unsigned long eventMask; + Tcl_HashEntry *hPtr; + + psPtr = FindSequence(interp, &bindPtr->patternTable, object, eventString, + 0, 1, &eventMask); + if (psPtr == NULL) { + Tcl_ResetResult(interp); + return TCL_OK; + } + + /* + * Unlink the binding from the list for its object, then from the + * list for its pattern. + */ + + hPtr = Tcl_FindHashEntry(&bindPtr->objectTable, (char *) object); + if (hPtr == NULL) { + panic("Tk_DeleteBinding couldn't find object table entry"); + } + prevPtr = (PatSeq *) Tcl_GetHashValue(hPtr); + if (prevPtr == psPtr) { + Tcl_SetHashValue(hPtr, psPtr->nextObjPtr); + } else { + for ( ; ; prevPtr = prevPtr->nextObjPtr) { + if (prevPtr == NULL) { + panic("Tk_DeleteBinding couldn't find on object list"); + } + if (prevPtr->nextObjPtr == psPtr) { + prevPtr->nextObjPtr = psPtr->nextObjPtr; + break; + } + } + } + prevPtr = (PatSeq *) Tcl_GetHashValue(psPtr->hPtr); + if (prevPtr == psPtr) { + if (psPtr->nextSeqPtr == NULL) { + Tcl_DeleteHashEntry(psPtr->hPtr); + } else { + Tcl_SetHashValue(psPtr->hPtr, psPtr->nextSeqPtr); + } + } else { + for ( ; ; prevPtr = prevPtr->nextSeqPtr) { + if (prevPtr == NULL) { + panic("Tk_DeleteBinding couldn't find on hash chain"); + } + if (prevPtr->nextSeqPtr == psPtr) { + prevPtr->nextSeqPtr = psPtr->nextSeqPtr; + break; + } + } + } + ckfree((char *) psPtr->command); + ckfree((char *) psPtr); + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * Tk_GetBinding -- + * + * Return the command associated with a given event string. + * + * Results: + * The return value is a pointer to the command string + * associated with eventString for object in the domain + * given by bindingTable. If there is no binding for + * eventString, or if eventString is improperly formed, + * then NULL is returned and an error message is left in + * interp->result. The return value is semi-static: it + * will persist until the binding is changed or deleted. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +char * +Tk_GetBinding(interp, bindingTable, object, eventString) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + Tk_BindingTable bindingTable; /* Table in which to look for + * binding. */ + ClientData object; /* Token for object with which binding + * is associated. */ + char *eventString; /* String describing event sequence + * that triggers binding. */ +{ + BindingTable *bindPtr = (BindingTable *) bindingTable; + PatSeq *psPtr; + unsigned long eventMask; + + psPtr = FindSequence(interp, &bindPtr->patternTable, object, eventString, + 0, 1, &eventMask); + if (psPtr == NULL) { + return NULL; + } + return psPtr->command; +} + +/* + *-------------------------------------------------------------- + * + * Tk_GetAllBindings -- + * + * Return a list of event strings for all the bindings + * associated with a given object. + * + * Results: + * There is no return value. Interp->result is modified to + * hold a Tcl list with one entry for each binding associated + * with object in bindingTable. Each entry in the list + * contains the event string associated with one binding. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +void +Tk_GetAllBindings(interp, bindingTable, object) + Tcl_Interp *interp; /* Interpreter returning result or + * error. */ + Tk_BindingTable bindingTable; /* Table in which to look for + * bindings. */ + ClientData object; /* Token for object. */ + +{ + BindingTable *bindPtr = (BindingTable *) bindingTable; + PatSeq *psPtr; + Tcl_HashEntry *hPtr; + Tcl_DString ds; + + hPtr = Tcl_FindHashEntry(&bindPtr->objectTable, (char *) object); + if (hPtr == NULL) { + return; + } + Tcl_DStringInit(&ds); + for (psPtr = (PatSeq *) Tcl_GetHashValue(hPtr); psPtr != NULL; + psPtr = psPtr->nextObjPtr) { + /* + * For each binding, output information about each of the + * patterns in its sequence. + */ + + Tcl_DStringSetLength(&ds, 0); + GetPatternString(psPtr, &ds); + Tcl_AppendElement(interp, Tcl_DStringValue(&ds)); + } + Tcl_DStringFree(&ds); +} + +/* + *-------------------------------------------------------------- + * + * Tk_DeleteAllBindings -- + * + * Remove all bindings associated with a given object in a + * given binding table. + * + * Results: + * All bindings associated with object are removed from + * bindingTable. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +void +Tk_DeleteAllBindings(bindingTable, object) + Tk_BindingTable bindingTable; /* Table in which to delete + * bindings. */ + ClientData object; /* Token for object. */ +{ + BindingTable *bindPtr = (BindingTable *) bindingTable; + PatSeq *psPtr, *prevPtr; + PatSeq *nextPtr; + Tcl_HashEntry *hPtr; + + hPtr = Tcl_FindHashEntry(&bindPtr->objectTable, (char *) object); + if (hPtr == NULL) { + return; + } + for (psPtr = (PatSeq *) Tcl_GetHashValue(hPtr); psPtr != NULL; + psPtr = nextPtr) { + nextPtr = psPtr->nextObjPtr; + + /* + * Be sure to remove each binding from its hash chain in the + * pattern table. If this is the last pattern in the chain, + * then delete the hash entry too. + */ + + prevPtr = (PatSeq *) Tcl_GetHashValue(psPtr->hPtr); + if (prevPtr == psPtr) { + if (psPtr->nextSeqPtr == NULL) { + Tcl_DeleteHashEntry(psPtr->hPtr); + } else { + Tcl_SetHashValue(psPtr->hPtr, psPtr->nextSeqPtr); + } + } else { + for ( ; ; prevPtr = prevPtr->nextSeqPtr) { + if (prevPtr == NULL) { + panic("Tk_DeleteAllBindings couldn't find on hash chain"); + } + if (prevPtr->nextSeqPtr == psPtr) { + prevPtr->nextSeqPtr = psPtr->nextSeqPtr; + break; + } + } + } + ckfree((char *) psPtr->command); + ckfree((char *) psPtr); + } + Tcl_DeleteHashEntry(hPtr); +} + +/* + *-------------------------------------------------------------- + * + * Tk_BindEvent -- + * + * This procedure is invoked to process an X event. The + * event is added to those recorded for the binding table. + * Then each of the objects at *objectPtr is checked in + * order to see if it has a binding that matches the recent + * events. If so, the most specific binding is invoked for + * each object. + * + * Results: + * None. + * + * Side effects: + * Depends on the command associated with the matching + * binding. + * + *-------------------------------------------------------------- + */ + +void +Tk_BindEvent(bindingTable, eventPtr, tkwin, numObjects, objectPtr) + Tk_BindingTable bindingTable; /* Table in which to look for + * bindings. */ + XEvent *eventPtr; /* What actually happened. */ + Tk_Window tkwin; /* Window on display where event + * occurred (needed in order to + * locate display information). */ + int numObjects; /* Number of objects at *objectPtr. */ + ClientData *objectPtr; /* Array of one or more objects + * to check for a matching binding. */ +{ + BindingTable *bindPtr = (BindingTable *) bindingTable; + TkDisplay *dispPtr = ((TkWindow *) tkwin)->dispPtr; + TkDisplay *oldDispPtr; + ScreenInfo *screenPtr; + XEvent *ringPtr; + PatSeq *vMatchDetailList, *vMatchNoDetailList; + PatternTableKey key; + Tcl_HashEntry *hPtr; + int flags, code, oldScreen; + Tcl_Interp *interp; + Tcl_DString scripts, savedResult; + char *p, *end; + Detail detail; + + /* + * Ignore the event completely if it is an Enter, Leave, FocusIn, + * or FocusOut event with detail NotifyInferior. The reason for + * ignoring these events is that we don't want transitions between + * a window and its children to visible to bindings on the parent: + * this would cause problems for mega-widgets, since the internal + * structure of a mega-widget isn't supposed to be visible to + * people watching the parent. + */ + + if ((eventPtr->type == EnterNotify) || (eventPtr->type == LeaveNotify)) { + if (eventPtr->xcrossing.detail == NotifyInferior) { + return; + } + } + if ((eventPtr->type == FocusIn) || (eventPtr->type == FocusOut)) { + if (eventPtr->xfocus.detail == NotifyInferior) { + return; + } + } + + /* + * Add the new event to the ring of saved events for the + * binding table. Two tricky points: + * + * 1. Combine consecutive MotionNotify events. Do this by putting + * the new event *on top* of the previous event. + * 2. If a modifier key is held down, it auto-repeats to generate + * continuous KeyPress and KeyRelease events. These can flush + * the event ring so that valuable information is lost (such + * as repeated button clicks). To handle this, check for the + * special case of a modifier KeyPress arriving when the previous + * two events are a KeyRelease and KeyPress of the same key. + * If this happens, mark the most recent event (the KeyRelease) + * invalid and put the new event on top of the event before that + * (the KeyPress). + */ + + if ((eventPtr->type == MotionNotify) + && (bindPtr->eventRing[bindPtr->curEvent].type == MotionNotify)) { + /* + * Don't advance the ring pointer. + */ + } else if (eventPtr->type == KeyPress) { + int i; + for (i = 0; ; i++) { + if (i >= dispPtr->numModKeyCodes) { + goto advanceRingPointer; + } + if (dispPtr->modKeyCodes[i] == eventPtr->xkey.keycode) { + break; + } + } + ringPtr = &bindPtr->eventRing[bindPtr->curEvent]; + if ((ringPtr->type != KeyRelease) + || (ringPtr->xkey.keycode != eventPtr->xkey.keycode)) { + goto advanceRingPointer; + } + if (bindPtr->curEvent <= 0) { + i = EVENT_BUFFER_SIZE - 1; + } else { + i = bindPtr->curEvent - 1; + } + ringPtr = &bindPtr->eventRing[i]; + if ((ringPtr->type != KeyPress) + || (ringPtr->xkey.keycode != eventPtr->xkey.keycode)) { + goto advanceRingPointer; + } + bindPtr->eventRing[bindPtr->curEvent].type = -1; + bindPtr->curEvent = i; + } else { + advanceRingPointer: + bindPtr->curEvent++; + if (bindPtr->curEvent >= EVENT_BUFFER_SIZE) { + bindPtr->curEvent = 0; + } + } + ringPtr = &bindPtr->eventRing[bindPtr->curEvent]; + memcpy((VOID *) ringPtr, (VOID *) eventPtr, sizeof(XEvent)); + detail.clientData = 0; + flags = flagArray[ringPtr->type]; + if (flags & KEY) { + detail.keySym = GetKeySym(dispPtr, ringPtr); + if (detail.keySym == NoSymbol) { + detail.keySym = 0; + } + } else if (flags & BUTTON) { + detail.button = ringPtr->xbutton.button; + } else if (flags & VIRTUAL) { + detail.name = ((XVirtualEvent *) ringPtr)->name; + } + bindPtr->detailRing[bindPtr->curEvent] = detail; + + /* + * Find out if there are any virtual events that correspond to this + * physical event (or sequence of physical events). + */ + + vMatchDetailList = NULL; + vMatchNoDetailList = NULL; + memset(&key, 0, sizeof(key)); + + if (ringPtr->type != VirtualEvent) { + TkWindow *winPtr = (TkWindow *) tkwin; + Tcl_HashTable *veptPtr = &winPtr->mainPtr->vetPtr->patternTable; + + key.object = NULL; + key.type = ringPtr->type; + key.detail = detail; + + hPtr = Tcl_FindHashEntry(veptPtr, (char *) &key); + if (hPtr != NULL) { + vMatchDetailList = (PatSeq *) Tcl_GetHashValue(hPtr); + } + + if (key.detail.clientData != 0) { + key.detail.clientData = 0; + hPtr = Tcl_FindHashEntry(veptPtr, (char *) &key); + if (hPtr != NULL) { + vMatchNoDetailList = (PatSeq *) Tcl_GetHashValue(hPtr); + } + } + } + + /* + * Loop over all the objects, finding the binding script for each + * one. Append all of the binding scripts, with %-sequences expanded, + * to "scripts", with null characters separating the scripts for + * each object. + */ + + Tcl_DStringInit(&scripts); + for ( ; numObjects > 0; numObjects--, objectPtr++) { + PatSeq *matchPtr; + char *command; + + matchPtr = NULL; + command = NULL; + + /* + * Match the new event against those recorded in the pattern table, + * saving the longest matching pattern. For events with details + * (button and key events), look for a binding for the specific + * key or button. First see if the event matches a physical event + * that the object is interested in, then look for a virtual event. + */ + + key.object = *objectPtr; + key.type = ringPtr->type; + key.detail = detail; + hPtr = Tcl_FindHashEntry(&bindPtr->patternTable, (char *) &key); + if (hPtr != NULL) { + matchPtr = MatchPatterns(dispPtr, bindPtr, + (PatSeq *) Tcl_GetHashValue(hPtr), matchPtr, NULL, + &command); + } + + if (vMatchDetailList != NULL) { + matchPtr = MatchPatterns(dispPtr, bindPtr, vMatchDetailList, + matchPtr, *objectPtr, &command); + } + + + /* + * If no match was found, look for a binding for all keys or buttons + * (detail of 0). Again, first match on a virtual event. + */ + + if ((detail.clientData != 0) && (matchPtr == NULL)) { + key.detail.clientData = 0; + hPtr = Tcl_FindHashEntry(&bindPtr->patternTable, (char *) &key); + if (hPtr != NULL) { + matchPtr = MatchPatterns(dispPtr, bindPtr, + (PatSeq *) Tcl_GetHashValue(hPtr), matchPtr, NULL, + &command); + } + + if (vMatchNoDetailList != NULL) { + matchPtr = MatchPatterns(dispPtr, bindPtr, vMatchNoDetailList, + matchPtr, *objectPtr, &command); + } + + } + + if (matchPtr != NULL) { + if (command == NULL) { + panic("Tk_BindEvent: missing command"); + } + ExpandPercents((TkWindow *) tkwin, command, eventPtr, + detail.keySym, &scripts); + Tcl_DStringAppend(&scripts, "", 1); + } + } + if (Tcl_DStringLength(&scripts) == 0) { + return; + } + + /* + * Now go back through and evaluate the script for each object, + * in order, dealing with "break" and "continue" exceptions + * appropriately. + * + * There are two tricks here: + * 1. Bindings can be invoked from in the middle of Tcl commands, + * where interp->result is significant (for example, a widget + * might be deleted because of an error in creating it, so the + * result contains an error message that is eventually going to + * be returned by the creating command). To preserve the result, + * we save it in a dynamic string. + * 2. The binding's action can potentially delete the binding, + * so bindPtr may not point to anything valid once the action + * completes. Thus we have to save bindPtr->interp in a + * local variable in order to restore the result. + */ + + interp = bindPtr->interp; + Tcl_DStringInit(&savedResult); + + /* + * Save information about the current screen, then invoke a script + * if the screen has changed. + */ + + Tcl_DStringGetResult(interp, &savedResult); + screenPtr = (ScreenInfo *) Tcl_GetAssocData(interp, "tkBind", + (Tcl_InterpDeleteProc **) NULL); + if (screenPtr == NULL) { + screenPtr = (ScreenInfo *) ckalloc(sizeof(ScreenInfo)); + screenPtr->curDispPtr = NULL; + screenPtr->curScreenIndex = -1; + screenPtr->bindingDepth = 0; + Tcl_SetAssocData(interp, "tkBind", FreeScreenInfo, + (ClientData) screenPtr); + } + oldDispPtr = screenPtr->curDispPtr; + oldScreen = screenPtr->curScreenIndex; + if ((dispPtr != screenPtr->curDispPtr) + || (Tk_ScreenNumber(tkwin) != screenPtr->curScreenIndex)) { + screenPtr->curDispPtr = dispPtr; + screenPtr->curScreenIndex = Tk_ScreenNumber(tkwin); + ChangeScreen(interp, dispPtr->name, screenPtr->curScreenIndex); + } + + p = Tcl_DStringValue(&scripts); + end = p + Tcl_DStringLength(&scripts); + while (p != end) { + screenPtr->bindingDepth += 1; + Tcl_AllowExceptions(interp); + code = Tcl_GlobalEval(interp, p); + screenPtr->bindingDepth -= 1; + if (code != TCL_OK) { + if (code == TCL_CONTINUE) { + /* + * Do nothing: just go on to the next script. + */ + } else if (code == TCL_BREAK) { + break; + } else { + Tcl_AddErrorInfo(interp, "\n (command bound to event)"); + Tcl_BackgroundError(interp); + break; + } + } + + /* + * Skip over the current script and its terminating null character. + */ + + while (*p != 0) { + p++; + } + p++; + } + if ((screenPtr->bindingDepth != 0) && + ((oldDispPtr != screenPtr->curDispPtr) + || (oldScreen != screenPtr->curScreenIndex))) { + + /* + * Some other binding script is currently executing, but its + * screen is no longer current. Change the current display + * back again. + */ + + screenPtr->curDispPtr = oldDispPtr; + screenPtr->curScreenIndex = oldScreen; + ChangeScreen(interp, oldDispPtr->name, oldScreen); + } + Tcl_DStringResult(interp, &savedResult); + Tcl_DStringFree(&scripts); +} + +/* + *---------------------------------------------------------------------- + * + * MatchPatterns -- + * + * Given a list of pattern sequences and a list of recent events, + * return the pattern sequence that best matches the event list, + * if there is one. + * + * This procedure is used in two different ways. In the simplest + * use, "object" is NULL and psPtr is a list of pattern sequences, + * each of which corresponds to a binding. In this case, the + * procedure finds the pattern sequences that match the event list + * and returns the most specify of those, if there is more than one. + * + * In the second case, psPtr is a list of pattern sequences, each + * of which corresponds to a definition for a virtual binding. + * In order for one of these sequences to "match", it must match + * the events (as above) but in addition there must be a binding + * for its associated virtual event on the current object. The + * "object" argument indicates which object the binding must be for. + * + * Results: + * The return value is NULL if bestPtr is NULL and no pattern matches + * the recent events from bindPtr. Otherwise the return value is + * the most specific pattern sequence among bestPtr and all those + * at psPtr that match the event list and object. If a pattern + * sequence other than bestPtr is returned, then *bestCommandPtr + * is filled in with a pointer to the command from the best sequence. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +static PatSeq * +MatchPatterns(dispPtr, bindPtr, psPtr, bestPtr, object, bestCommandPtr) + TkDisplay *dispPtr; /* Display from which the event came. */ + BindingTable *bindPtr; /* Information about binding table, such as + * ring of recent events. */ + PatSeq *psPtr; /* List of pattern sequences. */ + PatSeq *bestPtr; /* The best match seen so far, from a + * previous call to this procedure. NULL + * means no prior best match. */ + ClientData object; /* If NULL, the sequences at psPtr + * correspond to "normal" bindings. If + * non-NULL, the sequences at psPtr correspond + * to virtual bindings; in order to match each + * sequence must correspond to a virtual + * binding for which a binding exists for + * object in bindPtr. */ + char **bestCommandPtr; /* Returns the command associated with the + * best match. Not modified unless a result + * other than bestPtr is returned. */ +{ + PatSeq *matchPtr; + char *bestCommand, *command; + + bestCommand = *bestCommandPtr; + + /* + * Iterate over all the pattern sequences. + */ + + for ( ; psPtr != NULL; psPtr = psPtr->nextSeqPtr) { + XEvent *eventPtr; + Pattern *patPtr; + Window window; + Detail *detailPtr; + int patCount, ringCount, flags, state; + int modMask; + + /* + * Iterate over all the patterns in a sequence to be + * sure that they all match. + */ + + eventPtr = &bindPtr->eventRing[bindPtr->curEvent]; + detailPtr = &bindPtr->detailRing[bindPtr->curEvent]; + window = eventPtr->xany.window; + patPtr = psPtr->pats; + patCount = psPtr->numPats; + ringCount = EVENT_BUFFER_SIZE; + while (patCount > 0) { + if (ringCount <= 0) { + goto nextSequence; + } + if (eventPtr->xany.type != patPtr->eventType) { + /* + * Most of the event types are considered superfluous + * in that they are ignored if they occur in the middle + * of a pattern sequence and have mismatching types. The + * only ones that cannot be ignored are ButtonPress and + * ButtonRelease events (if the next event in the pattern + * is a KeyPress or KeyRelease) and KeyPress and KeyRelease + * events (if the next pattern event is a ButtonPress or + * ButtonRelease). Here are some tricky cases to consider: + * 1. Double-Button or Double-Key events. + * 2. Double-ButtonRelease or Double-KeyRelease events. + * 3. The arrival of various events like Enter and Leave + * and FocusIn and GraphicsExpose between two button + * presses or key presses. + * 4. Modifier keys like Shift and Control shouldn't + * generate conflicts with button events. + */ + + if ((patPtr->eventType == KeyPress) + || (patPtr->eventType == KeyRelease)) { + if ((eventPtr->xany.type == ButtonPress) + || (eventPtr->xany.type == ButtonRelease)) { + goto nextSequence; + } + } else if ((patPtr->eventType == ButtonPress) + || (patPtr->eventType == ButtonRelease)) { + if ((eventPtr->xany.type == KeyPress) + || (eventPtr->xany.type == KeyRelease)) { + int i; + + /* + * Ignore key events if they are modifier keys. + */ + + for (i = 0; i < dispPtr->numModKeyCodes; i++) { + if (dispPtr->modKeyCodes[i] + == eventPtr->xkey.keycode) { + /* + * This key is a modifier key, so ignore it. + */ + goto nextEvent; + } + } + goto nextSequence; + } + } + goto nextEvent; + } + if (eventPtr->xany.window != window) { + goto nextSequence; + } + + /* + * Note: it's important for the keysym check to go before + * the modifier check, so we can ignore unwanted modifier + * keys before choking on the modifier check. + */ + + if ((patPtr->detail.clientData != 0) + && (patPtr->detail.clientData != detailPtr->clientData)) { + /* + * The detail appears not to match. However, if the event + * is a KeyPress for a modifier key then just ignore the + * event. Otherwise event sequences like "aD" never match + * because the shift key goes down between the "a" and the + * "D". + */ + + if (eventPtr->xany.type == KeyPress) { + int i; + + for (i = 0; i < dispPtr->numModKeyCodes; i++) { + if (dispPtr->modKeyCodes[i] == eventPtr->xkey.keycode) { + goto nextEvent; + } + } + } + goto nextSequence; + } + flags = flagArray[eventPtr->type]; + if (flags & (KEY_BUTTON_MOTION_VIRTUAL)) { + state = eventPtr->xkey.state; + } else if (flags & CROSSING) { + state = eventPtr->xcrossing.state; + } else { + state = 0; + } + if (patPtr->needMods != 0) { + modMask = patPtr->needMods; + if ((modMask & META_MASK) && (dispPtr->metaModMask != 0)) { + modMask = (modMask & ~META_MASK) | dispPtr->metaModMask; + } + if ((modMask & ALT_MASK) && (dispPtr->altModMask != 0)) { + modMask = (modMask & ~ALT_MASK) | dispPtr->altModMask; + } + if ((state & modMask) != modMask) { + goto nextSequence; + } + } + if (psPtr->flags & PAT_NEARBY) { + XEvent *firstPtr; + int timeDiff; + + firstPtr = &bindPtr->eventRing[bindPtr->curEvent]; + timeDiff = (Time) firstPtr->xkey.time - eventPtr->xkey.time; + if ((firstPtr->xkey.x_root + < (eventPtr->xkey.x_root - NEARBY_PIXELS)) + || (firstPtr->xkey.x_root + > (eventPtr->xkey.x_root + NEARBY_PIXELS)) + || (firstPtr->xkey.y_root + < (eventPtr->xkey.y_root - NEARBY_PIXELS)) + || (firstPtr->xkey.y_root + > (eventPtr->xkey.y_root + NEARBY_PIXELS)) + || (timeDiff > NEARBY_MS)) { + goto nextSequence; + } + } + patPtr++; + patCount--; + nextEvent: + if (eventPtr == bindPtr->eventRing) { + eventPtr = &bindPtr->eventRing[EVENT_BUFFER_SIZE-1]; + detailPtr = &bindPtr->detailRing[EVENT_BUFFER_SIZE-1]; + } else { + eventPtr--; + detailPtr--; + } + ringCount--; + } + + matchPtr = psPtr; + command = matchPtr->command; + + if (object != NULL) { + int iVirt; + VirtualOwners *voPtr; + PatternTableKey key; + + /* + * The sequence matches the physical constraints. + * Is this object interested in any of the virtual events + * that correspond to this sequence? + */ + + voPtr = psPtr->voPtr; + + memset(&key, 0, sizeof(key)); + key.object = object; + key.type = VirtualEvent; + key.detail.clientData = 0; + + for (iVirt = 0; iVirt < voPtr->numOwners; iVirt++) { + Tcl_HashEntry *hPtr = voPtr->owners[iVirt]; + + key.detail.name = (Tk_Uid) Tcl_GetHashKey(hPtr->tablePtr, + hPtr); + hPtr = Tcl_FindHashEntry(&bindPtr->patternTable, + (char *) &key); + if (hPtr != NULL) { + + /* + * This tag is interested in this virtual event and its + * corresponding physical event is a good match with the + * virtual event's definition. + */ + + PatSeq *virtMatchPtr; + + virtMatchPtr = (PatSeq *) Tcl_GetHashValue(hPtr); + if ((virtMatchPtr->numPats != 1) + || (virtMatchPtr->nextSeqPtr != NULL)) { + panic("MatchPattern: badly constructed virtual event"); + } + command = virtMatchPtr->command; + + goto match; + } + } + + /* + * The physical event matches a virtual event's definition, but + * the tag isn't interested in it. + */ + goto nextSequence; + } + match: + + /* + * This sequence matches. If we've already got another match, + * pick whichever is most specific. Detail is most important, + * then needMods. + */ + + if (bestPtr != NULL) { + Pattern *patPtr2; + int i; + + if (matchPtr->numPats != bestPtr->numPats) { + if (bestPtr->numPats > matchPtr->numPats) { + goto nextSequence; + } else { + goto newBest; + } + } + for (i = 0, patPtr = matchPtr->pats, patPtr2 = bestPtr->pats; + i < matchPtr->numPats; i++, patPtr++, patPtr2++) { + if (patPtr->detail.clientData != patPtr2->detail.clientData) { + if (patPtr->detail.clientData == 0) { + goto nextSequence; + } else { + goto newBest; + } + } + if (patPtr->needMods != patPtr2->needMods) { + if ((patPtr->needMods & patPtr2->needMods) + == patPtr->needMods) { + goto nextSequence; + } else if ((patPtr->needMods & patPtr2->needMods) + == patPtr2->needMods) { + goto newBest; + } + } + } + /* + * Tie goes to current best pattern. + * + * (1) For virtual vs. virtual, the least recently defined + * virtual wins, because virtuals are examined in order of + * definition. This order is _not_ guaranteed in the + * documentation. + * + * (2) For virtual vs. physical, the physical wins because all + * the physicals are examined before the virtuals. This order + * is guaranteed in the documentation. + * + * (3) For physical vs. physical pattern, the most recently + * defined physical wins, because physicals are examined in + * reverse order of definition. This order is guaranteed in + * the documentation. + */ + + goto nextSequence; + } + newBest: + bestPtr = matchPtr; + bestCommand = command; + + nextSequence: continue; + } + + *bestCommandPtr = bestCommand; + return bestPtr; +} + +/* + *-------------------------------------------------------------- + * + * ExpandPercents -- + * + * Given a command and an event, produce a new command + * by replacing % constructs in the original command + * with information from the X event. + * + * Results: + * The new expanded command is appended to the dynamic string + * given by dsPtr. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static void +ExpandPercents(winPtr, before, eventPtr, keySym, dsPtr) + TkWindow *winPtr; /* Window where event occurred: needed to + * get input context. */ + char *before; /* Command containing percent expressions + * to be replaced. */ + XEvent *eventPtr; /* X event containing information to be + * used in % replacements. */ + KeySym keySym; /* KeySym: only relevant for KeyPress and + * KeyRelease events). */ + Tcl_DString *dsPtr; /* Dynamic string in which to append new + * command. */ +{ + int spaceNeeded, cvtFlags; /* Used to substitute string as proper Tcl + * list element. */ + int number, flags, length; +#define NUM_SIZE 40 + char *string; + char numStorage[NUM_SIZE+1]; + + if (eventPtr->type < TK_LASTEVENT) { + flags = flagArray[eventPtr->type]; + } else { + flags = 0; + } + while (1) { + /* + * Find everything up to the next % character and append it + * to the result string. + */ + + for (string = before; (*string != 0) && (*string != '%'); string++) { + /* Empty loop body. */ + } + if (string != before) { + Tcl_DStringAppend(dsPtr, before, string-before); + before = string; + } + if (*before == 0) { + break; + } + + /* + * There's a percent sequence here. Process it. + */ + + number = 0; + string = "??"; + switch (before[1]) { + case '#': + number = eventPtr->xany.serial; + goto doNumber; + case 'a': + sprintf(numStorage, "0x%x", (int) eventPtr->xconfigure.above); + string = numStorage; + goto doString; + case 'b': + number = eventPtr->xbutton.button; + goto doNumber; + case 'c': + if (flags & EXPOSE) { + number = eventPtr->xexpose.count; + } + goto doNumber; + case 'd': + if (flags & (CROSSING|FOCUS)) { + if (flags & FOCUS) { + number = eventPtr->xfocus.detail; + } else { + number = eventPtr->xcrossing.detail; + } + string = TkFindStateString(notifyDetail, number); + } + goto doString; + case 'f': + number = eventPtr->xcrossing.focus; + goto doNumber; + case 'h': + if (flags & EXPOSE) { + number = eventPtr->xexpose.height; + } else if (flags & (CONFIG)) { + number = eventPtr->xconfigure.height; + } + goto doNumber; + case 'k': + number = eventPtr->xkey.keycode; + goto doNumber; + case 'm': + if (flags & CROSSING) { + number = eventPtr->xcrossing.mode; + } else if (flags & FOCUS) { + number = eventPtr->xfocus.mode; + } + string = TkFindStateString(notifyMode, number); + goto doString; + case 'o': + if (flags & CREATE) { + number = eventPtr->xcreatewindow.override_redirect; + } else if (flags & MAP) { + number = eventPtr->xmap.override_redirect; + } else if (flags & REPARENT) { + number = eventPtr->xreparent.override_redirect; + } else if (flags & CONFIG) { + number = eventPtr->xconfigure.override_redirect; + } + goto doNumber; + case 'p': + string = TkFindStateString(circPlace, eventPtr->xcirculate.place); + goto doString; + case 's': + if (flags & (KEY_BUTTON_MOTION_VIRTUAL)) { + number = eventPtr->xkey.state; + } else if (flags & CROSSING) { + number = eventPtr->xcrossing.state; + } else if (flags & VISIBILITY) { + string = TkFindStateString(visNotify, + eventPtr->xvisibility.state); + goto doString; + } + goto doNumber; + case 't': + if (flags & (KEY_BUTTON_MOTION_VIRTUAL)) { + number = (int) eventPtr->xkey.time; + } else if (flags & CROSSING) { + number = (int) eventPtr->xcrossing.time; + } else if (flags & PROP) { + number = (int) eventPtr->xproperty.time; + } + goto doNumber; + case 'v': + number = eventPtr->xconfigurerequest.value_mask; + goto doNumber; + case 'w': + if (flags & EXPOSE) { + number = eventPtr->xexpose.width; + } else if (flags & CONFIG) { + number = eventPtr->xconfigure.width; + } + goto doNumber; + case 'x': + if (flags & (KEY_BUTTON_MOTION_VIRTUAL)) { + number = eventPtr->xkey.x; + } else if (flags & CROSSING) { + number = eventPtr->xcrossing.x; + } else if (flags & EXPOSE) { + number = eventPtr->xexpose.x; + } else if (flags & (CREATE|CONFIG|GRAVITY)) { + number = eventPtr->xcreatewindow.x; + } else if (flags & REPARENT) { + number = eventPtr->xreparent.x; + } + goto doNumber; + case 'y': + if (flags & (KEY_BUTTON_MOTION_VIRTUAL)) { + number = eventPtr->xkey.y; + } else if (flags & EXPOSE) { + number = eventPtr->xexpose.y; + } else if (flags & (CREATE|CONFIG|GRAVITY)) { + number = eventPtr->xcreatewindow.y; + } else if (flags & REPARENT) { + number = eventPtr->xreparent.y; + } else if (flags & CROSSING) { + number = eventPtr->xcrossing.y; + + } + goto doNumber; + case 'A': + if (flags & KEY) { + int numChars; + + /* + * If we're using input methods and this is a keypress + * event, invoke XmbTkFindStateString. Otherwise just use + * the older XTkFindStateString. + */ + +#ifdef TK_USE_INPUT_METHODS + Status status; + if ((winPtr->inputContext != NULL) + && (eventPtr->type == KeyPress)) { + numChars = XmbLookupString(winPtr->inputContext, + &eventPtr->xkey, numStorage, NUM_SIZE, + (KeySym *) NULL, &status); + if ((status != XLookupChars) + && (status != XLookupBoth)) { + numChars = 0; + } + } else { + numChars = XLookupString(&eventPtr->xkey, numStorage, + NUM_SIZE, (KeySym *) NULL, + (XComposeStatus *) NULL); + } +#else /* TK_USE_INPUT_METHODS */ + numChars = XLookupString(&eventPtr->xkey, numStorage, + NUM_SIZE, (KeySym *) NULL, + (XComposeStatus *) NULL); +#endif /* TK_USE_INPUT_METHODS */ + numStorage[numChars] = '\0'; + string = numStorage; + } + goto doString; + case 'B': + number = eventPtr->xcreatewindow.border_width; + goto doNumber; + case 'E': + number = (int) eventPtr->xany.send_event; + goto doNumber; + case 'K': + if (flags & KEY) { + char *name; + + name = TkKeysymToString(keySym); + if (name != NULL) { + string = name; + } + } + goto doString; + case 'N': + number = (int) keySym; + goto doNumber; + case 'R': + number = (int) eventPtr->xkey.root; + goto doNumber; + case 'S': + sprintf(numStorage, "0x%x", (int) eventPtr->xkey.subwindow); + string = numStorage; + goto doString; + case 'T': + number = eventPtr->type; + goto doNumber; + case 'W': { + Tk_Window tkwin; + + tkwin = Tk_IdToWindow(eventPtr->xany.display, + eventPtr->xany.window); + if (tkwin != NULL) { + string = Tk_PathName(tkwin); + } else { + string = "??"; + } + goto doString; + } + case 'X': { + Tk_Window tkwin; + int x, y; + int width, height; + + number = eventPtr->xkey.x_root; + tkwin = Tk_IdToWindow(eventPtr->xany.display, + eventPtr->xany.window); + if (tkwin != NULL) { + Tk_GetVRootGeometry(tkwin, &x, &y, &width, &height); + number -= x; + } + goto doNumber; + } + case 'Y': { + Tk_Window tkwin; + int x, y; + int width, height; + + number = eventPtr->xkey.y_root; + tkwin = Tk_IdToWindow(eventPtr->xany.display, + eventPtr->xany.window); + if (tkwin != NULL) { + Tk_GetVRootGeometry(tkwin, &x, &y, &width, &height); + number -= y; + } + goto doNumber; + } + default: + numStorage[0] = before[1]; + numStorage[1] = '\0'; + string = numStorage; + goto doString; + } + + doNumber: + sprintf(numStorage, "%d", number); + string = numStorage; + + doString: + spaceNeeded = Tcl_ScanElement(string, &cvtFlags); + length = Tcl_DStringLength(dsPtr); + Tcl_DStringSetLength(dsPtr, length + spaceNeeded); + spaceNeeded = Tcl_ConvertElement(string, + Tcl_DStringValue(dsPtr) + length, + cvtFlags | TCL_DONT_USE_BRACES); + Tcl_DStringSetLength(dsPtr, length + spaceNeeded); + before += 2; + } +} + +/* + *---------------------------------------------------------------------- + * + * FreeScreenInfo -- + * + * This procedure is invoked when an interpreter is deleted in + * order to free the ScreenInfo structure associated with the + * "tkBind" AssocData. + * + * Results: + * None. + * + * Side effects: + * Storage is freed. + * + *---------------------------------------------------------------------- + */ + +static void +FreeScreenInfo(clientData, interp) + ClientData clientData; /* Pointer to ScreenInfo structure. */ + Tcl_Interp *interp; /* Interpreter that is being deleted. */ +{ + ckfree((char *) clientData); +} + +/* + *---------------------------------------------------------------------- + * + * ChangeScreen -- + * + * This procedure is invoked whenever the current screen changes + * in an application. It invokes a Tcl procedure named + * "tkScreenChanged", passing it the screen name as argument. + * tkScreenChanged does things like making the tkPriv variable + * point to an array for the current display. + * + * Results: + * None. + * + * Side effects: + * Depends on what tkScreenChanged does. If an error occurs + * them tkError will be invoked. + * + *---------------------------------------------------------------------- + */ + +static void +ChangeScreen(interp, dispName, screenIndex) + Tcl_Interp *interp; /* Interpreter in which to invoke + * command. */ + char *dispName; /* Name of new display. */ + int screenIndex; /* Index of new screen. */ +{ + Tcl_DString cmd; + int code; + char screen[30]; + + Tcl_DStringInit(&cmd); + Tcl_DStringAppend(&cmd, "tkScreenChanged ", 16); + Tcl_DStringAppend(&cmd, dispName, -1); + sprintf(screen, ".%d", screenIndex); + Tcl_DStringAppend(&cmd, screen, -1); + code = Tcl_GlobalEval(interp, Tcl_DStringValue(&cmd)); + if (code != TCL_OK) { + Tcl_AddErrorInfo(interp, + "\n (changing screen in event binding)"); + Tcl_BackgroundError(interp); + } +} + + +/* + *---------------------------------------------------------------------- + * + * Tk_EventCmd -- + * + * This procedure is invoked to process the "event" Tcl command. + * It is used to define and generate events. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tk_EventCmd(clientData, interp, argc, argv) + ClientData clientData; /* Main window associated with + * interpreter. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int i; + size_t length; + char *option; + TkWindow *winPtr; + TkVirtualEventTable *vetPtr; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option ?arg1?\"", (char *) NULL); + return TCL_ERROR; + } + + option = argv[1]; + length = strlen(option); + if (length == 0) { + goto badopt; + } + + winPtr = (TkWindow *) Tk_MainWindow(interp); + vetPtr = winPtr->mainPtr->vetPtr; + + if (strncmp(option, "add", length) == 0) { + if (argc < 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " add virtual sequence ?sequence ...?\"", (char *) NULL); + return TCL_ERROR; + } + for (i = 3; i < argc; i++) { + if (CreateVirtualEvent(interp, vetPtr, argv[2], argv[i]) + != TCL_OK) { + return TCL_ERROR; + } + } + } else if (strncmp(option, "delete", length) == 0) { + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " delete virtual ?sequence sequence ...?\"", + (char *) NULL); + return TCL_ERROR; + } + if (argc == 3) { + return DeleteVirtualEvent(interp, vetPtr, argv[2], NULL); + } + for (i = 3; i < argc; i++) { + if (DeleteVirtualEvent(interp, vetPtr, argv[2], argv[i]) + != TCL_OK) { + return TCL_ERROR; + } + } + } else if (strncmp(option, "generate", length) == 0) { + if (argc < 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " generate window event ?options?\"", (char *) NULL); + return TCL_ERROR; + } + return HandleEventGenerate(interp, argc - 2, argv + 2); + } else if (strncmp(option, "info", length) == 0) { + if (argc == 2) { + GetAllVirtualEvents(interp, vetPtr); + return TCL_OK; + } else if (argc == 3) { + return GetVirtualEvent(interp, vetPtr, argv[2]); + } else { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " info ?virtual?\"", (char *) NULL); + return TCL_ERROR; + } + } else { + badopt: + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be add, delete, generate, info", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * CreateVirtualEventTable -- + * + * Set up a new domain in which virtual events may be defined. + * + * Results: + * The return value is a token for the new table, which must + * be passed to procedures like Tk_CreateVirtualEvent(). + * + * Side effects: + * The caller must have already called Tk_CreateBindingTable() to + * properly set up memory used by the entire event-handling subsystem. + * Memory is allocated for the new table. + * + *-------------------------------------------------------------- + */ +static TkVirtualEventTable * +CreateVirtualEventTable() +{ + TkVirtualEventTable *vetPtr; + + if (!initialized) { + panic("CreateVirtualEvent: Tk_CreateBindingTable never called"); + } + vetPtr = (TkVirtualEventTable *) ckalloc(sizeof(TkVirtualEventTable)); + Tcl_InitHashTable(&vetPtr->patternTable, + sizeof(PatternTableKey)/sizeof(int)); + Tcl_InitHashTable(&vetPtr->virtualTable, TCL_ONE_WORD_KEYS); + + return vetPtr; +} + +/* + *-------------------------------------------------------------- + * + * DeleteVirtualEventTable -- + * + * Destroy a virtual event table and free up all its memory. + * The caller should not use virtualEventTable again after + * this procedure returns. + * + * Results: + * None. + * + * Side effects: + * Memory is freed. + * + *-------------------------------------------------------------- + */ + +static void +DeleteVirtualEventTable(vetPtr) + TkVirtualEventTable *vetPtr;/* The virtual event table to be destroyed. */ +{ + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + PatSeq *psPtr, *nextPtr; + + hPtr = Tcl_FirstHashEntry(&vetPtr->patternTable, &search); + for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + psPtr = (PatSeq *) Tcl_GetHashValue(hPtr); + for ( ; psPtr != NULL; psPtr = nextPtr) { + nextPtr = psPtr->nextSeqPtr; + ckfree((char *) psPtr->voPtr); + ckfree((char *) psPtr); + } + } + Tcl_DeleteHashTable(&vetPtr->patternTable); + + hPtr = Tcl_FirstHashEntry(&vetPtr->virtualTable, &search); + for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + ckfree((char *) Tcl_GetHashValue(hPtr)); + } + Tcl_DeleteHashTable(&vetPtr->virtualTable); + + ckfree((char *) vetPtr); +} + +/* + *---------------------------------------------------------------------- + * + * CreateVirtualEvent -- + * + * Add a new definition for a virtual event. If the virtual event + * is already defined, the new definition augments those that + * already exist. + * + * Results: + * The return value is TCL_ERROR if an error occured while + * creating the virtual binding. In this case, an error message + * will be left in interp->result. If all went well then the return + * value is TCL_OK. + * + * Side effects: + * The virtual event may cause future calls to Tk_BindEvent to + * behave differently than they did previously. + * + *---------------------------------------------------------------------- + */ + +static int +CreateVirtualEvent(interp, vetPtr, virtString, eventString) + Tcl_Interp *interp; /* Used for error reporting. */ + TkVirtualEventTable *vetPtr;/* Table in which to augment virtual event. */ + char *virtString; /* Name of new virtual event. */ + char *eventString; /* String describing physical event that + * triggers virtual event. */ +{ + PatSeq *psPtr; + int dummy; + Tcl_HashEntry *vhPtr; + unsigned long eventMask; + PhysicalsOwned *poPtr; + VirtualOwners *voPtr; + Tk_Uid virtUid; + + virtUid = GetVirtualEventUid(interp, virtString); + if (virtUid == NULL) { + return TCL_ERROR; + } + + /* + * Find/create physical event + */ + + psPtr = FindSequence(interp, &vetPtr->patternTable, NULL, eventString, + 1, 0, &eventMask); + if (psPtr == NULL) { + return TCL_ERROR; + } + + /* + * Find/create virtual event. + */ + + vhPtr = Tcl_CreateHashEntry(&vetPtr->virtualTable, virtUid, &dummy); + + /* + * Make virtual event own the physical event. + */ + + poPtr = (PhysicalsOwned *) Tcl_GetHashValue(vhPtr); + if (poPtr == NULL) { + poPtr = (PhysicalsOwned *) ckalloc(sizeof(PhysicalsOwned)); + poPtr->numOwned = 0; + } else { + /* + * See if this virtual event is already defined for this physical + * event and just return if it is. + */ + + int i; + for (i = 0; i < poPtr->numOwned; i++) { + if (poPtr->patSeqs[i] == psPtr) { + return TCL_OK; + } + } + poPtr = (PhysicalsOwned *) ckrealloc((char *) poPtr, + sizeof(PhysicalsOwned) + poPtr->numOwned * sizeof(PatSeq *)); + } + Tcl_SetHashValue(vhPtr, (ClientData) poPtr); + poPtr->patSeqs[poPtr->numOwned] = psPtr; + poPtr->numOwned++; + + /* + * Make physical event so it can trigger the virtual event. + */ + + voPtr = psPtr->voPtr; + if (voPtr == NULL) { + voPtr = (VirtualOwners *) ckalloc(sizeof(VirtualOwners)); + voPtr->numOwners = 0; + } else { + voPtr = (VirtualOwners *) ckrealloc((char *) voPtr, + sizeof(VirtualOwners) + + voPtr->numOwners * sizeof(Tcl_HashEntry *)); + } + psPtr->voPtr = voPtr; + voPtr->owners[voPtr->numOwners] = vhPtr; + voPtr->numOwners++; + + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * DeleteVirtualEvent -- + * + * Remove the definition of a given virtual event. If the + * event string is NULL, all definitions of the virtual event + * will be removed. Otherwise, just the specified definition + * of the virtual event will be removed. + * + * Results: + * The result is a standard Tcl return value. If an error + * occurs then interp->result will contain an error message. + * It is not an error to attempt to delete a virtual event that + * does not exist or a definition that does not exist. + * + * Side effects: + * The virtual event given by virtString may be removed from the + * virtual event table. + * + *-------------------------------------------------------------- + */ + +static int +DeleteVirtualEvent(interp, vetPtr, virtString, eventString) + Tcl_Interp *interp; /* Used for error reporting. */ + TkVirtualEventTable *vetPtr;/* Table in which to delete event. */ + char *virtString; /* String describing event sequence that + * triggers binding. */ + char *eventString; /* The event sequence that should be deleted, + * or NULL to delete all event sequences for + * the entire virtual event. */ +{ + int iPhys; + Tk_Uid virtUid; + Tcl_HashEntry *vhPtr; + PhysicalsOwned *poPtr; + PatSeq *eventPSPtr; + + virtUid = GetVirtualEventUid(interp, virtString); + if (virtUid == NULL) { + return TCL_ERROR; + } + + vhPtr = Tcl_FindHashEntry(&vetPtr->virtualTable, virtUid); + if (vhPtr == NULL) { + return TCL_OK; + } + poPtr = (PhysicalsOwned *) Tcl_GetHashValue(vhPtr); + + eventPSPtr = NULL; + if (eventString != NULL) { + unsigned long eventMask; + + /* + * Delete only the specific physical event associated with the + * virtual event. If the physical event doesn't already exist, or + * the virtual event doesn't own that physical event, return w/o + * doing anything. + */ + + eventPSPtr = FindSequence(interp, &vetPtr->patternTable, NULL, + eventString, 0, 0, &eventMask); + if (eventPSPtr == NULL) { + return (interp->result[0] != '\0') ? TCL_ERROR : TCL_OK; + } + } + + for (iPhys = poPtr->numOwned; --iPhys >= 0; ) { + PatSeq *psPtr = poPtr->patSeqs[iPhys]; + if ((eventPSPtr == NULL) || (psPtr == eventPSPtr)) { + int iVirt; + VirtualOwners *voPtr; + + /* + * Remove association between this physical event and the given + * virtual event that it triggers. + */ + + voPtr = psPtr->voPtr; + for (iVirt = 0; iVirt < voPtr->numOwners; iVirt++) { + if (voPtr->owners[iVirt] == vhPtr) { + break; + } + } + if (iVirt == voPtr->numOwners) { + panic("DeleteVirtualEvent: couldn't find owner"); + } + voPtr->numOwners--; + if (voPtr->numOwners == 0) { + /* + * Removed last reference to this physical event, so + * remove it from physical->virtual map. + */ + PatSeq *prevPtr = (PatSeq *) Tcl_GetHashValue(psPtr->hPtr); + if (prevPtr == psPtr) { + if (psPtr->nextSeqPtr == NULL) { + Tcl_DeleteHashEntry(psPtr->hPtr); + } else { + Tcl_SetHashValue(psPtr->hPtr, + psPtr->nextSeqPtr); + } + } else { + for ( ; ; prevPtr = prevPtr->nextSeqPtr) { + if (prevPtr == NULL) { + panic("Tk_DeleteVirtualEvent couldn't find on hash chain"); + } + if (prevPtr->nextSeqPtr == psPtr) { + prevPtr->nextSeqPtr = psPtr->nextSeqPtr; + break; + } + } + } + ckfree((char *) psPtr->voPtr); + ckfree((char *) psPtr); + } else { + /* + * This physical event still triggers some other virtual + * event(s). Consolidate the list of virtual owners for + * this physical event so it no longer triggers the + * given virtual event. + */ + voPtr->owners[iVirt] = voPtr->owners[voPtr->numOwners]; + } + + /* + * Now delete the virtual event's reference to the physical + * event. + */ + + poPtr->numOwned--; + if (eventPSPtr != NULL && poPtr->numOwned != 0) { + /* + * Just deleting this one physical event. Consolidate list + * of owned physical events and return. + */ + + poPtr->patSeqs[iPhys] = poPtr->patSeqs[poPtr->numOwned]; + return TCL_OK; + } + } + } + + if (poPtr->numOwned == 0) { + /* + * All the physical events for this virtual event were deleted, + * either because there was only one associated physical event or + * because the caller was deleting the entire virtual event. Now + * the virtual event itself should be deleted. + */ + + ckfree((char *) poPtr); + Tcl_DeleteHashEntry(vhPtr); + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * GetVirtualEvent -- + * + * Return the list of physical events that can invoke the + * given virtual event. + * + * Results: + * The return value is TCL_OK and interp->result is filled with the + * string representation of the physical events associated with the + * virtual event; if there are no physical events for the given virtual + * event, interp->result is filled with and empty string. If the + * virtual event string is improperly formed, then TCL_ERROR is + * returned and an error message is left in interp->result. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static int +GetVirtualEvent(interp, vetPtr, virtString) + Tcl_Interp *interp; /* Interpreter for reporting. */ + TkVirtualEventTable *vetPtr;/* Table in which to look for event. */ + char *virtString; /* String describing virtual event. */ +{ + Tcl_HashEntry *vhPtr; + Tcl_DString ds; + int iPhys; + PhysicalsOwned *poPtr; + Tk_Uid virtUid; + + virtUid = GetVirtualEventUid(interp, virtString); + if (virtUid == NULL) { + return TCL_ERROR; + } + + vhPtr = Tcl_FindHashEntry(&vetPtr->virtualTable, virtUid); + if (vhPtr == NULL) { + return TCL_OK; + } + + Tcl_DStringInit(&ds); + + poPtr = (PhysicalsOwned *) Tcl_GetHashValue(vhPtr); + for (iPhys = 0; iPhys < poPtr->numOwned; iPhys++) { + Tcl_DStringSetLength(&ds, 0); + GetPatternString(poPtr->patSeqs[iPhys], &ds); + Tcl_AppendElement(interp, Tcl_DStringValue(&ds)); + } + Tcl_DStringFree(&ds); + + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * GetAllVirtualEvents -- + * + * Return a list that contains the names of all the virtual + * event defined. + * + * Results: + * There is no return value. Interp->result is modified to + * hold a Tcl list with one entry for each virtual event in + * virtualTable. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static void +GetAllVirtualEvents(interp, vetPtr) + Tcl_Interp *interp; /* Interpreter returning result. */ + TkVirtualEventTable *vetPtr;/* Table containing events. */ +{ + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Tcl_DString ds; + + Tcl_DStringInit(&ds); + + hPtr = Tcl_FirstHashEntry(&vetPtr->virtualTable, &search); + for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + Tcl_DStringSetLength(&ds, 0); + Tcl_DStringAppend(&ds, "<<", 2); + Tcl_DStringAppend(&ds, Tcl_GetHashKey(hPtr->tablePtr, hPtr), -1); + Tcl_DStringAppend(&ds, ">>", 2); + Tcl_AppendElement(interp, Tcl_DStringValue(&ds)); + } + + Tcl_DStringFree(&ds); +} + +/* + *--------------------------------------------------------------------------- + * + * HandleEventGenerate -- + * + * Helper function for the "event generate" command. Generate and + * process an XEvent, constructed from information parsed from the + * event description string and its optional arguments. + * + * argv[0] contains name of the target window. + * argv[1] contains pattern string for one event (e.g, ). + * argv[2..argc-1] contains -field/option pairs for specifying + * additional detail in the generated event. + * + * Either virtual or physical events can be generated this way. + * The event description string must contain the specification + * for only one event. + * + * Results: + * None. + * + * Side effects: + * When constructing the event, + * event.xany.serial is filled with the current X serial number. + * event.xany.window is filled with the target window. + * event.xany.display is filled with the target window's display. + * Any other fields in eventPtr which are not specified by the pattern + * string or the optional arguments, are set to 0. + * + * The event may be handled sychronously or asynchronously, depending + * on the value specified by the optional "-when" option. The + * default setting is synchronous. + * + *--------------------------------------------------------------------------- + */ +static int +HandleEventGenerate(interp, argc, argv) + Tcl_Interp *interp; /* Interp for error messages and name lookup. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Pattern pat; + Tk_Window tkwin, main; + char *p; + unsigned long eventMask; + int count, i, flags, synch; + Tcl_QueuePosition pos; + XEvent event; + + main = Tk_MainWindow(interp); + tkwin = Tk_NameToWindow(interp, argv[0], main); + if (tkwin == NULL) { + return TCL_ERROR; + } + + p = argv[1]; + count = ParseEventDescription(interp, &p, &pat, &eventMask); + if (count == 0) { + return TCL_ERROR; + } + if (count != 1) { + interp->result = "Double or Triple modifier not allowed"; + return TCL_ERROR; + } + if (*p != '\0') { + interp->result = "only one event specification allowed"; + return TCL_ERROR; + } + if (argc & 1) { + Tcl_AppendResult(interp, "value for \"", argv[argc - 1], + "\" missing", (char *) NULL); + return TCL_ERROR; + } + + memset((VOID *) &event, 0, sizeof(event)); + event.xany.type = pat.eventType; + event.xany.serial = NextRequest(Tk_Display(tkwin)); + event.xany.send_event = False; + event.xany.window = Tk_WindowId(tkwin); + event.xany.display = Tk_Display(tkwin); + + flags = flagArray[event.xany.type]; + if (flags & (KEY_BUTTON_MOTION_VIRTUAL)) { + event.xkey.state = pat.needMods; + if (flags & KEY) { + /* + * When mapping from a keysym to a keycode, need information about + * the modifier state that should be used so that when they call + * XKeycodeToKeysym taking into account the xkey.state, they will + * get back the original keysym. + */ + + event.xkey.keycode = XKeysymToKeycode(event.xany.display, + pat.detail.keySym); + for (i = 0; i < 4; i++) { + if (XKeycodeToKeysym(event.xany.display, event.xkey.keycode, + i) == pat.detail.keySym) { + if (i & 1) { + event.xkey.state |= ShiftMask; + } + if (i & 2) { + TkDisplay *dispPtr = ((TkWindow *) tkwin)->dispPtr; + event.xkey.state |= dispPtr->modeModMask; + } + break; + } + } + } else if (flags & BUTTON) { + event.xbutton.button = pat.detail.button; + } else if (flags & VIRTUAL) { + ((XVirtualEvent *) &event)->name = pat.detail.name; + } + } + if (flags & (CREATE|DESTROY|UNMAP|MAP|REPARENT|CONFIG|GRAVITY|CIRC)) { + event.xcreatewindow.window = event.xany.window; + } + + /* + * Process the remaining arguments to fill in additional fields + * of the event. + */ + + synch = 1; + pos = TCL_QUEUE_TAIL; + for (i = 2; i < argc; i += 2) { + char *field, *value; + Tk_Window tkwin2; + int number; + KeySym keysym; + + field = argv[i]; + value = argv[i+1]; + + if (strcmp(field, "-when") == 0) { + if (strcmp(value, "now") == 0) { + synch = 1; + } else if (strcmp(value, "head") == 0) { + pos = TCL_QUEUE_HEAD; + synch = 0; + } else if (strcmp(value, "mark") == 0) { + pos = TCL_QUEUE_MARK; + synch = 0; + } else if (strcmp(value, "tail") == 0) { + pos = TCL_QUEUE_TAIL; + synch = 0; + } else { + Tcl_AppendResult(interp, "bad position \"", value, + "\": should be now, head, mark, tail", (char *) NULL); + return TCL_ERROR; + } + } else if (strcmp(field, "-above") == 0) { + if (value[0] == '.') { + tkwin2 = Tk_NameToWindow(interp, value, main); + if (tkwin2 == NULL) { + return TCL_ERROR; + } + number = Tk_WindowId(tkwin2); + } else if (Tcl_GetInt(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + if (flags & CONFIG) { + event.xconfigure.above = number; + } else { + goto badopt; + } + } else if (strcmp(field, "-borderwidth") == 0) { + if (Tk_GetPixels(interp, tkwin, value, &number) != TCL_OK) { + return TCL_ERROR; + } + if (flags & (CREATE|CONFIG)) { + event.xcreatewindow.border_width = number; + } else { + goto badopt; + } + } else if (strcmp(field, "-button") == 0) { + if (Tcl_GetInt(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + if (flags & BUTTON) { + event.xbutton.button = number; + } else { + goto badopt; + } + } else if (strcmp(field, "-count") == 0) { + if (Tcl_GetInt(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + if (flags & EXPOSE) { + event.xexpose.count = number; + } else { + goto badopt; + } + } else if (strcmp(field, "-detail") == 0) { + number = TkFindStateNum(interp, field, notifyDetail, value); + if (number < 0) { + return TCL_ERROR; + } + if (flags & FOCUS) { + event.xfocus.detail = number; + } else if (flags & CROSSING) { + event.xcrossing.detail = number; + } else { + goto badopt; + } + } else if (strcmp(field, "-focus") == 0) { + if (Tcl_GetBoolean(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + if (flags & CROSSING) { + event.xcrossing.focus = number; + } else { + goto badopt; + } + } else if (strcmp(field, "-height") == 0) { + if (Tk_GetPixels(interp, tkwin, value, &number) != TCL_OK) { + return TCL_ERROR; + } + if (flags & EXPOSE) { + event.xexpose.height = number; + } else if (flags & CONFIG) { + event.xconfigure.height = number; + } else { + goto badopt; + } + } else if (strcmp(field, "-keycode") == 0) { + if (Tcl_GetInt(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + if (flags & KEY) { + event.xkey.keycode = number; + } else { + goto badopt; + } + } else if (strcmp(field, "-keysym") == 0) { + keysym = TkStringToKeysym(value); + if (keysym == NoSymbol) { + Tcl_AppendResult(interp, "unknown keysym \"", value, + "\"", (char *) NULL); + return TCL_ERROR; + } + number = XKeysymToKeycode(event.xany.display, keysym); + if (number == 0) { + Tcl_AppendResult(interp, "no keycode for keysym \"", value, + "\"", (char *) NULL); + return TCL_ERROR; + } + if (flags & KEY) { + event.xkey.keycode = number; + } else { + goto badopt; + } + } else if (strcmp(field, "-mode") == 0) { + number = TkFindStateNum(interp, field, notifyMode, value); + if (number < 0) { + return TCL_ERROR; + } + if (flags & CROSSING) { + event.xcrossing.mode = number; + } else if (flags & FOCUS) { + event.xfocus.mode = number; + } else { + goto badopt; + } + } else if (strcmp(field, "-override") == 0) { + if (Tcl_GetBoolean(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + if (flags & CREATE) { + event.xcreatewindow.override_redirect = number; + } else if (flags & MAP) { + event.xmap.override_redirect = number; + } else if (flags & REPARENT) { + event.xreparent.override_redirect = number; + } else if (flags & CONFIG) { + event.xconfigure.override_redirect = number; + } else { + goto badopt; + } + } else if (strcmp(field, "-place") == 0) { + number = TkFindStateNum(interp, field, circPlace, value); + if (number < 0) { + return TCL_ERROR; + } + if (flags & CIRC) { + event.xcirculate.place = number; + } else { + goto badopt; + } + } else if (strcmp(field, "-root") == 0) { + if (value[0] == '.') { + tkwin2 = Tk_NameToWindow(interp, value, main); + if (tkwin2 == NULL) { + return TCL_ERROR; + } + number = Tk_WindowId(tkwin2); + } else if (Tcl_GetInt(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + if (flags & (KEY_BUTTON_MOTION_VIRTUAL|CROSSING)) { + event.xkey.root = number; + } else { + goto badopt; + } + } else if (strcmp(field, "-rootx") == 0) { + if (Tk_GetPixels(interp, tkwin, value, &number) != TCL_OK) { + return TCL_ERROR; + } + if (flags & (KEY_BUTTON_MOTION_VIRTUAL|CROSSING)) { + event.xkey.x_root = number; + } else { + goto badopt; + } + } else if (strcmp(field, "-rooty") == 0) { + if (Tk_GetPixels(interp, tkwin, value, &number) != TCL_OK) { + return TCL_ERROR; + } + if (flags & (KEY_BUTTON_MOTION_VIRTUAL|CROSSING)) { + event.xkey.y_root = number; + } else { + goto badopt; + } + } else if (strcmp(field, "-sendevent") == 0) { + if (Tcl_GetBoolean(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + event.xany.send_event = number; + } else if (strcmp(field, "-serial") == 0) { + if (Tcl_GetInt(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + event.xany.serial = number; + } else if (strcmp(field, "-state") == 0) { + if (flags & (KEY_BUTTON_MOTION_VIRTUAL|CROSSING)) { + if (Tcl_GetInt(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + if (flags & (KEY_BUTTON_MOTION_VIRTUAL)) { + event.xkey.state = number; + } else { + event.xcrossing.state = number; + } + } else if (flags & VISIBILITY) { + number = TkFindStateNum(interp, field, visNotify, value); + if (number < 0) { + return TCL_ERROR; + } + event.xvisibility.state = number; + } else { + goto badopt; + } + } else if (strcmp(field, "-subwindow") == 0) { + if (value[0] == '.') { + tkwin2 = Tk_NameToWindow(interp, value, main); + if (tkwin2 == NULL) { + return TCL_ERROR; + } + number = Tk_WindowId(tkwin2); + } else if (Tcl_GetInt(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + if (flags & (KEY_BUTTON_MOTION_VIRTUAL|CROSSING)) { + event.xkey.subwindow = number; + } else { + goto badopt; + } + } else if (strcmp(field, "-time") == 0) { + if (Tcl_GetInt(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + if (flags & (KEY_BUTTON_MOTION_VIRTUAL|CROSSING)) { + event.xkey.time = (Time) number; + } else if (flags & PROP) { + event.xproperty.time = (Time) number; + } else { + goto badopt; + } + } else if (strcmp(field, "-width") == 0) { + if (Tk_GetPixels(interp, tkwin, value, &number) != TCL_OK) { + return TCL_ERROR; + } + if (flags & EXPOSE) { + event.xexpose.width = number; + } else if (flags & (CREATE|CONFIG)) { + event.xcreatewindow.width = number; + } else { + goto badopt; + } + } else if (strcmp(field, "-window") == 0) { + if (value[0] == '.') { + tkwin2 = Tk_NameToWindow(interp, value, main); + if (tkwin2 == NULL) { + return TCL_ERROR; + } + number = Tk_WindowId(tkwin2); + } else if (Tcl_GetInt(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + if (flags & (CREATE|DESTROY|UNMAP|MAP|REPARENT|CONFIG + |GRAVITY|CIRC)) { + event.xcreatewindow.window = number; + } else { + goto badopt; + } + } else if (strcmp(field, "-x") == 0) { + int rootX, rootY; + if (Tk_GetPixels(interp, tkwin, value, &number) != TCL_OK) { + return TCL_ERROR; + } + Tk_GetRootCoords(tkwin, &rootX, &rootY); + rootX += number; + if (flags & (KEY_BUTTON_MOTION_VIRTUAL|CROSSING)) { + event.xkey.x = number; + event.xkey.x_root = rootX; + } else if (flags & EXPOSE) { + event.xexpose.x = number; + } else if (flags & (CREATE|CONFIG|GRAVITY)) { + event.xcreatewindow.x = number; + } else if (flags & REPARENT) { + event.xreparent.x = number; + } else { + goto badopt; + } + } else if (strcmp(field, "-y") == 0) { + int rootX, rootY; + if (Tk_GetPixels(interp, tkwin, value, &number) != TCL_OK) { + return TCL_ERROR; + } + Tk_GetRootCoords(tkwin, &rootX, &rootY); + rootY += number; + if (flags & (KEY_BUTTON_MOTION_VIRTUAL|CROSSING)) { + event.xkey.y = number; + event.xkey.y_root = rootY; + } else if (flags & EXPOSE) { + event.xexpose.y = number; + } else if (flags & (CREATE|CONFIG|GRAVITY)) { + event.xcreatewindow.y = number; + } else if (flags & REPARENT) { + event.xreparent.y = number; + } else { + goto badopt; + } + } else { + badopt: + Tcl_AppendResult(interp, "bad option to ", argv[1], + " event: \"", field, "\"", (char *) NULL); + return TCL_ERROR; + } + } + + if (synch != 0) { + Tk_HandleEvent(&event); + } else { + Tk_QueueWindowEvent(&event, pos); + } + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * GetVirtualEventUid -- + * + * Determine if the given string is in the proper format for a + * virtual event. + * + * Results: + * The return value is NULL if the virtual event string was + * not in the proper format. In this case, an error message + * will be left in interp->result. Otherwise the return + * value is a Tk_Uid that represents the virtual event. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ +static Tk_Uid +GetVirtualEventUid(interp, virtString) + Tcl_Interp *interp; + char *virtString; +{ + Tk_Uid uid; + int length; + + length = strlen(virtString); + + if (length < 5 || virtString[0] != '<' || virtString[1] != '<' || + virtString[length - 2] != '>' || virtString[length - 1] != '>') { + Tcl_AppendResult(interp, "virtual event \"", virtString, + "\" is badly formed", (char *) NULL); + return NULL; + } + virtString[length - 2] = '\0'; + uid = Tk_GetUid(virtString + 2); + virtString[length - 2] = '>'; + + return uid; +} + + +/* + *---------------------------------------------------------------------- + * + * FindSequence -- + * + * Find the entry in the pattern table that corresponds to a + * particular pattern string, and return a pointer to that + * entry. + * + * Results: + * The return value is normally a pointer to the PatSeq + * in patternTable that corresponds to eventString. If an error + * was found while parsing eventString, or if "create" is 0 and + * no pattern sequence previously existed, then NULL is returned + * and interp->result contains a message describing the problem. + * If no pattern sequence previously existed for eventString, then + * a new one is created with a NULL command field. In a successful + * return, *maskPtr is filled in with a mask of the event types + * on which the pattern sequence depends. + * + * Side effects: + * A new pattern sequence may be allocated. + * + *---------------------------------------------------------------------- + */ + +static PatSeq * +FindSequence(interp, patternTablePtr, object, eventString, create, + allowVirtual, maskPtr) + Tcl_Interp *interp; /* Interpreter to use for error + * reporting. */ + Tcl_HashTable *patternTablePtr; /* Table to use for lookup. */ + ClientData object; /* For binding table, token for object with + * which binding is associated. + * For virtual event table, NULL. */ + char *eventString; /* String description of pattern to + * match on. See user documentation + * for details. */ + int create; /* 0 means don't create the entry if + * it doesn't already exist. Non-zero + * means create. */ + int allowVirtual; /* 0 means that virtual events are not + * allowed in the sequence. Non-zero + * otherwise. */ + unsigned long *maskPtr; /* *maskPtr is filled in with the event + * types on which this pattern sequence + * depends. */ +{ + + Pattern pats[EVENT_BUFFER_SIZE]; + int numPats, virtualFound; + char *p; + Pattern *patPtr; + PatSeq *psPtr; + Tcl_HashEntry *hPtr; + int flags, count, new; + size_t sequenceSize; + unsigned long eventMask; + PatternTableKey key; + + /* + *------------------------------------------------------------- + * Step 1: parse the pattern string to produce an array + * of Patterns. The array is generated backwards, so + * that the lowest-indexed pattern corresponds to the last + * event that must occur. + *------------------------------------------------------------- + */ + + p = eventString; + flags = 0; + eventMask = 0; + virtualFound = 0; + + patPtr = &pats[EVENT_BUFFER_SIZE-1]; + for (numPats = 0; numPats < EVENT_BUFFER_SIZE; numPats++, patPtr--) { + while (isspace(UCHAR(*p))) { + p++; + } + if (*p == '\0') { + break; + } + + count = ParseEventDescription(interp, &p, patPtr, &eventMask); + if (count == 0) { + return NULL; + } + + if (eventMask & VirtualEventMask) { + if (allowVirtual == 0) { + interp->result = + "virtual event not allowed in definition of another virtual event"; + return NULL; + } + virtualFound = 1; + } + + /* + * Replicate events for DOUBLE and TRIPLE. + */ + + if ((count > 1) && (numPats < EVENT_BUFFER_SIZE-1)) { + flags |= PAT_NEARBY; + patPtr[-1] = patPtr[0]; + patPtr--; + numPats++; + if ((count == 3) && (numPats < EVENT_BUFFER_SIZE-1)) { + patPtr[-1] = patPtr[0]; + patPtr--; + numPats++; + } + } + } + + /* + *------------------------------------------------------------- + * Step 2: find the sequence in the binding table if it exists, + * and add a new sequence to the table if it doesn't. + *------------------------------------------------------------- + */ + + if (numPats == 0) { + interp->result = "no events specified in binding"; + return NULL; + } + if ((numPats > 1) && (virtualFound != 0)) { + interp->result = "virtual events may not be composed"; + return NULL; + } + + patPtr = &pats[EVENT_BUFFER_SIZE-numPats]; + memset(&key, 0, sizeof(key)); + key.object = object; + key.type = patPtr->eventType; + key.detail = patPtr->detail; + hPtr = Tcl_CreateHashEntry(patternTablePtr, (char *) &key, &new); + sequenceSize = numPats*sizeof(Pattern); + if (!new) { + for (psPtr = (PatSeq *) Tcl_GetHashValue(hPtr); psPtr != NULL; + psPtr = psPtr->nextSeqPtr) { + if ((numPats == psPtr->numPats) + && ((flags & PAT_NEARBY) == (psPtr->flags & PAT_NEARBY)) + && (memcmp((char *) patPtr, (char *) psPtr->pats, + sequenceSize) == 0)) { + goto done; + } + } + } + if (!create) { + if (new) { + Tcl_DeleteHashEntry(hPtr); + } +/* Tcl_AppendResult(interp, "no binding exists for \"", + eventString, "\"", (char *) NULL);*/ + return NULL; + } + psPtr = (PatSeq *) ckalloc((unsigned) (sizeof(PatSeq) + + (numPats-1)*sizeof(Pattern))); + psPtr->numPats = numPats; + psPtr->command = NULL; + psPtr->flags = flags; + psPtr->nextSeqPtr = (PatSeq *) Tcl_GetHashValue(hPtr); + psPtr->hPtr = hPtr; + psPtr->voPtr = NULL; + psPtr->nextObjPtr = NULL; + Tcl_SetHashValue(hPtr, psPtr); + + memcpy((VOID *) psPtr->pats, (VOID *) patPtr, sequenceSize); + + done: + *maskPtr = eventMask; + return psPtr; +} + +/* + *--------------------------------------------------------------------------- + * + * ParseEventDescription -- + * + * Fill Pattern buffer with information about event from + * event string. + * + * Results: + * Leaves error message in interp and returns 0 if there was an + * error due to a badly formed event string. Returns 1 if proper + * event was specified, 2 if Double modifier was used in event + * string, or 3 if Triple was used. + * + * Side effects: + * On exit, eventStringPtr points to rest of event string (after the + * closing '>', so that this procedure can be called repeatedly to + * parse all the events in the entire sequence. + * + *--------------------------------------------------------------------------- + */ + +static int +ParseEventDescription(interp, eventStringPtr, patPtr, + eventMaskPtr) + Tcl_Interp *interp; /* For error messages. */ + char **eventStringPtr; /* On input, holds a pointer to start of + * event string. On exit, gets pointer to + * rest of string after parsed event. */ + Pattern *patPtr; /* Filled with the pattern parsed from the + * event string. */ + unsigned long *eventMaskPtr;/* Filled with event mask of matched event. */ + +{ + char *p; + unsigned long eventMask; + int count, eventFlags; +#define FIELD_SIZE 48 + char field[FIELD_SIZE]; + Tcl_HashEntry *hPtr; + + p = *eventStringPtr; + + patPtr->eventType = -1; + patPtr->needMods = 0; + patPtr->detail.clientData = 0; + + eventMask = 0; + count = 1; + + /* + * Handle simple ASCII characters. + */ + + if (*p != '<') { + char string[2]; + + patPtr->eventType = KeyPress; + eventMask = KeyPressMask; + string[0] = *p; + string[1] = 0; + patPtr->detail.keySym = TkStringToKeysym(string); + if (patPtr->detail.keySym == NoSymbol) { + if (isprint(UCHAR(*p))) { + patPtr->detail.keySym = *p; + } else { + sprintf(interp->result, + "bad ASCII character 0x%x", (unsigned char) *p); + return 0; + } + } + p++; + goto end; + } + + /* + * A fancier event description. This can be either a virtual event + * or a physical event. + * + * A virtual event description consists of: + * + * 1. double open angle brackets. + * 2. virtual event name. + * 3. double close angle brackets. + * + * A physical event description consists of: + * + * 1. open angle bracket. + * 2. any number of modifiers, each followed by spaces + * or dashes. + * 3. an optional event name. + * 4. an option button or keysym name. Either this or + * item 3 *must* be present; if both are present + * then they are separated by spaces or dashes. + * 5. a close angle bracket. + */ + + p++; + if (*p == '<') { + /* + * This is a virtual event: soak up all the characters up to + * the next '>'. + */ + + char *field = p + 1; + p = strchr(field, '>'); + if (p == field) { + interp->result = "virtual event \"<<>>\" is badly formed"; + return 0; + } + if ((p == NULL) || (p[1] != '>')) { + interp->result = "missing \">\" in virtual binding"; + return 0; + } + *p = '\0'; + patPtr->eventType = VirtualEvent; + eventMask = VirtualEventMask; + patPtr->detail.name = Tk_GetUid(field); + *p = '>'; + + p += 2; + goto end; + } + + while (1) { + ModInfo *modPtr; + p = GetField(p, field, FIELD_SIZE); + hPtr = Tcl_FindHashEntry(&modTable, field); + if (hPtr == NULL) { + break; + } + modPtr = (ModInfo *) Tcl_GetHashValue(hPtr); + patPtr->needMods |= modPtr->mask; + if (modPtr->flags & (DOUBLE|TRIPLE)) { + if (modPtr->flags & DOUBLE) { + count = 2; + } else { + count = 3; + } + } + while ((*p == '-') || isspace(UCHAR(*p))) { + p++; + } + } + + eventFlags = 0; + hPtr = Tcl_FindHashEntry(&eventTable, field); + if (hPtr != NULL) { + EventInfo *eiPtr; + eiPtr = (EventInfo *) Tcl_GetHashValue(hPtr); + + patPtr->eventType = eiPtr->type; + eventFlags = flagArray[eiPtr->type]; + eventMask = eiPtr->eventMask; + while ((*p == '-') || isspace(UCHAR(*p))) { + p++; + } + p = GetField(p, field, FIELD_SIZE); + } + if (*field != '\0') { + if ((*field >= '1') && (*field <= '5') && (field[1] == '\0')) { + if (eventFlags == 0) { + patPtr->eventType = ButtonPress; + eventMask = ButtonPressMask; + } else if (eventFlags & KEY) { + goto getKeysym; + } else if ((eventFlags & BUTTON) == 0) { + Tcl_AppendResult(interp, "specified button \"", field, + "\" for non-button event", (char *) NULL); + return 0; + } + patPtr->detail.button = (*field - '0'); + } else { + getKeysym: + patPtr->detail.keySym = TkStringToKeysym(field); + if (patPtr->detail.keySym == NoSymbol) { + Tcl_AppendResult(interp, "bad event type or keysym \"", + field, "\"", (char *) NULL); + return 0; + } + if (eventFlags == 0) { + patPtr->eventType = KeyPress; + eventMask = KeyPressMask; + } else if ((eventFlags & KEY) == 0) { + Tcl_AppendResult(interp, "specified keysym \"", field, + "\" for non-key event", (char *) NULL); + return 0; + } + } + } else if (eventFlags == 0) { + interp->result = "no event type or button # or keysym"; + return 0; + } + + while ((*p == '-') || isspace(UCHAR(*p))) { + p++; + } + if (*p != '>') { + while (*p != '\0') { + p++; + if (*p == '>') { + interp->result = "extra characters after detail in binding"; + return 0; + } + } + interp->result = "missing \">\" in binding"; + return 0; + } + p++; + +end: + *eventStringPtr = p; + *eventMaskPtr |= eventMask; + return count; +} + +/* + *---------------------------------------------------------------------- + * + * GetField -- + * + * Used to parse pattern descriptions. Copies up to + * size characters from p to copy, stopping at end of + * string, space, "-", ">", or whenever size is + * exceeded. + * + * Results: + * The return value is a pointer to the character just + * after the last one copied (usually "-" or space or + * ">", but could be anything if size was exceeded). + * Also places NULL-terminated string (up to size + * character, including NULL), at copy. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +GetField(p, copy, size) + char *p; /* Pointer to part of pattern. */ + char *copy; /* Place to copy field. */ + int size; /* Maximum number of characters to + * copy. */ +{ + while ((*p != '\0') && !isspace(UCHAR(*p)) && (*p != '>') + && (*p != '-') && (size > 1)) { + *copy = *p; + p++; + copy++; + size--; + } + *copy = '\0'; + return p; +} + +/* + *--------------------------------------------------------------------------- + * + * GetPatternString -- + * + * Produce a string version of the given event, for displaying to + * the user. + * + * Results: + * The string is left in dsPtr. + * + * Side effects: + * It is the caller's responsibility to initialize the DString before + * and to free it after calling this procedure. + * + *--------------------------------------------------------------------------- + */ +static void +GetPatternString(psPtr, dsPtr) + PatSeq *psPtr; + Tcl_DString *dsPtr; +{ + Pattern *patPtr; + char c, buffer[10]; + int patsLeft, needMods; + ModInfo *modPtr; + EventInfo *eiPtr; + + /* + * The order of the patterns in the sequence is backwards from the order + * in which they must be output. + */ + + for (patsLeft = psPtr->numPats, patPtr = &psPtr->pats[psPtr->numPats - 1]; + patsLeft > 0; patsLeft--, patPtr--) { + + /* + * Check for simple case of an ASCII character. + */ + + if ((patPtr->eventType == KeyPress) + && ((psPtr->flags & PAT_NEARBY) == 0) + && (patPtr->needMods == 0) + && (patPtr->detail.keySym < 128) + && isprint(UCHAR(patPtr->detail.keySym)) + && (patPtr->detail.keySym != '<') + && (patPtr->detail.keySym != ' ')) { + + c = (char) patPtr->detail.keySym; + Tcl_DStringAppend(dsPtr, &c, 1); + continue; + } + + /* + * Check for virtual event. + */ + + if (patPtr->eventType == VirtualEvent) { + Tcl_DStringAppend(dsPtr, "<<", 2); + Tcl_DStringAppend(dsPtr, patPtr->detail.name, -1); + Tcl_DStringAppend(dsPtr, ">>", 2); + continue; + } + + /* + * It's a more general event specification. First check + * for "Double" or "Triple", then modifiers, then event type, + * then keysym or button detail. + */ + + Tcl_DStringAppend(dsPtr, "<", 1); + if ((psPtr->flags & PAT_NEARBY) && (patsLeft > 1) + && (memcmp((char *) patPtr, (char *) (patPtr-1), + sizeof(Pattern)) == 0)) { + patsLeft--; + patPtr--; + if ((patsLeft > 1) && (memcmp((char *) patPtr, + (char *) (patPtr-1), sizeof(Pattern)) == 0)) { + patsLeft--; + patPtr--; + Tcl_DStringAppend(dsPtr, "Triple-", 7); + } else { + Tcl_DStringAppend(dsPtr, "Double-", 7); + } + } + for (needMods = patPtr->needMods, modPtr = modArray; + needMods != 0; modPtr++) { + if (modPtr->mask & needMods) { + needMods &= ~modPtr->mask; + Tcl_DStringAppend(dsPtr, modPtr->name, -1); + Tcl_DStringAppend(dsPtr, "-", 1); + } + } + for (eiPtr = eventArray; eiPtr->name != NULL; eiPtr++) { + if (eiPtr->type == patPtr->eventType) { + Tcl_DStringAppend(dsPtr, eiPtr->name, -1); + if (patPtr->detail.clientData != 0) { + Tcl_DStringAppend(dsPtr, "-", 1); + } + break; + } + } + + if (patPtr->detail.clientData != 0) { + if ((patPtr->eventType == KeyPress) + || (patPtr->eventType == KeyRelease)) { + char *string; + + string = TkKeysymToString(patPtr->detail.keySym); + if (string != NULL) { + Tcl_DStringAppend(dsPtr, string, -1); + } + } else { + sprintf(buffer, "%d", patPtr->detail.button); + Tcl_DStringAppend(dsPtr, buffer, -1); + } + } + Tcl_DStringAppend(dsPtr, ">", 1); + } +} + +/* + *---------------------------------------------------------------------- + * + * GetKeySym -- + * + * Given an X KeyPress or KeyRelease event, map the + * keycode in the event into a KeySym. + * + * Results: + * The return value is the KeySym corresponding to + * eventPtr, or NoSymbol if no matching Keysym could be + * found. + * + * Side effects: + * In the first call for a given display, keycode-to- + * KeySym maps get loaded. + * + *---------------------------------------------------------------------- + */ + +static KeySym +GetKeySym(dispPtr, eventPtr) + TkDisplay *dispPtr; /* Display in which to + * map keycode. */ + XEvent *eventPtr; /* Description of X event. */ +{ + KeySym sym; + int index; + + /* + * Refresh the mapping information if it's stale + */ + + if (dispPtr->bindInfoStale) { + InitKeymapInfo(dispPtr); + } + + /* + * Figure out which of the four slots in the keymap vector to + * use for this key. Refer to Xlib documentation for more info + * on how this computation works. + */ + + index = 0; + if (eventPtr->xkey.state & dispPtr->modeModMask) { + index = 2; + } + if ((eventPtr->xkey.state & ShiftMask) + || ((dispPtr->lockUsage != LU_IGNORE) + && (eventPtr->xkey.state & LockMask))) { + index += 1; + } + sym = XKeycodeToKeysym(dispPtr->display, eventPtr->xkey.keycode, index); + + /* + * Special handling: if the key was shifted because of Lock, but + * lock is only caps lock, not shift lock, and the shifted keysym + * isn't upper-case alphabetic, then switch back to the unshifted + * keysym. + */ + + if ((index & 1) && !(eventPtr->xkey.state & ShiftMask) + && (dispPtr->lockUsage == LU_CAPS)) { + if (!(((sym >= XK_A) && (sym <= XK_Z)) + || ((sym >= XK_Agrave) && (sym <= XK_Odiaeresis)) + || ((sym >= XK_Ooblique) && (sym <= XK_Thorn)))) { + index &= ~1; + sym = XKeycodeToKeysym(dispPtr->display, eventPtr->xkey.keycode, + index); + } + } + + /* + * Another bit of special handling: if this is a shifted key and there + * is no keysym defined, then use the keysym for the unshifted key. + */ + + if ((index & 1) && (sym == NoSymbol)) { + sym = XKeycodeToKeysym(dispPtr->display, eventPtr->xkey.keycode, + index & ~1); + } + return sym; +} + +/* + *-------------------------------------------------------------- + * + * InitKeymapInfo -- + * + * This procedure is invoked to scan keymap information + * to recompute stuff that's important for binding, such + * as the modifier key (if any) that corresponds to "mode + * switch". + * + * Results: + * None. + * + * Side effects: + * Keymap-related information in dispPtr is updated. + * + *-------------------------------------------------------------- + */ + +static void +InitKeymapInfo(dispPtr) + TkDisplay *dispPtr; /* Display for which to recompute keymap + * information. */ +{ + XModifierKeymap *modMapPtr; + KeyCode *codePtr; + KeySym keysym; + int count, i, j, max, arraySize; +#define KEYCODE_ARRAY_SIZE 20 + + dispPtr->bindInfoStale = 0; + modMapPtr = XGetModifierMapping(dispPtr->display); + + /* + * Check the keycodes associated with the Lock modifier. If + * any of them is associated with the XK_Shift_Lock modifier, + * then Lock has to be interpreted as Shift Lock, not Caps Lock. + */ + + dispPtr->lockUsage = LU_IGNORE; + codePtr = modMapPtr->modifiermap + modMapPtr->max_keypermod*LockMapIndex; + for (count = modMapPtr->max_keypermod; count > 0; count--, codePtr++) { + if (*codePtr == 0) { + continue; + } + keysym = XKeycodeToKeysym(dispPtr->display, *codePtr, 0); + if (keysym == XK_Shift_Lock) { + dispPtr->lockUsage = LU_SHIFT; + break; + } + if (keysym == XK_Caps_Lock) { + dispPtr->lockUsage = LU_CAPS; + break; + } + } + + /* + * Look through the keycodes associated with modifiers to see if + * the the "mode switch", "meta", or "alt" keysyms are associated + * with any modifiers. If so, remember their modifier mask bits. + */ + + dispPtr->modeModMask = 0; + dispPtr->metaModMask = 0; + dispPtr->altModMask = 0; + codePtr = modMapPtr->modifiermap; + max = 8*modMapPtr->max_keypermod; + for (i = 0; i < max; i++, codePtr++) { + if (*codePtr == 0) { + continue; + } + keysym = XKeycodeToKeysym(dispPtr->display, *codePtr, 0); + if (keysym == XK_Mode_switch) { + dispPtr->modeModMask |= ShiftMask << (i/modMapPtr->max_keypermod); + } + if ((keysym == XK_Meta_L) || (keysym == XK_Meta_R)) { + dispPtr->metaModMask |= ShiftMask << (i/modMapPtr->max_keypermod); + } + if ((keysym == XK_Alt_L) || (keysym == XK_Alt_R)) { + dispPtr->altModMask |= ShiftMask << (i/modMapPtr->max_keypermod); + } + } + + /* + * Create an array of the keycodes for all modifier keys. + */ + + if (dispPtr->modKeyCodes != NULL) { + ckfree((char *) dispPtr->modKeyCodes); + } + dispPtr->numModKeyCodes = 0; + arraySize = KEYCODE_ARRAY_SIZE; + dispPtr->modKeyCodes = (KeyCode *) ckalloc((unsigned) + (KEYCODE_ARRAY_SIZE * sizeof(KeyCode))); + for (i = 0, codePtr = modMapPtr->modifiermap; i < max; i++, codePtr++) { + if (*codePtr == 0) { + continue; + } + + /* + * Make sure that the keycode isn't already in the array. + */ + + for (j = 0; j < dispPtr->numModKeyCodes; j++) { + if (dispPtr->modKeyCodes[j] == *codePtr) { + goto nextModCode; + } + } + if (dispPtr->numModKeyCodes >= arraySize) { + KeyCode *new; + + /* + * Ran out of space in the array; grow it. + */ + + arraySize *= 2; + new = (KeyCode *) ckalloc((unsigned) + (arraySize * sizeof(KeyCode))); + memcpy((VOID *) new, (VOID *) dispPtr->modKeyCodes, + (dispPtr->numModKeyCodes * sizeof(KeyCode))); + ckfree((char *) dispPtr->modKeyCodes); + dispPtr->modKeyCodes = new; + } + dispPtr->modKeyCodes[dispPtr->numModKeyCodes] = *codePtr; + dispPtr->numModKeyCodes++; + nextModCode: continue; + } + XFreeModifiermap(modMapPtr); +} + + +/* + *---------------------------------------------------------------------- + * + * TkStringToKeysym -- + * + * This procedure finds the keysym associated with a given keysym + * name. + * + * Results: + * The return value is the keysym that corresponds to name, or + * NoSymbol if there is no such keysym. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +KeySym +TkStringToKeysym(name) + char *name; /* Name of a keysym. */ +{ +#ifdef REDO_KEYSYM_LOOKUP + Tcl_HashEntry *hPtr; + KeySym keysym; + + hPtr = Tcl_FindHashEntry(&keySymTable, name); + if (hPtr != NULL) { + return (KeySym) Tcl_GetHashValue(hPtr); + } + if (strlen(name) == 1) { + keysym = (KeySym) (unsigned char) name[0]; + if (TkKeysymToString(keysym) != NULL) { + return keysym; + } + } +#endif /* REDO_KEYSYM_LOOKUP */ + return XStringToKeysym(name); +} + +/* + *---------------------------------------------------------------------- + * + * TkKeysymToString -- + * + * This procedure finds the keysym name associated with a given + * keysym. + * + * Results: + * The return value is a pointer to a static string containing + * the name of the given keysym, or NULL if there is no known name. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +TkKeysymToString(keysym) + KeySym keysym; +{ +#ifdef REDO_KEYSYM_LOOKUP + Tcl_HashEntry *hPtr; + + hPtr = Tcl_FindHashEntry(&nameTable, (char *)keysym); + if (hPtr != NULL) { + return (char *) Tcl_GetHashValue(hPtr); + } +#endif /* REDO_KEYSYM_LOOKUP */ + return XKeysymToString(keysym); +} + +/* + *---------------------------------------------------------------------- + * + * TkCopyAndGlobalEval -- + * + * This procedure makes a copy of a script then calls Tcl_GlobalEval + * to evaluate it. It's used in situations where the execution of + * a command may cause the original command string to be reallocated. + * + * Results: + * Returns the result of evaluating script, including both a standard + * Tcl completion code and a string in interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TkCopyAndGlobalEval(interp, script) + Tcl_Interp *interp; /* Interpreter in which to evaluate + * script. */ + char *script; /* Script to evaluate. */ +{ + Tcl_DString buffer; + int code; + + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, script, -1); + code = Tcl_GlobalEval(interp, Tcl_DStringValue(&buffer)); + Tcl_DStringFree(&buffer); + return code; +} + + diff --git a/tk3.6/tkBitmap.c b/tk4.2/generic/tkBitmap.c similarity index 81% rename from tk3.6/tkBitmap.c rename to tk4.2/generic/tkBitmap.c index 2b8fe2a..f6bb172 100644 --- a/tk3.6/tkBitmap.c +++ b/tk4.2/generic/tkBitmap.c @@ -5,46 +5,31 @@ * toolkit. This allows bitmaps to be shared between widgets and * also avoids interactions with the X server. * - * Copyright (c) 1990-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tkBitmap.c 1.37 96/07/23 16:54:40 */ -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkBitmap.c,v 1.22 93/07/27 11:34:53 ouster Exp $ SPRITE (Berkeley)"; -#endif /* not lint */ - -#include "tkConfig.h" +#include "tkPort.h" #include "tk.h" /* * The includes below are for pre-defined bitmaps. */ -#include "bitmaps/error" -#include "bitmaps/gray25" -#include "bitmaps/gray50" -#include "bitmaps/hourglass" -#include "bitmaps/info" -#include "bitmaps/questhead" -#include "bitmaps/question" -#include "bitmaps/warning" +#include "error.bmp" +#include "gray12.bmp" +#include "gray25.bmp" +#include "gray50.bmp" +#include "hourglass.bmp" +#include "info.bmp" +#include "questhead.bmp" +#include "question.bmp" +#include "warning.bmp" /* * One of the following data structures exists for each bitmap that is @@ -56,7 +41,7 @@ typedef struct { Pixmap bitmap; /* X identifier for bitmap. None means this * bitmap was created by Tk_DefineBitmap * and it isn't currently in use. */ - unsigned int width, height; /* Dimensions of bitmap. */ + int width, height; /* Dimensions of bitmap. */ Display *display; /* Display for which bitmap is valid. */ int refCount; /* Number of active uses of bitmap. */ Tcl_HashEntry *hashPtr; /* Entry in nameTable for this structure @@ -72,7 +57,7 @@ typedef struct { static Tcl_HashTable nameTable; typedef struct { Tk_Uid name; /* Textual name for desired bitmap. */ - Display *display; /* Display for which bitmap will be used. */ + Screen *screen; /* Screen on which bitmap will be used. */ } NameKey; /* @@ -93,7 +78,7 @@ typedef struct { typedef struct { char *source; /* Bits for bitmap. */ - unsigned int width, height; /* Dimensions of bitmap. */ + int width, height; /* Dimensions of bitmap. */ } PredefBitmap; /* @@ -114,7 +99,7 @@ static Tcl_HashTable predefTable; static Tcl_HashTable dataTable; typedef struct { char *source; /* Bitmap bits. */ - unsigned int width, height; /* Dimensions of bitmap. */ + int width, height; /* Dimensions of bitmap. */ } DataKey; static int initialized = 0; /* 0 means static structures haven't been @@ -165,7 +150,7 @@ Tk_GetBitmap(interp, tkwin, string) PredefBitmap *predefPtr; int new; Pixmap bitmap; - unsigned int width, height; + int width, height; int dummy2; if (!initialized) { @@ -173,7 +158,7 @@ Tk_GetBitmap(interp, tkwin, string) } nameKey.name = string; - nameKey.display = Tk_Display(tkwin); + nameKey.screen = Tk_Screen(tkwin); nameHashPtr = Tcl_CreateHashEntry(&nameTable, (char *) &nameKey, &new); if (!new) { bitmapPtr = (TkBitmap *) Tcl_GetHashValue(nameHashPtr); @@ -193,13 +178,14 @@ Tk_GetBitmap(interp, tkwin, string) Tcl_DString buffer; int result; - string = Tcl_TildeSubst(interp, string + 1, &buffer); + string = Tcl_TranslateFileName(interp, string + 1, &buffer); if (string == NULL) { goto error; } - result = XReadBitmapFile(nameKey.display, - RootWindowOfScreen(Tk_Screen(tkwin)), string, &width, - &height, &bitmap, &dummy2, &dummy2); + result = XReadBitmapFile(Tk_Display(tkwin), + RootWindowOfScreen(nameKey.screen), string, + (unsigned int *) &width, (unsigned int *) &height, + &bitmap, &dummy2, &dummy2); Tcl_DStringFree(&buffer); if (result != BitmapSuccess) { Tcl_AppendResult(interp, "error reading bitmap file \"", string, @@ -209,16 +195,24 @@ Tk_GetBitmap(interp, tkwin, string) } else { predefHashPtr = Tcl_FindHashEntry(&predefTable, string); if (predefHashPtr == NULL) { - Tcl_AppendResult(interp, "bitmap \"", string, - "\" not defined", (char *) NULL); + /* + * The check for a NULL interpreter is a special hack that + * allows this procedure to be called from GetShadows in + * tk3d.c, where it doesn't have an intepreter handle. + */ + + if (interp != NULL) { + Tcl_AppendResult(interp, "bitmap \"", string, + "\" not defined", (char *) NULL); + } goto error; } predefPtr = (PredefBitmap *) Tcl_GetHashValue(predefHashPtr); width = predefPtr->width; height = predefPtr->height; - bitmap = XCreateBitmapFromData(nameKey.display, - DefaultRootWindow(nameKey.display), predefPtr->source, - width, height); + bitmap = XCreateBitmapFromData(Tk_Display(tkwin), + RootWindowOfScreen(nameKey.screen), predefPtr->source, + (unsigned) width, (unsigned) height); } /* @@ -229,10 +223,10 @@ Tk_GetBitmap(interp, tkwin, string) bitmapPtr->bitmap = bitmap; bitmapPtr->width = width; bitmapPtr->height = height; - bitmapPtr->display = nameKey.display; + bitmapPtr->display = Tk_Display(tkwin); bitmapPtr->refCount = 1; bitmapPtr->hashPtr = nameHashPtr; - idKey.display = nameKey.display; + idKey.display = bitmapPtr->display; idKey.pixmap = bitmap; idHashPtr = Tcl_CreateHashEntry(&idTable, (char *) &idKey, &new); @@ -274,8 +268,8 @@ Tk_DefineBitmap(interp, name, source, width, height) Tk_Uid name; /* Name to use for bitmap. Must not already * be defined as a bitmap. */ char *source; /* Address of bits for bitmap. */ - unsigned int width; /* Width of bitmap. */ - unsigned int height; /* Height of bitmap. */ + int width; /* Width of bitmap. */ + int height; /* Height of bitmap. */ { int new; Tcl_HashEntry *predefHashPtr; @@ -365,8 +359,8 @@ Tk_SizeOfBitmap(display, bitmap, widthPtr, heightPtr) Display *display; /* Display for which bitmap was * allocated. */ Pixmap bitmap; /* Bitmap whose size is wanted. */ - unsigned int *widthPtr; /* Store bitmap width here. */ - unsigned int *heightPtr; /* Store bitmap height here. */ + int *widthPtr; /* Store bitmap width here. */ + int *heightPtr; /* Store bitmap height here. */ { IdKey idKey; Tcl_HashEntry *idHashPtr; @@ -429,7 +423,7 @@ Tk_FreeBitmap(display, bitmap) bitmapPtr = (TkBitmap *) Tcl_GetHashValue(idHashPtr); bitmapPtr->refCount--; if (bitmapPtr->refCount == 0) { - XFreePixmap(bitmapPtr->display, bitmapPtr->bitmap); + Tk_FreePixmap(bitmapPtr->display, bitmapPtr->bitmap); Tcl_DeleteHashEntry(idHashPtr); Tcl_DeleteHashEntry(bitmapPtr->hashPtr); ckfree((char *) bitmapPtr); @@ -468,14 +462,14 @@ Tk_GetBitmapFromData(interp, tkwin, source, width, height) Tcl_Interp *interp; /* Interpreter to use for error reporting. */ Tk_Window tkwin; /* Window in which bitmap will be used. */ char *source; /* Bitmap data for bitmap shape. */ - unsigned int width, height; /* Dimensions of bitmap. */ + int width, height; /* Dimensions of bitmap. */ { DataKey nameKey; Tcl_HashEntry *dataHashPtr; Tk_Uid name = NULL; /* Initialization need only to prevent * compiler warning. */ int new; - static autoNumber = 0; + static int autoNumber = 0; char string[20]; if (!initialized) { @@ -537,21 +531,23 @@ BitmapInit() Tcl_InitHashTable(&idTable, (sizeof(Display *) + sizeof(Pixmap)) /sizeof(int)); - Tk_DefineBitmap(dummy, Tk_GetUid("error"), error_bits, + Tk_DefineBitmap(dummy, Tk_GetUid("error"), (char *) error_bits, error_width, error_height); - Tk_DefineBitmap(dummy, Tk_GetUid("gray50"), gray50_bits, + Tk_DefineBitmap(dummy, Tk_GetUid("gray50"), (char *) gray50_bits, gray50_width, gray50_height); - Tk_DefineBitmap(dummy, Tk_GetUid("gray25"), gray25_bits, + Tk_DefineBitmap(dummy, Tk_GetUid("gray25"), (char *) gray25_bits, gray25_width, gray25_height); - Tk_DefineBitmap(dummy, Tk_GetUid("hourglass"), hourglass_bits, + Tk_DefineBitmap(dummy, Tk_GetUid("gray12"), (char *) gray12_bits, + gray12_width, gray12_height); + Tk_DefineBitmap(dummy, Tk_GetUid("hourglass"), (char *) hourglass_bits, hourglass_width, hourglass_height); - Tk_DefineBitmap(dummy, Tk_GetUid("info"), info_bits, + Tk_DefineBitmap(dummy, Tk_GetUid("info"), (char *) info_bits, info_width, info_height); - Tk_DefineBitmap(dummy, Tk_GetUid("questhead"), questhead_bits, + Tk_DefineBitmap(dummy, Tk_GetUid("questhead"), (char *) questhead_bits, questhead_width, questhead_height); - Tk_DefineBitmap(dummy, Tk_GetUid("question"), question_bits, + Tk_DefineBitmap(dummy, Tk_GetUid("question"), (char *) question_bits, question_width, question_height); - Tk_DefineBitmap(dummy, Tk_GetUid("warning"), warning_bits, + Tk_DefineBitmap(dummy, Tk_GetUid("warning"), (char *) warning_bits, warning_width, warning_height); Tcl_DeleteInterp(dummy); } diff --git a/tk3.6/tkButton.c b/tk4.2/generic/tkButton.c similarity index 53% rename from tk3.6/tkButton.c rename to tk4.2/generic/tkButton.c index 6b2e819..1d7a2b1 100644 --- a/tk3.6/tkButton.c +++ b/tk4.2/generic/tkButton.c @@ -6,33 +6,17 @@ * include labels, buttons, check buttons, and radio * buttons. * - * Copyright (c) 1990-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tkButton.c 1.128 96/03/01 17:34:49 */ -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkButton.c,v 1.78 93/07/15 16:39:15 ouster Exp $ SPRITE (Berkeley)"; -#endif - #include "default.h" -#include "tkConfig.h" +#include "tkPort.h" #include "tkInt.h" /* @@ -46,6 +30,7 @@ typedef struct { Display *display; /* Display containing widget. Needed to * free up resources after tkwin is gone. */ Tcl_Interp *interp; /* Interpreter associated with button. */ + Tcl_Command widgetCmd; /* Token for button's widget command. */ int type; /* Type of widget: restricts operations * that may be performed on widget. See * below for possible values. */ @@ -56,12 +41,24 @@ typedef struct { char *text; /* Text to display in button (malloc'ed) * or NULL. */ - int textLength; /* # of characters in text. */ + int numChars; /* # of characters in text. */ + int underline; /* Index of character to underline. < 0 means + * don't underline anything. */ char *textVarName; /* Name of variable (malloc'ed) or NULL. * If non-NULL, button displays the contents * of this variable. */ Pixmap bitmap; /* Bitmap to display or None. If not None * then text and textVar are ignored. */ + char *imageString; /* Name of image to display (malloc'ed), or + * NULL. If non-NULL, bitmap, text, and + * textVarName are ignored. */ + Tk_Image image; /* Image to display in window, or NULL if + * none. */ + char *selectImageString; /* Name of image to display when selected + * (malloc'ed), or NULL. */ + Tk_Image selectImage; /* Image to display in window when selected, + * or NULL if none. Ignored if image is + * NULL. */ /* * Information used when displaying widget: @@ -79,6 +76,18 @@ typedef struct { * border exists. */ int borderWidth; /* Width of border. */ int relief; /* 3-d effect: TK_RELIEF_RAISED, etc. */ + int highlightWidth; /* Width in pixels of highlight to draw + * around widget when it has the focus. + * <= 0 means don't draw a highlight. */ + XColor *highlightBgColorPtr; + /* Color for drawing traversal highlight + * area when highlight is off. */ + XColor *highlightColorPtr; /* Color for drawing traversal highlight. */ + int inset; /* Total width of all borders, including + * traversal highlight and 3-D border. + * Indicates how much interior stuff must + * be offset from outside edges to leave + * room for borders. */ XFontStruct *fontPtr; /* Information about text font, or NULL. */ XColor *normalFg; /* Foreground color in normal mode. */ XColor *activeFg; /* Foreground color in active mode. NULL @@ -98,26 +107,36 @@ typedef struct { * draw button text or icon. Otherwise * text or icon is drawn with normalGC and * this GC is used to stipple background - * across it. */ - int leftBearing; /* Distance from origin of text to its leftmost - * drawn pixel, in pixels (positive measures - * to the right). */ - int rightBearing; /* Amount text sticks right from its origin. */ + * across it. For labels this is None. */ + GC copyGC; /* Used for copying information from an + * off-screen pixmap to the screen. */ + char *widthString; /* Value of -width option. Malloc'ed. */ + char *heightString; /* Value of -height option. Malloc'ed. */ int width, height; /* If > 0, these specify dimensions to request * for window, in characters for text and in * pixels for bitmaps. In this case the actual * size of the text string or bitmap is * ignored in computing desired window size. */ - int padX, padY; /* Extra space around text or bitmap (pixels - * on each side). */ + int wrapLength; /* Line length (in pixels) at which to wrap + * onto next line. <= 0 means don't wrap + * except at newlines. */ + int padX, padY; /* Extra space around text (pixels to leave + * on each side). Ignored for bitmaps and + * images. */ Tk_Anchor anchor; /* Where text/bitmap should be displayed * inside button region. */ - XColor *selectorFg; /* Color for selector. */ - GC selectorGC; /* For drawing highlight when this button - * is in selected state. */ - int selectorSpace; /* Horizontal space (in pixels) allocated for - * display of selector. */ - int selectorDiameter; /* Diameter of selector, in pixels. */ + Tk_Justify justify; /* Justification to use for multi-line text. */ + int indicatorOn; /* True means draw indicator, false means + * don't draw it. */ + Tk_3DBorder selectBorder; /* For drawing indicator background, or perhaps + * widget background, when selected. */ + int textWidth; /* Width needed to display text as requested, + * in pixels. */ + int textHeight; /* Height needed to display text as requested, + * in pixels. */ + int indicatorSpace; /* Horizontal space (in pixels) allocated for + * display of indicator. */ + int indicatorDiameter; /* Diameter of indicator, in pixels. */ /* * For check and radio buttons, the fields below are used @@ -139,7 +158,10 @@ typedef struct { * Miscellaneous information: */ - Cursor cursor; /* Current cursor for window, or None. */ + Tk_Cursor cursor; /* Current cursor for window, or None. */ + char *takeFocus; /* Value of -takefocus option; not used in + * the C code, but used by keyboard traversal + * scripts. Malloc'ed, but may be NULL. */ char *command; /* Command to execute when button is * invoked; valid for buttons only. * If not NULL, it's malloc-ed. */ @@ -173,10 +195,13 @@ static char *classNames[] = {"Label", "Button", "Checkbutton", "Radiobutton"}; * this window. * SELECTED: Non-zero means this button is selected, * so special highlight should be drawn. + * GOT_FOCUS: Non-zero means this button currently + * has the input focus. */ #define REDRAW_PENDING 1 #define SELECTED 2 +#define GOT_FOCUS 4 /* * Mask values used to selectively enable entries in the @@ -192,6 +217,7 @@ static char *classNames[] = {"Label", "Button", "Checkbutton", "Radiobutton"}; static int configFlags[] = {LABEL_MASK, BUTTON_MASK, CHECK_BUTTON_MASK, RADIO_BUTTON_MASK}; + /* * Information used for parsing configuration specs: */ @@ -251,8 +277,30 @@ static Tk_ConfigSpec configSpecs[] = { ALL_MASK}, {TK_CONFIG_COLOR, "-foreground", "foreground", "Foreground", DEF_BUTTON_FG, Tk_Offset(Button, normalFg), ALL_MASK}, - {TK_CONFIG_INT, "-height", "height", "Height", - DEF_BUTTON_HEIGHT, Tk_Offset(Button, height), ALL_MASK}, + {TK_CONFIG_STRING, "-height", "height", "Height", + DEF_BUTTON_HEIGHT, Tk_Offset(Button, heightString), ALL_MASK}, + {TK_CONFIG_COLOR, "-highlightbackground", "highlightBackground", + "HighlightBackground", DEF_BUTTON_HIGHLIGHT_BG, + Tk_Offset(Button, highlightBgColorPtr), ALL_MASK}, + {TK_CONFIG_COLOR, "-highlightcolor", "highlightColor", "HighlightColor", + DEF_BUTTON_HIGHLIGHT, Tk_Offset(Button, highlightColorPtr), + ALL_MASK}, + {TK_CONFIG_PIXELS, "-highlightthickness", "highlightThickness", + "HighlightThickness", + DEF_LABEL_HIGHLIGHT_WIDTH, Tk_Offset(Button, highlightWidth), + LABEL_MASK}, + {TK_CONFIG_PIXELS, "-highlightthickness", "highlightThickness", + "HighlightThickness", + DEF_BUTTON_HIGHLIGHT_WIDTH, Tk_Offset(Button, highlightWidth), + BUTTON_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK}, + {TK_CONFIG_STRING, "-image", "image", "Image", + DEF_BUTTON_IMAGE, Tk_Offset(Button, imageString), + ALL_MASK|TK_CONFIG_NULL_OK}, + {TK_CONFIG_BOOLEAN, "-indicatoron", "indicatorOn", "IndicatorOn", + DEF_BUTTON_INDICATOR, Tk_Offset(Button, indicatorOn), + CHECK_BUTTON_MASK|RADIO_BUTTON_MASK}, + {TK_CONFIG_JUSTIFY, "-justify", "justify", "Justify", + DEF_BUTTON_JUSTIFY, Tk_Offset(Button, justify), ALL_MASK}, {TK_CONFIG_STRING, "-offvalue", "offValue", "Value", DEF_BUTTON_OFF_VALUE, Tk_Offset(Button, offValue), CHECK_BUTTON_MASK}, @@ -260,41 +308,60 @@ static Tk_ConfigSpec configSpecs[] = { DEF_BUTTON_ON_VALUE, Tk_Offset(Button, onValue), CHECK_BUTTON_MASK}, {TK_CONFIG_PIXELS, "-padx", "padX", "Pad", - DEF_BUTTON_PADX, Tk_Offset(Button, padX), ALL_MASK}, + DEF_BUTTON_PADX, Tk_Offset(Button, padX), BUTTON_MASK}, + {TK_CONFIG_PIXELS, "-padx", "padX", "Pad", + DEF_LABCHKRAD_PADX, Tk_Offset(Button, padX), + LABEL_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK}, {TK_CONFIG_PIXELS, "-pady", "padY", "Pad", - DEF_BUTTON_PADY, Tk_Offset(Button, padY), ALL_MASK}, + DEF_BUTTON_PADY, Tk_Offset(Button, padY), BUTTON_MASK}, + {TK_CONFIG_PIXELS, "-pady", "padY", "Pad", + DEF_LABCHKRAD_PADY, Tk_Offset(Button, padY), + LABEL_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK}, {TK_CONFIG_RELIEF, "-relief", "relief", "Relief", - DEF_BUTTON_RELIEF, Tk_Offset(Button, relief), - BUTTON_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK}, + DEF_BUTTON_RELIEF, Tk_Offset(Button, relief), BUTTON_MASK}, {TK_CONFIG_RELIEF, "-relief", "relief", "Relief", - DEF_LABEL_RELIEF, Tk_Offset(Button, relief), LABEL_MASK}, - {TK_CONFIG_COLOR, "-selector", "selector", "Foreground", - DEF_BUTTON_SELECTOR_COLOR, Tk_Offset(Button, selectorFg), + DEF_LABCHKRAD_RELIEF, Tk_Offset(Button, relief), + LABEL_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK}, + {TK_CONFIG_BORDER, "-selectcolor", "selectColor", "Background", + DEF_BUTTON_SELECT_COLOR, Tk_Offset(Button, selectBorder), CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|TK_CONFIG_COLOR_ONLY |TK_CONFIG_NULL_OK}, - {TK_CONFIG_COLOR, "-selector", "selector", "Foreground", - DEF_BUTTON_SELECTOR_MONO, Tk_Offset(Button, selectorFg), + {TK_CONFIG_BORDER, "-selectcolor", "selectColor", "Background", + DEF_BUTTON_SELECT_MONO, Tk_Offset(Button, selectBorder), CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|TK_CONFIG_MONO_ONLY |TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-selectimage", "selectImage", "SelectImage", + DEF_BUTTON_SELECT_IMAGE, Tk_Offset(Button, selectImageString), + CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|TK_CONFIG_NULL_OK}, {TK_CONFIG_UID, "-state", "state", "State", DEF_BUTTON_STATE, Tk_Offset(Button, state), BUTTON_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK}, + {TK_CONFIG_STRING, "-takefocus", "takeFocus", "TakeFocus", + DEF_LABEL_TAKE_FOCUS, Tk_Offset(Button, takeFocus), + LABEL_MASK|TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-takefocus", "takeFocus", "TakeFocus", + DEF_BUTTON_TAKE_FOCUS, Tk_Offset(Button, takeFocus), + BUTTON_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|TK_CONFIG_NULL_OK}, {TK_CONFIG_STRING, "-text", "text", "Text", DEF_BUTTON_TEXT, Tk_Offset(Button, text), ALL_MASK}, {TK_CONFIG_STRING, "-textvariable", "textVariable", "Variable", DEF_BUTTON_TEXT_VARIABLE, Tk_Offset(Button, textVarName), ALL_MASK|TK_CONFIG_NULL_OK}, + {TK_CONFIG_INT, "-underline", "underline", "Underline", + DEF_BUTTON_UNDERLINE, Tk_Offset(Button, underline), ALL_MASK}, {TK_CONFIG_STRING, "-value", "value", "Value", DEF_BUTTON_VALUE, Tk_Offset(Button, onValue), - RADIO_BUTTON_MASK|TK_CONFIG_NULL_OK}, + RADIO_BUTTON_MASK}, {TK_CONFIG_STRING, "-variable", "variable", "Variable", DEF_RADIOBUTTON_VARIABLE, Tk_Offset(Button, selVarName), RADIO_BUTTON_MASK}, {TK_CONFIG_STRING, "-variable", "variable", "Variable", DEF_CHECKBUTTON_VARIABLE, Tk_Offset(Button, selVarName), CHECK_BUTTON_MASK|TK_CONFIG_NULL_OK}, - {TK_CONFIG_INT, "-width", "width", "Width", - DEF_BUTTON_WIDTH, Tk_Offset(Button, width), ALL_MASK}, + {TK_CONFIG_STRING, "-width", "width", "Width", + DEF_BUTTON_WIDTH, Tk_Offset(Button, widthString), ALL_MASK}, + {TK_CONFIG_PIXELS, "-wraplength", "wrapLength", "WrapLength", + DEF_BUTTON_WRAP_LENGTH, Tk_Offset(Button, wrapLength), ALL_MASK}, {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, (char *) NULL, 0, 0} }; @@ -305,18 +372,29 @@ static Tk_ConfigSpec configSpecs[] = { */ static char *optionStrings[] = { - "configure", - "activate, configure, deactivate, flash, or invoke", - "activate, configure, deactivate, deselect, flash, invoke, select, or toggle", - "activate, configure, deactivate, deselect, flash, invoke, or select" + "cget or configure", + "cget, configure, flash, or invoke", + "cget, configure, deselect, flash, invoke, select, or toggle", + "cget, configure, deselect, flash, invoke, or select" }; /* * Forward declarations for procedures defined later in this file: */ +static void ButtonCmdDeletedProc _ANSI_ARGS_(( + ClientData clientData)); +static int ButtonCreate _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv, + int type)); static void ButtonEventProc _ANSI_ARGS_((ClientData clientData, XEvent *eventPtr)); +static void ButtonImageProc _ANSI_ARGS_((ClientData clientData, + int x, int y, int width, int height, + int imgWidth, int imgHeight)); +static void ButtonSelectImageProc _ANSI_ARGS_(( + ClientData clientData, int x, int y, int width, + int height, int imgWidth, int imgHeight)); static char * ButtonTextVarProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, char *name1, char *name2, int flags)); @@ -329,24 +407,25 @@ static void ComputeButtonGeometry _ANSI_ARGS_((Button *butPtr)); static int ConfigureButton _ANSI_ARGS_((Tcl_Interp *interp, Button *butPtr, int argc, char **argv, int flags)); -static void DestroyButton _ANSI_ARGS_((ClientData clientData)); +static void DestroyButton _ANSI_ARGS_((Button *butPtr)); static void DisplayButton _ANSI_ARGS_((ClientData clientData)); static int InvokeButton _ANSI_ARGS_((Button *butPtr)); /* *-------------------------------------------------------------- * - * Tk_ButtonCmd -- + * Tk_ButtonCmd, Tk_CheckbuttonCmd, Tk_LabelCmd, Tk_RadiobuttonCmd -- * - * This procedure is invoked to process the "button", "label", + * These procedures are invoked to process the "button", "label", * "radiobutton", and "checkbutton" Tcl commands. See the - * user documentation for details on what it does. + * user documentation for details on what they do. * * Results: * A standard Tcl result. * * Side effects: - * See the user documentation. + * See the user documentation. These procedures are just wrappers; + * they call ButtonCreate to do all of the real work. * *-------------------------------------------------------------- */ @@ -358,37 +437,82 @@ Tk_ButtonCmd(clientData, interp, argc, argv) Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ +{ + return ButtonCreate(clientData, interp, argc, argv, TYPE_BUTTON); +} + +int +Tk_CheckbuttonCmd(clientData, interp, argc, argv) + ClientData clientData; /* Main window associated with + * interpreter. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + return ButtonCreate(clientData, interp, argc, argv, TYPE_CHECK_BUTTON); +} + +int +Tk_LabelCmd(clientData, interp, argc, argv) + ClientData clientData; /* Main window associated with + * interpreter. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + return ButtonCreate(clientData, interp, argc, argv, TYPE_LABEL); +} + +int +Tk_RadiobuttonCmd(clientData, interp, argc, argv) + ClientData clientData; /* Main window associated with + * interpreter. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + return ButtonCreate(clientData, interp, argc, argv, TYPE_RADIO_BUTTON); +} + +/* + *-------------------------------------------------------------- + * + * ButtonCreate -- + * + * This procedure does all the real work of implementing the + * "button", "label", "radiobutton", and "checkbutton" Tcl + * commands. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +static int +ButtonCreate(clientData, interp, argc, argv, type) + ClientData clientData; /* Main window associated with + * interpreter. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ + int type; /* Type of button to create: TYPE_LABEL, + * TYPE_BUTTON, TYPE_CHECK_BUTTON, or + * TYPE_RADIO_BUTTON. */ { register Button *butPtr; - int type; Tk_Window tkwin = (Tk_Window) clientData; Tk_Window new; if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " pathName ?options?\"", (char *) NULL); return TCL_ERROR; } - switch (argv[0][0]) { - case 'l': - type = TYPE_LABEL; - break; - case 'b': - type = TYPE_BUTTON; - break; - case 'c': - type = TYPE_CHECK_BUTTON; - break; - case 'r': - type = TYPE_RADIO_BUTTON; - break; - default: - sprintf(interp->result, - "unknown button-creation command \"%.50s\"", argv[0]); - return TCL_ERROR; - } - /* * Create the new window. */ @@ -405,17 +529,28 @@ Tk_ButtonCmd(clientData, interp, argc, argv) butPtr = (Button *) ckalloc(sizeof(Button)); butPtr->tkwin = new; butPtr->display = Tk_Display(new); + butPtr->widgetCmd = Tcl_CreateCommand(interp, Tk_PathName(butPtr->tkwin), + ButtonWidgetCmd, (ClientData) butPtr, ButtonCmdDeletedProc); butPtr->interp = interp; butPtr->type = type; butPtr->text = NULL; - butPtr->textLength = 0; + butPtr->numChars = 0; + butPtr->underline = -1; butPtr->textVarName = NULL; butPtr->bitmap = None; + butPtr->imageString = NULL; + butPtr->image = NULL; + butPtr->selectImageString = NULL; + butPtr->selectImage = NULL; butPtr->state = tkNormalUid; butPtr->normalBorder = NULL; butPtr->activeBorder = NULL; butPtr->borderWidth = 0; butPtr->relief = TK_RELIEF_FLAT; + butPtr->highlightWidth = 0; + butPtr->highlightBgColorPtr = NULL; + butPtr->highlightColorPtr = NULL; + butPtr->inset = 0; butPtr->fontPtr = NULL; butPtr->normalFg = NULL; butPtr->activeFg = NULL; @@ -424,29 +559,32 @@ Tk_ButtonCmd(clientData, interp, argc, argv) butPtr->activeTextGC = None; butPtr->gray = None; butPtr->disabledGC = None; - butPtr->leftBearing = 0; - butPtr->rightBearing = 0; + butPtr->copyGC = None; + butPtr->widthString = NULL; + butPtr->heightString = NULL; butPtr->width = 0; butPtr->height = 0; + butPtr->wrapLength = 0; butPtr->padX = 0; butPtr->padY = 0; butPtr->anchor = TK_ANCHOR_CENTER; - butPtr->selectorFg = NULL; - butPtr->selectorGC = None; - butPtr->selectorSpace = 0; - butPtr->selectorDiameter = 0; + butPtr->justify = TK_JUSTIFY_CENTER; + butPtr->indicatorOn = 0; + butPtr->selectBorder = NULL; + butPtr->indicatorSpace = 0; + butPtr->indicatorDiameter = 0; butPtr->selVarName = NULL; butPtr->onValue = NULL; butPtr->offValue = NULL; butPtr->cursor = None; butPtr->command = NULL; + butPtr->takeFocus = NULL; butPtr->flags = 0; Tk_SetClass(new, classNames[type]); - Tk_CreateEventHandler(butPtr->tkwin, ExposureMask|StructureNotifyMask, + Tk_CreateEventHandler(butPtr->tkwin, + ExposureMask|StructureNotifyMask|FocusChangeMask, ButtonEventProc, (ClientData) butPtr); - Tcl_CreateCommand(interp, Tk_PathName(butPtr->tkwin), ButtonWidgetCmd, - (ClientData) butPtr, (void (*)()) NULL); if (ConfigureButton(interp, butPtr, argc-2, argv+2, configFlags[type]) != TCL_OK) { Tk_DestroyWindow(butPtr->tkwin); @@ -484,32 +622,30 @@ ButtonWidgetCmd(clientData, interp, argc, argv) { register Button *butPtr = (Button *) clientData; int result = TCL_OK; - int length; - char c; + size_t length; + int c; if (argc < 2) { sprintf(interp->result, - "wrong # args: should be \"%.50s option [arg arg ...]\"", + "wrong # args: should be \"%.50s option ?arg arg ...?\"", argv[0]); return TCL_ERROR; } - Tk_Preserve((ClientData) butPtr); + Tcl_Preserve((ClientData) butPtr); c = argv[1][0]; length = strlen(argv[1]); - if ((c == 'a') && (strncmp(argv[1], "activate", length) == 0) - && (butPtr->type != TYPE_LABEL)) { - if (argc > 2) { - sprintf(interp->result, - "wrong # args: should be \"%.50s activate\"", - argv[0]); + if ((c == 'c') && (strncmp(argv[1], "cget", length) == 0) + && (length >= 2)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " cget option\"", + (char *) NULL); goto error; } - if (butPtr->state != tkDisabledUid) { - butPtr->state = tkActiveUid; - Tk_SetBackgroundFromBorder(butPtr->tkwin, butPtr->activeBorder); - goto redisplay; - } - } else if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0)) { + result = Tk_ConfigureValue(interp, butPtr->tkwin, configSpecs, + (char *) butPtr, argv[2], configFlags[butPtr->type]); + } else if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0) + && (length >= 2)) { if (argc == 2) { result = Tk_ConfigureInfo(interp, butPtr->tkwin, configSpecs, (char *) butPtr, (char *) NULL, configFlags[butPtr->type]); @@ -521,21 +657,8 @@ ButtonWidgetCmd(clientData, interp, argc, argv) result = ConfigureButton(interp, butPtr, argc-2, argv+2, configFlags[butPtr->type] | TK_CONFIG_ARGV_ONLY); } - } else if ((c == 'd') && (strncmp(argv[1], "deactivate", length) == 0) - && (length > 2) && (butPtr->type != TYPE_LABEL)) { - if (argc > 2) { - sprintf(interp->result, - "wrong # args: should be \"%.50s deactivate\"", - argv[0]); - goto error; - } - if (butPtr->state != tkDisabledUid) { - butPtr->state = tkNormalUid; - Tk_SetBackgroundFromBorder(butPtr->tkwin, butPtr->normalBorder); - goto redisplay; - } } else if ((c == 'd') && (strncmp(argv[1], "deselect", length) == 0) - && (length > 2) && (butPtr->type >= TYPE_CHECK_BUTTON)) { + && (butPtr->type >= TYPE_CHECK_BUTTON)) { if (argc > 2) { sprintf(interp->result, "wrong # args: should be \"%.50s deselect\"", @@ -543,13 +666,18 @@ ButtonWidgetCmd(clientData, interp, argc, argv) goto error; } if (butPtr->type == TYPE_CHECK_BUTTON) { - Tcl_SetVar(interp, butPtr->selVarName, butPtr->offValue, - TCL_GLOBAL_ONLY); + if (Tcl_SetVar(interp, butPtr->selVarName, butPtr->offValue, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { + result = TCL_ERROR; + } } else if (butPtr->flags & SELECTED) { - Tcl_SetVar(interp, butPtr->selVarName, "", TCL_GLOBAL_ONLY); + if (Tcl_SetVar(interp, butPtr->selVarName, "", + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { + result = TCL_ERROR; + }; } } else if ((c == 'f') && (strncmp(argv[1], "flash", length) == 0) - && (butPtr->type != TYPE_LABEL)) { + && (butPtr->type != TYPE_LABEL)) { int i; if (argc > 2) { @@ -566,8 +694,16 @@ ButtonWidgetCmd(clientData, interp, argc, argv) (butPtr->state == tkActiveUid) ? butPtr->activeBorder : butPtr->normalBorder); DisplayButton((ClientData) butPtr); + + /* + * Special note: must cancel any existing idle handler + * for DisplayButton; it's no longer needed, and DisplayButton + * cleared the REDRAW_PENDING flag. + */ + + Tcl_CancelIdleCall(DisplayButton, (ClientData) butPtr); XFlush(butPtr->display); - Tk_Sleep(50); + Tcl_Sleep(50); } } } else if ((c == 'i') && (strncmp(argv[1], "invoke", length) == 0) @@ -589,39 +725,40 @@ ButtonWidgetCmd(clientData, interp, argc, argv) argv[0]); goto error; } - Tcl_SetVar(interp, butPtr->selVarName, butPtr->onValue, TCL_GLOBAL_ONLY); + if (Tcl_SetVar(interp, butPtr->selVarName, butPtr->onValue, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { + result = TCL_ERROR; + } } else if ((c == 't') && (strncmp(argv[1], "toggle", length) == 0) && (length >= 2) && (butPtr->type == TYPE_CHECK_BUTTON)) { if (argc > 2) { sprintf(interp->result, - "wrong # args: should be \"%.50s select\"", + "wrong # args: should be \"%.50s toggle\"", argv[0]); goto error; } if (butPtr->flags & SELECTED) { - Tcl_SetVar(interp, butPtr->selVarName, butPtr->offValue, TCL_GLOBAL_ONLY); + if (Tcl_SetVar(interp, butPtr->selVarName, butPtr->offValue, + TCL_GLOBAL_ONLY) == NULL) { + result = TCL_ERROR; + } } else { - Tcl_SetVar(interp, butPtr->selVarName, butPtr->onValue, TCL_GLOBAL_ONLY); + if (Tcl_SetVar(interp, butPtr->selVarName, butPtr->onValue, + TCL_GLOBAL_ONLY) == NULL) { + result = TCL_ERROR; + } } } else { sprintf(interp->result, - "bad option \"%.50s\": must be %s", argv[1], + "bad option \"%.50s\": must be %s", argv[1], optionStrings[butPtr->type]); goto error; } - Tk_Release((ClientData) butPtr); + Tcl_Release((ClientData) butPtr); return result; - redisplay: - if (Tk_IsMapped(butPtr->tkwin) && !(butPtr->flags & REDRAW_PENDING)) { - Tk_DoWhenIdle(DisplayButton, (ClientData) butPtr); - butPtr->flags |= REDRAW_PENDING; - } - Tk_Release((ClientData) butPtr); - return TCL_OK; - error: - Tk_Release((ClientData) butPtr); + Tcl_Release((ClientData) butPtr); return TCL_ERROR; } @@ -630,7 +767,7 @@ ButtonWidgetCmd(clientData, interp, argc, argv) * * DestroyButton -- * - * This procedure is invoked by Tk_EventuallyFree or Tk_Release + * This procedure is invoked by Tcl_EventuallyFree or Tcl_Release * to clean up the internal structure of a button at a safe time * (when no-one is using it anymore). * @@ -644,11 +781,9 @@ ButtonWidgetCmd(clientData, interp, argc, argv) */ static void -DestroyButton(clientData) - ClientData clientData; /* Info about entry widget. */ +DestroyButton(butPtr) + Button *butPtr; /* Info about button widget. */ { - register Button *butPtr = (Button *) clientData; - /* * Free up all the stuff that requires special handling, then * let Tk_FreeOptions handle all the standard option-related @@ -660,6 +795,12 @@ DestroyButton(clientData) TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, ButtonTextVarProc, (ClientData) butPtr); } + if (butPtr->image != NULL) { + Tk_FreeImage(butPtr->image); + } + if (butPtr->selectImage != NULL) { + Tk_FreeImage(butPtr->selectImage); + } if (butPtr->normalTextGC != None) { Tk_FreeGC(butPtr->display, butPtr->normalTextGC); } @@ -672,8 +813,8 @@ DestroyButton(clientData) if (butPtr->disabledGC != None) { Tk_FreeGC(butPtr->display, butPtr->disabledGC); } - if (butPtr->selectorGC != None) { - Tk_FreeGC(butPtr->display, butPtr->selectorGC); + if (butPtr->copyGC != None) { + Tk_FreeGC(butPtr->display, butPtr->copyGC); } if (butPtr->selVarName != NULL) { Tcl_UntraceVar(butPtr->interp, butPtr->selVarName, @@ -682,7 +823,7 @@ DestroyButton(clientData) } Tk_FreeOptions(configSpecs, (char *) butPtr, butPtr->display, configFlags[butPtr->type]); - ckfree((char *) butPtr); + Tcl_EventuallyFree((ClientData)butPtr, TCL_DYNAMIC); } /* @@ -718,6 +859,7 @@ ConfigureButton(interp, butPtr, argc, argv, flags) XGCValues gcValues; GC newGC; unsigned long mask; + Tk_Image image; /* * Eliminate any existing trace on variables monitored by the button. @@ -745,23 +887,27 @@ ConfigureButton(interp, butPtr, argc, argv, flags) * defaults that couldn't be specified to Tk_ConfigureWidget. */ - if (butPtr->state == tkActiveUid) { + if ((butPtr->state == tkActiveUid) && !Tk_StrictMotif(butPtr->tkwin)) { Tk_SetBackgroundFromBorder(butPtr->tkwin, butPtr->activeBorder); } else { Tk_SetBackgroundFromBorder(butPtr->tkwin, butPtr->normalBorder); - if ((butPtr->state != tkNormalUid) + if ((butPtr->state != tkNormalUid) && (butPtr->state != tkActiveUid) && (butPtr->state != tkDisabledUid)) { Tcl_AppendResult(interp, "bad state value \"", butPtr->state, - "\": must be normal, active, or disabled", (char *) NULL); + "\": must be normal, active, or disabled", (char *) NULL); butPtr->state = tkNormalUid; return TCL_ERROR; } } + if (butPtr->highlightWidth < 0) { + butPtr->highlightWidth = 0; + } + gcValues.font = butPtr->fontPtr->fid; gcValues.foreground = butPtr->normalFg->pixel; gcValues.background = Tk_3DBorderColor(butPtr->normalBorder)->pixel; - + /* * Note: GraphicsExpose events are disabled in normalTextGC because it's * used to copy stuff from an off-screen pixmap onto the screen (we know @@ -770,7 +916,8 @@ ConfigureButton(interp, butPtr, argc, argv, flags) gcValues.graphics_exposures = False; newGC = Tk_GetGC(butPtr->tkwin, - GCForeground|GCBackground|GCFont|GCGraphicsExposures, &gcValues); + GCForeground|GCBackground|GCFont|GCGraphicsExposures, + &gcValues); if (butPtr->normalTextGC != None) { Tk_FreeGC(butPtr->display, butPtr->normalTextGC); } @@ -780,37 +927,43 @@ ConfigureButton(interp, butPtr, argc, argv, flags) gcValues.font = butPtr->fontPtr->fid; gcValues.foreground = butPtr->activeFg->pixel; gcValues.background = Tk_3DBorderColor(butPtr->activeBorder)->pixel; - newGC = Tk_GetGC(butPtr->tkwin, GCForeground|GCBackground|GCFont, - &gcValues); + newGC = Tk_GetGC(butPtr->tkwin, + GCForeground|GCBackground|GCFont, &gcValues); if (butPtr->activeTextGC != None) { Tk_FreeGC(butPtr->display, butPtr->activeTextGC); } butPtr->activeTextGC = newGC; } - gcValues.font = butPtr->fontPtr->fid; - gcValues.background = Tk_3DBorderColor(butPtr->normalBorder)->pixel; - if (butPtr->disabledFg != NULL) { - gcValues.foreground = butPtr->disabledFg->pixel; - mask = GCForeground|GCBackground|GCFont; - } else { - gcValues.foreground = gcValues.background; - if (butPtr->gray == None) { - butPtr->gray = Tk_GetBitmap(interp, butPtr->tkwin, - Tk_GetUid("gray50")); + if (butPtr->type != TYPE_LABEL) { + gcValues.font = butPtr->fontPtr-> fid; + gcValues.background = Tk_3DBorderColor(butPtr->normalBorder)->pixel; + if ((butPtr->disabledFg != NULL) && (butPtr->imageString == NULL)) { + gcValues.foreground = butPtr->disabledFg->pixel; + mask = GCForeground|GCBackground|GCFont; + } else { + gcValues.foreground = gcValues.background; if (butPtr->gray == None) { - return TCL_ERROR; + butPtr->gray = Tk_GetBitmap(interp, butPtr->tkwin, + Tk_GetUid("gray50")); + if (butPtr->gray == None) { + return TCL_ERROR; + } } + gcValues.fill_style = FillStippled; + gcValues.stipple = butPtr->gray; + mask = GCForeground|GCFillStyle|GCStipple; } - gcValues.fill_style = FillStippled; - gcValues.stipple = butPtr->gray; - mask = GCForeground|GCFillStyle|GCStipple; + newGC = Tk_GetGC(butPtr->tkwin, mask, &gcValues); + if (butPtr->disabledGC != None) { + Tk_FreeGC(butPtr->display, butPtr->disabledGC); + } + butPtr->disabledGC = newGC; } - newGC = Tk_GetGC(butPtr->tkwin, mask, &gcValues); - if (butPtr->disabledGC != None) { - Tk_FreeGC(butPtr->display, butPtr->disabledGC); + + if (butPtr->copyGC == None) { + butPtr->copyGC = Tk_GetGC(butPtr->tkwin, 0, &gcValues); } - butPtr->disabledGC = newGC; if (butPtr->padX < 0) { butPtr->padX = 0; @@ -822,27 +975,11 @@ ConfigureButton(interp, butPtr, argc, argv, flags) if (butPtr->type >= TYPE_CHECK_BUTTON) { char *value; - if (butPtr->selectorFg != NULL) { - gcValues.foreground = butPtr->selectorFg->pixel; - newGC = Tk_GetGC(butPtr->tkwin, GCForeground, &gcValues); - } else { - newGC = None; - } - if (butPtr->selectorGC != None) { - Tk_FreeGC(butPtr->display, butPtr->selectorGC); - } - butPtr->selectorGC = newGC; - if (butPtr->selVarName == NULL) { butPtr->selVarName = (char *) ckalloc((unsigned) (strlen(Tk_Name(butPtr->tkwin)) + 1)); strcpy(butPtr->selVarName, Tk_Name(butPtr->tkwin)); } - if (butPtr->onValue == NULL) { - butPtr->onValue = (char *) ckalloc((unsigned) - (strlen(Tk_Name(butPtr->tkwin)) + 1)); - strcpy(butPtr->onValue, Tk_Name(butPtr->tkwin)); - } /* * Select the button if the associated variable has the @@ -858,9 +995,11 @@ ConfigureButton(interp, butPtr, argc, argv, flags) butPtr->flags |= SELECTED; } } else { - Tcl_SetVar(interp, butPtr->selVarName, + if (Tcl_SetVar(interp, butPtr->selVarName, (butPtr->type == TYPE_CHECK_BUTTON) ? butPtr->offValue : "", - TCL_GLOBAL_ONLY); + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } } Tcl_TraceVar(interp, butPtr->selVarName, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, @@ -868,23 +1007,60 @@ ConfigureButton(interp, butPtr, argc, argv, flags) } /* - * If the button is to display the value of a variable, then set up - * a trace on the variable's value, create the variable if it doesn't - * exist, and fetch its current value. + * Get the images for the widget, if there are any. Allocate the + * new images before freeing the old ones, so that the reference + * counts don't go to zero and cause image data to be discarded. */ - if ((butPtr->bitmap == None) && (butPtr->textVarName != NULL)) { + if (butPtr->imageString != NULL) { + image = Tk_GetImage(butPtr->interp, butPtr->tkwin, + butPtr->imageString, ButtonImageProc, (ClientData) butPtr); + if (image == NULL) { + return TCL_ERROR; + } + } else { + image = NULL; + } + if (butPtr->image != NULL) { + Tk_FreeImage(butPtr->image); + } + butPtr->image = image; + if (butPtr->selectImageString != NULL) { + image = Tk_GetImage(butPtr->interp, butPtr->tkwin, + butPtr->selectImageString, ButtonSelectImageProc, + (ClientData) butPtr); + if (image == NULL) { + return TCL_ERROR; + } + } else { + image = NULL; + } + if (butPtr->selectImage != NULL) { + Tk_FreeImage(butPtr->selectImage); + } + butPtr->selectImage = image; + + if ((butPtr->image == NULL) && (butPtr->bitmap == None) + && (butPtr->textVarName != NULL)) { + /* + * The button must display the value of a variable: set up a trace + * on the variable's value, create the variable if it doesn't + * exist, and fetch its current value. + */ + char *value; value = Tcl_GetVar(interp, butPtr->textVarName, TCL_GLOBAL_ONLY); if (value == NULL) { - Tcl_SetVar(interp, butPtr->textVarName, butPtr->text, - TCL_GLOBAL_ONLY); + if (Tcl_SetVar(interp, butPtr->textVarName, butPtr->text, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } } else { if (butPtr->text != NULL) { ckfree(butPtr->text); } - butPtr->text = ckalloc((unsigned) (strlen(value) + 1)); + butPtr->text = (char *) ckalloc((unsigned) (strlen(value) + 1)); strcpy(butPtr->text, value); } Tcl_TraceVar(interp, butPtr->textVarName, @@ -892,6 +1068,29 @@ ConfigureButton(interp, butPtr, argc, argv, flags) ButtonTextVarProc, (ClientData) butPtr); } + if ((butPtr->bitmap != None) || (butPtr->image != NULL)) { + if (Tk_GetPixels(interp, butPtr->tkwin, butPtr->widthString, + &butPtr->width) != TCL_OK) { + widthError: + Tcl_AddErrorInfo(interp, "\n (processing -width option)"); + return TCL_ERROR; + } + if (Tk_GetPixels(interp, butPtr->tkwin, butPtr->heightString, + &butPtr->height) != TCL_OK) { + heightError: + Tcl_AddErrorInfo(interp, "\n (processing -height option)"); + return TCL_ERROR; + } + } else { + if (Tcl_GetInt(interp, butPtr->widthString, &butPtr->width) + != TCL_OK) { + goto widthError; + } + if (Tcl_GetInt(interp, butPtr->heightString, &butPtr->height) + != TCL_OK) { + goto heightError; + } + } ComputeButtonGeometry(butPtr); /* @@ -899,7 +1098,7 @@ ConfigureButton(interp, butPtr, argc, argv, flags) */ if (Tk_IsMapped(butPtr->tkwin) && !(butPtr->flags & REDRAW_PENDING)) { - Tk_DoWhenIdle(DisplayButton, (ClientData) butPtr); + Tcl_DoWhenIdle(DisplayButton, (ClientData) butPtr); butPtr->flags |= REDRAW_PENDING; } @@ -911,14 +1110,15 @@ ConfigureButton(interp, butPtr, argc, argv, flags) * * DisplayButton -- * - * This procedure is invoked to display a button widget. + * This procedure is invoked to display a button widget. It is + * normally invoked as an idle handler. * * Results: * None. * * Side effects: * Commands are output to X to display the button in its - * current mode. + * current mode. The REDRAW_PENDING flag is cleared. * *---------------------------------------------------------------------- */ @@ -933,24 +1133,46 @@ DisplayButton(clientData) Pixmap pixmap; int x = 0; /* Initialization only needed to stop * compiler warning. */ - int y; + int y, relief; register Tk_Window tkwin = butPtr->tkwin; + int width, height; + int offset; /* 0 means this is a label widget. 1 means + * it is a flavor of button, so we offset + * the text to make the button appear to + * move up and down as the relief changes. */ butPtr->flags &= ~REDRAW_PENDING; if ((butPtr->tkwin == NULL) || !Tk_IsMapped(tkwin)) { return; } + border = butPtr->normalBorder; if ((butPtr->state == tkDisabledUid) && (butPtr->disabledFg != NULL)) { gc = butPtr->disabledGC; - border = butPtr->normalBorder; - } else if (butPtr->state == tkActiveUid) { + } else if ((butPtr->state == tkActiveUid) + && !Tk_StrictMotif(butPtr->tkwin)) { gc = butPtr->activeTextGC; border = butPtr->activeBorder; } else { gc = butPtr->normalTextGC; - border = butPtr->normalBorder; } + if ((butPtr->flags & SELECTED) && (butPtr->state != tkActiveUid) + && (butPtr->selectBorder != NULL) && !butPtr->indicatorOn) { + border = butPtr->selectBorder; + } + + /* + * Override the relief specified for the button if this is a + * checkbutton or radiobutton and there's no indicator. + */ + + relief = butPtr->relief; + if ((butPtr->type >= TYPE_CHECK_BUTTON) && !butPtr->indicatorOn) { + relief = (butPtr->flags & SELECTED) ? TK_RELIEF_SUNKEN + : TK_RELIEF_RAISED; + } + + offset = (butPtr->type == TYPE_BUTTON) && !Tk_StrictMotif(butPtr->tkwin); /* * In order to avoid screen flashes, this procedure redraws @@ -959,129 +1181,146 @@ DisplayButton(clientData) * point in time where the on-sreen image has been cleared. */ - pixmap = XCreatePixmap(butPtr->display, Tk_WindowId(tkwin), + pixmap = Tk_GetPixmap(butPtr->display, Tk_WindowId(tkwin), Tk_Width(tkwin), Tk_Height(tkwin), Tk_Depth(tkwin)); - Tk_Fill3DRectangle(butPtr->display, pixmap, border, - 0, 0, Tk_Width(tkwin), Tk_Height(tkwin), 0, TK_RELIEF_FLAT); + Tk_Fill3DRectangle(tkwin, pixmap, border, 0, 0, Tk_Width(tkwin), + Tk_Height(tkwin), 0, TK_RELIEF_FLAT); /* - * Display bitmap or text for button. + * Display image or bitmap or text for button. */ - if (butPtr->bitmap != None) { - unsigned int width, height; + if (butPtr->image != None) { + Tk_SizeOfImage(butPtr->image, &width, &height); - Tk_SizeOfBitmap(butPtr->display, butPtr->bitmap, &width, &height); + imageOrBitmap: switch (butPtr->anchor) { case TK_ANCHOR_NW: case TK_ANCHOR_W: case TK_ANCHOR_SW: - x = butPtr->borderWidth + butPtr->selectorSpace - + butPtr->padX + 1; + x = butPtr->inset + butPtr->indicatorSpace + offset; break; case TK_ANCHOR_N: case TK_ANCHOR_CENTER: case TK_ANCHOR_S: - x = (Tk_Width(tkwin) + butPtr->selectorSpace - width)/2; + x = ((int) (Tk_Width(tkwin) + butPtr->indicatorSpace + - width))/2; break; default: - x = Tk_Width(tkwin) - butPtr->borderWidth - butPtr->padX - - width - 1; + x = Tk_Width(tkwin) - butPtr->inset - width - offset; break; } switch (butPtr->anchor) { case TK_ANCHOR_NW: case TK_ANCHOR_N: case TK_ANCHOR_NE: - y = butPtr->borderWidth + butPtr->padY + 1; + y = butPtr->inset + offset; break; case TK_ANCHOR_W: case TK_ANCHOR_CENTER: case TK_ANCHOR_E: - y = (Tk_Height(tkwin) - height)/2; + y = ((int) (Tk_Height(tkwin) - height))/2; break; default: - y = Tk_Height(tkwin) - butPtr->borderWidth - butPtr->padY - - height - 1; + y = Tk_Height(tkwin) - butPtr->inset - height - offset; break; } - if (butPtr->relief == TK_RELIEF_RAISED) { - x -= 1; - y -= 1; - } else if (butPtr->relief == TK_RELIEF_SUNKEN) { - x += 1; - y += 1; + if (relief == TK_RELIEF_RAISED) { + x -= offset; + y -= offset; + } else if (relief == TK_RELIEF_SUNKEN) { + x += offset; + y += offset; + } + if (butPtr->image != NULL) { + if ((butPtr->selectImage != NULL) && (butPtr->flags & SELECTED)) { + Tk_RedrawImage(butPtr->selectImage, 0, 0, width, height, pixmap, + x, y); + } else { + Tk_RedrawImage(butPtr->image, 0, 0, width, height, pixmap, + x, y); + } + } else { + XSetClipOrigin(butPtr->display, gc, x, y); + XCopyPlane(butPtr->display, butPtr->bitmap, pixmap, gc, 0, 0, + (unsigned int) width, (unsigned int) height, x, y, 1); + XSetClipOrigin(butPtr->display, gc, 0, 0); } - XCopyPlane(butPtr->display, butPtr->bitmap, pixmap, - gc, 0, 0, width, height, x, y, 1); y += height/2; + } else if (butPtr->bitmap != None) { + Tk_SizeOfBitmap(butPtr->display, butPtr->bitmap, &width, &height); + goto imageOrBitmap; } else { switch (butPtr->anchor) { case TK_ANCHOR_NW: case TK_ANCHOR_W: case TK_ANCHOR_SW: - x = butPtr->borderWidth + butPtr->padX + butPtr->selectorSpace - - butPtr->leftBearing + 1; + x = butPtr->inset + butPtr->padX + butPtr->indicatorSpace + + offset; break; case TK_ANCHOR_N: case TK_ANCHOR_CENTER: case TK_ANCHOR_S: - x = (Tk_Width(tkwin) + butPtr->selectorSpace - - butPtr->leftBearing - butPtr->rightBearing)/2; + x = ((int) (Tk_Width(tkwin) + butPtr->indicatorSpace + - butPtr->textWidth))/2; break; default: - x = Tk_Width(tkwin) - butPtr->borderWidth - butPtr->padX - - butPtr->rightBearing - 1; + x = Tk_Width(tkwin) - butPtr->inset - butPtr->padX + - butPtr->textWidth - offset; break; } switch (butPtr->anchor) { case TK_ANCHOR_NW: case TK_ANCHOR_N: case TK_ANCHOR_NE: - y = butPtr->borderWidth + butPtr->fontPtr->ascent - + butPtr->padY + 1; + y = butPtr->inset + butPtr->padY + offset; break; case TK_ANCHOR_W: case TK_ANCHOR_CENTER: case TK_ANCHOR_E: - y = (Tk_Height(tkwin) + butPtr->fontPtr->ascent - - butPtr->fontPtr->descent)/2; + y = ((int) (Tk_Height(tkwin) - butPtr->textHeight))/2; break; default: - y = Tk_Height(tkwin) - butPtr->borderWidth - butPtr->padY - - butPtr->fontPtr->descent - 1; + y = Tk_Height(tkwin) - butPtr->inset - butPtr->padY + - butPtr->textHeight - offset; break; } - if (butPtr->relief == TK_RELIEF_RAISED) { - x -= 1; - y -= 1; - } else if (butPtr->relief == TK_RELIEF_SUNKEN) { - x += 1; - y += 1; + if (relief == TK_RELIEF_RAISED) { + x -= offset; + y -= offset; + } else if (relief == TK_RELIEF_SUNKEN) { + x += offset; + y += offset; } - XDrawString(butPtr->display, pixmap, gc, x, y, - butPtr->text, butPtr->textLength); - y -= (butPtr->fontPtr->ascent - butPtr->fontPtr->descent)/2; - x += butPtr->leftBearing; + TkDisplayText(butPtr->display, pixmap, butPtr->fontPtr, + butPtr->text, butPtr->numChars, x, y, butPtr->textWidth, + butPtr->justify, butPtr->underline, gc); + y += butPtr->textHeight/2; } /* - * Draw the selector for check buttons and radio buttons. At this - * point x and y refer to the top-left corner of the text or bitmap. + * Draw the indicator for check buttons and radio buttons. At this + * point x and y refer to the top-left corner of the text or image + * or bitmap. */ - if ((butPtr->type == TYPE_CHECK_BUTTON) && (butPtr->selectorGC != None)) { + if ((butPtr->type == TYPE_CHECK_BUTTON) && butPtr->indicatorOn) { int dim; - dim = butPtr->selectorDiameter; - x -= butPtr->selectorSpace; + dim = butPtr->indicatorDiameter; + x -= butPtr->indicatorSpace; y -= dim/2; - Tk_Draw3DRectangle(butPtr->display, pixmap, border, x, y, - dim, dim, butPtr->borderWidth, TK_RELIEF_SUNKEN); - x += butPtr->borderWidth; - y += butPtr->borderWidth; - dim -= 2*butPtr->borderWidth; - if (dim > 0) { + if (dim > 2*butPtr->borderWidth) { + Tk_Draw3DRectangle(tkwin, pixmap, border, x, y, dim, dim, + butPtr->borderWidth, + (butPtr->flags & SELECTED) ? TK_RELIEF_SUNKEN : + TK_RELIEF_RAISED); + x += butPtr->borderWidth; + y += butPtr->borderWidth; + dim -= 2*butPtr->borderWidth; if (butPtr->flags & SELECTED) { - XFillRectangle(butPtr->display, pixmap, butPtr->selectorGC, - x, y, (unsigned int) dim, (unsigned int) dim); + GC gc; + + gc = Tk_3DBorderGC(tkwin,(butPtr->selectBorder != NULL) + ? butPtr->selectBorder : butPtr->normalBorder, + TK_3D_FLAT_GC); + XFillRectangle(butPtr->display, pixmap, gc, x, y, + (unsigned int) dim, (unsigned int) dim); } else { - Tk_Fill3DRectangle(butPtr->display, pixmap, - butPtr->normalBorder, x, y, dim, dim, - butPtr->borderWidth, TK_RELIEF_FLAT); + Tk_Fill3DRectangle(tkwin, pixmap, butPtr->normalBorder, x, y, + dim, dim, butPtr->borderWidth, TK_RELIEF_FLAT); } } - } else if ((butPtr->type == TYPE_RADIO_BUTTON) - && (butPtr->selectorGC != None)) { + } else if ((butPtr->type == TYPE_RADIO_BUTTON) && butPtr->indicatorOn) { XPoint points[4]; int radius; - radius = butPtr->selectorDiameter/2; - points[0].x = x - butPtr->selectorSpace; + radius = butPtr->indicatorDiameter/2; + points[0].x = x - butPtr->indicatorSpace; points[0].y = y; points[1].x = points[0].x + radius; points[1].y = points[0].y + radius; @@ -1090,37 +1329,68 @@ DisplayButton(clientData) points[3].x = points[1].x; points[3].y = points[0].y - radius; if (butPtr->flags & SELECTED) { - XFillPolygon(butPtr->display, pixmap, butPtr->selectorGC, - points, 4, Convex, CoordModeOrigin); + GC gc; + + gc = Tk_3DBorderGC(tkwin, (butPtr->selectBorder != NULL) + ? butPtr->selectBorder : butPtr->normalBorder, + TK_3D_FLAT_GC); + XFillPolygon(butPtr->display, pixmap, gc, points, 4, Convex, + CoordModeOrigin); } else { - Tk_Fill3DPolygon(butPtr->display, pixmap, butPtr->normalBorder, - points, 4, butPtr->borderWidth, TK_RELIEF_FLAT); + Tk_Fill3DPolygon(tkwin, pixmap, butPtr->normalBorder, points, + 4, butPtr->borderWidth, TK_RELIEF_FLAT); } - Tk_Draw3DPolygon(butPtr->display, pixmap, border, - points, 4, butPtr->borderWidth, TK_RELIEF_RAISED); + Tk_Draw3DPolygon(tkwin, pixmap, border, points, 4, butPtr->borderWidth, + (butPtr->flags & SELECTED) ? TK_RELIEF_SUNKEN : + TK_RELIEF_RAISED); } /* * If the button is disabled with a stipple rather than a special - * foreground color, generate the stippled effect. + * foreground color, generate the stippled effect. If the widget + * is selected and we use a different background color when selected, + * must temporarily modify the GC. */ - if ((butPtr->state == tkDisabledUid) && (butPtr->disabledFg == NULL)) { + if ((butPtr->state == tkDisabledUid) + && ((butPtr->disabledFg == NULL) || (butPtr->image != NULL))) { + if ((butPtr->flags & SELECTED) && !butPtr->indicatorOn + && (butPtr->selectBorder != NULL)) { + XSetForeground(butPtr->display, butPtr->disabledGC, + Tk_3DBorderColor(butPtr->selectBorder)->pixel); + } XFillRectangle(butPtr->display, pixmap, butPtr->disabledGC, - butPtr->borderWidth, butPtr->borderWidth, - (unsigned) (Tk_Width(tkwin) - 2*butPtr->borderWidth), - (unsigned) (Tk_Height(tkwin) - 2*butPtr->borderWidth)); + butPtr->inset, butPtr->inset, + (unsigned) (Tk_Width(tkwin) - 2*butPtr->inset), + (unsigned) (Tk_Height(tkwin) - 2*butPtr->inset)); + if ((butPtr->flags & SELECTED) && !butPtr->indicatorOn + && (butPtr->selectBorder != NULL)) { + XSetForeground(butPtr->display, butPtr->disabledGC, + Tk_3DBorderColor(butPtr->normalBorder)->pixel); + } } /* - * Draw the border last. This way, if the button's contents - * overflow onto the border they'll be covered up by the border. + * Draw the border and traversal highlight last. This way, if the + * button's contents overflow they'll be covered up by the border. */ - if (butPtr->relief != TK_RELIEF_FLAT) { - Tk_Draw3DRectangle(butPtr->display, pixmap, border,0, 0, - Tk_Width(tkwin), Tk_Height(tkwin), butPtr->borderWidth, - butPtr->relief); + if (relief != TK_RELIEF_FLAT) { + Tk_Draw3DRectangle(tkwin, pixmap, border, + butPtr->highlightWidth, butPtr->highlightWidth, + Tk_Width(tkwin) - 2*butPtr->highlightWidth, + Tk_Height(tkwin) - 2*butPtr->highlightWidth, + butPtr->borderWidth, relief); + } + if (butPtr->highlightWidth != 0) { + GC gc; + + if (butPtr->flags & GOT_FOCUS) { + gc = Tk_GCForColor(butPtr->highlightColorPtr, pixmap); + } else { + gc = Tk_GCForColor(butPtr->highlightBgColorPtr, pixmap); + } + Tk_DrawFocusHighlight(tkwin, gc, butPtr->highlightWidth, pixmap); } /* @@ -1129,8 +1399,9 @@ DisplayButton(clientData) */ XCopyArea(butPtr->display, pixmap, Tk_WindowId(tkwin), - butPtr->normalTextGC, 0, 0, Tk_Width(tkwin), Tk_Height(tkwin), 0, 0); - XFreePixmap(butPtr->display, pixmap); + butPtr->copyGC, 0, 0, (unsigned) Tk_Width(tkwin), + (unsigned) Tk_Height(tkwin), 0, 0); + Tk_FreePixmap(butPtr->display, pixmap); } /* @@ -1158,17 +1429,83 @@ ButtonEventProc(clientData, eventPtr) { Button *butPtr = (Button *) clientData; if ((eventPtr->type == Expose) && (eventPtr->xexpose.count == 0)) { - if ((butPtr->tkwin != NULL) && !(butPtr->flags & REDRAW_PENDING)) { - Tk_DoWhenIdle(DisplayButton, (ClientData) butPtr); - butPtr->flags |= REDRAW_PENDING; - } + goto redraw; + } else if (eventPtr->type == ConfigureNotify) { + /* + * Must redraw after size changes, since layout could have changed + * and borders will need to be redrawn. + */ + + goto redraw; } else if (eventPtr->type == DestroyNotify) { - Tcl_DeleteCommand(butPtr->interp, Tk_PathName(butPtr->tkwin)); - butPtr->tkwin = NULL; - if (butPtr->flags & REDRAW_PENDING) { - Tk_CancelIdleCall(DisplayButton, (ClientData) butPtr); + if (butPtr->tkwin != NULL) { + butPtr->tkwin = NULL; + Tcl_DeleteCommand(butPtr->interp, + Tcl_GetCommandName(butPtr->interp, butPtr->widgetCmd)); } - Tk_EventuallyFree((ClientData) butPtr, DestroyButton); + if (butPtr->flags & REDRAW_PENDING) { + Tcl_CancelIdleCall(DisplayButton, (ClientData) butPtr); + } + DestroyButton(butPtr); + } else if (eventPtr->type == FocusIn) { + if (eventPtr->xfocus.detail != NotifyInferior) { + butPtr->flags |= GOT_FOCUS; + if (butPtr->highlightWidth > 0) { + goto redraw; + } + } + } else if (eventPtr->type == FocusOut) { + if (eventPtr->xfocus.detail != NotifyInferior) { + butPtr->flags &= ~GOT_FOCUS; + if (butPtr->highlightWidth > 0) { + goto redraw; + } + } + } + return; + + redraw: + if ((butPtr->tkwin != NULL) && !(butPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(DisplayButton, (ClientData) butPtr); + butPtr->flags |= REDRAW_PENDING; + } +} + +/* + *---------------------------------------------------------------------- + * + * ButtonCmdDeletedProc -- + * + * This procedure is invoked when a widget command is deleted. If + * the widget isn't already in the process of being destroyed, + * this command destroys it. + * + * Results: + * None. + * + * Side effects: + * The widget is destroyed. + * + *---------------------------------------------------------------------- + */ + +static void +ButtonCmdDeletedProc(clientData) + ClientData clientData; /* Pointer to widget record for widget. */ +{ + Button *butPtr = (Button *) clientData; + Tk_Window tkwin = butPtr->tkwin; + + /* + * This procedure could be invoked either because the window was + * destroyed and the command was then deleted (in which case tkwin + * is NULL) or because the command was deleted, and then this procedure + * destroys the widget. + */ + + if (tkwin != NULL) { + butPtr->tkwin = NULL; + Tk_DestroyWindow(tkwin); } } @@ -1194,67 +1531,76 @@ static void ComputeButtonGeometry(butPtr) register Button *butPtr; /* Button whose geometry may have changed. */ { - XCharStruct bbox; - int dummy; - unsigned int width, height; + int width, height; - butPtr->selectorSpace = 0; - if (butPtr->bitmap != None) { - Tk_SizeOfBitmap(butPtr->display, butPtr->bitmap, &width, &height); + if (butPtr->highlightWidth < 0) { + butPtr->highlightWidth = 0; + } + butPtr->inset = butPtr->highlightWidth + butPtr->borderWidth; + butPtr->indicatorSpace = 0; + if (butPtr->image != NULL) { + Tk_SizeOfImage(butPtr->image, &width, &height); + imageOrBitmap: if (butPtr->width > 0) { width = butPtr->width; } if (butPtr->height > 0) { height = butPtr->height; } - if ((butPtr->type >= TYPE_CHECK_BUTTON) - && (butPtr->selectorGC != None)) { - butPtr->selectorSpace = height; + if ((butPtr->type >= TYPE_CHECK_BUTTON) && butPtr->indicatorOn) { + butPtr->indicatorSpace = height; if (butPtr->type == TYPE_CHECK_BUTTON) { - butPtr->selectorDiameter = (65*height)/100; + butPtr->indicatorDiameter = (65*height)/100; } else { - butPtr->selectorDiameter = (75*height)/100; + butPtr->indicatorDiameter = (75*height)/100; } } + } else if (butPtr->bitmap != None) { + Tk_SizeOfBitmap(butPtr->display, butPtr->bitmap, &width, &height); + goto imageOrBitmap; } else { - butPtr->textLength = strlen(butPtr->text); - XTextExtents(butPtr->fontPtr, butPtr->text, butPtr->textLength, - &dummy, &dummy, &dummy, &bbox); - butPtr->leftBearing = bbox.lbearing; - butPtr->rightBearing = bbox.rbearing; - width = bbox.rbearing - bbox.lbearing; - height = butPtr->fontPtr->ascent + butPtr->fontPtr->descent; + butPtr->numChars = strlen(butPtr->text); + TkComputeTextGeometry(butPtr->fontPtr, butPtr->text, + butPtr->numChars, butPtr->wrapLength, &butPtr->textWidth, + &butPtr->textHeight); + width = butPtr->textWidth; + height = butPtr->textHeight; if (butPtr->width > 0) { width = butPtr->width * XTextWidth(butPtr->fontPtr, "0", 1); } if (butPtr->height > 0) { - height *= butPtr->height; + height = butPtr->height * (butPtr->fontPtr->ascent + + butPtr->fontPtr->descent); } - if ((butPtr->type >= TYPE_CHECK_BUTTON) - && (butPtr->selectorGC != None)) { - butPtr->selectorDiameter = butPtr->fontPtr->ascent + if ((butPtr->type >= TYPE_CHECK_BUTTON) && butPtr->indicatorOn) { + butPtr->indicatorDiameter = butPtr->fontPtr->ascent + butPtr->fontPtr->descent; if (butPtr->type == TYPE_CHECK_BUTTON) { - butPtr->selectorDiameter = (80*butPtr->selectorDiameter)/100; + butPtr->indicatorDiameter = (80*butPtr->indicatorDiameter)/100; } - butPtr->selectorSpace = butPtr->selectorDiameter + butPtr->indicatorSpace = butPtr->indicatorDiameter + XTextWidth(butPtr->fontPtr, "0", 1); } } /* - * When issuing the geometry request, add extra space for the selector, + * When issuing the geometry request, add extra space for the indicator, * if any, and for the border and padding, plus two extra pixels so the * display can be offset by 1 pixel in either direction for the raised * or lowered effect. */ - width += 2*butPtr->padX; - height += 2*butPtr->padY; - Tk_GeometryRequest(butPtr->tkwin, (int) (width + butPtr->selectorSpace - + 2*butPtr->borderWidth + 2), - (int) (height + 2*butPtr->borderWidth + 2)); - Tk_SetInternalBorder(butPtr->tkwin, butPtr->borderWidth); + if ((butPtr->image == NULL) && (butPtr->bitmap == None)) { + width += 2*butPtr->padX; + height += 2*butPtr->padY; + } + if ((butPtr->type == TYPE_BUTTON) && !Tk_StrictMotif(butPtr->tkwin)) { + width += 2; + height += 2; + } + Tk_GeometryRequest(butPtr->tkwin, (int) (width + butPtr->indicatorSpace + + 2*butPtr->inset), (int) (height + 2*butPtr->inset)); + Tk_SetInternalBorder(butPtr->tkwin, butPtr->inset); } /* @@ -1283,15 +1629,21 @@ InvokeButton(butPtr) { if (butPtr->type == TYPE_CHECK_BUTTON) { if (butPtr->flags & SELECTED) { - Tcl_SetVar(butPtr->interp, butPtr->selVarName, butPtr->offValue, - TCL_GLOBAL_ONLY); + if (Tcl_SetVar(butPtr->interp, butPtr->selVarName, butPtr->offValue, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } } else { - Tcl_SetVar(butPtr->interp, butPtr->selVarName, butPtr->onValue, - TCL_GLOBAL_ONLY); + if (Tcl_SetVar(butPtr->interp, butPtr->selVarName, butPtr->onValue, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } } } else if (butPtr->type == TYPE_RADIO_BUTTON) { - Tcl_SetVar(butPtr->interp, butPtr->selVarName, butPtr->onValue, - TCL_GLOBAL_ONLY); + if (Tcl_SetVar(butPtr->interp, butPtr->selVarName, butPtr->onValue, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } } if ((butPtr->type != TYPE_LABEL) && (butPtr->command != NULL)) { return TkCopyAndGlobalEval(butPtr->interp, butPtr->command); @@ -1338,7 +1690,7 @@ ButtonVarProc(clientData, interp, name1, name2, flags) if (flags & TCL_TRACE_UNSETS) { butPtr->flags &= ~SELECTED; if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) { - Tcl_TraceVar2(interp, name1, name2, + Tcl_TraceVar(interp, butPtr->selVarName, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, ButtonVarProc, clientData); } @@ -1350,7 +1702,10 @@ ButtonVarProc(clientData, interp, name1, name2, flags) * the button. */ - value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY); + value = Tcl_GetVar(interp, butPtr->selVarName, TCL_GLOBAL_ONLY); + if (value == NULL) { + value = ""; + } if (strcmp(value, butPtr->onValue) == 0) { if (butPtr->flags & SELECTED) { return (char *) NULL; @@ -1365,7 +1720,7 @@ ButtonVarProc(clientData, interp, name1, name2, flags) redisplay: if ((butPtr->tkwin != NULL) && Tk_IsMapped(butPtr->tkwin) && !(butPtr->flags & REDRAW_PENDING)) { - Tk_DoWhenIdle(DisplayButton, (ClientData) butPtr); + Tcl_DoWhenIdle(DisplayButton, (ClientData) butPtr); butPtr->flags |= REDRAW_PENDING; } return (char *) NULL; @@ -1394,8 +1749,8 @@ static char * ButtonTextVarProc(clientData, interp, name1, name2, flags) ClientData clientData; /* Information about button. */ Tcl_Interp *interp; /* Interpreter containing variable. */ - char *name1; /* Name of variable. */ - char *name2; /* Second part of variable name. */ + char *name1; /* Not used. */ + char *name2; /* Not used. */ int flags; /* Information about what happened. */ { register Button *butPtr = (Button *) clientData; @@ -1408,30 +1763,109 @@ ButtonTextVarProc(clientData, interp, name1, name2, flags) if (flags & TCL_TRACE_UNSETS) { if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) { - Tcl_SetVar2(interp, name1, name2, butPtr->text, - flags & TCL_GLOBAL_ONLY); - Tcl_TraceVar2(interp, name1, name2, + Tcl_SetVar(interp, butPtr->textVarName, butPtr->text, + TCL_GLOBAL_ONLY); + Tcl_TraceVar(interp, butPtr->textVarName, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, ButtonTextVarProc, clientData); } return (char *) NULL; } - value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY); + value = Tcl_GetVar(interp, butPtr->textVarName, TCL_GLOBAL_ONLY); if (value == NULL) { value = ""; } if (butPtr->text != NULL) { ckfree(butPtr->text); } - butPtr->text = ckalloc((unsigned) (strlen(value) + 1)); + butPtr->text = (char *) ckalloc((unsigned) (strlen(value) + 1)); strcpy(butPtr->text, value); ComputeButtonGeometry(butPtr); if ((butPtr->tkwin != NULL) && Tk_IsMapped(butPtr->tkwin) && !(butPtr->flags & REDRAW_PENDING)) { - Tk_DoWhenIdle(DisplayButton, (ClientData) butPtr); + Tcl_DoWhenIdle(DisplayButton, (ClientData) butPtr); butPtr->flags |= REDRAW_PENDING; } return (char *) NULL; } + +/* + *---------------------------------------------------------------------- + * + * ButtonImageProc -- + * + * This procedure is invoked by the image code whenever the manager + * for an image does something that affects the size of contents + * of an image displayed in a button. + * + * Results: + * None. + * + * Side effects: + * Arranges for the button to get redisplayed. + * + *---------------------------------------------------------------------- + */ + +static void +ButtonImageProc(clientData, x, y, width, height, imgWidth, imgHeight) + ClientData clientData; /* Pointer to widget record. */ + int x, y; /* Upper left pixel (within image) + * that must be redisplayed. */ + int width, height; /* Dimensions of area to redisplay + * (may be <= 0). */ + int imgWidth, imgHeight; /* New dimensions of image. */ +{ + register Button *butPtr = (Button *) clientData; + + if (butPtr->tkwin != NULL) { + ComputeButtonGeometry(butPtr); + if (Tk_IsMapped(butPtr->tkwin) && !(butPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(DisplayButton, (ClientData) butPtr); + butPtr->flags |= REDRAW_PENDING; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * ButtonSelectImageProc -- + * + * This procedure is invoked by the image code whenever the manager + * for an image does something that affects the size of contents + * of the image displayed in a button when it is selected. + * + * Results: + * None. + * + * Side effects: + * May arrange for the button to get redisplayed. + * + *---------------------------------------------------------------------- + */ + +static void +ButtonSelectImageProc(clientData, x, y, width, height, imgWidth, imgHeight) + ClientData clientData; /* Pointer to widget record. */ + int x, y; /* Upper left pixel (within image) + * that must be redisplayed. */ + int width, height; /* Dimensions of area to redisplay + * (may be <= 0). */ + int imgWidth, imgHeight; /* New dimensions of image. */ +{ + register Button *butPtr = (Button *) clientData; + + /* + * Don't recompute geometry: it's controlled by the primary image. + */ + + if ((butPtr->flags & SELECTED) && (butPtr->tkwin != NULL) + && Tk_IsMapped(butPtr->tkwin) + && !(butPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(DisplayButton, (ClientData) butPtr); + butPtr->flags |= REDRAW_PENDING; + } +} diff --git a/tk3.6/tkCanvArc.c b/tk4.2/generic/tkCanvArc.c similarity index 79% rename from tk3.6/tkCanvArc.c rename to tk4.2/generic/tkCanvArc.c index b018f6d..186e644 100644 --- a/tk3.6/tkCanvArc.c +++ b/tk4.2/generic/tkCanvArc.c @@ -3,35 +3,18 @@ * * This file implements arc items for canvas widgets. * - * Copyright (c) 1992-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1992-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tkCanvArc.c 1.32 96/02/17 16:59:09 */ -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkCanvArc.c,v 1.16 93/09/15 08:19:59 ouster Exp $ SPRITE (Berkeley)"; -#endif - #include -#include "tkConfig.h" +#include "tkPort.h" #include "tkInt.h" -#include "tkCanvas.h" /* * The structure below defines the record for each arc item. @@ -62,13 +45,10 @@ typedef struct ArcItem { * outline too when style is "arc"). NULL * means don't fill arc. */ Pixmap fillStipple; /* Stipple bitmap for filling item. */ + Pixmap outlineStipple; /* Stipple bitmap for outline. */ Tk_Uid style; /* How to draw arc: arc, chord, or pieslice. */ GC outlineGC; /* Graphics context for outline. */ GC fillGC; /* Graphics context for filling item. */ - GC *stippleGCPtr; /* If not NULL, points to a GC (either - * outlineGC or fillGC) containing a stipple - * offset that must be adjusted on each - * redisplay. */ double center1[2]; /* Coordinates of center of arc outline at * start (see ComputeArcOutline). */ double center2[2]; /* Coordinates of center of arc outline at @@ -88,6 +68,10 @@ typedef struct ArcItem { * Information used for parsing configuration specs: */ +static Tk_CustomOption tagsOption = {Tk_CanvasTagsParseProc, + Tk_CanvasTagsPrintProc, (ClientData) NULL +}; + static Tk_ConfigSpec configSpecs[] = { {TK_CONFIG_DOUBLE, "-extent", (char *) NULL, (char *) NULL, "90", Tk_Offset(ArcItem, extent), TK_CONFIG_DONT_SET_DEFAULT}, @@ -95,6 +79,8 @@ static Tk_ConfigSpec configSpecs[] = { (char *) NULL, Tk_Offset(ArcItem, fillColor), TK_CONFIG_NULL_OK}, {TK_CONFIG_COLOR, "-outline", (char *) NULL, (char *) NULL, "black", Tk_Offset(ArcItem, outlineColor), TK_CONFIG_NULL_OK}, + {TK_CONFIG_BITMAP, "-outlinestipple", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(ArcItem, outlineStipple), TK_CONFIG_NULL_OK}, {TK_CONFIG_DOUBLE, "-start", (char *) NULL, (char *) NULL, "0", Tk_Offset(ArcItem, start), TK_CONFIG_DONT_SET_DEFAULT}, {TK_CONFIG_BITMAP, "-stipple", (char *) NULL, (char *) NULL, @@ -102,7 +88,7 @@ static Tk_ConfigSpec configSpecs[] = { {TK_CONFIG_UID, "-style", (char *) NULL, (char *) NULL, "pieslice", Tk_Offset(ArcItem, style), TK_CONFIG_DONT_SET_DEFAULT}, {TK_CONFIG_CUSTOM, "-tags", (char *) NULL, (char *) NULL, - (char *) NULL, 0, TK_CONFIG_NULL_OK, &tkCanvasTagsOption}, + (char *) NULL, 0, TK_CONFIG_NULL_OK, &tagsOption}, {TK_CONFIG_PIXELS, "-width", (char *) NULL, (char *) NULL, "1", Tk_Offset(ArcItem, width), TK_CONFIG_DONT_SET_DEFAULT}, {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, @@ -113,36 +99,39 @@ static Tk_ConfigSpec configSpecs[] = { * Prototypes for procedures defined in this file: */ -static int ArcCoords _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, int argc, char **argv)); +static void ComputeArcBbox _ANSI_ARGS_((Tk_Canvas canvas, + ArcItem *arcPtr)); +static int ConfigureArc _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int argc, + char **argv, int flags)); +static int CreateArc _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, struct Tk_Item *itemPtr, + int argc, char **argv)); +static void DeleteArc _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, Display *display)); +static void DisplayArc _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, Display *display, Drawable dst, + int x, int y, int width, int height)); +static int ArcCoords _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int argc, + char **argv)); +static int ArcToArea _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double *rectPtr)); +static double ArcToPoint _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double *coordPtr)); +static int ArcToPostscript _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int prepass)); +static void ScaleArc _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double originX, double originY, + double scaleX, double scaleY)); +static void TranslateArc _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double deltaX, double deltaY)); static int AngleInRange _ANSI_ARGS_((double x, double y, double start, double extent)); -static int ArcToArea _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, double *rectPtr)); -static double ArcToPoint _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, double *coordPtr)); -static int ArcToPostscript _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, Tk_PostscriptInfo *psInfoPtr)); -static void ComputeArcBbox _ANSI_ARGS_((Tk_Canvas *canvasPtr, - ArcItem *arcPtr)); static void ComputeArcOutline _ANSI_ARGS_((ArcItem *arcPtr)); -static int ConfigureArc _ANSI_ARGS_(( - Tk_Canvas *canvasPtr, Tk_Item *itemPtr, int argc, - char **argv, int flags)); -static int CreateArc _ANSI_ARGS_((Tk_Canvas *canvasPtr, - struct Tk_Item *itemPtr, int argc, char **argv)); -static void DeleteArc _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr)); -static void DisplayArc _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, Drawable dst)); static int HorizLineToArc _ANSI_ARGS_((double x1, double x2, double y, double rx, double ry, double start, double extent)); -static void ScaleArc _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, double originX, double originY, - double scaleX, double scaleY)); -static void TranslateArc _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, double deltaX, double deltaY)); static int VertLineToArc _ANSI_ARGS_((double x, double y1, double y2, double rx, double ry, double start, double extent)); @@ -152,7 +141,7 @@ static int VertLineToArc _ANSI_ARGS_((double x, double y1, * that can be invoked by generic item code. */ -Tk_ItemType TkArcType = { +Tk_ItemType tkArcType = { "arc", /* name */ sizeof(ArcItem), /* itemSize */ CreateArc, /* createProc */ @@ -199,7 +188,7 @@ static Tk_Uid pieSliceUid = NULL; * Results: * A standard Tcl return value. If an error occurred in * creating the item, then an error message is left in - * canvasPtr->interp->result; in this case itemPtr is + * interp->result; in this case itemPtr is * left uninitialized, so it can be safely freed by the * caller. * @@ -210,19 +199,20 @@ static Tk_Uid pieSliceUid = NULL; */ static int -CreateArc(canvasPtr, itemPtr, argc, argv) - register Tk_Canvas *canvasPtr; /* Canvas to hold new item. */ +CreateArc(interp, canvas, itemPtr, argc, argv) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + Tk_Canvas canvas; /* Canvas to hold new item. */ Tk_Item *itemPtr; /* Record to hold new item; header * has been initialized by caller. */ int argc; /* Number of arguments in argv. */ char **argv; /* Arguments describing arc. */ { - register ArcItem *arcPtr = (ArcItem *) itemPtr; + ArcItem *arcPtr = (ArcItem *) itemPtr; if (argc < 4) { - Tcl_AppendResult(canvasPtr->interp, "wrong # args: should be \"", - Tk_PathName(canvasPtr->tkwin), "\" create ", - itemPtr->typePtr->name, " x1 y1 x2 y2 ?options?", + Tcl_AppendResult(interp, "wrong # args: should be \"", + Tk_PathName(Tk_CanvasTkwin(canvas)), " create ", + itemPtr->typePtr->name, " x1 y1 x2 y2 ?options?\"", (char *) NULL); return TCL_ERROR; } @@ -250,27 +240,27 @@ CreateArc(canvasPtr, itemPtr, argc, argv) arcPtr->outlineColor = NULL; arcPtr->fillColor = NULL; arcPtr->fillStipple = None; + arcPtr->outlineStipple = None; arcPtr->style = pieSliceUid; arcPtr->outlineGC = None; arcPtr->fillGC = None; - arcPtr->stippleGCPtr = NULL; /* * Process the arguments to fill in the item record. */ - if ((TkGetCanvasCoord(canvasPtr, argv[0], &arcPtr->bbox[0]) != TCL_OK) - || (TkGetCanvasCoord(canvasPtr, argv[1], + if ((Tk_CanvasGetCoord(interp, canvas, argv[0], &arcPtr->bbox[0]) != TCL_OK) + || (Tk_CanvasGetCoord(interp, canvas, argv[1], &arcPtr->bbox[1]) != TCL_OK) - || (TkGetCanvasCoord(canvasPtr, argv[2], + || (Tk_CanvasGetCoord(interp, canvas, argv[2], &arcPtr->bbox[2]) != TCL_OK) - || (TkGetCanvasCoord(canvasPtr, argv[3], + || (Tk_CanvasGetCoord(interp, canvas, argv[3], &arcPtr->bbox[3]) != TCL_OK)) { return TCL_ERROR; } - if (ConfigureArc(canvasPtr, itemPtr, argc-4, argv+4, 0) != TCL_OK) { - DeleteArc(canvasPtr, itemPtr); + if (ConfigureArc(interp, canvas, itemPtr, argc-4, argv+4, 0) != TCL_OK) { + DeleteArc(canvas, itemPtr, Tk_Display(Tk_CanvasTkwin(canvas))); return TCL_ERROR; } return TCL_OK; @@ -286,7 +276,7 @@ CreateArc(canvasPtr, itemPtr, argc, argv) * on what it does. * * Results: - * Returns TCL_OK or TCL_ERROR, and sets canvasPtr->interp->result. + * Returns TCL_OK or TCL_ERROR, and sets interp->result. * * Side effects: * The coordinates for the given item may be changed. @@ -295,8 +285,9 @@ CreateArc(canvasPtr, itemPtr, argc, argv) */ static int -ArcCoords(canvasPtr, itemPtr, argc, argv) - register Tk_Canvas *canvasPtr; /* Canvas containing item. */ +ArcCoords(interp, canvas, itemPtr, argc, argv) + Tcl_Interp *interp; /* Used for error reporting. */ + Tk_Canvas canvas; /* Canvas containing item. */ Tk_Item *itemPtr; /* Item whose coordinates are to be * read or modified. */ int argc; /* Number of coordinates supplied in @@ -304,32 +295,32 @@ ArcCoords(canvasPtr, itemPtr, argc, argv) char **argv; /* Array of coordinates: x1, y1, * x2, y2, ... */ { - register ArcItem *arcPtr = (ArcItem *) itemPtr; + ArcItem *arcPtr = (ArcItem *) itemPtr; char c0[TCL_DOUBLE_SPACE], c1[TCL_DOUBLE_SPACE]; char c2[TCL_DOUBLE_SPACE], c3[TCL_DOUBLE_SPACE]; if (argc == 0) { - Tcl_PrintDouble(canvasPtr->interp, arcPtr->bbox[0], c0); - Tcl_PrintDouble(canvasPtr->interp, arcPtr->bbox[1], c1); - Tcl_PrintDouble(canvasPtr->interp, arcPtr->bbox[2], c2); - Tcl_PrintDouble(canvasPtr->interp, arcPtr->bbox[3], c3); - Tcl_AppendResult(canvasPtr->interp, c0, " ", c1, " ", - c2, " ", c3, (char *) NULL); + Tcl_PrintDouble(interp, arcPtr->bbox[0], c0); + Tcl_PrintDouble(interp, arcPtr->bbox[1], c1); + Tcl_PrintDouble(interp, arcPtr->bbox[2], c2); + Tcl_PrintDouble(interp, arcPtr->bbox[3], c3); + Tcl_AppendResult(interp, c0, " ", c1, " ", c2, " ", c3, + (char *) NULL); } else if (argc == 4) { - if ((TkGetCanvasCoord(canvasPtr, argv[0], + if ((Tk_CanvasGetCoord(interp, canvas, argv[0], &arcPtr->bbox[0]) != TCL_OK) - || (TkGetCanvasCoord(canvasPtr, argv[1], + || (Tk_CanvasGetCoord(interp, canvas, argv[1], &arcPtr->bbox[1]) != TCL_OK) - || (TkGetCanvasCoord(canvasPtr, argv[2], + || (Tk_CanvasGetCoord(interp, canvas, argv[2], &arcPtr->bbox[2]) != TCL_OK) - || (TkGetCanvasCoord(canvasPtr, argv[3], + || (Tk_CanvasGetCoord(interp, canvas, argv[3], &arcPtr->bbox[3]) != TCL_OK)) { return TCL_ERROR; } - ComputeArcBbox(canvasPtr, arcPtr); + ComputeArcBbox(canvas, arcPtr); } else { - sprintf(canvasPtr->interp->result, - "wrong # coordinates: expected 0 or 4, got %d", + sprintf(interp->result, + "wrong # coordinates: expected 0 or 4, got %d", argc); return TCL_ERROR; } @@ -346,7 +337,7 @@ ArcCoords(canvasPtr, itemPtr, argc, argv) * * Results: * A standard Tcl result code. If an error occurs, then - * an error message is left in canvasPtr->interp->result. + * an error message is left in interp->result. * * Side effects: * Configuration information, such as colors and stipple @@ -356,21 +347,24 @@ ArcCoords(canvasPtr, itemPtr, argc, argv) */ static int -ConfigureArc(canvasPtr, itemPtr, argc, argv, flags) - Tk_Canvas *canvasPtr; /* Canvas containing itemPtr. */ +ConfigureArc(interp, canvas, itemPtr, argc, argv, flags) + Tcl_Interp *interp; /* Used for error reporting. */ + Tk_Canvas canvas; /* Canvas containing itemPtr. */ Tk_Item *itemPtr; /* Arc item to reconfigure. */ int argc; /* Number of elements in argv. */ char **argv; /* Arguments describing things to configure. */ int flags; /* Flags to pass to Tk_ConfigureWidget. */ { - register ArcItem *arcPtr = (ArcItem *) itemPtr; + ArcItem *arcPtr = (ArcItem *) itemPtr; XGCValues gcValues; GC newGC; unsigned long mask; int i; + Tk_Window tkwin; - if (Tk_ConfigureWidget(canvasPtr->interp, canvasPtr->tkwin, - configSpecs, argc, argv, (char *) arcPtr, flags) != TCL_OK) { + tkwin = Tk_CanvasTkwin(canvas); + if (Tk_ConfigureWidget(interp, tkwin, configSpecs, argc, argv, + (char *) arcPtr, flags) != TCL_OK) { return TCL_ERROR; } @@ -389,7 +383,7 @@ ConfigureArc(canvasPtr, itemPtr, argc, argv, flags) if ((arcPtr->style != arcUid) && (arcPtr->style != chordUid) && (arcPtr->style != pieSliceUid)) { - Tcl_AppendResult(canvasPtr->interp, "bad -style option \"", + Tcl_AppendResult(interp, "bad -style option \"", arcPtr->style, "\": must be arc, chord, or pieslice", (char *) NULL); arcPtr->style = pieSliceUid; @@ -399,34 +393,22 @@ ConfigureArc(canvasPtr, itemPtr, argc, argv, flags) if (arcPtr->width < 0) { arcPtr->width = 1; } - arcPtr->stippleGCPtr = NULL; - if (arcPtr->style == arcUid) { - if (arcPtr->fillColor == NULL) { - newGC = None; - } else { - gcValues.foreground = arcPtr->fillColor->pixel; - gcValues.cap_style = CapButt; - gcValues.line_width = arcPtr->width; - mask = GCForeground|GCCapStyle|GCLineWidth; - if (arcPtr->fillStipple != None) { - gcValues.stipple = arcPtr->fillStipple; - gcValues.fill_style = FillStippled; - mask |= GCStipple|GCFillStyle; - arcPtr->stippleGCPtr = &arcPtr->outlineGC; - } - newGC = Tk_GetGC(canvasPtr->tkwin, mask, &gcValues); - } - } else if (arcPtr->outlineColor == NULL) { + if (arcPtr->outlineColor == NULL) { newGC = None; } else { gcValues.foreground = arcPtr->outlineColor->pixel; gcValues.cap_style = CapButt; gcValues.line_width = arcPtr->width; mask = GCForeground|GCCapStyle|GCLineWidth; - newGC = Tk_GetGC(canvasPtr->tkwin, mask, &gcValues); + if (arcPtr->outlineStipple != None) { + gcValues.stipple = arcPtr->outlineStipple; + gcValues.fill_style = FillStippled; + mask |= GCStipple|GCFillStyle; + } + newGC = Tk_GetGC(tkwin, mask, &gcValues); } if (arcPtr->outlineGC != None) { - Tk_FreeGC(canvasPtr->display, arcPtr->outlineGC); + Tk_FreeGC(Tk_Display(tkwin), arcPtr->outlineGC); } arcPtr->outlineGC = newGC; @@ -444,16 +426,15 @@ ConfigureArc(canvasPtr, itemPtr, argc, argv, flags) gcValues.stipple = arcPtr->fillStipple; gcValues.fill_style = FillStippled; mask |= GCStipple|GCFillStyle; - arcPtr->stippleGCPtr = &arcPtr->fillGC; } - newGC = Tk_GetGC(canvasPtr->tkwin, mask, &gcValues); + newGC = Tk_GetGC(tkwin, mask, &gcValues); } if (arcPtr->fillGC != None) { - Tk_FreeGC(canvasPtr->display, arcPtr->fillGC); + Tk_FreeGC(Tk_Display(tkwin), arcPtr->fillGC); } arcPtr->fillGC = newGC; - ComputeArcBbox(canvasPtr, arcPtr); + ComputeArcBbox(canvas, arcPtr); return TCL_OK; } @@ -475,11 +456,13 @@ ConfigureArc(canvasPtr, itemPtr, argc, argv, flags) */ static void -DeleteArc(canvasPtr, itemPtr) - Tk_Canvas *canvasPtr; /* Info about overall canvas. */ +DeleteArc(canvas, itemPtr, display) + Tk_Canvas canvas; /* Info about overall canvas. */ Tk_Item *itemPtr; /* Item that is being deleted. */ + Display *display; /* Display containing window for + * canvas. */ { - register ArcItem *arcPtr = (ArcItem *) itemPtr; + ArcItem *arcPtr = (ArcItem *) itemPtr; if (arcPtr->numOutlinePoints != 0) { ckfree((char *) arcPtr->outlinePtr); @@ -491,13 +474,16 @@ DeleteArc(canvasPtr, itemPtr) Tk_FreeColor(arcPtr->fillColor); } if (arcPtr->fillStipple != None) { - Tk_FreeBitmap(canvasPtr->display, arcPtr->fillStipple); + Tk_FreeBitmap(display, arcPtr->fillStipple); + } + if (arcPtr->outlineStipple != None) { + Tk_FreeBitmap(display, arcPtr->outlineStipple); } if (arcPtr->outlineGC != None) { - Tk_FreeGC(canvasPtr->display, arcPtr->outlineGC); + Tk_FreeGC(display, arcPtr->outlineGC); } if (arcPtr->fillGC != None) { - Tk_FreeGC(canvasPtr->display, arcPtr->fillGC); + Tk_FreeGC(display, arcPtr->fillGC); } } @@ -521,9 +507,9 @@ DeleteArc(canvasPtr, itemPtr) /* ARGSUSED */ static void -ComputeArcBbox(canvasPtr, arcPtr) - register Tk_Canvas *canvasPtr; /* Canvas that contains item. */ - register ArcItem *arcPtr; /* Item whose bbox is to be +ComputeArcBbox(canvas, arcPtr) + Tk_Canvas canvas; /* Canvas that contains item. */ + ArcItem *arcPtr; /* Item whose bbox is to be * recomputed. */ { double tmp, center[2], point[2]; @@ -556,11 +542,11 @@ ComputeArcBbox(canvasPtr, arcPtr) arcPtr->header.x1 = arcPtr->header.x2 = arcPtr->center1[0]; arcPtr->header.y1 = arcPtr->header.y2 = arcPtr->center1[1]; - TkIncludePoint(canvasPtr, (Tk_Item *) arcPtr, arcPtr->center2); + TkIncludePoint((Tk_Item *) arcPtr, arcPtr->center2); center[0] = (arcPtr->bbox[0] + arcPtr->bbox[2])/2; center[1] = (arcPtr->bbox[1] + arcPtr->bbox[3])/2; if (arcPtr->style != arcUid) { - TkIncludePoint(canvasPtr, (Tk_Item *) arcPtr, center); + TkIncludePoint((Tk_Item *) arcPtr, center); } tmp = -arcPtr->start; @@ -570,7 +556,7 @@ ComputeArcBbox(canvasPtr, arcPtr) if ((tmp < arcPtr->extent) || ((tmp-360) > arcPtr->extent)) { point[0] = arcPtr->bbox[2]; point[1] = center[1]; - TkIncludePoint(canvasPtr, (Tk_Item *) arcPtr, point); + TkIncludePoint((Tk_Item *) arcPtr, point); } tmp = 90.0 - arcPtr->start; if (tmp < 0) { @@ -579,7 +565,7 @@ ComputeArcBbox(canvasPtr, arcPtr) if ((tmp < arcPtr->extent) || ((tmp-360) > arcPtr->extent)) { point[0] = center[0]; point[1] = arcPtr->bbox[1]; - TkIncludePoint(canvasPtr, (Tk_Item *) arcPtr, point); + TkIncludePoint((Tk_Item *) arcPtr, point); } tmp = 180.0 - arcPtr->start; if (tmp < 0) { @@ -588,7 +574,7 @@ ComputeArcBbox(canvasPtr, arcPtr) if ((tmp < arcPtr->extent) || ((tmp-360) > arcPtr->extent)) { point[0] = arcPtr->bbox[0]; point[1] = center[1]; - TkIncludePoint(canvasPtr, (Tk_Item *) arcPtr, point); + TkIncludePoint((Tk_Item *) arcPtr, point); } tmp = 270.0 - arcPtr->start; if (tmp < 0) { @@ -597,7 +583,7 @@ ComputeArcBbox(canvasPtr, arcPtr) if ((tmp < arcPtr->extent) || ((tmp-360) > arcPtr->extent)) { point[0] = center[0]; point[1] = arcPtr->bbox[3]; - TkIncludePoint(canvasPtr, (Tk_Item *) arcPtr, point); + TkIncludePoint((Tk_Item *) arcPtr, point); } /* @@ -629,31 +615,34 @@ ComputeArcBbox(canvasPtr, arcPtr) * * Side effects: * ItemPtr is drawn in drawable using the transformation - * information in canvasPtr. + * information in canvas. * *-------------------------------------------------------------- */ static void -DisplayArc(canvasPtr, itemPtr, drawable) - register Tk_Canvas *canvasPtr; /* Canvas that contains item. */ +DisplayArc(canvas, itemPtr, display, drawable, x, y, width, height) + Tk_Canvas canvas; /* Canvas that contains item. */ Tk_Item *itemPtr; /* Item to be displayed. */ + Display *display; /* Display on which to draw item. */ Drawable drawable; /* Pixmap or window in which to draw * item. */ + int x, y, width, height; /* Describes region of canvas that + * must be redisplayed (not used). */ { - register ArcItem *arcPtr = (ArcItem *) itemPtr; - Display *display = Tk_Display(canvasPtr->tkwin); - int x1, y1, x2, y2, start, extent; + ArcItem *arcPtr = (ArcItem *) itemPtr; + short x1, y1, x2, y2; + int start, extent; /* * Compute the screen coordinates of the bounding box for the item, * plus integer values for the angles. */ - x1 = SCREEN_X(canvasPtr, arcPtr->bbox[0]); - y1 = SCREEN_Y(canvasPtr, arcPtr->bbox[1]); - x2 = SCREEN_X(canvasPtr, arcPtr->bbox[2]); - y2 = SCREEN_Y(canvasPtr, arcPtr->bbox[3]); + Tk_CanvasDrawableCoords(canvas, arcPtr->bbox[0], arcPtr->bbox[1], + &x1, &y1); + Tk_CanvasDrawableCoords(canvas, arcPtr->bbox[2], arcPtr->bbox[3], + &x2, &y2); if (x2 <= x1) { x2 = x1+1; } @@ -663,17 +652,6 @@ DisplayArc(canvasPtr, itemPtr, drawable) start = (64*arcPtr->start) + 0.5; extent = (64*arcPtr->extent) + 0.5; - /* - * If the arc is being filled with a stipple pattern, modify the - * stipple offset in the GC. Be sure to reset the offset when done, - * since the GC is supposed to be read-only. - */ - - if (arcPtr->stippleGCPtr != NULL) { - XSetTSOrigin(display, *arcPtr->stippleGCPtr, - -canvasPtr->drawableXOrigin, -canvasPtr->drawableYOrigin); - } - /* * Display filled arc first (if wanted), then outline. If the extent * is zero then don't invoke XFillArc or XDrawArc, since this causes @@ -681,16 +659,22 @@ DisplayArc(canvasPtr, itemPtr, drawable) */ if ((arcPtr->fillGC != None) && (extent != 0)) { - XFillArc(display, drawable, arcPtr->fillGC, x1, y1, (x2-x1), - (y2-y1), start, extent); + if (arcPtr->fillStipple != None) { + Tk_CanvasSetStippleOrigin(canvas, arcPtr->fillGC); + } + XFillArc(display, drawable, arcPtr->fillGC, x1, y1, (unsigned) (x2-x1), + (unsigned) (y2-y1), start, extent); if (arcPtr->fillStipple != None) { XSetTSOrigin(display, arcPtr->fillGC, 0, 0); } } if (arcPtr->outlineGC != None) { + if (arcPtr->outlineStipple != None) { + Tk_CanvasSetStippleOrigin(canvas, arcPtr->outlineGC); + } if (extent != 0) { - XDrawArc(display, drawable, arcPtr->outlineGC, x1, y1, (x2-x1), - (y2-y1), start, extent); + XDrawArc(display, drawable, arcPtr->outlineGC, x1, y1, + (unsigned) (x2-x1), (unsigned) (y2-y1), start, extent); } /* @@ -700,19 +684,20 @@ DisplayArc(canvasPtr, itemPtr, drawable) */ if (arcPtr->width <= 2) { - x1 = SCREEN_X(canvasPtr, arcPtr->center1[0]); - y1 = SCREEN_Y(canvasPtr, arcPtr->center1[1]); - x2 = SCREEN_X(canvasPtr, arcPtr->center2[0]); - y2 = SCREEN_Y(canvasPtr, arcPtr->center2[1]); + Tk_CanvasDrawableCoords(canvas, arcPtr->center1[0], + arcPtr->center1[1], &x1, &y1); + Tk_CanvasDrawableCoords(canvas, arcPtr->center2[0], + arcPtr->center2[1], &x2, &y2); if (arcPtr->style == chordUid) { XDrawLine(display, drawable, arcPtr->outlineGC, x1, y1, x2, y2); } else if (arcPtr->style == pieSliceUid) { - int cx, cy; - - cx = SCREEN_X(canvasPtr, (arcPtr->bbox[0] + arcPtr->bbox[2])/2.0); - cy = SCREEN_Y(canvasPtr, (arcPtr->bbox[1] + arcPtr->bbox[3])/2.0); + short cx, cy; + + Tk_CanvasDrawableCoords(canvas, + (arcPtr->bbox[0] + arcPtr->bbox[2])/2.0, + (arcPtr->bbox[1] + arcPtr->bbox[3])/2.0, &cx, &cy); XDrawLine(display, drawable, arcPtr->outlineGC, cx, cy, x1, y1); XDrawLine(display, drawable, arcPtr->outlineGC, @@ -720,19 +705,19 @@ DisplayArc(canvasPtr, itemPtr, drawable) } } else { if (arcPtr->style == chordUid) { - TkFillPolygon(canvasPtr, arcPtr->outlinePtr, - CHORD_OUTLINE_PTS, drawable, arcPtr->outlineGC); + TkFillPolygon(canvas, arcPtr->outlinePtr, CHORD_OUTLINE_PTS, + display, drawable, arcPtr->outlineGC, None); } else if (arcPtr->style == pieSliceUid) { - TkFillPolygon(canvasPtr, arcPtr->outlinePtr, - PIE_OUTLINE1_PTS, drawable, arcPtr->outlineGC); - TkFillPolygon(canvasPtr, - arcPtr->outlinePtr + 2*PIE_OUTLINE1_PTS, - PIE_OUTLINE2_PTS, drawable, arcPtr->outlineGC); + TkFillPolygon(canvas, arcPtr->outlinePtr, PIE_OUTLINE1_PTS, + display, drawable, arcPtr->outlineGC, None); + TkFillPolygon(canvas, arcPtr->outlinePtr + 2*PIE_OUTLINE1_PTS, + PIE_OUTLINE2_PTS, display, drawable, arcPtr->outlineGC, + None); } } - } - if (arcPtr->stippleGCPtr != NULL) { - XSetTSOrigin(display, *arcPtr->stippleGCPtr, 0, 0); + if (arcPtr->outlineStipple != None) { + XSetTSOrigin(display, arcPtr->outlineGC, 0, 0); + } } } @@ -761,12 +746,12 @@ DisplayArc(canvasPtr, itemPtr, drawable) /* ARGSUSED */ static double -ArcToPoint(canvasPtr, itemPtr, pointPtr) - Tk_Canvas *canvasPtr; /* Canvas containing item. */ +ArcToPoint(canvas, itemPtr, pointPtr) + Tk_Canvas canvas; /* Canvas containing item. */ Tk_Item *itemPtr; /* Item to check against point. */ double *pointPtr; /* Pointer to x and y coordinates. */ { - register ArcItem *arcPtr = (ArcItem *) itemPtr; + ArcItem *arcPtr = (ArcItem *) itemPtr; double vertex[2], pointAngle, diff, dist, newDist; double poly[8], polyDist, width, t1, t2; int filled, angleInRange; @@ -916,14 +901,14 @@ ArcToPoint(canvasPtr, itemPtr, pointPtr) /* ARGSUSED */ static int -ArcToArea(canvasPtr, itemPtr, rectPtr) - Tk_Canvas *canvasPtr; /* Canvas containing item. */ +ArcToArea(canvas, itemPtr, rectPtr) + Tk_Canvas canvas; /* Canvas containing item. */ Tk_Item *itemPtr; /* Item to check against arc. */ double *rectPtr; /* Pointer to array of four coordinates * (x1, y1, x2, y2) describing rectangular * area. */ { - register ArcItem *arcPtr = (ArcItem *) itemPtr; + ArcItem *arcPtr = (ArcItem *) itemPtr; double rx, ry; /* Radii for transformed oval: these define * an oval centered at the origin. */ double tRect[4]; /* Transformed version of x1, y1, x2, y2, @@ -1132,7 +1117,7 @@ ArcToArea(canvasPtr, itemPtr, rectPtr) * it isn't, the arc's really outside the rectangle. */ - if (ArcToPoint(canvasPtr, itemPtr, rectPtr) == 0.0) { + if (ArcToPoint(canvas, itemPtr, rectPtr) == 0.0) { return 0; } return -1; @@ -1159,20 +1144,20 @@ ArcToArea(canvasPtr, itemPtr, rectPtr) */ static void -ScaleArc(canvasPtr, itemPtr, originX, originY, scaleX, scaleY) - Tk_Canvas *canvasPtr; /* Canvas containing arc. */ +ScaleArc(canvas, itemPtr, originX, originY, scaleX, scaleY) + Tk_Canvas canvas; /* Canvas containing arc. */ Tk_Item *itemPtr; /* Arc to be scaled. */ double originX, originY; /* Origin about which to scale rect. */ double scaleX; /* Amount to scale in X direction. */ double scaleY; /* Amount to scale in Y direction. */ { - register ArcItem *arcPtr = (ArcItem *) itemPtr; + ArcItem *arcPtr = (ArcItem *) itemPtr; arcPtr->bbox[0] = originX + scaleX*(arcPtr->bbox[0] - originX); arcPtr->bbox[1] = originY + scaleY*(arcPtr->bbox[1] - originY); arcPtr->bbox[2] = originX + scaleX*(arcPtr->bbox[2] - originX); arcPtr->bbox[3] = originY + scaleY*(arcPtr->bbox[3] - originY); - ComputeArcBbox(canvasPtr, arcPtr); + ComputeArcBbox(canvas, arcPtr); } /* @@ -1194,19 +1179,19 @@ ScaleArc(canvasPtr, itemPtr, originX, originY, scaleX, scaleY) */ static void -TranslateArc(canvasPtr, itemPtr, deltaX, deltaY) - Tk_Canvas *canvasPtr; /* Canvas containing item. */ +TranslateArc(canvas, itemPtr, deltaX, deltaY) + Tk_Canvas canvas; /* Canvas containing item. */ Tk_Item *itemPtr; /* Item that is being moved. */ double deltaX, deltaY; /* Amount by which item is to be * moved. */ { - register ArcItem *arcPtr = (ArcItem *) itemPtr; + ArcItem *arcPtr = (ArcItem *) itemPtr; arcPtr->bbox[0] += deltaX; arcPtr->bbox[1] += deltaY; arcPtr->bbox[2] += deltaX; arcPtr->bbox[3] += deltaY; - ComputeArcBbox(canvasPtr, arcPtr); + ComputeArcBbox(canvas, arcPtr); } /* @@ -1232,7 +1217,7 @@ TranslateArc(canvasPtr, itemPtr, deltaX, deltaY) static void ComputeArcOutline(arcPtr) - register ArcItem *arcPtr; + ArcItem *arcPtr; /* Information about arc. */ { double sin1, cos1, sin2, cos2, angle, halfWidth; double boxWidth, boxHeight; @@ -1308,10 +1293,18 @@ ComputeArcOutline(arcPtr) */ halfWidth = arcPtr->width/2.0; - angle = atan2(boxWidth*sin1, boxHeight*cos1); + if (((boxWidth*sin1) == 0.0) && ((boxHeight*cos1) == 0.0)) { + angle = 0.0; + } else { + angle = atan2(boxWidth*sin1, boxHeight*cos1); + } corner1[0] = arcPtr->center1[0] + cos(angle)*halfWidth; corner1[1] = arcPtr->center1[1] + sin(angle)*halfWidth; - angle = atan2(boxWidth*sin2, boxHeight*cos2); + if (((boxWidth*sin2) == 0.0) && ((boxHeight*cos2) == 0.0)) { + angle = 0.0; + } else { + angle = atan2(boxWidth*sin2, boxHeight*cos2); + } corner2[0] = arcPtr->center2[0] + cos(angle)*halfWidth; corner2[1] = arcPtr->center2[1] + sin(angle)*halfWidth; @@ -1561,10 +1554,10 @@ AngleInRange(x, y, start, extent) { double diff; - diff = -atan2(y, x); if ((x == 0.0) && (y == 0.0)) { return 1; } + diff = -atan2(y, x); diff = diff*(180.0/PI) - start; while (diff > 360.0) { diff -= 360.0; @@ -1589,7 +1582,7 @@ AngleInRange(x, y, start, extent) * Results: * The return value is a standard Tcl result. If an error * occurs in generating Postscript then an error message is - * left in canvasPtr->interp->result, replacing whatever used + * left in interp->result, replacing whatever used * to be there. If no error occurs, then Postscript for the * item is appended to the result. * @@ -1600,20 +1593,22 @@ AngleInRange(x, y, start, extent) */ static int -ArcToPostscript(canvasPtr, itemPtr, psInfoPtr) - Tk_Canvas *canvasPtr; /* Information about overall canvas. */ +ArcToPostscript(interp, canvas, itemPtr, prepass) + Tcl_Interp *interp; /* Leave Postscript or error message + * here. */ + Tk_Canvas canvas; /* Information about overall canvas. */ Tk_Item *itemPtr; /* Item for which Postscript is * wanted. */ - Tk_PostscriptInfo *psInfoPtr; /* Information about the Postscript; - * must be passed back to Postscript - * utility procedures. */ + int prepass; /* 1 means this is a prepass to + * collect font information; 0 means + * final Postscript is being created. */ { - register ArcItem *arcPtr = (ArcItem *) itemPtr; + ArcItem *arcPtr = (ArcItem *) itemPtr; char buffer[400]; double y1, y2, ang1, ang2; - y1 = TkCanvPsY(psInfoPtr, arcPtr->bbox[1]); - y2 = TkCanvPsY(psInfoPtr, arcPtr->bbox[3]); + y1 = Tk_CanvasPsY(canvas, arcPtr->bbox[1]); + y2 = Tk_CanvasPsY(canvas, arcPtr->bbox[3]); ang1 = arcPtr->start; ang2 = ang1 + arcPtr->extent; if (ang2 < ang1) { @@ -1630,7 +1625,7 @@ ArcToPostscript(canvasPtr, itemPtr, psInfoPtr) sprintf(buffer, "matrix currentmatrix\n%.15g %.15g translate %.15g %.15g scale\n", (arcPtr->bbox[0] + arcPtr->bbox[2])/2, (y1 + y2)/2, (arcPtr->bbox[2] - arcPtr->bbox[0])/2, (y1 - y2)/2); - Tcl_AppendResult(canvasPtr->interp, buffer, (char *) NULL); + Tcl_AppendResult(interp, buffer, (char *) NULL); if (arcPtr->style == chordUid) { sprintf(buffer, "0 0 1 %.15g %.15g arc closepath\nsetmatrix\n", ang1, ang2); @@ -1639,17 +1634,21 @@ ArcToPostscript(canvasPtr, itemPtr, psInfoPtr) "0 0 moveto 0 0 1 %.15g %.15g arc closepath\nsetmatrix\n", ang1, ang2); } - Tcl_AppendResult(canvasPtr->interp, buffer, (char *) NULL); - if (TkCanvPsColor(canvasPtr, psInfoPtr, arcPtr->fillColor) != TCL_OK) { + Tcl_AppendResult(interp, buffer, (char *) NULL); + if (Tk_CanvasPsColor(interp, canvas, arcPtr->fillColor) != TCL_OK) { return TCL_ERROR; }; if (arcPtr->fillStipple != None) { - if (TkCanvPsStipple(canvasPtr, psInfoPtr, arcPtr->fillStipple, 1) + Tcl_AppendResult(interp, "clip ", (char *) NULL); + if (Tk_CanvasPsStipple(interp, canvas, arcPtr->fillStipple) != TCL_OK) { return TCL_ERROR; } + if (arcPtr->outlineGC != None) { + Tcl_AppendResult(interp, "grestore gsave\n", (char *) NULL); + } } else { - Tcl_AppendResult(canvasPtr->interp, "fill\n", (char *) NULL); + Tcl_AppendResult(interp, "fill\n", (char *) NULL); } } @@ -1661,42 +1660,62 @@ ArcToPostscript(canvasPtr, itemPtr, psInfoPtr) sprintf(buffer, "matrix currentmatrix\n%.15g %.15g translate %.15g %.15g scale\n", (arcPtr->bbox[0] + arcPtr->bbox[2])/2, (y1 + y2)/2, (arcPtr->bbox[2] - arcPtr->bbox[0])/2, (y1 - y2)/2); - Tcl_AppendResult(canvasPtr->interp, buffer, (char *) NULL); + Tcl_AppendResult(interp, buffer, (char *) NULL); sprintf(buffer, "0 0 1 %.15g %.15g arc\nsetmatrix\n", ang1, ang2); - Tcl_AppendResult(canvasPtr->interp, buffer, (char *) NULL); + Tcl_AppendResult(interp, buffer, (char *) NULL); sprintf(buffer, "%d setlinewidth\n0 setlinecap\n", arcPtr->width); - Tcl_AppendResult(canvasPtr->interp, buffer, (char *) NULL); - if (arcPtr->style == arcUid) { - if (TkCanvPsColor(canvasPtr, psInfoPtr, arcPtr->fillColor) + Tcl_AppendResult(interp, buffer, (char *) NULL); + if (Tk_CanvasPsColor(interp, canvas, arcPtr->outlineColor) + != TCL_OK) { + return TCL_ERROR; + } + if (arcPtr->outlineStipple != None) { + Tcl_AppendResult(interp, "StrokeClip ", (char *) NULL); + if (Tk_CanvasPsStipple(interp, canvas, + arcPtr->outlineStipple) != TCL_OK) { + return TCL_ERROR; + } + } else { + Tcl_AppendResult(interp, "stroke\n", (char *) NULL); + } + if (arcPtr->style != arcUid) { + Tcl_AppendResult(interp, "grestore gsave\n", (char *) NULL); + if (arcPtr->style == chordUid) { + Tk_CanvasPsPath(interp, canvas, arcPtr->outlinePtr, + CHORD_OUTLINE_PTS); + } else { + Tk_CanvasPsPath(interp, canvas, arcPtr->outlinePtr, + PIE_OUTLINE1_PTS); + if (Tk_CanvasPsColor(interp, canvas, arcPtr->outlineColor) + != TCL_OK) { + return TCL_ERROR; + } + if (arcPtr->outlineStipple != None) { + Tcl_AppendResult(interp, "clip ", (char *) NULL); + if (Tk_CanvasPsStipple(interp, canvas, + arcPtr->outlineStipple) != TCL_OK) { + return TCL_ERROR; + } + } else { + Tcl_AppendResult(interp, "fill\n", (char *) NULL); + } + Tcl_AppendResult(interp, "grestore gsave\n", (char *) NULL); + Tk_CanvasPsPath(interp, canvas, + arcPtr->outlinePtr + 2*PIE_OUTLINE1_PTS, + PIE_OUTLINE2_PTS); + } + if (Tk_CanvasPsColor(interp, canvas, arcPtr->outlineColor) != TCL_OK) { return TCL_ERROR; - }; - if (arcPtr->fillStipple != None) { - if (TkCanvPsStipple(canvasPtr, psInfoPtr, - arcPtr->fillStipple, 0) != TCL_OK) { + } + if (arcPtr->outlineStipple != None) { + Tcl_AppendResult(interp, "clip ", (char *) NULL); + if (Tk_CanvasPsStipple(interp, canvas, + arcPtr->outlineStipple) != TCL_OK) { return TCL_ERROR; } } else { - Tcl_AppendResult(canvasPtr->interp, "stroke\n", (char *) NULL); - } - } else { - if (TkCanvPsColor(canvasPtr, psInfoPtr, arcPtr->outlineColor) - != TCL_OK) { - return TCL_ERROR; - }; - Tcl_AppendResult(canvasPtr->interp, "stroke\n", (char *) NULL); - if (arcPtr->style == chordUid) { - TkCanvPsPath(canvasPtr->interp, arcPtr->outlinePtr, - CHORD_OUTLINE_PTS, psInfoPtr); - Tcl_AppendResult(canvasPtr->interp, "fill\n", (char *) NULL); - } else { - TkCanvPsPath(canvasPtr->interp, arcPtr->outlinePtr, - PIE_OUTLINE1_PTS, psInfoPtr); - Tcl_AppendResult(canvasPtr->interp, "fill\n", (char *) NULL); - TkCanvPsPath(canvasPtr->interp, - arcPtr->outlinePtr + 2*PIE_OUTLINE1_PTS, - PIE_OUTLINE2_PTS, psInfoPtr); - Tcl_AppendResult(canvasPtr->interp, "fill\n", (char *) NULL); + Tcl_AppendResult(interp, "fill\n", (char *) NULL); } } } diff --git a/tk3.6/tkCanvBmap.c b/tk4.2/generic/tkCanvBmap.c similarity index 57% rename from tk3.6/tkCanvBmap.c rename to tk4.2/generic/tkCanvBmap.c index caef4ef..5cddcff 100644 --- a/tk3.6/tkCanvBmap.c +++ b/tk4.2/generic/tkCanvBmap.c @@ -3,38 +3,22 @@ * * This file implements bitmap items for canvas widgets. * - * Copyright (c) 1992-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1992-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tkCanvBmap.c 1.29 96/02/17 16:59:10 */ -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkCanvBmap.c,v 1.12 93/09/15 08:19:47 ouster Exp $ SPRITE (Berkeley)"; -#endif - #include #include "tkInt.h" -#include "tkConfig.h" +#include "tkPort.h" #include "tkCanvas.h" /* - * The structure below defines the record for each rectangle/oval item. + * The structure below defines the record for each bitmap item. */ typedef struct BitmapItem { @@ -55,6 +39,10 @@ typedef struct BitmapItem { * Information used for parsing configuration specs: */ +static Tk_CustomOption tagsOption = {Tk_CanvasTagsParseProc, + Tk_CanvasTagsPrintProc, (ClientData) NULL +}; + static Tk_ConfigSpec configSpecs[] = { {TK_CONFIG_ANCHOR, "-anchor", (char *) NULL, (char *) NULL, "center", Tk_Offset(BitmapItem, anchor), TK_CONFIG_DONT_SET_DEFAULT}, @@ -65,7 +53,7 @@ static Tk_ConfigSpec configSpecs[] = { {TK_CONFIG_COLOR, "-foreground", (char *) NULL, (char *) NULL, "black", Tk_Offset(BitmapItem, fgColor), 0}, {TK_CONFIG_CUSTOM, "-tags", (char *) NULL, (char *) NULL, - (char *) NULL, 0, TK_CONFIG_NULL_OK, &tkCanvasTagsOption}, + (char *) NULL, 0, TK_CONFIG_NULL_OK, &tagsOption}, {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, (char *) NULL, 0, 0} }; @@ -74,37 +62,40 @@ static Tk_ConfigSpec configSpecs[] = { * Prototypes for procedures defined in this file: */ -static int BitmapCoords _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, int argc, char **argv)); -static int BitmapToArea _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static int BitmapCoords _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int argc, + char **argv)); +static int BitmapToArea _ANSI_ARGS_((Tk_Canvas canvas, Tk_Item *itemPtr, double *rectPtr)); -static double BitmapToPoint _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static double BitmapToPoint _ANSI_ARGS_((Tk_Canvas canvas, Tk_Item *itemPtr, double *coordPtr)); -static int BitmapToPostscript _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, Tk_PostscriptInfo *psInfoPtr)); -static void ComputeBitmapBbox _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static int BitmapToPostscript _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int prepass)); +static void ComputeBitmapBbox _ANSI_ARGS_((Tk_Canvas canvas, BitmapItem *bmapPtr)); -static int ConfigureBitmap _ANSI_ARGS_(( - Tk_Canvas *canvasPtr, Tk_Item *itemPtr, int argc, +static int ConfigureBitmap _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int argc, char **argv, int flags)); -static int CreateBitmap _ANSI_ARGS_((Tk_Canvas *canvasPtr, - struct Tk_Item *itemPtr, int argc, char **argv)); -static void DeleteBitmap _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr)); -static void DisplayBitmap _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, Drawable dst)); -static void ScaleBitmap _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static int CreateBitmap _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, struct Tk_Item *itemPtr, + int argc, char **argv)); +static void DeleteBitmap _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, Display *display)); +static void DisplayBitmap _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, Display *display, Drawable dst, + int x, int y, int width, int height)); +static void ScaleBitmap _ANSI_ARGS_((Tk_Canvas canvas, Tk_Item *itemPtr, double originX, double originY, double scaleX, double scaleY)); -static void TranslateBitmap _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static void TranslateBitmap _ANSI_ARGS_((Tk_Canvas canvas, Tk_Item *itemPtr, double deltaX, double deltaY)); /* - * The structures below defines the rectangle and oval item types - * by means of procedures that can be invoked by generic item code. + * The structures below defines the bitmap item type in terms of + * procedures that can be invoked by generic item code. */ -Tk_ItemType TkBitmapType = { +Tk_ItemType tkBitmapType = { "bitmap", /* name */ sizeof(BitmapItem), /* itemSize */ CreateBitmap, /* createProc */ @@ -138,9 +129,8 @@ Tk_ItemType TkBitmapType = { * Results: * A standard Tcl return value. If an error occurred in * creating the item, then an error message is left in - * canvasPtr->interp->result; in this case itemPtr is - * left uninitialized, so it can be safely freed by the - * caller. + * interp->result; in this case itemPtr is left uninitialized, + * so it can be safely freed by the caller. * * Side effects: * A new bitmap item is created. @@ -149,19 +139,20 @@ Tk_ItemType TkBitmapType = { */ static int -CreateBitmap(canvasPtr, itemPtr, argc, argv) - register Tk_Canvas *canvasPtr; /* Canvas to hold new item. */ +CreateBitmap(interp, canvas, itemPtr, argc, argv) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + Tk_Canvas canvas; /* Canvas to hold new item. */ Tk_Item *itemPtr; /* Record to hold new item; header * has been initialized by caller. */ int argc; /* Number of arguments in argv. */ char **argv; /* Arguments describing rectangle. */ { - register BitmapItem *bmapPtr = (BitmapItem *) itemPtr; + BitmapItem *bmapPtr = (BitmapItem *) itemPtr; if (argc < 2) { - Tcl_AppendResult(canvasPtr->interp, "wrong # args: should be \"", - Tk_PathName(canvasPtr->tkwin), "\" create ", - itemPtr->typePtr->name, " x y ?options?", + Tcl_AppendResult(interp, "wrong # args: should be \"", + Tk_PathName(Tk_CanvasTkwin(canvas)), " create ", + itemPtr->typePtr->name, " x y ?options?\"", (char *) NULL); return TCL_ERROR; } @@ -180,14 +171,14 @@ CreateBitmap(canvasPtr, itemPtr, argc, argv) * Process the arguments to fill in the item record. */ - if ((TkGetCanvasCoord(canvasPtr, argv[0], &bmapPtr->x) != TCL_OK) - || (TkGetCanvasCoord(canvasPtr, argv[1], - &bmapPtr->y) != TCL_OK)) { + if ((Tk_CanvasGetCoord(interp, canvas, argv[0], &bmapPtr->x) != TCL_OK) + || (Tk_CanvasGetCoord(interp, canvas, argv[1], &bmapPtr->y) + != TCL_OK)) { return TCL_ERROR; } - if (ConfigureBitmap(canvasPtr, itemPtr, argc-2, argv+2, 0) != TCL_OK) { - DeleteBitmap(canvasPtr, itemPtr); + if (ConfigureBitmap(interp, canvas, itemPtr, argc-2, argv+2, 0) != TCL_OK) { + DeleteBitmap(canvas, itemPtr, Tk_Display(Tk_CanvasTkwin(canvas))); return TCL_ERROR; } return TCL_OK; @@ -203,7 +194,7 @@ CreateBitmap(canvasPtr, itemPtr, argc, argv) * details on what it does. * * Results: - * Returns TCL_OK or TCL_ERROR, and sets canvasPtr->interp->result. + * Returns TCL_OK or TCL_ERROR, and sets interp->result. * * Side effects: * The coordinates for the given item may be changed. @@ -212,8 +203,9 @@ CreateBitmap(canvasPtr, itemPtr, argc, argv) */ static int -BitmapCoords(canvasPtr, itemPtr, argc, argv) - register Tk_Canvas *canvasPtr; /* Canvas containing item. */ +BitmapCoords(interp, canvas, itemPtr, argc, argv) + Tcl_Interp *interp; /* Used for error reporting. */ + Tk_Canvas canvas; /* Canvas containing item. */ Tk_Item *itemPtr; /* Item whose coordinates are to be * read or modified. */ int argc; /* Number of coordinates supplied in @@ -221,24 +213,23 @@ BitmapCoords(canvasPtr, itemPtr, argc, argv) char **argv; /* Array of coordinates: x1, y1, * x2, y2, ... */ { - register BitmapItem *bmapPtr = (BitmapItem *) itemPtr; + BitmapItem *bmapPtr = (BitmapItem *) itemPtr; char x[TCL_DOUBLE_SPACE], y[TCL_DOUBLE_SPACE]; if (argc == 0) { - Tcl_PrintDouble(canvasPtr->interp, bmapPtr->x, x); - Tcl_PrintDouble(canvasPtr->interp, bmapPtr->y, y); - Tcl_AppendResult(canvasPtr->interp, x, " ", y, (char *) NULL); + Tcl_PrintDouble(interp, bmapPtr->x, x); + Tcl_PrintDouble(interp, bmapPtr->y, y); + Tcl_AppendResult(interp, x, " ", y, (char *) NULL); } else if (argc == 2) { - if ((TkGetCanvasCoord(canvasPtr, argv[0], &bmapPtr->x) != TCL_OK) - || (TkGetCanvasCoord(canvasPtr, argv[1], - &bmapPtr->y) != TCL_OK)) { + if ((Tk_CanvasGetCoord(interp, canvas, argv[0], &bmapPtr->x) != TCL_OK) + || (Tk_CanvasGetCoord(interp, canvas, argv[1], &bmapPtr->y) + != TCL_OK)) { return TCL_ERROR; } - ComputeBitmapBbox(canvasPtr, bmapPtr); + ComputeBitmapBbox(canvas, bmapPtr); } else { - sprintf(canvasPtr->interp->result, - "wrong # coordinates: expected 0 or 2, got %d", - argc); + sprintf(interp->result, + "wrong # coordinates: expected 0 or 2, got %d", argc); return TCL_ERROR; } return TCL_OK; @@ -254,7 +245,7 @@ BitmapCoords(canvasPtr, itemPtr, argc, argv) * * Results: * A standard Tcl result code. If an error occurs, then - * an error message is left in canvasPtr->interp->result. + * an error message is left in interp->result. * * Side effects: * Configuration information may be set for itemPtr. @@ -263,19 +254,23 @@ BitmapCoords(canvasPtr, itemPtr, argc, argv) */ static int -ConfigureBitmap(canvasPtr, itemPtr, argc, argv, flags) - Tk_Canvas *canvasPtr; /* Canvas containing itemPtr. */ +ConfigureBitmap(interp, canvas, itemPtr, argc, argv, flags) + Tcl_Interp *interp; /* Used for error reporting. */ + Tk_Canvas canvas; /* Canvas containing itemPtr. */ Tk_Item *itemPtr; /* Bitmap item to reconfigure. */ int argc; /* Number of elements in argv. */ char **argv; /* Arguments describing things to configure. */ int flags; /* Flags to pass to Tk_ConfigureWidget. */ { - register BitmapItem *bmapPtr = (BitmapItem *) itemPtr; + BitmapItem *bmapPtr = (BitmapItem *) itemPtr; XGCValues gcValues; GC newGC; + Tk_Window tkwin; + unsigned long mask; - if (Tk_ConfigureWidget(canvasPtr->interp, canvasPtr->tkwin, - configSpecs, argc, argv, (char *) bmapPtr, flags) != TCL_OK) { + tkwin = Tk_CanvasTkwin(canvas); + if (Tk_ConfigureWidget(interp, tkwin, configSpecs, argc, argv, + (char *) bmapPtr, flags) != TCL_OK) { return TCL_ERROR; } @@ -285,18 +280,21 @@ ConfigureBitmap(canvasPtr, itemPtr, argc, argv, flags) */ gcValues.foreground = bmapPtr->fgColor->pixel; + mask = GCForeground; if (bmapPtr->bgColor != NULL) { gcValues.background = bmapPtr->bgColor->pixel; + mask |= GCBackground; } else { - gcValues.background = Tk_3DBorderColor(canvasPtr->bgBorder)->pixel; + gcValues.clip_mask = bmapPtr->bitmap; + mask |= GCClipMask; } - newGC = Tk_GetGC(canvasPtr->tkwin, GCForeground|GCBackground, &gcValues); + newGC = Tk_GetGC(tkwin, mask, &gcValues); if (bmapPtr->gc != None) { - Tk_FreeGC(canvasPtr->display, bmapPtr->gc); + Tk_FreeGC(Tk_Display(tkwin), bmapPtr->gc); } bmapPtr->gc = newGC; - ComputeBitmapBbox(canvasPtr, bmapPtr); + ComputeBitmapBbox(canvas, bmapPtr); return TCL_OK; } @@ -319,14 +317,16 @@ ConfigureBitmap(canvasPtr, itemPtr, argc, argv, flags) */ static void -DeleteBitmap(canvasPtr, itemPtr) - Tk_Canvas *canvasPtr; /* Info about overall canvas widget. */ +DeleteBitmap(canvas, itemPtr, display) + Tk_Canvas canvas; /* Info about overall canvas widget. */ Tk_Item *itemPtr; /* Item that is being deleted. */ + Display *display; /* Display containing window for + * canvas. */ { - register BitmapItem *bmapPtr = (BitmapItem *) itemPtr; + BitmapItem *bmapPtr = (BitmapItem *) itemPtr; if (bmapPtr->bitmap != None) { - Tk_FreeBitmap(canvasPtr->display, bmapPtr->bitmap); + Tk_FreeBitmap(display, bmapPtr->bitmap); } if (bmapPtr->fgColor != NULL) { Tk_FreeColor(bmapPtr->fgColor); @@ -335,7 +335,7 @@ DeleteBitmap(canvasPtr, itemPtr) Tk_FreeColor(bmapPtr->bgColor); } if (bmapPtr->gc != NULL) { - Tk_FreeGC(canvasPtr->display, bmapPtr->gc); + Tk_FreeGC(display, bmapPtr->gc); } } @@ -361,16 +361,16 @@ DeleteBitmap(canvasPtr, itemPtr) /* ARGSUSED */ static void -ComputeBitmapBbox(canvasPtr, bmapPtr) - Tk_Canvas *canvasPtr; /* Canvas that contains item. */ - register BitmapItem *bmapPtr; /* Item whose bbox is to be +ComputeBitmapBbox(canvas, bmapPtr) + Tk_Canvas canvas; /* Canvas that contains item. */ + BitmapItem *bmapPtr; /* Item whose bbox is to be * recomputed. */ { - unsigned int width, height; + int width, height; int x, y; - x = bmapPtr->x + 0.5; - y = bmapPtr->y + 0.5; + x = bmapPtr->x + ((bmapPtr->x >= 0) ? 0.5 : - 0.5); + y = bmapPtr->y + ((bmapPtr->y >= 0) ? 0.5 : - 0.5); if (bmapPtr->bitmap == None) { bmapPtr->header.x1 = bmapPtr->header.x2 = x; @@ -382,7 +382,8 @@ ComputeBitmapBbox(canvasPtr, bmapPtr) * Compute location and size of bitmap, using anchor information. */ - Tk_SizeOfBitmap(canvasPtr->display, bmapPtr->bitmap, &width, &height); + Tk_SizeOfBitmap(Tk_Display(Tk_CanvasTkwin(canvas)), bmapPtr->bitmap, + &width, &height); switch (bmapPtr->anchor) { case TK_ANCHOR_N: x -= width/2; @@ -439,27 +440,70 @@ ComputeBitmapBbox(canvasPtr, bmapPtr) * * Side effects: * ItemPtr is drawn in drawable using the transformation - * information in canvasPtr. + * information in canvas. * *-------------------------------------------------------------- */ static void -DisplayBitmap(canvasPtr, itemPtr, drawable) - register Tk_Canvas *canvasPtr; /* Canvas that contains item. */ +DisplayBitmap(canvas, itemPtr, display, drawable, x, y, width, height) + Tk_Canvas canvas; /* Canvas that contains item. */ Tk_Item *itemPtr; /* Item to be displayed. */ + Display *display; /* Display on which to draw item. */ Drawable drawable; /* Pixmap or window in which to draw * item. */ + int x, y, width, height; /* Describes region of canvas that + * must be redisplayed (not used). */ { - register BitmapItem *bmapPtr = (BitmapItem *) itemPtr; + BitmapItem *bmapPtr = (BitmapItem *) itemPtr; + int bmapX, bmapY, bmapWidth, bmapHeight; + short drawableX, drawableY; + + /* + * If the area being displayed doesn't cover the whole bitmap, + * then only redisplay the part of the bitmap that needs + * redisplay. + */ if (bmapPtr->bitmap != None) { - XCopyPlane(Tk_Display(canvasPtr->tkwin), bmapPtr->bitmap, drawable, - bmapPtr->gc, 0, 0, - (unsigned int) bmapPtr->header.x2 - bmapPtr->header.x1, - (unsigned int) bmapPtr->header.y2 - bmapPtr->header.y1, - bmapPtr->header.x1 - canvasPtr->drawableXOrigin, - bmapPtr->header.y1 - canvasPtr->drawableYOrigin, 1); + if (x > bmapPtr->header.x1) { + bmapX = x - bmapPtr->header.x1; + bmapWidth = bmapPtr->header.x2 - x; + } else { + bmapX = 0; + if ((x+width) < bmapPtr->header.x2) { + bmapWidth = x + width - bmapPtr->header.x1; + } else { + bmapWidth = bmapPtr->header.x2 - bmapPtr->header.x1; + } + } + if (y > bmapPtr->header.y1) { + bmapY = y - bmapPtr->header.y1; + bmapHeight = bmapPtr->header.y2 - y; + } else { + bmapY = 0; + if ((y+height) < bmapPtr->header.y2) { + bmapHeight = y + height - bmapPtr->header.y1; + } else { + bmapHeight = bmapPtr->header.y2 - bmapPtr->header.y1; + } + } + Tk_CanvasDrawableCoords(canvas, + (double) (bmapPtr->header.x1 + bmapX), + (double) (bmapPtr->header.y1 + bmapY), + &drawableX, &drawableY); + + /* + * Must modify the mask origin within the graphics context + * to line up with the bitmap's origin (in order to make + * bitmaps with "-background {}" work right). + */ + + XSetClipOrigin(display, bmapPtr->gc, drawableX - bmapX, + drawableY - bmapY); + XCopyPlane(display, bmapPtr->bitmap, drawable, + bmapPtr->gc, bmapX, bmapY, (unsigned int) bmapWidth, + (unsigned int) bmapHeight, drawableX, drawableY, 1); } } @@ -485,12 +529,12 @@ DisplayBitmap(canvasPtr, itemPtr, drawable) /* ARGSUSED */ static double -BitmapToPoint(canvasPtr, itemPtr, coordPtr) - Tk_Canvas *canvasPtr; /* Canvas containing item. */ +BitmapToPoint(canvas, itemPtr, coordPtr) + Tk_Canvas canvas; /* Canvas containing item. */ Tk_Item *itemPtr; /* Item to check against point. */ double *coordPtr; /* Pointer to x and y coordinates. */ { - register BitmapItem *bmapPtr = (BitmapItem *) itemPtr; + BitmapItem *bmapPtr = (BitmapItem *) itemPtr; double x1, x2, y1, y2, xDiff, yDiff; x1 = bmapPtr->header.x1; @@ -543,14 +587,14 @@ BitmapToPoint(canvasPtr, itemPtr, coordPtr) /* ARGSUSED */ static int -BitmapToArea(canvasPtr, itemPtr, rectPtr) - Tk_Canvas *canvasPtr; /* Canvas containing item. */ +BitmapToArea(canvas, itemPtr, rectPtr) + Tk_Canvas canvas; /* Canvas containing item. */ Tk_Item *itemPtr; /* Item to check against rectangle. */ double *rectPtr; /* Pointer to array of four coordinates * (x1, y1, x2, y2) describing rectangular * area. */ { - register BitmapItem *bmapPtr = (BitmapItem *) itemPtr; + BitmapItem *bmapPtr = (BitmapItem *) itemPtr; if ((rectPtr[2] <= bmapPtr->header.x1) || (rectPtr[0] >= bmapPtr->header.x2) @@ -572,16 +616,16 @@ BitmapToArea(canvasPtr, itemPtr, rectPtr) * * ScaleBitmap -- * - * This procedure is invoked to rescale a rectangle or oval - * item. + * This procedure is invoked to rescale a bitmap item in a + * canvas. It is one of the standard item procedures for + * bitmap items, and is invoked by the generic canvas code. * * Results: * None. * * Side effects: - * The rectangle or oval referred to by itemPtr is rescaled - * so that the following transformation is applied to all - * point coordinates: + * The item referred to by itemPtr is rescaled so that the + * following transformation is applied to all point coordinates: * x' = originX + scaleX*(x-originX) * y' = originY + scaleY*(y-originY) * @@ -589,18 +633,18 @@ BitmapToArea(canvasPtr, itemPtr, rectPtr) */ static void -ScaleBitmap(canvasPtr, itemPtr, originX, originY, scaleX, scaleY) - Tk_Canvas *canvasPtr; /* Canvas containing rectangle. */ +ScaleBitmap(canvas, itemPtr, originX, originY, scaleX, scaleY) + Tk_Canvas canvas; /* Canvas containing rectangle. */ Tk_Item *itemPtr; /* Rectangle to be scaled. */ - double originX, originY; /* Origin about which to scale rect. */ + double originX, originY; /* Origin about which to scale item. */ double scaleX; /* Amount to scale in X direction. */ double scaleY; /* Amount to scale in Y direction. */ { - register BitmapItem *bmapPtr = (BitmapItem *) itemPtr; + BitmapItem *bmapPtr = (BitmapItem *) itemPtr; bmapPtr->x = originX + scaleX*(bmapPtr->x - originX); bmapPtr->y = originY + scaleY*(bmapPtr->y - originY); - ComputeBitmapBbox(canvasPtr, bmapPtr); + ComputeBitmapBbox(canvas, bmapPtr); } /* @@ -608,32 +652,31 @@ ScaleBitmap(canvasPtr, itemPtr, originX, originY, scaleX, scaleY) * * TranslateBitmap -- * - * This procedure is called to move a rectangle or oval by a - * given amount. + * This procedure is called to move an item by a given amount. * * Results: * None. * * Side effects: - * The position of the rectangle or oval is offset by - * (xDelta, yDelta), and the bounding box is updated in the - * generic part of the item structure. + * The position of the item is offset by (xDelta, yDelta), and + * the bounding box is updated in the generic part of the item + * structure. * *-------------------------------------------------------------- */ static void -TranslateBitmap(canvasPtr, itemPtr, deltaX, deltaY) - Tk_Canvas *canvasPtr; /* Canvas containing item. */ +TranslateBitmap(canvas, itemPtr, deltaX, deltaY) + Tk_Canvas canvas; /* Canvas containing item. */ Tk_Item *itemPtr; /* Item that is being moved. */ double deltaX, deltaY; /* Amount by which item is to be * moved. */ { - register BitmapItem *bmapPtr = (BitmapItem *) itemPtr; + BitmapItem *bmapPtr = (BitmapItem *) itemPtr; bmapPtr->x += deltaX; bmapPtr->y += deltaY; - ComputeBitmapBbox(canvasPtr, bmapPtr); + ComputeBitmapBbox(canvas, bmapPtr); } /* @@ -647,9 +690,9 @@ TranslateBitmap(canvasPtr, itemPtr, deltaX, deltaY) * Results: * The return value is a standard Tcl result. If an error * occurs in generating Postscript then an error message is - * left in canvasPtr->interp->result, replacing whatever used - * to be there. If no error occurs, then Postscript for the - * item is appended to the result. + * left in interp->result, replacing whatever used to be there. + * If no error occurs, then Postscript for the item is appended + * to the result. * * Side effects: * None. @@ -658,17 +701,20 @@ TranslateBitmap(canvasPtr, itemPtr, deltaX, deltaY) */ static int -BitmapToPostscript(canvasPtr, itemPtr, psInfoPtr) - Tk_Canvas *canvasPtr; /* Information about overall canvas. */ +BitmapToPostscript(interp, canvas, itemPtr, prepass) + Tcl_Interp *interp; /* Leave Postscript or error message + * here. */ + Tk_Canvas canvas; /* Information about overall canvas. */ Tk_Item *itemPtr; /* Item for which Postscript is * wanted. */ - Tk_PostscriptInfo *psInfoPtr; /* Information about the Postscript; - * must be passed back to Postscript - * utility procedures. */ + int prepass; /* 1 means this is a prepass to + * collect font information; 0 means + * final Postscript is being created. */ { - register BitmapItem *bmapPtr = (BitmapItem *) itemPtr; + BitmapItem *bmapPtr = (BitmapItem *) itemPtr; double x, y; - unsigned int width, height; + int width, height, rowsAtOnce, rowsThisTime; + int curRow; char buffer[200]; if (bmapPtr->bitmap == None) { @@ -681,8 +727,9 @@ BitmapToPostscript(canvasPtr, itemPtr, psInfoPtr) */ x = bmapPtr->x; - y = TkCanvPsY(psInfoPtr, bmapPtr->y); - Tk_SizeOfBitmap(canvasPtr->display, bmapPtr->bitmap, &width, &height); + y = Tk_CanvasPsY(canvas, bmapPtr->y); + Tk_SizeOfBitmap(Tk_Display(Tk_CanvasTkwin(canvas)), bmapPtr->bitmap, + &width, &height); switch (bmapPtr->anchor) { case TK_ANCHOR_NW: y -= height; break; case TK_ANCHOR_N: x -= width/2.0; y -= height; break; @@ -703,28 +750,51 @@ BitmapToPostscript(canvasPtr, itemPtr, psInfoPtr) sprintf(buffer, "%.15g %.15g moveto %d 0 rlineto 0 %d rlineto %d %s\n", x, y, width, height, -width,"0 rlineto closepath"); - Tcl_AppendResult(canvasPtr->interp, buffer, (char *) NULL); - if (TkCanvPsColor(canvasPtr, psInfoPtr, bmapPtr->bgColor) != TCL_OK) { + Tcl_AppendResult(interp, buffer, (char *) NULL); + if (Tk_CanvasPsColor(interp, canvas, bmapPtr->bgColor) != TCL_OK) { return TCL_ERROR; } - Tcl_AppendResult(canvasPtr->interp, "fill\n", (char *) NULL); + Tcl_AppendResult(interp, "fill\n", (char *) NULL); } /* - * Draw the bitmap, if there is a foreground color. + * Draw the bitmap, if there is a foreground color. If the bitmap + * is very large, then chop it up into multiple bitmaps, each + * consisting of one or more rows. This is needed because Postscript + * can't handle single strings longer than 64 KBytes long. */ if (bmapPtr->fgColor != NULL) { - if (TkCanvPsColor(canvasPtr, psInfoPtr, bmapPtr->fgColor) != TCL_OK) { + if (Tk_CanvasPsColor(interp, canvas, bmapPtr->fgColor) != TCL_OK) { return TCL_ERROR; } - sprintf(buffer, "%.15g %.15g translate\n %d %d true matrix {\n", - x, y, width, height); - Tcl_AppendResult(canvasPtr->interp, buffer, (char *) NULL); - if (TkCanvPsBitmap(canvasPtr, psInfoPtr, bmapPtr->bitmap) != TCL_OK) { + if (width > 60000) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "can't generate Postscript", + " for bitmaps more than 60000 pixels wide", + (char *) NULL); return TCL_ERROR; } - Tcl_AppendResult(canvasPtr->interp, "\n} imagemask\n", (char *) NULL); + rowsAtOnce = 60000/width; + if (rowsAtOnce < 1) { + rowsAtOnce = 1; + } + sprintf(buffer, "%.15g %.15g translate\n", x, y+height); + Tcl_AppendResult(interp, buffer, (char *) NULL); + for (curRow = 0; curRow < height; curRow += rowsAtOnce) { + rowsThisTime = rowsAtOnce; + if (rowsThisTime > (height - curRow)) { + rowsThisTime = height - curRow; + } + sprintf(buffer, "0 -%.15g translate\n%d %d true matrix {\n", + (double) rowsThisTime, width, rowsThisTime); + Tcl_AppendResult(interp, buffer, (char *) NULL); + if (Tk_CanvasPsBitmap(interp, canvas, bmapPtr->bitmap, + 0, curRow, width, rowsThisTime) != TCL_OK) { + return TCL_ERROR; + } + Tcl_AppendResult(interp, "\n} imagemask\n", (char *) NULL); + } } return TCL_OK; } diff --git a/tk4.2/generic/tkCanvImg.c b/tk4.2/generic/tkCanvImg.c new file mode 100644 index 0000000..4385219 --- /dev/null +++ b/tk4.2/generic/tkCanvImg.c @@ -0,0 +1,677 @@ +/* + * tkCanvImg.c -- + * + * This file implements image items for canvas widgets. + * + * Copyright (c) 1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkCanvImg.c 1.17 96/02/17 17:18:43 + */ + +#include +#include "tkInt.h" +#include "tkPort.h" +#include "tkCanvas.h" + +/* + * The structure below defines the record for each image item. + */ + +typedef struct ImageItem { + Tk_Item header; /* Generic stuff that's the same for all + * types. MUST BE FIRST IN STRUCTURE. */ + Tk_Canvas canvas; /* Canvas containing the image. */ + double x, y; /* Coordinates of positioning point for + * image. */ + Tk_Anchor anchor; /* Where to anchor image relative to + * (x,y). */ + char *imageString; /* String describing -image option (malloc-ed). + * NULL means no image right now. */ + Tk_Image image; /* Image to display in window, or NULL if + * no image at present. */ +} ImageItem; + +/* + * Information used for parsing configuration specs: + */ + +static Tk_CustomOption tagsOption = {Tk_CanvasTagsParseProc, + Tk_CanvasTagsPrintProc, (ClientData) NULL +}; + +static Tk_ConfigSpec configSpecs[] = { + {TK_CONFIG_ANCHOR, "-anchor", (char *) NULL, (char *) NULL, + "center", Tk_Offset(ImageItem, anchor), TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_STRING, "-image", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(ImageItem, imageString), TK_CONFIG_NULL_OK}, + {TK_CONFIG_CUSTOM, "-tags", (char *) NULL, (char *) NULL, + (char *) NULL, 0, TK_CONFIG_NULL_OK, &tagsOption}, + {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, 0} +}; + +/* + * Prototypes for procedures defined in this file: + */ + +static void ImageChangedProc _ANSI_ARGS_((ClientData clientData, + int x, int y, int width, int height, int imgWidth, + int imgHeight)); +static int ImageCoords _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int argc, + char **argv)); +static int ImageToArea _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double *rectPtr)); +static double ImageToPoint _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double *coordPtr)); +static void ComputeImageBbox _ANSI_ARGS_((Tk_Canvas canvas, + ImageItem *imgPtr)); +static int ConfigureImage _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int argc, + char **argv, int flags)); +static int CreateImage _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, struct Tk_Item *itemPtr, + int argc, char **argv)); +static void DeleteImage _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, Display *display)); +static void DisplayImage _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, Display *display, Drawable dst, + int x, int y, int width, int height)); +static void ScaleImage _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double originX, double originY, + double scaleX, double scaleY)); +static void TranslateImage _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double deltaX, double deltaY)); + +/* + * The structures below defines the image item type in terms of + * procedures that can be invoked by generic item code. + */ + +Tk_ItemType tkImageType = { + "image", /* name */ + sizeof(ImageItem), /* itemSize */ + CreateImage, /* createProc */ + configSpecs, /* configSpecs */ + ConfigureImage, /* configureProc */ + ImageCoords, /* coordProc */ + DeleteImage, /* deleteProc */ + DisplayImage, /* displayProc */ + 0, /* alwaysRedraw */ + ImageToPoint, /* pointProc */ + ImageToArea, /* areaProc */ + (Tk_ItemPostscriptProc *) NULL, /* postscriptProc */ + ScaleImage, /* scaleProc */ + TranslateImage, /* translateProc */ + (Tk_ItemIndexProc *) NULL, /* indexProc */ + (Tk_ItemCursorProc *) NULL, /* icursorProc */ + (Tk_ItemSelectionProc *) NULL, /* selectionProc */ + (Tk_ItemInsertProc *) NULL, /* insertProc */ + (Tk_ItemDCharsProc *) NULL, /* dTextProc */ + (Tk_ItemType *) NULL /* nextPtr */ +}; + +/* + *-------------------------------------------------------------- + * + * CreateImage -- + * + * This procedure is invoked to create a new image + * item in a canvas. + * + * Results: + * A standard Tcl return value. If an error occurred in + * creating the item, then an error message is left in + * interp->result; in this case itemPtr is left uninitialized, + * so it can be safely freed by the caller. + * + * Side effects: + * A new image item is created. + * + *-------------------------------------------------------------- + */ + +static int +CreateImage(interp, canvas, itemPtr, argc, argv) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + Tk_Canvas canvas; /* Canvas to hold new item. */ + Tk_Item *itemPtr; /* Record to hold new item; header + * has been initialized by caller. */ + int argc; /* Number of arguments in argv. */ + char **argv; /* Arguments describing rectangle. */ +{ + ImageItem *imgPtr = (ImageItem *) itemPtr; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + Tk_PathName(Tk_CanvasTkwin(canvas)), " create ", + itemPtr->typePtr->name, " x y ?options?\"", + (char *) NULL); + return TCL_ERROR; + } + + /* + * Initialize item's record. + */ + + imgPtr->canvas = canvas; + imgPtr->anchor = TK_ANCHOR_CENTER; + imgPtr->imageString = NULL; + imgPtr->image = NULL; + + /* + * Process the arguments to fill in the item record. + */ + + if ((Tk_CanvasGetCoord(interp, canvas, argv[0], &imgPtr->x) != TCL_OK) + || (Tk_CanvasGetCoord(interp, canvas, argv[1], &imgPtr->y) + != TCL_OK)) { + return TCL_ERROR; + } + + if (ConfigureImage(interp, canvas, itemPtr, argc-2, argv+2, 0) != TCL_OK) { + DeleteImage(canvas, itemPtr, Tk_Display(Tk_CanvasTkwin(canvas))); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * ImageCoords -- + * + * This procedure is invoked to process the "coords" widget + * command on image items. See the user documentation for + * details on what it does. + * + * Results: + * Returns TCL_OK or TCL_ERROR, and sets interp->result. + * + * Side effects: + * The coordinates for the given item may be changed. + * + *-------------------------------------------------------------- + */ + +static int +ImageCoords(interp, canvas, itemPtr, argc, argv) + Tcl_Interp *interp; /* Used for error reporting. */ + Tk_Canvas canvas; /* Canvas containing item. */ + Tk_Item *itemPtr; /* Item whose coordinates are to be + * read or modified. */ + int argc; /* Number of coordinates supplied in + * argv. */ + char **argv; /* Array of coordinates: x1, y1, + * x2, y2, ... */ +{ + ImageItem *imgPtr = (ImageItem *) itemPtr; + char x[TCL_DOUBLE_SPACE], y[TCL_DOUBLE_SPACE]; + + if (argc == 0) { + Tcl_PrintDouble(interp, imgPtr->x, x); + Tcl_PrintDouble(interp, imgPtr->y, y); + Tcl_AppendResult(interp, x, " ", y, (char *) NULL); + } else if (argc == 2) { + if ((Tk_CanvasGetCoord(interp, canvas, argv[0], &imgPtr->x) != TCL_OK) + || (Tk_CanvasGetCoord(interp, canvas, argv[1], + &imgPtr->y) != TCL_OK)) { + return TCL_ERROR; + } + ComputeImageBbox(canvas, imgPtr); + } else { + sprintf(interp->result, + "wrong # coordinates: expected 0 or 2, got %d", argc); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * ConfigureImage -- + * + * This procedure is invoked to configure various aspects + * of an image item, such as its anchor position. + * + * Results: + * A standard Tcl result code. If an error occurs, then + * an error message is left in interp->result. + * + * Side effects: + * Configuration information may be set for itemPtr. + * + *-------------------------------------------------------------- + */ + +static int +ConfigureImage(interp, canvas, itemPtr, argc, argv, flags) + Tcl_Interp *interp; /* Used for error reporting. */ + Tk_Canvas canvas; /* Canvas containing itemPtr. */ + Tk_Item *itemPtr; /* Image item to reconfigure. */ + int argc; /* Number of elements in argv. */ + char **argv; /* Arguments describing things to configure. */ + int flags; /* Flags to pass to Tk_ConfigureWidget. */ +{ + ImageItem *imgPtr = (ImageItem *) itemPtr; + Tk_Window tkwin; + Tk_Image image; + + tkwin = Tk_CanvasTkwin(canvas); + if (Tk_ConfigureWidget(interp, tkwin, configSpecs, argc, + argv, (char *) imgPtr, flags) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Create the image. Save the old image around and don't free it + * until after the new one is allocated. This keeps the reference + * count from going to zero so the image doesn't have to be recreated + * if it hasn't changed. + */ + + if (imgPtr->imageString != NULL) { + image = Tk_GetImage(interp, tkwin, imgPtr->imageString, + ImageChangedProc, (ClientData) imgPtr); + if (image == NULL) { + return TCL_ERROR; + } + } else { + image = NULL; + } + if (imgPtr->image != NULL) { + Tk_FreeImage(imgPtr->image); + } + imgPtr->image = image; + ComputeImageBbox(canvas, imgPtr); + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * DeleteImage -- + * + * This procedure is called to clean up the data structure + * associated with a image item. + * + * Results: + * None. + * + * Side effects: + * Resources associated with itemPtr are released. + * + *-------------------------------------------------------------- + */ + +static void +DeleteImage(canvas, itemPtr, display) + Tk_Canvas canvas; /* Info about overall canvas widget. */ + Tk_Item *itemPtr; /* Item that is being deleted. */ + Display *display; /* Display containing window for + * canvas. */ +{ + ImageItem *imgPtr = (ImageItem *) itemPtr; + + if (imgPtr->imageString != NULL) { + ckfree(imgPtr->imageString); + } + if (imgPtr->image != NULL) { + Tk_FreeImage(imgPtr->image); + } +} + +/* + *-------------------------------------------------------------- + * + * ComputeImageBbox -- + * + * This procedure is invoked to compute the bounding box of + * all the pixels that may be drawn as part of a image item. + * This procedure is where the child image's placement is + * computed. + * + * Results: + * None. + * + * Side effects: + * The fields x1, y1, x2, and y2 are updated in the header + * for itemPtr. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +ComputeImageBbox(canvas, imgPtr) + Tk_Canvas canvas; /* Canvas that contains item. */ + ImageItem *imgPtr; /* Item whose bbox is to be + * recomputed. */ +{ + int width, height; + int x, y; + + x = imgPtr->x + ((imgPtr->x >= 0) ? 0.5 : - 0.5); + y = imgPtr->y + ((imgPtr->y >= 0) ? 0.5 : - 0.5); + + if (imgPtr->image == None) { + imgPtr->header.x1 = imgPtr->header.x2 = x; + imgPtr->header.y1 = imgPtr->header.y2 = y; + return; + } + + /* + * Compute location and size of image, using anchor information. + */ + + Tk_SizeOfImage(imgPtr->image, &width, &height); + switch (imgPtr->anchor) { + case TK_ANCHOR_N: + x -= width/2; + break; + case TK_ANCHOR_NE: + x -= width; + break; + case TK_ANCHOR_E: + x -= width; + y -= height/2; + break; + case TK_ANCHOR_SE: + x -= width; + y -= height; + break; + case TK_ANCHOR_S: + x -= width/2; + y -= height; + break; + case TK_ANCHOR_SW: + y -= height; + break; + case TK_ANCHOR_W: + y -= height/2; + break; + case TK_ANCHOR_NW: + break; + case TK_ANCHOR_CENTER: + x -= width/2; + y -= height/2; + break; + } + + /* + * Store the information in the item header. + */ + + imgPtr->header.x1 = x; + imgPtr->header.y1 = y; + imgPtr->header.x2 = x + width; + imgPtr->header.y2 = y + height; +} + +/* + *-------------------------------------------------------------- + * + * DisplayImage -- + * + * This procedure is invoked to draw a image item in a given + * drawable. + * + * Results: + * None. + * + * Side effects: + * ItemPtr is drawn in drawable using the transformation + * information in canvas. + * + *-------------------------------------------------------------- + */ + +static void +DisplayImage(canvas, itemPtr, display, drawable, x, y, width, height) + Tk_Canvas canvas; /* Canvas that contains item. */ + Tk_Item *itemPtr; /* Item to be displayed. */ + Display *display; /* Display on which to draw item. */ + Drawable drawable; /* Pixmap or window in which to draw + * item. */ + int x, y, width, height; /* Describes region of canvas that + * must be redisplayed (not used). */ +{ + ImageItem *imgPtr = (ImageItem *) itemPtr; + short drawableX, drawableY; + + if (imgPtr->image == NULL) { + return; + } + + /* + * Translate the coordinates to those of the image, then redisplay it. + */ + + Tk_CanvasDrawableCoords(canvas, (double) x, (double) y, + &drawableX, &drawableY); + Tk_RedrawImage(imgPtr->image, x - imgPtr->header.x1, y - imgPtr->header.y1, + width, height, drawable, drawableX, drawableY); +} + +/* + *-------------------------------------------------------------- + * + * ImageToPoint -- + * + * Computes the distance from a given point to a given + * rectangle, in canvas units. + * + * Results: + * The return value is 0 if the point whose x and y coordinates + * are coordPtr[0] and coordPtr[1] is inside the image. If the + * point isn't inside the image then the return value is the + * distance from the point to the image. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static double +ImageToPoint(canvas, itemPtr, coordPtr) + Tk_Canvas canvas; /* Canvas containing item. */ + Tk_Item *itemPtr; /* Item to check against point. */ + double *coordPtr; /* Pointer to x and y coordinates. */ +{ + ImageItem *imgPtr = (ImageItem *) itemPtr; + double x1, x2, y1, y2, xDiff, yDiff; + + x1 = imgPtr->header.x1; + y1 = imgPtr->header.y1; + x2 = imgPtr->header.x2; + y2 = imgPtr->header.y2; + + /* + * Point is outside rectangle. + */ + + if (coordPtr[0] < x1) { + xDiff = x1 - coordPtr[0]; + } else if (coordPtr[0] > x2) { + xDiff = coordPtr[0] - x2; + } else { + xDiff = 0; + } + + if (coordPtr[1] < y1) { + yDiff = y1 - coordPtr[1]; + } else if (coordPtr[1] > y2) { + yDiff = coordPtr[1] - y2; + } else { + yDiff = 0; + } + + return hypot(xDiff, yDiff); +} + +/* + *-------------------------------------------------------------- + * + * ImageToArea -- + * + * This procedure is called to determine whether an item + * lies entirely inside, entirely outside, or overlapping + * a given rectangle. + * + * Results: + * -1 is returned if the item is entirely outside the area + * given by rectPtr, 0 if it overlaps, and 1 if it is entirely + * inside the given area. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static int +ImageToArea(canvas, itemPtr, rectPtr) + Tk_Canvas canvas; /* Canvas containing item. */ + Tk_Item *itemPtr; /* Item to check against rectangle. */ + double *rectPtr; /* Pointer to array of four coordinates + * (x1, y1, x2, y2) describing rectangular + * area. */ +{ + ImageItem *imgPtr = (ImageItem *) itemPtr; + + if ((rectPtr[2] <= imgPtr->header.x1) + || (rectPtr[0] >= imgPtr->header.x2) + || (rectPtr[3] <= imgPtr->header.y1) + || (rectPtr[1] >= imgPtr->header.y2)) { + return -1; + } + if ((rectPtr[0] <= imgPtr->header.x1) + && (rectPtr[1] <= imgPtr->header.y1) + && (rectPtr[2] >= imgPtr->header.x2) + && (rectPtr[3] >= imgPtr->header.y2)) { + return 1; + } + return 0; +} + +/* + *-------------------------------------------------------------- + * + * ScaleImage -- + * + * This procedure is invoked to rescale an item. + * + * Results: + * None. + * + * Side effects: + * The item referred to by itemPtr is rescaled so that the + * following transformation is applied to all point coordinates: + * x' = originX + scaleX*(x-originX) + * y' = originY + scaleY*(y-originY) + * + *-------------------------------------------------------------- + */ + +static void +ScaleImage(canvas, itemPtr, originX, originY, scaleX, scaleY) + Tk_Canvas canvas; /* Canvas containing rectangle. */ + Tk_Item *itemPtr; /* Rectangle to be scaled. */ + double originX, originY; /* Origin about which to scale rect. */ + double scaleX; /* Amount to scale in X direction. */ + double scaleY; /* Amount to scale in Y direction. */ +{ + ImageItem *imgPtr = (ImageItem *) itemPtr; + + imgPtr->x = originX + scaleX*(imgPtr->x - originX); + imgPtr->y = originY + scaleY*(imgPtr->y - originY); + ComputeImageBbox(canvas, imgPtr); +} + +/* + *-------------------------------------------------------------- + * + * TranslateImage -- + * + * This procedure is called to move an item by a given amount. + * + * Results: + * None. + * + * Side effects: + * The position of the item is offset by (xDelta, yDelta), and + * the bounding box is updated in the generic part of the item + * structure. + * + *-------------------------------------------------------------- + */ + +static void +TranslateImage(canvas, itemPtr, deltaX, deltaY) + Tk_Canvas canvas; /* Canvas containing item. */ + Tk_Item *itemPtr; /* Item that is being moved. */ + double deltaX, deltaY; /* Amount by which item is to be + * moved. */ +{ + ImageItem *imgPtr = (ImageItem *) itemPtr; + + imgPtr->x += deltaX; + imgPtr->y += deltaY; + ComputeImageBbox(canvas, imgPtr); +} + +/* + *---------------------------------------------------------------------- + * + * ImageChangedProc -- + * + * This procedure is invoked by the image code whenever the manager + * for an image does something that affects the image's size or + * how it is displayed. + * + * Results: + * None. + * + * Side effects: + * Arranges for the canvas to get redisplayed. + * + *---------------------------------------------------------------------- + */ + +static void +ImageChangedProc(clientData, x, y, width, height, imgWidth, imgHeight) + ClientData clientData; /* Pointer to canvas item for image. */ + int x, y; /* Upper left pixel (within image) + * that must be redisplayed. */ + int width, height; /* Dimensions of area to redisplay + * (may be <= 0). */ + int imgWidth, imgHeight; /* New dimensions of image. */ +{ + ImageItem *imgPtr = (ImageItem *) clientData; + + /* + * If the image's size changed and it's not anchored at its + * northwest corner then just redisplay the entire area of the + * image. This is a bit over-conservative, but we need to do + * something because a size change also means a position change. + */ + + if (((imgPtr->header.x2 - imgPtr->header.x1) != imgWidth) + || ((imgPtr->header.y2 - imgPtr->header.y1) != imgHeight)) { + x = y = 0; + width = imgWidth; + height = imgHeight; + Tk_CanvasEventuallyRedraw(imgPtr->canvas, imgPtr->header.x1, + imgPtr->header.y1, imgPtr->header.x2, imgPtr->header.y2); + } + ComputeImageBbox(imgPtr->canvas, imgPtr); + Tk_CanvasEventuallyRedraw(imgPtr->canvas, imgPtr->header.x1 + x, + imgPtr->header.y1 + y, (int) (imgPtr->header.x1 + x + width), + (int) (imgPtr->header.y1 + y + height)); +} diff --git a/tk3.6/tkCanvLine.c b/tk4.2/generic/tkCanvLine.c similarity index 72% rename from tk3.6/tkCanvLine.c rename to tk4.2/generic/tkCanvLine.c index 62273d1..950e788 100644 --- a/tk3.6/tkCanvLine.c +++ b/tk4.2/generic/tkCanvLine.c @@ -3,35 +3,18 @@ * * This file implements line items for canvas widgets. * - * Copyright (c) 1991-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tkCanvLine.c 1.43 96/02/15 18:52:30 */ -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkCanvLine.c,v 1.20 93/09/15 08:19:56 ouster Exp $ SPRITE (Berkeley)"; -#endif - #include #include "tkInt.h" -#include "tkCanvas.h" -#include "tkConfig.h" +#include "tkPort.h" /* * The structure below defines the record for each line item. @@ -40,7 +23,7 @@ static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkCanvLine.c,v 1.20 93/09 typedef struct LineItem { Tk_Item header; /* Generic stuff that's the same for all * types. MUST BE FIRST IN STRUCTURE. */ - Tk_Canvas *canvasPtr; /* Canvas containing item. Needed for + Tk_Canvas canvas; /* Canvas containing item. Needed for * parsing arrow shapes. */ int numPoints; /* Number of points in line (always >= 2). */ double *coordPtr; /* Pointer to malloc-ed array containing @@ -59,6 +42,7 @@ typedef struct LineItem { int capStyle; /* Cap style for line. */ int joinStyle; /* Join style for line. */ GC gc; /* Graphics context for filling line. */ + GC arrowGC; /* Graphics context for drawing arrowheads. */ Tk_Uid arrow; /* Indicates whether or not to draw arrowheads: * "none", "first", "last", or "both". */ float arrowShapeA; /* Distance from tip of arrowhead to center. */ @@ -90,40 +74,43 @@ typedef struct LineItem { * Prototypes for procedures defined in this file: */ -static int ArrowheadPostscript _ANSI_ARGS_((Tk_Canvas *canvasPtr, - LineItem *linePtr, double *arrowPtr, - Tk_PostscriptInfo *psInfoPtr)); -static void ComputeLineBbox _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static int ArrowheadPostscript _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, LineItem *linePtr, + double *arrowPtr)); +static void ComputeLineBbox _ANSI_ARGS_((Tk_Canvas canvas, LineItem *linePtr)); -static int ConfigureLine _ANSI_ARGS_(( - Tk_Canvas *canvasPtr, Tk_Item *itemPtr, int argc, +static int ConfigureLine _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int argc, char **argv, int flags)); -static int ConfigureArrows _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static int ConfigureArrows _ANSI_ARGS_((Tk_Canvas canvas, LineItem *linePtr)); -static int CreateLine _ANSI_ARGS_((Tk_Canvas *canvasPtr, - struct Tk_Item *itemPtr, int argc, char **argv)); -static void DeleteLine _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr)); -static void DisplayLine _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, Drawable dst)); -static int LineCoords _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, int argc, char **argv)); -static int LineToArea _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static int CreateLine _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, struct Tk_Item *itemPtr, + int argc, char **argv)); +static void DeleteLine _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, Display *display)); +static void DisplayLine _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, Display *display, Drawable dst, + int x, int y, int width, int height)); +static int LineCoords _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, + int argc, char **argv)); +static int LineToArea _ANSI_ARGS_((Tk_Canvas canvas, Tk_Item *itemPtr, double *rectPtr)); -static double LineToPoint _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static double LineToPoint _ANSI_ARGS_((Tk_Canvas canvas, Tk_Item *itemPtr, double *coordPtr)); -static int LineToPostscript _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, Tk_PostscriptInfo *psInfoPtr)); +static int LineToPostscript _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int prepass)); static int ParseArrowShape _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, Tk_Window tkwin, char *value, char *recordPtr, int offset)); static char * PrintArrowShape _ANSI_ARGS_((ClientData clientData, Tk_Window tkwin, char *recordPtr, int offset, Tcl_FreeProc **freeProcPtr)); -static void ScaleLine _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static void ScaleLine _ANSI_ARGS_((Tk_Canvas canvas, Tk_Item *itemPtr, double originX, double originY, double scaleX, double scaleY)); -static void TranslateLine _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static void TranslateLine _ANSI_ARGS_((Tk_Canvas canvas, Tk_Item *itemPtr, double deltaX, double deltaY)); /* @@ -134,6 +121,9 @@ static void TranslateLine _ANSI_ARGS_((Tk_Canvas *canvasPtr, static Tk_CustomOption arrowShapeOption = {ParseArrowShape, PrintArrowShape, (ClientData) NULL}; +static Tk_CustomOption tagsOption = {Tk_CanvasTagsParseProc, + Tk_CanvasTagsPrintProc, (ClientData) NULL +}; static Tk_ConfigSpec configSpecs[] = { {TK_CONFIG_UID, "-arrow", (char *) NULL, (char *) NULL, @@ -154,7 +144,7 @@ static Tk_ConfigSpec configSpecs[] = { {TK_CONFIG_BITMAP, "-stipple", (char *) NULL, (char *) NULL, (char *) NULL, Tk_Offset(LineItem, fillStipple), TK_CONFIG_NULL_OK}, {TK_CONFIG_CUSTOM, "-tags", (char *) NULL, (char *) NULL, - (char *) NULL, 0, TK_CONFIG_NULL_OK, &tkCanvasTagsOption}, + (char *) NULL, 0, TK_CONFIG_NULL_OK, &tagsOption}, {TK_CONFIG_PIXELS, "-width", (char *) NULL, (char *) NULL, "1", Tk_Offset(LineItem, width), TK_CONFIG_DONT_SET_DEFAULT}, {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, @@ -166,7 +156,7 @@ static Tk_ConfigSpec configSpecs[] = { * of procedures that can be invoked by generic item code. */ -Tk_ItemType TkLineType = { +Tk_ItemType tkLineType = { "line", /* name */ sizeof(LineItem), /* itemSize */ CreateLine, /* createProc */ @@ -217,9 +207,8 @@ static Tk_Uid bothUid = NULL; * Results: * A standard Tcl return value. If an error occurred in * creating the item, then an error message is left in - * canvasPtr->interp->result; in this case itemPtr is - * left uninitialized, so it can be safely freed by the - * caller. + * interp->result; in this case itemPtr is left uninitialized, + * so it can be safely freed by the caller. * * Side effects: * A new line item is created. @@ -228,20 +217,21 @@ static Tk_Uid bothUid = NULL; */ static int -CreateLine(canvasPtr, itemPtr, argc, argv) - register Tk_Canvas *canvasPtr; /* Canvas to hold new item. */ +CreateLine(interp, canvas, itemPtr, argc, argv) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + Tk_Canvas canvas; /* Canvas to hold new item. */ Tk_Item *itemPtr; /* Record to hold new item; header * has been initialized by caller. */ int argc; /* Number of arguments in argv. */ char **argv; /* Arguments describing line. */ { - register LineItem *linePtr = (LineItem *) itemPtr; + LineItem *linePtr = (LineItem *) itemPtr; int i; if (argc < 4) { - Tcl_AppendResult(canvasPtr->interp, "wrong # args: should be \"", - Tk_PathName(canvasPtr->tkwin), "\" create ", - itemPtr->typePtr->name, " x1 y1 x2 y2 ?x3 y3 ...? ?options?", + Tcl_AppendResult(interp, "wrong # args: should be \"", + Tk_PathName(Tk_CanvasTkwin(canvas)), " create ", + itemPtr->typePtr->name, " x1 y1 x2 y2 ?x3 y3 ...? ?options?\"", (char *) NULL); return TCL_ERROR; } @@ -252,7 +242,7 @@ CreateLine(canvasPtr, itemPtr, argc, argv) * this procedure. */ - linePtr->canvasPtr = canvasPtr; + linePtr->canvas = canvas; linePtr->numPoints = 0; linePtr->coordPtr = NULL; linePtr->width = 1; @@ -261,6 +251,7 @@ CreateLine(canvasPtr, itemPtr, argc, argv) linePtr->capStyle = CapButt; linePtr->joinStyle = JoinRound; linePtr->gc = None; + linePtr->arrowGC = None; if (noneUid == NULL) { noneUid = Tk_GetUid("none"); firstUid = Tk_GetUid("first"); @@ -284,19 +275,20 @@ CreateLine(canvasPtr, itemPtr, argc, argv) for (i = 4; i < (argc-1); i+=2) { if ((!isdigit(UCHAR(argv[i][0]))) && - ((argv[i][0] != '-') || (!isdigit(UCHAR(argv[i][1]))))) { + ((argv[i][0] != '-') + || ((argv[i][1] != '.') && !isdigit(UCHAR(argv[i][1]))))) { break; } } - if (LineCoords(canvasPtr, itemPtr, i, argv) != TCL_OK) { + if (LineCoords(interp, canvas, itemPtr, i, argv) != TCL_OK) { goto error; } - if (ConfigureLine(canvasPtr, itemPtr, argc-i, argv+i, 0) == TCL_OK) { + if (ConfigureLine(interp, canvas, itemPtr, argc-i, argv+i, 0) == TCL_OK) { return TCL_OK; } error: - DeleteLine(canvasPtr, itemPtr); + DeleteLine(canvas, itemPtr, Tk_Display(Tk_CanvasTkwin(canvas))); return TCL_ERROR; } @@ -310,7 +302,7 @@ CreateLine(canvasPtr, itemPtr, argc, argv) * on what it does. * * Results: - * Returns TCL_OK or TCL_ERROR, and sets canvasPtr->interp->result. + * Returns TCL_OK or TCL_ERROR, and sets interp->result. * * Side effects: * The coordinates for the given item may be changed. @@ -319,8 +311,9 @@ CreateLine(canvasPtr, itemPtr, argc, argv) */ static int -LineCoords(canvasPtr, itemPtr, argc, argv) - register Tk_Canvas *canvasPtr; /* Canvas containing item. */ +LineCoords(interp, canvas, itemPtr, argc, argv) + Tcl_Interp *interp; /* Used for error reporting. */ + Tk_Canvas canvas; /* Canvas containing item. */ Tk_Item *itemPtr; /* Item whose coordinates are to be * read or modified. */ int argc; /* Number of coordinates supplied in @@ -328,7 +321,7 @@ LineCoords(canvasPtr, itemPtr, argc, argv) char **argv; /* Array of coordinates: x1, y1, * x2, y2, ... */ { - register LineItem *linePtr = (LineItem *) itemPtr; + LineItem *linePtr = (LineItem *) itemPtr; char buffer[TCL_DOUBLE_SPACE]; int i, numPoints; @@ -349,16 +342,16 @@ LineCoords(canvasPtr, itemPtr, argc, argv) if ((linePtr->lastArrowPtr != NULL) && (i == (numCoords-2))) { coordPtr = linePtr->lastArrowPtr; } - Tcl_PrintDouble(canvasPtr->interp, *coordPtr, buffer); - Tcl_AppendElement(canvasPtr->interp, buffer); + Tcl_PrintDouble(interp, *coordPtr, buffer); + Tcl_AppendElement(interp, buffer); } } else if (argc < 4) { - Tcl_AppendResult(canvasPtr->interp, - "too few coordinates for line: must have at least 4", + Tcl_AppendResult(interp, + "too few coordinates for line: must have at least 4", (char *) NULL); return TCL_ERROR; } else if (argc & 1) { - Tcl_AppendResult(canvasPtr->interp, + Tcl_AppendResult(interp, "odd number of coordinates specified for line", (char *) NULL); return TCL_ERROR; @@ -373,8 +366,8 @@ LineCoords(canvasPtr, itemPtr, argc, argv) linePtr->numPoints = numPoints; } for (i = argc-1; i >= 0; i--) { - if (TkGetCanvasCoord(canvasPtr, argv[i], &linePtr->coordPtr[i]) - != TCL_OK) { + if (Tk_CanvasGetCoord(interp, canvas, argv[i], + &linePtr->coordPtr[i]) != TCL_OK) { return TCL_ERROR; } } @@ -393,9 +386,9 @@ LineCoords(canvasPtr, itemPtr, argc, argv) linePtr->lastArrowPtr = NULL; } if (linePtr->arrow != noneUid) { - ConfigureArrows(canvasPtr, linePtr); + ConfigureArrows(canvas, linePtr); } - ComputeLineBbox(canvasPtr, linePtr); + ComputeLineBbox(canvas, linePtr); } return TCL_OK; } @@ -410,7 +403,7 @@ LineCoords(canvasPtr, itemPtr, argc, argv) * * Results: * A standard Tcl result code. If an error occurs, then - * an error message is left in canvasPtr->interp->result. + * an error message is left in interp->result. * * Side effects: * Configuration information, such as colors and stipple @@ -420,20 +413,23 @@ LineCoords(canvasPtr, itemPtr, argc, argv) */ static int -ConfigureLine(canvasPtr, itemPtr, argc, argv, flags) - Tk_Canvas *canvasPtr; /* Canvas containing itemPtr. */ +ConfigureLine(interp, canvas, itemPtr, argc, argv, flags) + Tcl_Interp *interp; /* Used for error reporting. */ + Tk_Canvas canvas; /* Canvas containing itemPtr. */ Tk_Item *itemPtr; /* Line item to reconfigure. */ int argc; /* Number of elements in argv. */ char **argv; /* Arguments describing things to configure. */ int flags; /* Flags to pass to Tk_ConfigureWidget. */ { - register LineItem *linePtr = (LineItem *) itemPtr; + LineItem *linePtr = (LineItem *) itemPtr; XGCValues gcValues; - GC newGC; + GC newGC, arrowGC; unsigned long mask; + Tk_Window tkwin; - if (Tk_ConfigureWidget(canvasPtr->interp, canvasPtr->tkwin, - configSpecs, argc, argv, (char *) linePtr, flags) != TCL_OK) { + tkwin = Tk_CanvasTkwin(canvas); + if (Tk_ConfigureWidget(interp, tkwin, configSpecs, argc, argv, + (char *) linePtr, flags) != TCL_OK) { return TCL_ERROR; } @@ -443,7 +439,7 @@ ConfigureLine(canvasPtr, itemPtr, argc, argv, flags) */ if (linePtr->fg == NULL) { - newGC = None; + newGC = arrowGC = None; } else { gcValues.foreground = linePtr->fg->pixel; gcValues.join_style = linePtr->joinStyle; @@ -461,12 +457,18 @@ ConfigureLine(canvasPtr, itemPtr, argc, argv, flags) gcValues.cap_style = linePtr->capStyle; mask |= GCCapStyle; } - newGC = Tk_GetGC(canvasPtr->tkwin, mask, &gcValues); + newGC = Tk_GetGC(tkwin, mask, &gcValues); + gcValues.line_width = 0; + arrowGC = Tk_GetGC(tkwin, mask, &gcValues); } if (linePtr->gc != None) { - Tk_FreeGC(canvasPtr->display, linePtr->gc); + Tk_FreeGC(Tk_Display(tkwin), linePtr->gc); + } + if (linePtr->arrowGC != None) { + Tk_FreeGC(Tk_Display(tkwin), linePtr->arrowGC); } linePtr->gc = newGC; + linePtr->arrowGC = arrowGC; /* * Keep spline parameters within reasonable limits. @@ -493,31 +495,31 @@ ConfigureLine(canvasPtr, itemPtr, argc, argv, flags) } if ((linePtr->lastArrowPtr != NULL) && (linePtr->arrow != lastUid) && (linePtr->arrow != bothUid)) { - int index; + int i; - index = 2*(linePtr->numPoints-1); - linePtr->coordPtr[index] = linePtr->lastArrowPtr[0]; - linePtr->coordPtr[index+1] = linePtr->lastArrowPtr[1]; + i = 2*(linePtr->numPoints-1); + linePtr->coordPtr[i] = linePtr->lastArrowPtr[0]; + linePtr->coordPtr[i+1] = linePtr->lastArrowPtr[1]; ckfree((char *) linePtr->lastArrowPtr); linePtr->lastArrowPtr = NULL; } if (linePtr->arrow != noneUid) { if ((linePtr->arrow != firstUid) && (linePtr->arrow != lastUid) && (linePtr->arrow != bothUid)) { - Tcl_AppendResult(canvasPtr->interp, "bad arrow spec \"", + Tcl_AppendResult(interp, "bad arrow spec \"", linePtr->arrow, "\": must be none, first, last, or both", (char *) NULL); linePtr->arrow = noneUid; return TCL_ERROR; } - ConfigureArrows(canvasPtr, linePtr); + ConfigureArrows(canvas, linePtr); } /* * Recompute bounding box for line. */ - ComputeLineBbox(canvasPtr, linePtr); + ComputeLineBbox(canvas, linePtr); return TCL_OK; } @@ -540,11 +542,13 @@ ConfigureLine(canvasPtr, itemPtr, argc, argv, flags) */ static void -DeleteLine(canvasPtr, itemPtr) - Tk_Canvas *canvasPtr; /* Info about overall canvas widget. */ +DeleteLine(canvas, itemPtr, display) + Tk_Canvas canvas; /* Info about overall canvas widget. */ Tk_Item *itemPtr; /* Item that is being deleted. */ + Display *display; /* Display containing window for + * canvas. */ { - register LineItem *linePtr = (LineItem *) itemPtr; + LineItem *linePtr = (LineItem *) itemPtr; if (linePtr->coordPtr != NULL) { ckfree((char *) linePtr->coordPtr); @@ -553,10 +557,13 @@ DeleteLine(canvasPtr, itemPtr) Tk_FreeColor(linePtr->fg); } if (linePtr->fillStipple != None) { - Tk_FreeBitmap(canvasPtr->display, linePtr->fillStipple); + Tk_FreeBitmap(display, linePtr->fillStipple); } if (linePtr->gc != None) { - Tk_FreeGC(canvasPtr->display, linePtr->gc); + Tk_FreeGC(display, linePtr->gc); + } + if (linePtr->arrowGC != None) { + Tk_FreeGC(display, linePtr->arrowGC); } if (linePtr->firstArrowPtr != NULL) { ckfree((char *) linePtr->firstArrowPtr); @@ -585,12 +592,12 @@ DeleteLine(canvasPtr, itemPtr) */ static void -ComputeLineBbox(canvasPtr, linePtr) - register Tk_Canvas *canvasPtr; /* Canvas that contains item. */ +ComputeLineBbox(canvas, linePtr) + Tk_Canvas canvas; /* Canvas that contains item. */ LineItem *linePtr; /* Item whose bbos is to be * recomputed. */ { - register double *coordPtr; + double *coordPtr; int i; coordPtr = linePtr->coordPtr; @@ -609,7 +616,7 @@ ComputeLineBbox(canvasPtr, linePtr) for (i = 1, coordPtr = linePtr->coordPtr+2; i < linePtr->numPoints; i++, coordPtr += 2) { - TkIncludePoint(canvasPtr, (Tk_Item *) linePtr, coordPtr); + TkIncludePoint((Tk_Item *) linePtr, coordPtr); } linePtr->header.x1 -= linePtr->width; linePtr->header.x2 += linePtr->width; @@ -631,7 +638,7 @@ ComputeLineBbox(canvasPtr, linePtr) if (TkGetMiterPoints(coordPtr, coordPtr+2, coordPtr+4, (double) linePtr->width, miter, miter+2)) { for (j = 0; j < 4; j += 2) { - TkIncludePoint(canvasPtr, (Tk_Item *) linePtr, miter+j); + TkIncludePoint((Tk_Item *) linePtr, miter+j); } } } @@ -645,13 +652,13 @@ ComputeLineBbox(canvasPtr, linePtr) if (linePtr->arrow != lastUid) { for (i = 0, coordPtr = linePtr->firstArrowPtr; i < PTS_IN_ARROW; i++, coordPtr += 2) { - TkIncludePoint(canvasPtr, (Tk_Item *) linePtr, coordPtr); + TkIncludePoint((Tk_Item *) linePtr, coordPtr); } } if (linePtr->arrow != firstUid) { for (i = 0, coordPtr = linePtr->lastArrowPtr; i < PTS_IN_ARROW; i++, coordPtr += 2) { - TkIncludePoint(canvasPtr, (Tk_Item *) linePtr, coordPtr); + TkIncludePoint((Tk_Item *) linePtr, coordPtr); } } } @@ -680,23 +687,26 @@ ComputeLineBbox(canvasPtr, linePtr) * * Side effects: * ItemPtr is drawn in drawable using the transformation - * information in canvasPtr. + * information in canvas. * *-------------------------------------------------------------- */ static void -DisplayLine(canvasPtr, itemPtr, drawable) - register Tk_Canvas *canvasPtr; /* Canvas that contains item. */ +DisplayLine(canvas, itemPtr, display, drawable, x, y, width, height) + Tk_Canvas canvas; /* Canvas that contains item. */ Tk_Item *itemPtr; /* Item to be displayed. */ + Display *display; /* Display on which to draw item. */ Drawable drawable; /* Pixmap or window in which to draw * item. */ + int x, y, width, height; /* Describes region of canvas that + * must be redisplayed (not used). */ { - register LineItem *linePtr = (LineItem *) itemPtr; + LineItem *linePtr = (LineItem *) itemPtr; XPoint staticPoints[MAX_STATIC_POINTS]; XPoint *pointPtr; - register XPoint *pPtr; - register double *coordPtr; + XPoint *pPtr; + double *coordPtr; int i, numPoints; if (linePtr->gc == None) { @@ -722,15 +732,15 @@ DisplayLine(canvasPtr, itemPtr, drawable) pointPtr = (XPoint *) ckalloc((unsigned) (numPoints * sizeof(XPoint))); } - if (linePtr->smooth) { - numPoints = TkMakeBezierCurve(canvasPtr, linePtr->coordPtr, + if ((linePtr->smooth) && (linePtr->numPoints > 2)) { + numPoints = TkMakeBezierCurve(canvas, linePtr->coordPtr, linePtr->numPoints, linePtr->splineSteps, pointPtr, (double *) NULL); } else { for (i = 0, coordPtr = linePtr->coordPtr, pPtr = pointPtr; i < linePtr->numPoints; i += 1, coordPtr += 2, pPtr++) { - pPtr->x = SCREEN_X(canvasPtr, *coordPtr); - pPtr->y = SCREEN_Y(canvasPtr, coordPtr[1]); + Tk_CanvasDrawableCoords(canvas, coordPtr[0], coordPtr[1], + &pPtr->x, &pPtr->y); } } @@ -742,11 +752,11 @@ DisplayLine(canvasPtr, itemPtr, drawable) */ if (linePtr->fillStipple != None) { - XSetTSOrigin(Tk_Display(canvasPtr->tkwin), linePtr->gc, - -canvasPtr->drawableXOrigin, -canvasPtr->drawableYOrigin); + Tk_CanvasSetStippleOrigin(canvas, linePtr->gc); + Tk_CanvasSetStippleOrigin(canvas, linePtr->arrowGC); } - XDrawLines(Tk_Display(canvasPtr->tkwin), drawable, linePtr->gc, - pointPtr, numPoints, CoordModeOrigin); + XDrawLines(display, drawable, linePtr->gc, pointPtr, numPoints, + CoordModeOrigin); if (pointPtr != staticPoints) { ckfree((char *) pointPtr); } @@ -755,18 +765,17 @@ DisplayLine(canvasPtr, itemPtr, drawable) * Display arrowheads, if they are wanted. */ - if (linePtr->arrow != noneUid) { - if (linePtr->arrow != lastUid) { - TkFillPolygon(canvasPtr, linePtr->firstArrowPtr, PTS_IN_ARROW, - drawable, linePtr->gc); - } - if (linePtr->arrow != firstUid) { - TkFillPolygon(canvasPtr, linePtr->lastArrowPtr, PTS_IN_ARROW, - drawable, linePtr->gc); - } + if (linePtr->firstArrowPtr != NULL) { + TkFillPolygon(canvas, linePtr->firstArrowPtr, PTS_IN_ARROW, + display, drawable, linePtr->gc, NULL); + } + if (linePtr->lastArrowPtr != NULL) { + TkFillPolygon(canvas, linePtr->lastArrowPtr, PTS_IN_ARROW, + display, drawable, linePtr->gc, NULL); } if (linePtr->fillStipple != None) { - XSetTSOrigin(Tk_Display(canvasPtr->tkwin), linePtr->gc, 0, 0); + XSetTSOrigin(display, linePtr->gc, 0, 0); + XSetTSOrigin(display, linePtr->arrowGC, 0, 0); } } @@ -792,13 +801,13 @@ DisplayLine(canvasPtr, itemPtr, drawable) /* ARGSUSED */ static double -LineToPoint(canvasPtr, itemPtr, pointPtr) - Tk_Canvas *canvasPtr; /* Canvas containing item. */ +LineToPoint(canvas, itemPtr, pointPtr) + Tk_Canvas canvas; /* Canvas containing item. */ Tk_Item *itemPtr; /* Item to check against point. */ double *pointPtr; /* Pointer to x and y coordinates. */ { - register LineItem *linePtr = (LineItem *) itemPtr; - register double *coordPtr, *linePoints; + LineItem *linePtr = (LineItem *) itemPtr; + double *coordPtr, *linePoints; double staticSpace[2*MAX_STATIC_POINTS]; double poly[10]; double bestDist, dist; @@ -807,7 +816,7 @@ LineToPoint(canvasPtr, itemPtr, pointPtr) * had to be treated as beveled after all * because the angle was < 11 degrees. */ - bestDist = 1.0e40; + bestDist = 1.0e36; /* * Handle smoothed lines by generating an expanded set of points @@ -822,7 +831,7 @@ LineToPoint(canvasPtr, itemPtr, pointPtr) linePoints = (double *) ckalloc((unsigned) (2*numPoints*sizeof(double))); } - numPoints = TkMakeBezierCurve(canvasPtr, linePtr->coordPtr, + numPoints = TkMakeBezierCurve(canvas, linePtr->coordPtr, linePtr->numPoints, linePtr->splineSteps, (XPoint *) NULL, linePoints); } else { @@ -994,29 +1003,18 @@ LineToPoint(canvasPtr, itemPtr, pointPtr) /* ARGSUSED */ static int -LineToArea(canvasPtr, itemPtr, rectPtr) - Tk_Canvas *canvasPtr; /* Canvas containing item. */ +LineToArea(canvas, itemPtr, rectPtr) + Tk_Canvas canvas; /* Canvas containing item. */ Tk_Item *itemPtr; /* Item to check against line. */ double *rectPtr; { - register LineItem *linePtr = (LineItem *) itemPtr; - register double *coordPtr; + LineItem *linePtr = (LineItem *) itemPtr; double staticSpace[2*MAX_STATIC_POINTS]; - double *linePoints, poly[10]; + double *linePoints; double radius; - int numPoints, count; - int changedMiterToBevel; /* Non-zero means that a mitered corner - * had to be treated as beveled after all - * because the angle was < 11 degrees. */ - int inside; /* Tentative guess about what to return, - * based on all points seen so far: one - * means everything seen so far was - * inside the area; -1 means everything - * was outside the area. 0 means overlap - * has been found. */ + int numPoints, result; radius = linePtr->width/2.0; - inside = -1; /* * Handle smoothed lines by generating an expanded set of points @@ -1031,7 +1029,7 @@ LineToArea(canvasPtr, itemPtr, rectPtr) linePoints = (double *) ckalloc((unsigned) (2*numPoints*sizeof(double))); } - numPoints = TkMakeBezierCurve(canvasPtr, linePtr->coordPtr, + numPoints = TkMakeBezierCurve(canvas, linePtr->coordPtr, linePtr->numPoints, linePtr->splineSteps, (XPoint *) NULL, linePoints); } else { @@ -1039,112 +1037,15 @@ LineToArea(canvasPtr, itemPtr, rectPtr) linePoints = linePtr->coordPtr; } - coordPtr = linePoints; - if ((coordPtr[0] >= rectPtr[0]) && (coordPtr[0] <= rectPtr[2]) - && (coordPtr[1] >= rectPtr[1]) && (coordPtr[1] <= rectPtr[3])) { - inside = 1; - } - /* - * Iterate through all of the edges of the line, computing a polygon - * for each edge and testing the area against that polygon. In - * addition, there are additional tests to deal with rounded joints - * and caps. + * Check the segments of the line. */ - changedMiterToBevel = 0; - for (count = numPoints; count >= 2; count--, coordPtr += 2) { - - /* - * If rounding is done around the first point of the edge - * then test a circular region around the point with the - * area. - */ - - if (((linePtr->capStyle == CapRound) && (count == numPoints)) - || ((linePtr->joinStyle == JoinRound) - && (count != numPoints))) { - poly[0] = coordPtr[0] - radius; - poly[1] = coordPtr[1] - radius; - poly[2] = coordPtr[0] + radius; - poly[3] = coordPtr[1] + radius; - if (TkOvalToArea(poly, rectPtr) != inside) { - inside = 0; - goto done; - } - } - - /* - * Compute the polygonal shape corresponding to this edge, - * consisting of two points for the first point of the edge - * and two points for the last point of the edge. - */ - - if (count == numPoints) { - TkGetButtPoints(coordPtr+2, coordPtr, (double) linePtr->width, - linePtr->capStyle == CapProjecting, poly, poly+2); - } else if ((linePtr->joinStyle == JoinMiter) && !changedMiterToBevel) { - poly[0] = poly[6]; - poly[1] = poly[7]; - poly[2] = poly[4]; - poly[3] = poly[5]; - } else { - TkGetButtPoints(coordPtr+2, coordPtr, (double) linePtr->width, 0, - poly, poly+2); - - /* - * If the last joint was beveled, then also check a - * polygon comprising the last two points of the previous - * polygon and the first two from this polygon; this checks - * the wedges that fill the beveled joint. - */ - - if ((linePtr->joinStyle == JoinBevel) || changedMiterToBevel) { - poly[8] = poly[0]; - poly[9] = poly[1]; - if (TkPolygonToArea(poly, 5, rectPtr) != inside) { - inside = 0; - goto done; - } - changedMiterToBevel = 0; - } - } - if (count == 2) { - TkGetButtPoints(coordPtr, coordPtr+2, (double) linePtr->width, - linePtr->capStyle == CapProjecting, poly+4, poly+6); - } else if (linePtr->joinStyle == JoinMiter) { - if (TkGetMiterPoints(coordPtr, coordPtr+2, coordPtr+4, - (double) linePtr->width, poly+4, poly+6) == 0) { - changedMiterToBevel = 1; - TkGetButtPoints(coordPtr, coordPtr+2, (double) linePtr->width, - 0, poly+4, poly+6); - } - } else { - TkGetButtPoints(coordPtr, coordPtr+2, (double) linePtr->width, 0, - poly+4, poly+6); - } - poly[8] = poly[0]; - poly[9] = poly[1]; - if (TkPolygonToArea(poly, 5, rectPtr) != inside) { - inside = 0; - goto done; - } - } - - /* - * If caps are rounded, check the cap around the final point - * of the line. - */ - - if (linePtr->capStyle == CapRound) { - poly[0] = coordPtr[0] - radius; - poly[1] = coordPtr[1] - radius; - poly[2] = coordPtr[0] + radius; - poly[3] = coordPtr[1] + radius; - if (TkOvalToArea(poly, rectPtr) != inside) { - inside = 0; - goto done; - } + result = TkThickPolyLineToArea(linePoints, numPoints, + (double) linePtr->width, linePtr->capStyle, linePtr->joinStyle, + rectPtr); + if (result == 0) { + goto done; } /* @@ -1154,15 +1055,15 @@ LineToArea(canvasPtr, itemPtr, rectPtr) if (linePtr->arrow != noneUid) { if (linePtr->arrow != lastUid) { if (TkPolygonToArea(linePtr->firstArrowPtr, PTS_IN_ARROW, - rectPtr) != inside) { - inside = 0; + rectPtr) != result) { + result = 0; goto done; } } if (linePtr->arrow != firstUid) { if (TkPolygonToArea(linePtr->lastArrowPtr, PTS_IN_ARROW, - rectPtr) != inside) { - inside = 0; + rectPtr) != result) { + result = 0; goto done; } } @@ -1172,7 +1073,7 @@ LineToArea(canvasPtr, itemPtr, rectPtr) if ((linePoints != staticSpace) && (linePoints != linePtr->coordPtr)) { ckfree((char *) linePoints); } - return inside; + return result; } /* @@ -1196,37 +1097,46 @@ LineToArea(canvasPtr, itemPtr, rectPtr) */ static void -ScaleLine(canvasPtr, itemPtr, originX, originY, scaleX, scaleY) - Tk_Canvas *canvasPtr; /* Canvas containing line. */ +ScaleLine(canvas, itemPtr, originX, originY, scaleX, scaleY) + Tk_Canvas canvas; /* Canvas containing line. */ Tk_Item *itemPtr; /* Line to be scaled. */ double originX, originY; /* Origin about which to scale rect. */ double scaleX; /* Amount to scale in X direction. */ double scaleY; /* Amount to scale in Y direction. */ { LineItem *linePtr = (LineItem *) itemPtr; - register double *coordPtr; + double *coordPtr; int i; + /* + * Delete any arrowheads before scaling all the points (so that + * the end-points of the line get restored). + */ + + if (linePtr->firstArrowPtr != NULL) { + linePtr->coordPtr[0] = linePtr->firstArrowPtr[0]; + linePtr->coordPtr[1] = linePtr->firstArrowPtr[1]; + ckfree((char *) linePtr->firstArrowPtr); + linePtr->firstArrowPtr = NULL; + } + if (linePtr->lastArrowPtr != NULL) { + int i; + + i = 2*(linePtr->numPoints-1); + linePtr->coordPtr[i] = linePtr->lastArrowPtr[0]; + linePtr->coordPtr[i+1] = linePtr->lastArrowPtr[1]; + ckfree((char *) linePtr->lastArrowPtr); + linePtr->lastArrowPtr = NULL; + } for (i = 0, coordPtr = linePtr->coordPtr; i < linePtr->numPoints; i++, coordPtr += 2) { coordPtr[0] = originX + scaleX*(*coordPtr - originX); coordPtr[1] = originY + scaleY*(coordPtr[1] - originY); } - if (linePtr->firstArrowPtr != NULL) { - for (i = 0, coordPtr = linePtr->firstArrowPtr; i < PTS_IN_ARROW; - i++, coordPtr += 2) { - coordPtr[0] = originX + scaleX*(coordPtr[0] - originX); - coordPtr[1] = originY + scaleY*(coordPtr[1] - originY); - } + if (linePtr->arrow != noneUid) { + ConfigureArrows(canvas, linePtr); } - if (linePtr->lastArrowPtr != NULL) { - for (i = 0, coordPtr = linePtr->lastArrowPtr; i < PTS_IN_ARROW; - i++, coordPtr += 2) { - coordPtr[0] = originX + scaleX*(coordPtr[0] - originX); - coordPtr[1] = originY + scaleY*(coordPtr[1] - originY); - } - } - ComputeLineBbox(canvasPtr, linePtr); + ComputeLineBbox(canvas, linePtr); } /* @@ -1248,14 +1158,14 @@ ScaleLine(canvasPtr, itemPtr, originX, originY, scaleX, scaleY) */ static void -TranslateLine(canvasPtr, itemPtr, deltaX, deltaY) - Tk_Canvas *canvasPtr; /* Canvas containing item. */ +TranslateLine(canvas, itemPtr, deltaX, deltaY) + Tk_Canvas canvas; /* Canvas containing item. */ Tk_Item *itemPtr; /* Item that is being moved. */ double deltaX, deltaY; /* Amount by which item is to be * moved. */ { LineItem *linePtr = (LineItem *) itemPtr; - register double *coordPtr; + double *coordPtr; int i; for (i = 0, coordPtr = linePtr->coordPtr; i < linePtr->numPoints; @@ -1277,7 +1187,7 @@ TranslateLine(canvasPtr, itemPtr, deltaX, deltaY) coordPtr[1] += deltaY; } } - ComputeLineBbox(canvasPtr, linePtr); + ComputeLineBbox(canvas, linePtr); } /* @@ -1333,9 +1243,11 @@ ParseArrowShape(clientData, interp, tkwin, value, recordPtr, offset) if (argc != 3) { goto syntaxError; } - if ((TkGetCanvasCoord(linePtr->canvasPtr, argv[0], &a) != TCL_OK) - || (TkGetCanvasCoord(linePtr->canvasPtr, argv[1], &b) != TCL_OK) - || (TkGetCanvasCoord(linePtr->canvasPtr, argv[2], &c) != TCL_OK)) { + if ((Tk_CanvasGetCoord(interp, linePtr->canvas, argv[0], &a) != TCL_OK) + || (Tk_CanvasGetCoord(interp, linePtr->canvas, argv[1], &b) + != TCL_OK) + || (Tk_CanvasGetCoord(interp, linePtr->canvas, argv[2], &c) + != TCL_OK)) { goto syntaxError; } linePtr->arrowShapeA = a; @@ -1376,10 +1288,10 @@ PrintArrowShape(clientData, tkwin, recordPtr, offset, freeProcPtr) LineItem *linePtr = (LineItem *) recordPtr; char *buffer; - buffer = ckalloc(120); + buffer = (char *) ckalloc(120); sprintf(buffer, "%.5g %.5g %.5g", linePtr->arrowShapeA, linePtr->arrowShapeB, linePtr->arrowShapeC); - *freeProcPtr = (Tcl_FreeProc *) free; + *freeProcPtr = TCL_DYNAMIC; return buffer; } @@ -1392,8 +1304,7 @@ PrintArrowShape(clientData, tkwin, recordPtr, offset, freeProcPtr) * procedure makes arrangements for the arrowheads. * * Results: - * A standard Tcl return value. If an error occurs, then - * an error message is left in canvasPtr->interp->result. + * Always returns TCL_OK. * * Side effects: * Information in linePtr is set up for one or two arrowheads. @@ -1407,20 +1318,33 @@ PrintArrowShape(clientData, tkwin, recordPtr, offset, freeProcPtr) /* ARGSUSED */ static int -ConfigureArrows(canvasPtr, linePtr) - Tk_Canvas *canvasPtr; /* Canvas in which arrows will be +ConfigureArrows(canvas, linePtr) + Tk_Canvas canvas; /* Canvas in which arrows will be * displayed (interp and tkwin * fields are needed). */ - register LineItem *linePtr; /* Item to configure for arrows. */ + LineItem *linePtr; /* Item to configure for arrows. */ { double *poly, *coordPtr; - double dx, dy, length, sinTheta, cosTheta, temp, shapeC; + double dx, dy, length, sinTheta, cosTheta, temp; double fracHeight; /* Line width as fraction of * arrowhead width. */ double backup; /* Distance to backup end points * so the line ends in the middle * of the arrowhead. */ double vertX, vertY; /* Position of arrowhead vertex. */ + double shapeA, shapeB, shapeC; /* Adjusted coordinates (see + * explanation below). */ + + /* + * The code below makes a tiny increase in the shape parameters + * for the line. This is a bit of a hack, but it seems to result + * in displays that more closely approximate the specified parameters. + * Without the adjustment, the arrows come out smaller than expected. + */ + + shapeA = linePtr->arrowShapeA + 0.001; + shapeB = linePtr->arrowShapeB + 0.001; + shapeC = linePtr->arrowShapeC + linePtr->width/2.0 + 0.001; /* * If there's an arrowhead on the first point of the line, compute @@ -1428,10 +1352,8 @@ ConfigureArrows(canvasPtr, linePtr) * line doesn't stick out past the leading edge of the arrowhead. */ - shapeC = linePtr->arrowShapeC + linePtr->width/2.0; fracHeight = (linePtr->width/2.0)/shapeC; - backup = fracHeight*linePtr->arrowShapeB - + linePtr->arrowShapeA*(1.0 - fracHeight)/2.0; + backup = fracHeight*shapeB + shapeA*(1.0 - fracHeight)/2.0; if (linePtr->arrow != lastUid) { poly = linePtr->firstArrowPtr; if (poly == NULL) { @@ -1450,13 +1372,13 @@ ConfigureArrows(canvasPtr, linePtr) sinTheta = dy/length; cosTheta = dx/length; } - vertX = poly[0] - linePtr->arrowShapeA*cosTheta; - vertY = poly[1] - linePtr->arrowShapeA*sinTheta; + vertX = poly[0] - shapeA*cosTheta; + vertY = poly[1] - shapeA*sinTheta; temp = shapeC*sinTheta; - poly[2] = poly[0] - linePtr->arrowShapeB*cosTheta + temp; + poly[2] = poly[0] - shapeB*cosTheta + temp; poly[8] = poly[2] - 2*temp; temp = shapeC*cosTheta; - poly[3] = poly[1] - linePtr->arrowShapeB*sinTheta - temp; + poly[3] = poly[1] - shapeB*sinTheta - temp; poly[9] = poly[3] + 2*temp; poly[4] = poly[2]*fracHeight + vertX*(1.0-fracHeight); poly[5] = poly[3]*fracHeight + vertY*(1.0-fracHeight); @@ -1496,13 +1418,13 @@ ConfigureArrows(canvasPtr, linePtr) sinTheta = dy/length; cosTheta = dx/length; } - vertX = poly[0] - linePtr->arrowShapeA*cosTheta; - vertY = poly[1] - linePtr->arrowShapeA*sinTheta; + vertX = poly[0] - shapeA*cosTheta; + vertY = poly[1] - shapeA*sinTheta; temp = shapeC*sinTheta; - poly[2] = poly[0] - linePtr->arrowShapeB*cosTheta + temp; + poly[2] = poly[0] - shapeB*cosTheta + temp; poly[8] = poly[2] - 2*temp; temp = shapeC*cosTheta; - poly[3] = poly[1] - linePtr->arrowShapeB*sinTheta - temp; + poly[3] = poly[1] - shapeB*sinTheta - temp; poly[9] = poly[3] + 2*temp; poly[4] = poly[2]*fracHeight + vertX*(1.0-fracHeight); poly[5] = poly[3]*fracHeight + vertY*(1.0-fracHeight); @@ -1526,7 +1448,7 @@ ConfigureArrows(canvasPtr, linePtr) * Results: * The return value is a standard Tcl result. If an error * occurs in generating Postscript then an error message is - * left in canvasPtr->interp->result, replacing whatever used + * left in interp->result, replacing whatever used * to be there. If no error occurs, then Postscript for the * item is appended to the result. * @@ -1537,15 +1459,17 @@ ConfigureArrows(canvasPtr, linePtr) */ static int -LineToPostscript(canvasPtr, itemPtr, psInfoPtr) - Tk_Canvas *canvasPtr; /* Information about overall canvas. */ +LineToPostscript(interp, canvas, itemPtr, prepass) + Tcl_Interp *interp; /* Leave Postscript or error message + * here. */ + Tk_Canvas canvas; /* Information about overall canvas. */ Tk_Item *itemPtr; /* Item for which Postscript is * wanted. */ - Tk_PostscriptInfo *psInfoPtr; /* Information about the Postscript; - * must be passed back to Postscript - * utility procedures. */ + int prepass; /* 1 means this is a prepass to + * collect font information; 0 means + * final Postscript is being created. */ { - register LineItem *linePtr = (LineItem *) itemPtr; + LineItem *linePtr = (LineItem *) itemPtr; char buffer[200]; char *style; @@ -1558,13 +1482,12 @@ LineToPostscript(canvasPtr, itemPtr, psInfoPtr) * for straight lines and smoothed lines). */ - if (!linePtr->smooth) { - TkCanvPsPath(canvasPtr->interp, linePtr->coordPtr, linePtr->numPoints, - psInfoPtr); + if ((!linePtr->smooth) || (linePtr->numPoints <= 2)) { + Tk_CanvasPsPath(interp, canvas, linePtr->coordPtr, linePtr->numPoints); } else { if (linePtr->fillStipple == None) { - TkMakeBezierPostscript(canvasPtr->interp, linePtr->coordPtr, - linePtr->numPoints, psInfoPtr); + TkMakeBezierPostscript(interp, canvas, linePtr->coordPtr, + linePtr->numPoints); } else { /* * Special hack: Postscript printers don't appear to be able @@ -1585,10 +1508,10 @@ LineToPostscript(canvasPtr, itemPtr, psInfoPtr) pointPtr = (double *) ckalloc((unsigned) (numPoints * 2 * sizeof(double))); } - numPoints = TkMakeBezierCurve(canvasPtr, linePtr->coordPtr, + numPoints = TkMakeBezierCurve(canvas, linePtr->coordPtr, linePtr->numPoints, linePtr->splineSteps, (XPoint *) NULL, pointPtr); - TkCanvPsPath(canvasPtr->interp, pointPtr, numPoints, psInfoPtr); + Tk_CanvasPsPath(interp, canvas, pointPtr, numPoints); if (pointPtr != staticPoints) { ckfree((char *) pointPtr); } @@ -1600,31 +1523,32 @@ LineToPostscript(canvasPtr, itemPtr, psInfoPtr) */ sprintf(buffer, "%d setlinewidth\n", linePtr->width); - Tcl_AppendResult(canvasPtr->interp, buffer, (char *) NULL); + Tcl_AppendResult(interp, buffer, (char *) NULL); style = "0 setlinecap\n"; if (linePtr->capStyle == CapRound) { style = "1 setlinecap\n"; } else if (linePtr->capStyle == CapProjecting) { style = "2 setlinecap\n"; } - Tcl_AppendResult(canvasPtr->interp, style, (char *) NULL); + Tcl_AppendResult(interp, style, (char *) NULL); style = "0 setlinejoin\n"; if (linePtr->joinStyle == JoinRound) { style = "1 setlinejoin\n"; } else if (linePtr->joinStyle == JoinBevel) { style = "2 setlinejoin\n"; } - Tcl_AppendResult(canvasPtr->interp, style, (char *) NULL); - if (TkCanvPsColor(canvasPtr, psInfoPtr, linePtr->fg) != TCL_OK) { + Tcl_AppendResult(interp, style, (char *) NULL); + if (Tk_CanvasPsColor(interp, canvas, linePtr->fg) != TCL_OK) { return TCL_ERROR; }; if (linePtr->fillStipple != None) { - if (TkCanvPsStipple(canvasPtr, psInfoPtr, linePtr->fillStipple, 0) + Tcl_AppendResult(interp, "StrokeClip ", (char *) NULL); + if (Tk_CanvasPsStipple(interp, canvas, linePtr->fillStipple) != TCL_OK) { return TCL_ERROR; } } else { - Tcl_AppendResult(canvasPtr->interp, "stroke\n", (char *) NULL); + Tcl_AppendResult(interp, "stroke\n", (char *) NULL); } /* @@ -1632,14 +1556,21 @@ LineToPostscript(canvasPtr, itemPtr, psInfoPtr) */ if (linePtr->firstArrowPtr != NULL) { - if (ArrowheadPostscript(canvasPtr, linePtr, linePtr->firstArrowPtr, - psInfoPtr) != TCL_OK) { + if (linePtr->fillStipple != None) { + Tcl_AppendResult(interp, "grestore gsave\n", + (char *) NULL); + } + if (ArrowheadPostscript(interp, canvas, linePtr, + linePtr->firstArrowPtr) != TCL_OK) { return TCL_ERROR; } } if (linePtr->lastArrowPtr != NULL) { - if (ArrowheadPostscript(canvasPtr, linePtr, linePtr->lastArrowPtr, - psInfoPtr) != TCL_OK) { + if (linePtr->fillStipple != None) { + Tcl_AppendResult(interp, "grestore gsave\n", (char *) NULL); + } + if (ArrowheadPostscript(interp, canvas, linePtr, + linePtr->lastArrowPtr) != TCL_OK) { return TCL_ERROR; } } @@ -1657,7 +1588,7 @@ LineToPostscript(canvasPtr, itemPtr, psInfoPtr) * Results: * The return value is a standard Tcl result. If an error * occurs in generating Postscript then an error message is - * left in canvasPtr->interp->result, replacing whatever used + * left in interp->result, replacing whatever used * to be there. If no error occurs, then Postscript for the * arrowhead is appended to the result. * @@ -1668,24 +1599,24 @@ LineToPostscript(canvasPtr, itemPtr, psInfoPtr) */ static int -ArrowheadPostscript(canvasPtr, linePtr, arrowPtr, psInfoPtr) - Tk_Canvas *canvasPtr; /* Information about overall canvas. */ +ArrowheadPostscript(interp, canvas, linePtr, arrowPtr) + Tcl_Interp *interp; /* Leave Postscript or error message + * here. */ + Tk_Canvas canvas; /* Information about overall canvas. */ LineItem *linePtr; /* Line item for which Postscript is * being generated. */ double *arrowPtr; /* Pointer to first of five points * describing arrowhead polygon. */ - Tk_PostscriptInfo *psInfoPtr; /* Information about the Postscript; - * must be passed back to Postscript - * utility procedures. */ { - TkCanvPsPath(canvasPtr->interp, arrowPtr, PTS_IN_ARROW, psInfoPtr); + Tk_CanvasPsPath(interp, canvas, arrowPtr, PTS_IN_ARROW); if (linePtr->fillStipple != None) { - if (TkCanvPsStipple(canvasPtr, psInfoPtr, linePtr->fillStipple, 1) + Tcl_AppendResult(interp, "clip ", (char *) NULL); + if (Tk_CanvasPsStipple(interp, canvas, linePtr->fillStipple) != TCL_OK) { return TCL_ERROR; } } else { - Tcl_AppendResult(canvasPtr->interp, "fill\n", (char *) NULL); + Tcl_AppendResult(interp, "fill\n", (char *) NULL); } return TCL_OK; } diff --git a/tk3.6/tkCanvPoly.c b/tk4.2/generic/tkCanvPoly.c similarity index 56% rename from tk3.6/tkCanvPoly.c rename to tk4.2/generic/tkCanvPoly.c index 3b8cf61..07799f8 100644 --- a/tk3.6/tkCanvPoly.c +++ b/tk4.2/generic/tkCanvPoly.c @@ -3,35 +3,18 @@ * * This file implements polygon items for canvas widgets. * - * Copyright (c) 1991-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tkCanvPoly.c 1.34 96/02/15 18:52:32 */ -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkCanvPoly.c,v 1.17 93/09/15 08:19:50 ouster Exp $ SPRITE (Berkeley)"; -#endif - #include #include "tkInt.h" -#include "tkCanvas.h" -#include "tkConfig.h" +#include "tkPort.h" /* * The structure below defines the record for each polygon item. @@ -48,9 +31,12 @@ typedef struct PolygonItem { * x- and y-coords of all points in polygon. * X-coords are even-valued indices, y-coords * are corresponding odd-valued indices. */ - XColor *fg; /* Foreground color for polygon. */ + int width; /* Width of outline. */ + XColor *outlineColor; /* Color for outline. */ + GC outlineGC; /* Graphics context for drawing outline. */ + XColor *fillColor; /* Foreground color for polygon. */ Pixmap fillStipple; /* Stipple bitmap for filling polygon. */ - GC gc; /* Graphics context for filling polygon. */ + GC fillGC; /* Graphics context for filling polygon. */ int smooth; /* Non-zero means draw shape smoothed (i.e. * with Bezier splines). */ int splineSteps; /* Number of steps in each spline segment. */ @@ -60,9 +46,15 @@ typedef struct PolygonItem { * Information used for parsing configuration specs: */ +static Tk_CustomOption tagsOption = {Tk_CanvasTagsParseProc, + Tk_CanvasTagsPrintProc, (ClientData) NULL +}; + static Tk_ConfigSpec configSpecs[] = { {TK_CONFIG_COLOR, "-fill", (char *) NULL, (char *) NULL, - "black", Tk_Offset(PolygonItem, fg), TK_CONFIG_NULL_OK}, + "black", Tk_Offset(PolygonItem, fillColor), TK_CONFIG_NULL_OK}, + {TK_CONFIG_COLOR, "-outline", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(PolygonItem, outlineColor), TK_CONFIG_NULL_OK}, {TK_CONFIG_BOOLEAN, "-smooth", (char *) NULL, (char *) NULL, "0", Tk_Offset(PolygonItem, smooth), TK_CONFIG_DONT_SET_DEFAULT}, {TK_CONFIG_INT, "-splinesteps", (char *) NULL, (char *) NULL, @@ -70,7 +62,9 @@ static Tk_ConfigSpec configSpecs[] = { {TK_CONFIG_BITMAP, "-stipple", (char *) NULL, (char *) NULL, (char *) NULL, Tk_Offset(PolygonItem, fillStipple), TK_CONFIG_NULL_OK}, {TK_CONFIG_CUSTOM, "-tags", (char *) NULL, (char *) NULL, - (char *) NULL, 0, TK_CONFIG_NULL_OK, &tkCanvasTagsOption}, + (char *) NULL, 0, TK_CONFIG_NULL_OK, &tagsOption}, + {TK_CONFIG_PIXELS, "-width", (char *) NULL, (char *) NULL, + "1", Tk_Offset(PolygonItem, width), TK_CONFIG_DONT_SET_DEFAULT}, {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, (char *) NULL, 0, 0} }; @@ -79,29 +73,32 @@ static Tk_ConfigSpec configSpecs[] = { * Prototypes for procedures defined in this file: */ -static void ComputePolygonBbox _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static void ComputePolygonBbox _ANSI_ARGS_((Tk_Canvas canvas, PolygonItem *polyPtr)); -static int ConfigurePolygon _ANSI_ARGS_(( - Tk_Canvas *canvasPtr, Tk_Item *itemPtr, int argc, +static int ConfigurePolygon _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int argc, char **argv, int flags)); -static int CreatePolygon _ANSI_ARGS_((Tk_Canvas *canvasPtr, - struct Tk_Item *itemPtr, int argc, char **argv)); -static void DeletePolygon _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr)); -static void DisplayPolygon _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, Drawable dst)); -static int PolygonCoords _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, int argc, char **argv)); -static int PolygonToArea _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static int CreatePolygon _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, struct Tk_Item *itemPtr, + int argc, char **argv)); +static void DeletePolygon _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, Display *display)); +static void DisplayPolygon _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, Display *display, Drawable dst, + int x, int y, int width, int height)); +static int PolygonCoords _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, + int argc, char **argv)); +static int PolygonToArea _ANSI_ARGS_((Tk_Canvas canvas, Tk_Item *itemPtr, double *rectPtr)); -static double PolygonToPoint _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static double PolygonToPoint _ANSI_ARGS_((Tk_Canvas canvas, Tk_Item *itemPtr, double *pointPtr)); -static int PolygonToPostscript _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, Tk_PostscriptInfo *psInfoPtr)); -static void ScalePolygon _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static int PolygonToPostscript _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int prepass)); +static void ScalePolygon _ANSI_ARGS_((Tk_Canvas canvas, Tk_Item *itemPtr, double originX, double originY, double scaleX, double scaleY)); -static void TranslatePolygon _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static void TranslatePolygon _ANSI_ARGS_((Tk_Canvas canvas, Tk_Item *itemPtr, double deltaX, double deltaY)); /* @@ -109,7 +106,7 @@ static void TranslatePolygon _ANSI_ARGS_((Tk_Canvas *canvasPtr, * of procedures that can be invoked by generic item code. */ -Tk_ItemType TkPolygonType = { +Tk_ItemType tkPolygonType = { "polygon", /* name */ sizeof(PolygonItem), /* itemSize */ CreatePolygon, /* createProc */ @@ -151,7 +148,7 @@ Tk_ItemType TkPolygonType = { * Results: * A standard Tcl return value. If an error occurred in * creating the item, then an error message is left in - * canvasPtr->interp->result; in this case itemPtr is + * interp->result; in this case itemPtr is * left uninitialized, so it can be safely freed by the * caller. * @@ -162,21 +159,22 @@ Tk_ItemType TkPolygonType = { */ static int -CreatePolygon(canvasPtr, itemPtr, argc, argv) - register Tk_Canvas *canvasPtr; /* Canvas to hold new item. */ +CreatePolygon(interp, canvas, itemPtr, argc, argv) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + Tk_Canvas canvas; /* Canvas to hold new item. */ Tk_Item *itemPtr; /* Record to hold new item; header * has been initialized by caller. */ int argc; /* Number of arguments in argv. */ char **argv; /* Arguments describing polygon. */ { - register PolygonItem *polyPtr = (PolygonItem *) itemPtr; + PolygonItem *polyPtr = (PolygonItem *) itemPtr; int i; if (argc < 6) { - Tcl_AppendResult(canvasPtr->interp, "wrong # args: should be \"", - Tk_PathName(canvasPtr->tkwin), "\" create ", + Tcl_AppendResult(interp, "wrong # args: should be \"", + Tk_PathName(Tk_CanvasTkwin(canvas)), " create ", itemPtr->typePtr->name, - " x1 y1 x2 y2 x3 y3 ?x4 y4 ...? ?options?", (char *) NULL); + " x1 y1 x2 y2 x3 y3 ?x4 y4 ...? ?options?\"", (char *) NULL); return TCL_ERROR; } @@ -188,9 +186,12 @@ CreatePolygon(canvasPtr, itemPtr, argc, argv) polyPtr->numPoints = 0; polyPtr->pointsAllocated = 0; polyPtr->coordPtr = NULL; - polyPtr->fg = None; + polyPtr->width = 1; + polyPtr->outlineColor = NULL; + polyPtr->outlineGC = None; + polyPtr->fillColor = NULL; polyPtr->fillStipple = None; - polyPtr->gc = None; + polyPtr->fillGC = None; polyPtr->smooth = 0; polyPtr->splineSteps = 12; @@ -206,16 +207,17 @@ CreatePolygon(canvasPtr, itemPtr, argc, argv) break; } } - if (PolygonCoords(canvasPtr, itemPtr, i, argv) != TCL_OK) { + if (PolygonCoords(interp, canvas, itemPtr, i, argv) != TCL_OK) { goto error; } - if (ConfigurePolygon(canvasPtr, itemPtr, argc-i, argv+i, 0) == TCL_OK) { + if (ConfigurePolygon(interp, canvas, itemPtr, argc-i, argv+i, 0) + == TCL_OK) { return TCL_OK; } error: - DeletePolygon(canvasPtr, itemPtr); + DeletePolygon(canvas, itemPtr, Tk_Display(Tk_CanvasTkwin(canvas))); return TCL_ERROR; } @@ -229,7 +231,7 @@ CreatePolygon(canvasPtr, itemPtr, argc, argv) * on what it does. * * Results: - * Returns TCL_OK or TCL_ERROR, and sets canvasPtr->interp->result. + * Returns TCL_OK or TCL_ERROR, and sets interp->result. * * Side effects: * The coordinates for the given item may be changed. @@ -238,8 +240,9 @@ CreatePolygon(canvasPtr, itemPtr, argc, argv) */ static int -PolygonCoords(canvasPtr, itemPtr, argc, argv) - register Tk_Canvas *canvasPtr; /* Canvas containing item. */ +PolygonCoords(interp, canvas, itemPtr, argc, argv) + Tcl_Interp *interp; /* Used for error reporting. */ + Tk_Canvas canvas; /* Canvas containing item. */ Tk_Item *itemPtr; /* Item whose coordinates are to be * read or modified. */ int argc; /* Number of coordinates supplied in @@ -247,22 +250,22 @@ PolygonCoords(canvasPtr, itemPtr, argc, argv) char **argv; /* Array of coordinates: x1, y1, * x2, y2, ... */ { - register PolygonItem *polyPtr = (PolygonItem *) itemPtr; + PolygonItem *polyPtr = (PolygonItem *) itemPtr; char buffer[TCL_DOUBLE_SPACE]; int i, numPoints; if (argc == 0) { for (i = 0; i < 2*polyPtr->numPoints; i++) { - Tcl_PrintDouble(canvasPtr->interp, polyPtr->coordPtr[i], buffer); - Tcl_AppendElement(canvasPtr->interp, buffer); + Tcl_PrintDouble(interp, polyPtr->coordPtr[i], buffer); + Tcl_AppendElement(interp, buffer); } } else if (argc < 6) { - Tcl_AppendResult(canvasPtr->interp, - "too few coordinates for polygon: must have at least 6", + Tcl_AppendResult(interp, + "too few coordinates for polygon: must have at least 6", (char *) NULL); return TCL_ERROR; } else if (argc & 1) { - Tcl_AppendResult(canvasPtr->interp, + Tcl_AppendResult(interp, "odd number of coordinates specified for polygon", (char *) NULL); return TCL_ERROR; @@ -280,14 +283,15 @@ PolygonCoords(canvasPtr, itemPtr, argc, argv) polyPtr->coordPtr = (double *) ckalloc((unsigned) (sizeof(double) * (argc+2))); - polyPtr->pointsAllocated = polyPtr->numPoints = numPoints; + polyPtr->pointsAllocated = numPoints+1; } for (i = argc-1; i >= 0; i--) { - if (TkGetCanvasCoord(canvasPtr, argv[i], &polyPtr->coordPtr[i]) - != TCL_OK) { + if (Tk_CanvasGetCoord(interp, canvas, argv[i], + &polyPtr->coordPtr[i]) != TCL_OK) { return TCL_ERROR; } } + polyPtr->numPoints = numPoints; /* * Close the polygon if it isn't already closed. @@ -299,7 +303,7 @@ PolygonCoords(canvasPtr, itemPtr, argc, argv) polyPtr->coordPtr[argc] = polyPtr->coordPtr[0]; polyPtr->coordPtr[argc+1] = polyPtr->coordPtr[1]; } - ComputePolygonBbox(canvasPtr, polyPtr); + ComputePolygonBbox(canvas, polyPtr); } return TCL_OK; } @@ -314,7 +318,7 @@ PolygonCoords(canvasPtr, itemPtr, argc, argv) * * Results: * A standard Tcl result code. If an error occurs, then - * an error message is left in canvasPtr->interp->result. + * an error message is left in interp->result. * * Side effects: * Configuration information, such as colors and stipple @@ -324,20 +328,23 @@ PolygonCoords(canvasPtr, itemPtr, argc, argv) */ static int -ConfigurePolygon(canvasPtr, itemPtr, argc, argv, flags) - Tk_Canvas *canvasPtr; /* Canvas containing itemPtr. */ +ConfigurePolygon(interp, canvas, itemPtr, argc, argv, flags) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + Tk_Canvas canvas; /* Canvas containing itemPtr. */ Tk_Item *itemPtr; /* Polygon item to reconfigure. */ int argc; /* Number of elements in argv. */ char **argv; /* Arguments describing things to configure. */ int flags; /* Flags to pass to Tk_ConfigureWidget. */ { - register PolygonItem *polyPtr = (PolygonItem *) itemPtr; + PolygonItem *polyPtr = (PolygonItem *) itemPtr; XGCValues gcValues; GC newGC; unsigned long mask; + Tk_Window tkwin; - if (Tk_ConfigureWidget(canvasPtr->interp, canvasPtr->tkwin, - configSpecs, argc, argv, (char *) polyPtr, flags) != TCL_OK) { + tkwin = Tk_CanvasTkwin(canvas); + if (Tk_ConfigureWidget(interp, tkwin, configSpecs, argc, argv, + (char *) polyPtr, flags) != TCL_OK) { return TCL_ERROR; } @@ -346,22 +353,40 @@ ConfigurePolygon(canvasPtr, itemPtr, argc, argv, flags) * graphics contexts. */ - if (polyPtr->fg == NULL) { + if (polyPtr->width < 1) { + polyPtr->width = 1; + } + if (polyPtr->outlineColor == NULL) { newGC = None; } else { - gcValues.foreground = polyPtr->fg->pixel; + gcValues.foreground = polyPtr->outlineColor->pixel; + gcValues.line_width = polyPtr->width; + gcValues.cap_style = CapRound; + gcValues.join_style = JoinRound; + mask = GCForeground|GCLineWidth|GCCapStyle|GCJoinStyle; + newGC = Tk_GetGC(tkwin, mask, &gcValues); + } + if (polyPtr->outlineGC != None) { + Tk_FreeGC(Tk_Display(tkwin), polyPtr->outlineGC); + } + polyPtr->outlineGC = newGC; + + if (polyPtr->fillColor == NULL) { + newGC = None; + } else { + gcValues.foreground = polyPtr->fillColor->pixel; mask = GCForeground; if (polyPtr->fillStipple != None) { gcValues.stipple = polyPtr->fillStipple; gcValues.fill_style = FillStippled; mask |= GCStipple|GCFillStyle; } - newGC = Tk_GetGC(canvasPtr->tkwin, mask, &gcValues); + newGC = Tk_GetGC(tkwin, mask, &gcValues); } - if (polyPtr->gc != None) { - Tk_FreeGC(canvasPtr->display, polyPtr->gc); + if (polyPtr->fillGC != None) { + Tk_FreeGC(Tk_Display(tkwin), polyPtr->fillGC); } - polyPtr->gc = newGC; + polyPtr->fillGC = newGC; /* * Keep spline parameters within reasonable limits. @@ -373,7 +398,7 @@ ConfigurePolygon(canvasPtr, itemPtr, argc, argv, flags) polyPtr->splineSteps = 100; } - ComputePolygonBbox(canvasPtr, polyPtr); + ComputePolygonBbox(canvas, polyPtr); return TCL_OK; } @@ -395,23 +420,31 @@ ConfigurePolygon(canvasPtr, itemPtr, argc, argv, flags) */ static void -DeletePolygon(canvasPtr, itemPtr) - Tk_Canvas *canvasPtr; /* Info about overall canvas widget. */ +DeletePolygon(canvas, itemPtr, display) + Tk_Canvas canvas; /* Info about overall canvas widget. */ Tk_Item *itemPtr; /* Item that is being deleted. */ + Display *display; /* Display containing window for + * canvas. */ { - register PolygonItem *polyPtr = (PolygonItem *) itemPtr; + PolygonItem *polyPtr = (PolygonItem *) itemPtr; if (polyPtr->coordPtr != NULL) { ckfree((char *) polyPtr->coordPtr); } - if (polyPtr->fg != NULL) { - Tk_FreeColor(polyPtr->fg); + if (polyPtr->fillColor != NULL) { + Tk_FreeColor(polyPtr->fillColor); } if (polyPtr->fillStipple != None) { - Tk_FreeBitmap(canvasPtr->display, polyPtr->fillStipple); + Tk_FreeBitmap(display, polyPtr->fillStipple); } - if (polyPtr->gc != None) { - Tk_FreeGC(canvasPtr->display, polyPtr->gc); + if (polyPtr->outlineColor != NULL) { + Tk_FreeColor(polyPtr->outlineColor); + } + if (polyPtr->outlineGC != None) { + Tk_FreeGC(display, polyPtr->outlineGC); + } + if (polyPtr->fillGC != None) { + Tk_FreeGC(display, polyPtr->fillGC); } } @@ -434,12 +467,12 @@ DeletePolygon(canvasPtr, itemPtr) */ static void -ComputePolygonBbox(canvasPtr, polyPtr) - register Tk_Canvas *canvasPtr; /* Canvas that contains item. */ +ComputePolygonBbox(canvas, polyPtr) + Tk_Canvas canvas; /* Canvas that contains item. */ PolygonItem *polyPtr; /* Item whose bbox is to be * recomputed. */ { - register double *coordPtr; + double *coordPtr; int i; coordPtr = polyPtr->coordPtr; @@ -448,18 +481,20 @@ ComputePolygonBbox(canvasPtr, polyPtr) for (i = 1, coordPtr = polyPtr->coordPtr+2; i < polyPtr->numPoints; i++, coordPtr += 2) { - TkIncludePoint(canvasPtr, (Tk_Item *) polyPtr, coordPtr); + TkIncludePoint((Tk_Item *) polyPtr, coordPtr); } /* - * Add one more pixel of fudge factor just to be safe (e.g. - * X may round differently than we do). + * Expand bounding box in all directions to account for the outline, + * which can stick out beyond the polygon. Add one extra pixel of + * fudge, just in case X rounds differently than we do. */ - polyPtr->header.x1 -= 1; - polyPtr->header.x2 += 1; - polyPtr->header.y1 -= 1; - polyPtr->header.y2 += 1; + i = (polyPtr->width+1)/2 + 1; + polyPtr->header.x1 -= i; + polyPtr->header.x2 += i; + polyPtr->header.y1 -= i; + polyPtr->header.y2 += i; } /* @@ -475,26 +510,30 @@ ComputePolygonBbox(canvasPtr, polyPtr) * * Side effects: * ItemPtr is drawn in drawable using the transformation - * information in canvasPtr. + * information in canvas. * *-------------------------------------------------------------- */ void -TkFillPolygon(canvasPtr, coordPtr, numPoints, drawable, gc) - register Tk_Canvas *canvasPtr; /* Canvas whose coordinate system +TkFillPolygon(canvas, coordPtr, numPoints, display, drawable, gc, outlineGC) + Tk_Canvas canvas; /* Canvas whose coordinate system * is to be used for drawing. */ double *coordPtr; /* Array of coordinates for polygon: * x1, y1, x2, y2, .... */ int numPoints; /* Twice this many coordinates are * present at *coordPtr. */ + Display *display; /* Display on which to draw polygon. */ Drawable drawable; /* Pixmap or window in which to draw * polygon. */ GC gc; /* Graphics context for drawing. */ + GC outlineGC; /* If not None, use this to draw an + * outline around the polygon after + * filling it. */ { XPoint staticPoints[MAX_STATIC_POINTS]; XPoint *pointPtr; - register XPoint *pPtr; + XPoint *pPtr; int i; /* @@ -510,8 +549,8 @@ TkFillPolygon(canvasPtr, coordPtr, numPoints, drawable, gc) } for (i = 0, pPtr = pointPtr; i < numPoints; i += 1, coordPtr += 2, pPtr++) { - pPtr->x = SCREEN_X(canvasPtr, coordPtr[0]); - pPtr->y = SCREEN_Y(canvasPtr, coordPtr[1]); + Tk_CanvasDrawableCoords(canvas, coordPtr[0], coordPtr[1], &pPtr->x, + &pPtr->y); } /* @@ -519,12 +558,17 @@ TkFillPolygon(canvasPtr, coordPtr, numPoints, drawable, gc) * allocated. */ - XFillPolygon(Tk_Display(canvasPtr->tkwin), drawable, gc, pointPtr, - numPoints, Complex, CoordModeOrigin); + if (gc != None) { + XFillPolygon(display, drawable, gc, pointPtr, numPoints, Complex, + CoordModeOrigin); + } + if (outlineGC != None) { + XDrawLines(display, drawable, outlineGC, pointPtr, + numPoints, CoordModeOrigin); + } if (pointPtr != staticPoints) { ckfree((char *) pointPtr); } - } /* @@ -540,21 +584,24 @@ TkFillPolygon(canvasPtr, coordPtr, numPoints, drawable, gc) * * Side effects: * ItemPtr is drawn in drawable using the transformation - * information in canvasPtr. + * information in canvas. * *-------------------------------------------------------------- */ static void -DisplayPolygon(canvasPtr, itemPtr, drawable) - register Tk_Canvas *canvasPtr; /* Canvas that contains item. */ +DisplayPolygon(canvas, itemPtr, display, drawable, x, y, width, height) + Tk_Canvas canvas; /* Canvas that contains item. */ Tk_Item *itemPtr; /* Item to be displayed. */ + Display *display; /* Display on which to draw item. */ Drawable drawable; /* Pixmap or window in which to draw * item. */ + int x, y, width, height; /* Describes region of canvas that + * must be redisplayed (not used). */ { - register PolygonItem *polyPtr = (PolygonItem *) itemPtr; + PolygonItem *polyPtr = (PolygonItem *) itemPtr; - if (polyPtr->gc == None) { + if ((polyPtr->fillGC == None) && (polyPtr->outlineGC == None)) { return; } @@ -564,14 +611,13 @@ DisplayPolygon(canvasPtr, itemPtr, drawable) * read-only. */ - if (polyPtr->fillStipple != None) { - XSetTSOrigin(Tk_Display(canvasPtr->tkwin), polyPtr->gc, - -canvasPtr->drawableXOrigin, -canvasPtr->drawableYOrigin); + if ((polyPtr->fillStipple != None) && (polyPtr->fillGC != None)) { + Tk_CanvasSetStippleOrigin(canvas, polyPtr->fillGC); } if (!polyPtr->smooth) { - TkFillPolygon(canvasPtr, polyPtr->coordPtr, polyPtr->numPoints, - drawable, polyPtr->gc); + TkFillPolygon(canvas, polyPtr->coordPtr, polyPtr->numPoints, + display, drawable, polyPtr->fillGC, polyPtr->outlineGC); } else { int numPoints; XPoint staticPoints[MAX_STATIC_POINTS]; @@ -589,17 +635,23 @@ DisplayPolygon(canvasPtr, itemPtr, drawable) pointPtr = (XPoint *) ckalloc((unsigned) (numPoints * sizeof(XPoint))); } - numPoints = TkMakeBezierCurve(canvasPtr, polyPtr->coordPtr, + numPoints = TkMakeBezierCurve(canvas, polyPtr->coordPtr, polyPtr->numPoints, polyPtr->splineSteps, pointPtr, (double *) NULL); - XFillPolygon(Tk_Display(canvasPtr->tkwin), drawable, polyPtr->gc, - pointPtr, numPoints, Complex, CoordModeOrigin); + if (polyPtr->fillGC != None) { + XFillPolygon(display, drawable, polyPtr->fillGC, pointPtr, + numPoints, Complex, CoordModeOrigin); + } + if (polyPtr->outlineGC != None) { + XDrawLines(display, drawable, polyPtr->outlineGC, pointPtr, + numPoints, CoordModeOrigin); + } if (pointPtr != staticPoints) { ckfree((char *) pointPtr); } } - if (polyPtr->fillStipple != None) { - XSetTSOrigin(Tk_Display(canvasPtr->tkwin), polyPtr->gc, 0, 0); + if ((polyPtr->fillStipple != None) && (polyPtr->fillGC != None)) { + XSetTSOrigin(display, polyPtr->fillGC, 0, 0); } } @@ -625,8 +677,8 @@ DisplayPolygon(canvasPtr, itemPtr, drawable) /* ARGSUSED */ static double -PolygonToPoint(canvasPtr, itemPtr, pointPtr) - Tk_Canvas *canvasPtr; /* Canvas containing item. */ +PolygonToPoint(canvas, itemPtr, pointPtr) + Tk_Canvas canvas; /* Canvas containing item. */ Tk_Item *itemPtr; /* Item to check against point. */ double *pointPtr; /* Pointer to x and y coordinates. */ { @@ -636,28 +688,34 @@ PolygonToPoint(canvasPtr, itemPtr, pointPtr) int numPoints; if (!polyPtr->smooth) { - return TkPolygonToPoint(polyPtr->coordPtr, polyPtr->numPoints, + distance = TkPolygonToPoint(polyPtr->coordPtr, polyPtr->numPoints, pointPtr); - } - - /* - * Smoothed polygon. Generate a new set of points and use them - * for comparison. - */ - - numPoints = 1 + polyPtr->numPoints*polyPtr->splineSteps; - if (numPoints <= MAX_STATIC_POINTS) { - coordPtr = staticSpace; } else { - coordPtr = (double *) ckalloc((unsigned) - (2*numPoints*sizeof(double))); + /* + * Smoothed polygon. Generate a new set of points and use them + * for comparison. + */ + + numPoints = 1 + polyPtr->numPoints*polyPtr->splineSteps; + if (numPoints <= MAX_STATIC_POINTS) { + coordPtr = staticSpace; + } else { + coordPtr = (double *) ckalloc((unsigned) + (2*numPoints*sizeof(double))); + } + numPoints = TkMakeBezierCurve(canvas, polyPtr->coordPtr, + polyPtr->numPoints, polyPtr->splineSteps, (XPoint *) NULL, + coordPtr); + distance = TkPolygonToPoint(coordPtr, numPoints, pointPtr); + if (coordPtr != staticSpace) { + ckfree((char *) coordPtr); + } } - numPoints = TkMakeBezierCurve(canvasPtr, polyPtr->coordPtr, - polyPtr->numPoints, polyPtr->splineSteps, (XPoint *) NULL, - coordPtr); - distance = TkPolygonToPoint(coordPtr, numPoints, pointPtr); - if (coordPtr != staticSpace) { - ckfree((char *) coordPtr); + if (polyPtr->outlineColor != NULL) { + distance -= polyPtr->width/2.0; + if (distance < 0) { + distance = 0; + } } return distance; } @@ -684,39 +742,80 @@ PolygonToPoint(canvasPtr, itemPtr, pointPtr) /* ARGSUSED */ static int -PolygonToArea(canvasPtr, itemPtr, rectPtr) - Tk_Canvas *canvasPtr; /* Canvas containing item. */ +PolygonToArea(canvas, itemPtr, rectPtr) + Tk_Canvas canvas; /* Canvas containing item. */ Tk_Item *itemPtr; /* Item to check against polygon. */ double *rectPtr; /* Pointer to array of four coordinates * (x1, y1, x2, y2) describing rectangular * area. */ { PolygonItem *polyPtr = (PolygonItem *) itemPtr; - double *coordPtr; + double *coordPtr, rect2[4], halfWidth; double staticSpace[2*MAX_STATIC_POINTS]; int numPoints, result; - if (!polyPtr->smooth) { - return TkPolygonToArea(polyPtr->coordPtr, polyPtr->numPoints, rectPtr); - } - /* - * Smoothed polygon. Generate a new set of points and use them - * for comparison. + * Handle smoothed polygons by generating an expanded set of points + * against which to do the check. */ - numPoints = 1 + polyPtr->numPoints*polyPtr->splineSteps; - if (numPoints <= MAX_STATIC_POINTS) { - coordPtr = staticSpace; + if (polyPtr->smooth) { + numPoints = 1 + polyPtr->numPoints*polyPtr->splineSteps; + if (numPoints <= MAX_STATIC_POINTS) { + coordPtr = staticSpace; + } else { + coordPtr = (double *) ckalloc((unsigned) + (2*numPoints*sizeof(double))); + } + numPoints = TkMakeBezierCurve(canvas, polyPtr->coordPtr, + polyPtr->numPoints, polyPtr->splineSteps, (XPoint *) NULL, + coordPtr); } else { - coordPtr = (double *) ckalloc((unsigned) - (2*numPoints*sizeof(double))); + numPoints = polyPtr->numPoints; + coordPtr = polyPtr->coordPtr; } - numPoints = TkMakeBezierCurve(canvasPtr, polyPtr->coordPtr, - polyPtr->numPoints, polyPtr->splineSteps, (XPoint *) NULL, - coordPtr); - result = TkPolygonToArea(coordPtr, numPoints, rectPtr); - if (coordPtr != staticSpace) { + + if (polyPtr->width <= 1) { + /* + * The outline of the polygon doesn't stick out, so we can + * do a simple check. + */ + + result = TkPolygonToArea(coordPtr, numPoints, rectPtr); + } else { + /* + * The polygon has a wide outline, so the check is more complicated. + * First, check the line segments to see if they overlap the area. + */ + + result = TkThickPolyLineToArea(coordPtr, numPoints, + (double) polyPtr->width, CapRound, JoinRound, rectPtr); + if (result >= 0) { + goto done; + } + + /* + * There is no overlap between the polygon's outline and the + * rectangle. This means either the rectangle is entirely outside + * the polygon or entirely inside. To tell the difference, + * see whether the polygon (with 0 outline width) overlaps the + * rectangle bloated by half the outline width. + */ + + halfWidth = polyPtr->width/2.0; + rect2[0] = rectPtr[0] - halfWidth; + rect2[1] = rectPtr[1] - halfWidth; + rect2[2] = rectPtr[2] + halfWidth; + rect2[3] = rectPtr[3] + halfWidth; + if (TkPolygonToArea(coordPtr, numPoints, rect2) == -1) { + result = -1; + } else { + result = 0; + } + } + + done: + if ((coordPtr != staticSpace) && (coordPtr != polyPtr->coordPtr)) { ckfree((char *) coordPtr); } return result; @@ -743,15 +842,15 @@ PolygonToArea(canvasPtr, itemPtr, rectPtr) */ static void -ScalePolygon(canvasPtr, itemPtr, originX, originY, scaleX, scaleY) - Tk_Canvas *canvasPtr; /* Canvas containing polygon. */ +ScalePolygon(canvas, itemPtr, originX, originY, scaleX, scaleY) + Tk_Canvas canvas; /* Canvas containing polygon. */ Tk_Item *itemPtr; /* Polygon to be scaled. */ double originX, originY; /* Origin about which to scale rect. */ double scaleX; /* Amount to scale in X direction. */ double scaleY; /* Amount to scale in Y direction. */ { PolygonItem *polyPtr = (PolygonItem *) itemPtr; - register double *coordPtr; + double *coordPtr; int i; for (i = 0, coordPtr = polyPtr->coordPtr; i < polyPtr->numPoints; @@ -759,7 +858,7 @@ ScalePolygon(canvasPtr, itemPtr, originX, originY, scaleX, scaleY) *coordPtr = originX + scaleX*(*coordPtr - originX); coordPtr[1] = originY + scaleY*(coordPtr[1] - originY); } - ComputePolygonBbox(canvasPtr, polyPtr); + ComputePolygonBbox(canvas, polyPtr); } /* @@ -782,14 +881,14 @@ ScalePolygon(canvasPtr, itemPtr, originX, originY, scaleX, scaleY) */ static void -TranslatePolygon(canvasPtr, itemPtr, deltaX, deltaY) - Tk_Canvas *canvasPtr; /* Canvas containing item. */ +TranslatePolygon(canvas, itemPtr, deltaX, deltaY) + Tk_Canvas canvas; /* Canvas containing item. */ Tk_Item *itemPtr; /* Item that is being moved. */ double deltaX, deltaY; /* Amount by which item is to be * moved. */ { PolygonItem *polyPtr = (PolygonItem *) itemPtr; - register double *coordPtr; + double *coordPtr; int i; for (i = 0, coordPtr = polyPtr->coordPtr; i < polyPtr->numPoints; @@ -797,7 +896,7 @@ TranslatePolygon(canvasPtr, itemPtr, deltaX, deltaY) *coordPtr += deltaX; coordPtr[1] += deltaY; } - ComputePolygonBbox(canvasPtr, polyPtr); + ComputePolygonBbox(canvas, polyPtr); } /* @@ -811,7 +910,7 @@ TranslatePolygon(canvasPtr, itemPtr, deltaX, deltaY) * Results: * The return value is a standard Tcl result. If an error * occurs in generating Postscript then an error message is - * left in canvasPtr->interp->result, replacing whatever used + * left in interp->result, replacing whatever used * to be there. If no error occurs, then Postscript for the * item is appended to the result. * @@ -822,47 +921,69 @@ TranslatePolygon(canvasPtr, itemPtr, deltaX, deltaY) */ static int -PolygonToPostscript(canvasPtr, itemPtr, psInfoPtr) - Tk_Canvas *canvasPtr; /* Information about overall canvas. */ +PolygonToPostscript(interp, canvas, itemPtr, prepass) + Tcl_Interp *interp; /* Leave Postscript or error message + * here. */ + Tk_Canvas canvas; /* Information about overall canvas. */ Tk_Item *itemPtr; /* Item for which Postscript is * wanted. */ - Tk_PostscriptInfo *psInfoPtr; /* Information about the Postscript; - * must be passed back to Postscript - * utility procedures. */ + int prepass; /* 1 means this is a prepass to + * collect font information; 0 means + * final Postscript is being created. */ { - register PolygonItem *polyPtr = (PolygonItem *) itemPtr; - - if (polyPtr->fg == NULL) { - return TCL_OK; - } - - /* - * Generate a path for the polygon's outline (do this differently - * for smoothed and linear polygons). - */ - - if (!polyPtr->smooth) { - TkCanvPsPath(canvasPtr->interp, polyPtr->coordPtr, - polyPtr->numPoints, psInfoPtr); - } else { - TkMakeBezierPostscript(canvasPtr->interp, polyPtr->coordPtr, - polyPtr->numPoints, psInfoPtr); - } + char string[100]; + PolygonItem *polyPtr = (PolygonItem *) itemPtr; /* * Fill the area of the polygon. */ - if (TkCanvPsColor(canvasPtr, psInfoPtr, polyPtr->fg) != TCL_OK) { - return TCL_ERROR; - }; - if (polyPtr->fillStipple != None) { - if (TkCanvPsStipple(canvasPtr, psInfoPtr, polyPtr->fillStipple, 1) + if (polyPtr->fillColor != NULL) { + if (!polyPtr->smooth) { + Tk_CanvasPsPath(interp, canvas, polyPtr->coordPtr, + polyPtr->numPoints); + } else { + TkMakeBezierPostscript(interp, canvas, polyPtr->coordPtr, + polyPtr->numPoints); + } + if (Tk_CanvasPsColor(interp, canvas, polyPtr->fillColor) != TCL_OK) { + return TCL_ERROR; + } + if (polyPtr->fillStipple != None) { + Tcl_AppendResult(interp, "eoclip ", (char *) NULL); + if (Tk_CanvasPsStipple(interp, canvas, polyPtr->fillStipple) + != TCL_OK) { + return TCL_ERROR; + } + if (polyPtr->outlineColor != NULL) { + Tcl_AppendResult(interp, "grestore gsave\n", (char *) NULL); + } + } else { + Tcl_AppendResult(interp, "eofill\n", (char *) NULL); + } + } + + /* + * Now draw the outline, if there is one. + */ + + if (polyPtr->outlineColor != NULL) { + if (!polyPtr->smooth) { + Tk_CanvasPsPath(interp, canvas, polyPtr->coordPtr, + polyPtr->numPoints); + } else { + TkMakeBezierPostscript(interp, canvas, polyPtr->coordPtr, + polyPtr->numPoints); + } + + sprintf(string, "%d setlinewidth\n", polyPtr->width); + Tcl_AppendResult(interp, string, + "1 setlinecap\n1 setlinejoin\n", (char *) NULL); + if (Tk_CanvasPsColor(interp, canvas, polyPtr->outlineColor) != TCL_OK) { return TCL_ERROR; } - } else { - Tcl_AppendResult(canvasPtr->interp, "eofill\n", (char *) NULL); + Tcl_AppendResult(interp, "stroke\n", (char *) NULL); } return TCL_OK; } diff --git a/tk3.6/tkCanvPs.c b/tk4.2/generic/tkCanvPs.c similarity index 68% rename from tk3.6/tkCanvPs.c rename to tk4.2/generic/tkCanvPs.c index 04f948f..e8b5ca4 100644 --- a/tk3.6/tkCanvPs.c +++ b/tk4.2/generic/tkCanvPs.c @@ -5,35 +5,18 @@ * including the "postscript" widget command plus a few utility * procedures used for generating Postscript. * - * Copyright (c) 1991-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tkCanvPs.c 1.50 96/10/02 15:42:41 */ -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkCanvPs.c,v 1.18 93/08/18 16:26:03 ouster Exp $ SPRITE (Berkeley)"; -#endif - -#include #include "tkInt.h" #include "tkCanvas.h" -#include "tkConfig.h" +#include "tkPort.h" /* * See tkCanvas.h for key data structures used to implement canvases. @@ -45,7 +28,7 @@ static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkCanvPs.c,v 1.18 93/08/1 * the widget command line. */ -typedef struct PostscriptInfo { +typedef struct TkPostscriptInfo { int x, y, width, height; /* Area to print, in canvas pixel * coordinates. */ int x2, y2; /* x+width and y+height. */ @@ -75,7 +58,7 @@ typedef struct PostscriptInfo { char *fileName; /* Name of file in which to write Postscript; * NULL means return Postscript info as * result. Malloc'ed. */ - FILE *f; /* Open file corresponding to fileName. */ + Tcl_Channel chan; /* Open channel corresponding to fileName. */ Tcl_HashTable fontTable; /* Hash table containing names of all font * families used in output. The hash table * values are not used. */ @@ -83,43 +66,43 @@ typedef struct PostscriptInfo { * the pre-pass that collects font information, * so the Postscript generated isn't * relevant. */ -} PostscriptInfo; +} TkPostscriptInfo; /* * The table below provides a template that's used to process arguments - * to the canvas "postscript" command and fill in PostscriptInfo + * to the canvas "postscript" command and fill in TkPostscriptInfo * structures. */ static Tk_ConfigSpec configSpecs[] = { {TK_CONFIG_STRING, "-colormap", (char *) NULL, (char *) NULL, - "", Tk_Offset(PostscriptInfo, colorVar), 0}, + "", Tk_Offset(TkPostscriptInfo, colorVar), 0}, {TK_CONFIG_STRING, "-colormode", (char *) NULL, (char *) NULL, - "", Tk_Offset(PostscriptInfo, colorMode), 0}, + "", Tk_Offset(TkPostscriptInfo, colorMode), 0}, {TK_CONFIG_STRING, "-file", (char *) NULL, (char *) NULL, - "", Tk_Offset(PostscriptInfo, fileName), 0}, + "", Tk_Offset(TkPostscriptInfo, fileName), 0}, {TK_CONFIG_STRING, "-fontmap", (char *) NULL, (char *) NULL, - "", Tk_Offset(PostscriptInfo, fontVar), 0}, + "", Tk_Offset(TkPostscriptInfo, fontVar), 0}, {TK_CONFIG_PIXELS, "-height", (char *) NULL, (char *) NULL, - "", Tk_Offset(PostscriptInfo, height), 0}, + "", Tk_Offset(TkPostscriptInfo, height), 0}, {TK_CONFIG_ANCHOR, "-pageanchor", (char *) NULL, (char *) NULL, - "", Tk_Offset(PostscriptInfo, pageAnchor), 0}, + "", Tk_Offset(TkPostscriptInfo, pageAnchor), 0}, {TK_CONFIG_STRING, "-pageheight", (char *) NULL, (char *) NULL, - "", Tk_Offset(PostscriptInfo, pageHeightString), 0}, + "", Tk_Offset(TkPostscriptInfo, pageHeightString), 0}, {TK_CONFIG_STRING, "-pagewidth", (char *) NULL, (char *) NULL, - "", Tk_Offset(PostscriptInfo, pageWidthString), 0}, + "", Tk_Offset(TkPostscriptInfo, pageWidthString), 0}, {TK_CONFIG_STRING, "-pagex", (char *) NULL, (char *) NULL, - "", Tk_Offset(PostscriptInfo, pageXString), 0}, + "", Tk_Offset(TkPostscriptInfo, pageXString), 0}, {TK_CONFIG_STRING, "-pagey", (char *) NULL, (char *) NULL, - "", Tk_Offset(PostscriptInfo, pageYString), 0}, + "", Tk_Offset(TkPostscriptInfo, pageYString), 0}, {TK_CONFIG_BOOLEAN, "-rotate", (char *) NULL, (char *) NULL, - "", Tk_Offset(PostscriptInfo, rotate), 0}, + "", Tk_Offset(TkPostscriptInfo, rotate), 0}, {TK_CONFIG_PIXELS, "-width", (char *) NULL, (char *) NULL, - "", Tk_Offset(PostscriptInfo, width), 0}, + "", Tk_Offset(TkPostscriptInfo, width), 0}, {TK_CONFIG_PIXELS, "-x", (char *) NULL, (char *) NULL, - "", Tk_Offset(PostscriptInfo, x), 0}, + "", Tk_Offset(TkPostscriptInfo, x), 0}, {TK_CONFIG_PIXELS, "-y", (char *) NULL, (char *) NULL, - "", Tk_Offset(PostscriptInfo, y), 0}, + "", Tk_Offset(TkPostscriptInfo, y), 0}, {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, (char *) NULL, 0, 0} }; @@ -128,7 +111,6 @@ static Tk_ConfigSpec configSpecs[] = { * Forward declarations for procedures defined later in this file: */ -static int CaseCmp _ANSI_ARGS_((char *s1, char *s2, int length)); static int GetPostscriptPoints _ANSI_ARGS_((Tcl_Interp *interp, char *string, double *doublePtr)); @@ -153,7 +135,7 @@ static int GetPostscriptPoints _ANSI_ARGS_((Tcl_Interp *interp, /* ARGSUSED */ int TkCanvPostscriptCmd(canvasPtr, interp, argc, argv) - register Tk_Canvas *canvasPtr; /* Information about canvas widget. */ + TkCanvas *canvasPtr; /* Information about canvas widget. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. Caller has @@ -161,15 +143,16 @@ TkCanvPostscriptCmd(canvasPtr, interp, argc, argv) * to know that argv[1] is * "postscript". */ { - PostscriptInfo psInfo; + TkPostscriptInfo psInfo, *oldInfoPtr; int result = TCL_ERROR; - register Tk_Item *itemPtr; + Tk_Item *itemPtr; #define STRING_LENGTH 400 char string[STRING_LENGTH+1], *p; time_t now; +#if !(defined(__WIN32__) || defined(MAC_TCL)) struct passwd *pwPtr; - FILE *f; - int length; +#endif /* __WIN32__ || MAC_TCL */ + size_t length; int deltaX = 0, deltaY = 0; /* Offset of lower-left corner of * area to be marked up, measured * in canvas units from the positioning @@ -180,7 +163,6 @@ TkCanvPostscriptCmd(canvasPtr, interp, argc, argv) Tcl_HashSearch search; Tcl_HashEntry *hPtr; Tcl_DString buffer; - char *libDir; /* *---------------------------------------------------------------- @@ -189,6 +171,8 @@ TkCanvPostscriptCmd(canvasPtr, interp, argc, argv) *---------------------------------------------------------------- */ + oldInfoPtr = canvasPtr->psInfoPtr; + canvasPtr->psInfoPtr = &psInfo; psInfo.x = canvasPtr->xOrigin; psInfo.y = canvasPtr->yOrigin; psInfo.width = -1; @@ -207,7 +191,7 @@ TkCanvPostscriptCmd(canvasPtr, interp, argc, argv) psInfo.colorMode = NULL; psInfo.colorLevel = 0; psInfo.fileName = NULL; - psInfo.f = NULL; + psInfo.chan = NULL; psInfo.prepass = 0; Tcl_InitHashTable(&psInfo.fontTable, TCL_STRING_KEYS); result = Tk_ConfigureWidget(canvasPtr->interp, canvasPtr->tkwin, @@ -308,16 +292,13 @@ TkCanvPostscriptCmd(canvasPtr, interp, argc, argv) } if (psInfo.fileName != NULL) { - p = Tcl_TildeSubst(canvasPtr->interp, psInfo.fileName, &buffer); + p = Tcl_TranslateFileName(canvasPtr->interp, psInfo.fileName, &buffer); if (p == NULL) { goto cleanup; } - psInfo.f = fopen(p, "w"); + psInfo.chan = Tcl_OpenFileChannel(canvasPtr->interp, p, "w", 0); Tcl_DStringFree(&buffer); - if (psInfo.f == NULL) { - Tcl_AppendResult(canvasPtr->interp, "couldn't write file \"", - psInfo.fileName, "\": ", - Tcl_PosixError(canvasPtr->interp), (char *) NULL); + if (psInfo.chan == NULL) { goto cleanup; } } @@ -342,8 +323,8 @@ TkCanvPostscriptCmd(canvasPtr, interp, argc, argv) if (itemPtr->typePtr->postscriptProc == NULL) { continue; } - result = (*itemPtr->typePtr->postscriptProc)(canvasPtr, itemPtr, - (Tk_PostscriptInfo *) &psInfo); + result = (*itemPtr->typePtr->postscriptProc)(canvasPtr->interp, + (Tk_Canvas) canvasPtr, itemPtr, 1); Tcl_ResetResult(canvasPtr->interp); if (result != TCL_OK) { /* @@ -366,11 +347,13 @@ TkCanvPostscriptCmd(canvasPtr, interp, argc, argv) Tcl_AppendResult(canvasPtr->interp, "%!PS-Adobe-3.0 EPSF-3.0\n", "%%Creator: Tk Canvas Widget\n", (char *) NULL); +#if !(defined(__WIN32__) || defined(MAC_TCL)) pwPtr = getpwuid(getuid()); Tcl_AppendResult(canvasPtr->interp, "%%For: ", (pwPtr != NULL) ? pwPtr->pw_gecos : "Unknown", "\n", (char *) NULL); endpwent(); +#endif /* __WIN32__ || MAC_TCL */ Tcl_AppendResult(canvasPtr->interp, "%%Title: Window ", Tk_PathName(canvasPtr->tkwin), "\n", (char *) NULL); time(&now); @@ -409,40 +392,15 @@ TkCanvPostscriptCmd(canvasPtr, interp, argc, argv) Tcl_AppendResult(canvasPtr->interp, "%%EndComments\n\n", (char *) NULL); /* - * Read a standard prolog file from disk and insert it into + * Read a standard prolog file in a native way and insert it into * the Postscript. */ - libDir = Tcl_GetVar(canvasPtr->interp, "tk_library", TCL_GLOBAL_ONLY); - if (libDir == NULL) { - Tcl_ResetResult(canvasPtr->interp); - Tcl_AppendResult(canvasPtr->interp, "couldn't find library directory: ", - "tk_library variable doesn't exist", (char *) NULL); + if (TkGetNativeProlog(canvasPtr->interp) != TCL_OK) { goto cleanup; } - sprintf(string, "%.350s/prolog.ps", libDir); - f = fopen(string, "r"); - if (f == NULL) { - Tcl_ResetResult(canvasPtr->interp); - Tcl_AppendResult(canvasPtr->interp, "couldn't open prolog file \"", - string, "\": ", Tcl_PosixError(canvasPtr->interp), - (char *) NULL); - goto cleanup; - } - while (fgets(string, STRING_LENGTH, f) != NULL) { - Tcl_AppendResult(canvasPtr->interp, string, (char *) NULL); - } - if (ferror(f)) { - fclose(f); - Tcl_ResetResult(canvasPtr->interp); - Tcl_AppendResult(canvasPtr->interp, "error reading prolog file \"", - string, "\": ", - Tcl_PosixError(canvasPtr->interp), (char *) NULL); - goto cleanup; - } - fclose(f); - if (psInfo.f != NULL) { - fputs(canvasPtr->interp->result, psInfo.f); + if (psInfo.chan != NULL) { + Tcl_Write(psInfo.chan, canvasPtr->interp->result, -1); Tcl_ResetResult(canvasPtr->interp); } @@ -482,18 +440,14 @@ TkCanvPostscriptCmd(canvasPtr, interp, argc, argv) sprintf(string, "%d %d translate\n", deltaX - psInfo.x, deltaY); Tcl_AppendResult(canvasPtr->interp, string, (char *) NULL); sprintf(string, "%d %.15g moveto %d %.15g lineto %d %.15g lineto %d %.15g", - psInfo.x, - TkCanvPsY((Tk_PostscriptInfo *) &psInfo, (double) psInfo.y), - psInfo.x2, - TkCanvPsY((Tk_PostscriptInfo *) &psInfo, (double) psInfo.y), - psInfo.x2, - TkCanvPsY((Tk_PostscriptInfo *) &psInfo, (double) psInfo.y2), - psInfo.x, - TkCanvPsY((Tk_PostscriptInfo *) &psInfo, (double) psInfo.y2)); + psInfo.x, Tk_CanvasPsY((Tk_Canvas) canvasPtr, (double) psInfo.y), + psInfo.x2, Tk_CanvasPsY((Tk_Canvas) canvasPtr, (double) psInfo.y), + psInfo.x2, Tk_CanvasPsY((Tk_Canvas) canvasPtr, (double) psInfo.y2), + psInfo.x, Tk_CanvasPsY((Tk_Canvas) canvasPtr, (double) psInfo.y2)); Tcl_AppendResult(canvasPtr->interp, string, " lineto closepath clip newpath\n", (char *) NULL); - if (psInfo.f != NULL) { - fputs(canvasPtr->interp->result, psInfo.f); + if (psInfo.chan != NULL) { + Tcl_Write(psInfo.chan, canvasPtr->interp->result, -1); Tcl_ResetResult(canvasPtr->interp); } @@ -515,8 +469,8 @@ TkCanvPostscriptCmd(canvasPtr, interp, argc, argv) continue; } Tcl_AppendResult(canvasPtr->interp, "gsave\n", (char *) NULL); - result = (*itemPtr->typePtr->postscriptProc)(canvasPtr, itemPtr, - (Tk_PostscriptInfo *) &psInfo); + result = (*itemPtr->typePtr->postscriptProc)(canvasPtr->interp, + (Tk_Canvas) canvasPtr, itemPtr, 0); if (result != TCL_OK) { char msg[100]; @@ -526,8 +480,8 @@ TkCanvPostscriptCmd(canvasPtr, interp, argc, argv) goto cleanup; } Tcl_AppendResult(canvasPtr->interp, "grestore\n", (char *) NULL); - if (psInfo.f != NULL) { - fputs(canvasPtr->interp->result, psInfo.f); + if (psInfo.chan != NULL) { + Tcl_Write(psInfo.chan, canvasPtr->interp->result, -1); Tcl_ResetResult(canvasPtr->interp); } } @@ -541,8 +495,8 @@ TkCanvPostscriptCmd(canvasPtr, interp, argc, argv) Tcl_AppendResult(canvasPtr->interp, "restore showpage\n\n", "%%Trailer\nend\n%%EOF\n", (char *) NULL); - if (psInfo.f != NULL) { - fputs(canvasPtr->interp->result, psInfo.f); + if (psInfo.chan != NULL) { + Tcl_Write(psInfo.chan, canvasPtr->interp->result, -1); Tcl_ResetResult(canvasPtr->interp); } @@ -575,17 +529,18 @@ TkCanvPostscriptCmd(canvasPtr, interp, argc, argv) if (psInfo.fileName != NULL) { ckfree(psInfo.fileName); } - if (psInfo.f != NULL) { - fclose(psInfo.f); + if (psInfo.chan != NULL) { + Tcl_Close(canvasPtr->interp, psInfo.chan); } Tcl_DeleteHashTable(&psInfo.fontTable); + canvasPtr->psInfoPtr = oldInfoPtr; return result; } /* *-------------------------------------------------------------- * - * TkCanvPsColor -- + * Tk_CanvasPsColor -- * * This procedure is called by individual canvas items when * they want to set a color value for output. Given information @@ -594,9 +549,9 @@ TkCanvPostscriptCmd(canvasPtr, interp, argc, argv) * * Results: * Returns a standard Tcl return value. If an error occurs - * then an error message will be left in canvasPtr->interp->result. + * then an error message will be left in interp->result. * If no error occurs, then additional Postscript will be - * appended to canvasPtr->interp->result. + * appended to interp->result. * * Side effects: * None. @@ -605,13 +560,15 @@ TkCanvPostscriptCmd(canvasPtr, interp, argc, argv) */ int -TkCanvPsColor(canvasPtr, handle, colorPtr) - Tk_Canvas *canvasPtr; /* Information about canvas. */ - Tk_PostscriptInfo *handle; /* Information about Postscript being - * generated. */ +Tk_CanvasPsColor(interp, canvas, colorPtr) + Tcl_Interp *interp; /* Interpreter for returning Postscript + * or error message. */ + Tk_Canvas canvas; /* Information about canvas. */ XColor *colorPtr; /* Information about color. */ { - PostscriptInfo *psInfoPtr = (PostscriptInfo *) handle; + TkCanvas *canvasPtr = (TkCanvas *) canvas; + TkPostscriptInfo *psInfoPtr = canvasPtr->psInfoPtr; + int tmp; double red, green, blue; char string[200]; @@ -628,33 +585,43 @@ TkCanvPsColor(canvasPtr, handle, colorPtr) if (psInfoPtr->colorVar != NULL) { char *cmdString; - cmdString = Tcl_GetVar2(canvasPtr->interp, psInfoPtr->colorVar, + cmdString = Tcl_GetVar2(interp, psInfoPtr->colorVar, Tk_NameOfColor(colorPtr), 0); if (cmdString != NULL) { - Tcl_AppendResult(canvasPtr->interp, cmdString, "\n", - (char *) NULL); + Tcl_AppendResult(interp, cmdString, "\n", (char *) NULL); return TCL_OK; } } /* * No color map entry for this color. Grab the color's intensities - * and output Postscript commands for them. + * and output Postscript commands for them. Special note: X uses + * a range of 0-65535 for intensities, but most displays only use + * a range of 0-255, which maps to (0, 256, 512, ... 65280) in the + * X scale. This means that there's no way to get perfect white, + * since the highest intensity is only 65280 out of 65535. To + * work around this problem, rescale the X intensity to a 0-255 + * scale and use that as the basis for the Postscript colors. This + * scheme still won't work if the display only uses 4 bits per color, + * but most diplays use at least 8 bits. */ - red = colorPtr->red/65535.0; - green = colorPtr->green/65535.0; - blue = colorPtr->blue/65535.0; + tmp = colorPtr->red; + red = ((double) (tmp >> 8))/255.0; + tmp = colorPtr->green; + green = ((double) (tmp >> 8))/255.0; + tmp = colorPtr->blue; + blue = ((double) (tmp >> 8))/255.0; sprintf(string, "%.3f %.3f %.3f setrgbcolor AdjustColor\n", red, green, blue); - Tcl_AppendResult(canvasPtr->interp, string, (char *) NULL); + Tcl_AppendResult(interp, string, (char *) NULL); return TCL_OK; } /* *-------------------------------------------------------------- * - * TkCanvPsFont -- + * Tk_CanvasPsFont -- * * This procedure is called by individual canvas items when * they want to output text. Given information about an X @@ -663,9 +630,9 @@ TkCanvPsColor(canvasPtr, handle, colorPtr) * * Results: * Returns a standard Tcl return value. If an error occurs - * then an error message will be left in canvasPtr->interp->result. + * then an error message will be left in interp->result. * If no error occurs, then additional Postscript will be - * appended to the canvasPtr->interp->result. + * appended to the interp->result. * * Side effects: * The Postscript font name is entered into psInfoPtr->fontTable @@ -675,14 +642,15 @@ TkCanvPsColor(canvasPtr, handle, colorPtr) */ int -TkCanvPsFont(canvasPtr, handle, fontStructPtr) - register Tk_Canvas *canvasPtr; /* Information about canvas. */ - Tk_PostscriptInfo *handle; /* Information about Postscript being - * generated. */ +Tk_CanvasPsFont(interp, canvas, fontStructPtr) + Tcl_Interp *interp; /* Interpreter for returning Postscript + * or error message. */ + Tk_Canvas canvas; /* Information about canvas. */ XFontStruct *fontStructPtr; /* Information about font in which text * is to be printed. */ { - PostscriptInfo *psInfoPtr = (PostscriptInfo *) handle; + TkCanvas *canvasPtr = (TkCanvas *) canvas; + TkPostscriptInfo *psInfoPtr = canvasPtr->psInfoPtr; char *name, *end, *weightString, *slantString; #define TOTAL_FIELDS 8 #define FAMILY_FIELD 1 @@ -693,7 +661,7 @@ TkCanvPsFont(canvasPtr, handle, fontStructPtr) #define MAX_NAME_SIZE 100 char fontName[MAX_NAME_SIZE+50], pointString[20]; int i, c, weightSize, nameSize, points; - register char *p; + char *p; name = Tk_NameOfFontStruct(fontStructPtr); @@ -708,15 +676,13 @@ TkCanvPsFont(canvasPtr, handle, fontStructPtr) int argc; double size; - list = Tcl_GetVar2(canvasPtr->interp, psInfoPtr->fontVar, + list = Tcl_GetVar2(interp, psInfoPtr->fontVar, name, 0); if (list != NULL) { - if (Tcl_SplitList(canvasPtr->interp, list, &argc, &argv) - != TCL_OK) { + if (Tcl_SplitList(interp, list, &argc, &argv) != TCL_OK) { badMapEntry: - Tcl_ResetResult(canvasPtr->interp); - Tcl_AppendResult(canvasPtr->interp, - "bad font map entry for \"", name, + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad font map entry for \"", name, "\": \"", list, "\"", (char *) NULL); return TCL_ERROR; } @@ -728,8 +694,12 @@ TkCanvPsFont(canvasPtr, handle, fontStructPtr) goto badMapEntry; } sprintf(pointString, "%.15g", size); - Tcl_AppendResult(canvasPtr->interp, "/", argv[0], " findfont ", - pointString, " scalefont setfont\n", (char *) NULL); + Tcl_AppendResult(interp, "/", argv[0], " findfont ", + pointString, " scalefont ", (char *) NULL); + if (strncasecmp(argv[0], "Symbol", 7) != 0) { + Tcl_AppendResult(interp, "ISOEncode ", (char *) NULL); + } + Tcl_AppendResult(interp, "setfont\n", (char *) NULL); Tcl_CreateHashEntry(&psInfoPtr->fontTable, argv[0], &i); ckfree((char *) argv); return TCL_OK; @@ -772,13 +742,13 @@ TkCanvPsFont(canvasPtr, handle, fontStructPtr) if ((nameSize == 0) || (nameSize > MAX_NAME_SIZE)) { goto error; } - strncpy(fontName, fieldPtrs[FAMILY_FIELD], nameSize); + strncpy(fontName, fieldPtrs[FAMILY_FIELD], (size_t) nameSize); if (islower(UCHAR(fontName[0]))) { - fontName[0] = toupper(fontName[0]); + fontName[0] = toupper(UCHAR(fontName[0])); } for (p = fontName+1, i = nameSize-1; i > 0; p++, i--) { if (isupper(UCHAR(*p))) { - *p = tolower(*p); + *p = tolower(UCHAR(*p)); } } *p = 0; @@ -786,9 +756,11 @@ TkCanvPsFont(canvasPtr, handle, fontStructPtr) if (weightSize == 0) { goto error; } - if (CaseCmp(fieldPtrs[WEIGHT_FIELD], "medium", weightSize) == 0) { + if (strncasecmp(fieldPtrs[WEIGHT_FIELD], "medium", + (size_t) weightSize) == 0) { weightString = ""; - } else if (CaseCmp(fieldPtrs[WEIGHT_FIELD], "bold", weightSize) == 0) { + } else if (strncasecmp(fieldPtrs[WEIGHT_FIELD], "bold", + (size_t) weightSize) == 0) { weightString = "Bold"; } else { goto error; @@ -818,14 +790,18 @@ TkCanvPsFont(canvasPtr, handle, fontStructPtr) goto error; } sprintf(pointString, "%.15g", ((double) points)/10.0); - Tcl_AppendResult(canvasPtr->interp, "/", fontName, " findfont ", - pointString, " scalefont setfont\n", (char *) NULL); + Tcl_AppendResult(interp, "/", fontName, " findfont ", + pointString, " scalefont ", (char *) NULL); + if (strcmp(fontName, "Symbol") != 0) { + Tcl_AppendResult(interp, "ISOEncode ", (char *) NULL); + } + Tcl_AppendResult(interp, "setfont\n", (char *) NULL); Tcl_CreateHashEntry(&psInfoPtr->fontTable, fontName, &i); return TCL_OK; error: - Tcl_ResetResult(canvasPtr->interp); - Tcl_AppendResult(canvasPtr->interp, "couldn't translate font name \"", + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "couldn't translate font name \"", name, "\" to Postscript", (char *) NULL); return TCL_ERROR; } @@ -833,17 +809,18 @@ TkCanvPsFont(canvasPtr, handle, fontStructPtr) /* *-------------------------------------------------------------- * - * TkCanvPsBitmap -- + * Tk_CanvasPsBitmap -- * * This procedure is called to output the contents of a - * bitmap in proper image data format for Postscript (i.e. - * data between angle brackets, one bit per pixel). + * sub-region of a bitmap in proper image data format for + * Postscript (i.e. data between angle brackets, one bit + * per pixel). * * Results: * Returns a standard Tcl return value. If an error occurs - * then an error message will be left in canvasPtr->interp->result. + * then an error message will be left in interp->result. * If no error occurs, then additional Postscript will be - * appended to canvasPtr->interp->result. + * appended to interp->result. * * Side effects: * None. @@ -852,56 +829,76 @@ TkCanvPsFont(canvasPtr, handle, fontStructPtr) */ int -TkCanvPsBitmap(canvasPtr, handle, bitmap) - Tk_Canvas *canvasPtr; /* Information about canvas. */ - Tk_PostscriptInfo *handle; /* Information about Postscript being - * generated. */ - Pixmap bitmap; /* Bitmap to use for stippling. */ +Tk_CanvasPsBitmap(interp, canvas, bitmap, startX, startY, width, height) + Tcl_Interp *interp; /* Interpreter for returning Postscript + * or error message. */ + Tk_Canvas canvas; /* Information about canvas. */ + Pixmap bitmap; /* Bitmap for which to generate + * Postscript. */ + int startX, startY; /* Coordinates of upper-left corner + * of rectangular region to output. */ + int width, height; /* Height of rectangular region. */ { - PostscriptInfo *psInfoPtr = (PostscriptInfo *) handle; - unsigned int width, height; + TkCanvas *canvasPtr = (TkCanvas *) canvas; + TkPostscriptInfo *psInfoPtr = canvasPtr->psInfoPtr; XImage *imagePtr; - int charsInLine, x, y, value, mask; + int charsInLine, x, y, lastX, lastY, value, mask; + unsigned int totalWidth, totalHeight; char string[100]; + Window dummyRoot; + int dummyX, dummyY; + unsigned dummyBorderwidth, dummyDepth; if (psInfoPtr->prepass) { return TCL_OK; } - Tk_SizeOfBitmap(canvasPtr->display, bitmap, &width, &height); + /* + * The following call should probably be a call to Tk_SizeOfBitmap + * instead, but it seems that we are occasionally invoked by custom + * item types that create their own bitmaps without registering them + * with Tk. XGetGeometry is a bit slower than Tk_SizeOfBitmap, but + * it shouldn't matter here. + */ + + XGetGeometry(Tk_Display(Tk_CanvasTkwin(canvas)), bitmap, &dummyRoot, + (int *) &dummyX, (int *) &dummyY, (unsigned int *) &totalWidth, + (unsigned int *) &totalHeight, &dummyBorderwidth, &dummyDepth); imagePtr = XGetImage(Tk_Display(canvasPtr->tkwin), bitmap, 0, 0, - width, height, 1, XYPixmap); - Tcl_AppendResult(canvasPtr->interp, "<", (char *) NULL); + totalWidth, totalHeight, 1, XYPixmap); + Tcl_AppendResult(interp, "<", (char *) NULL); mask = 0x80; value = 0; charsInLine = 0; - for (y = 1; y <= height; y++) { - for (x = 0; x < width; x++) { - if (XGetPixel(imagePtr, x, height-y)) { + lastX = startX + width - 1; + lastY = startY + height - 1; + for (y = lastY; y >= startY; y--) { + for (x = startX; x <= lastX; x++) { + if (XGetPixel(imagePtr, x, y)) { value |= mask; } mask >>= 1; if (mask == 0) { sprintf(string, "%02x", value); - Tcl_AppendResult(canvasPtr->interp, string, (char *) NULL); + Tcl_AppendResult(interp, string, (char *) NULL); mask = 0x80; value = 0; charsInLine += 2; if (charsInLine >= 60) { - Tcl_AppendResult(canvasPtr->interp, "\n", (char *) NULL); + Tcl_AppendResult(interp, "\n", (char *) NULL); charsInLine = 0; } } } if (mask != 0x80) { sprintf(string, "%02x", value); - Tcl_AppendResult(canvasPtr->interp, string, (char *) NULL); + Tcl_AppendResult(interp, string, (char *) NULL); mask = 0x80; value = 0; charsInLine += 2; } } - Tcl_AppendResult(canvasPtr->interp, ">", (char *) NULL); + Tcl_AppendResult(interp, ">", (char *) NULL); XDestroyImage(imagePtr); return TCL_OK; } @@ -909,20 +906,20 @@ TkCanvPsBitmap(canvasPtr, handle, bitmap) /* *-------------------------------------------------------------- * - * TkCanvPsStipple -- + * Tk_CanvasPsStipple -- * * This procedure is called by individual canvas items when * they have created a path that they'd like to be filled with * a stipple pattern. Given information about an X bitmap, * this procedure will generate Postscript commands to fill - * the current path using a stipple pattern defined by the + * the current clip region using a stipple pattern defined by the * bitmap. * * Results: * Returns a standard Tcl return value. If an error occurs - * then an error message will be left in canvasPtr->interp->result. + * then an error message will be left in interp->result. * If no error occurs, then additional Postscript will be - * appended to canvasPtr->interp->result. + * appended to interp->result. * * Side effects: * None. @@ -931,40 +928,49 @@ TkCanvPsBitmap(canvasPtr, handle, bitmap) */ int -TkCanvPsStipple(canvasPtr, handle, bitmap, filled) - Tk_Canvas *canvasPtr; /* Information about canvas. */ - Tk_PostscriptInfo *handle; /* Information about Postscript being - * generated. */ +Tk_CanvasPsStipple(interp, canvas, bitmap) + Tcl_Interp *interp; /* Interpreter for returning Postscript + * or error message. */ + Tk_Canvas canvas; /* Information about canvas. */ Pixmap bitmap; /* Bitmap to use for stippling. */ - int filled; /* Non-zero means the area defined by - * the path should be filled with the - * stipple pattern; zero means the - * path should be stroked in the - * stipple pattern. */ { - PostscriptInfo *psInfoPtr = (PostscriptInfo *) handle; - unsigned int width, height; + TkCanvas *canvasPtr = (TkCanvas *) canvas; + TkPostscriptInfo *psInfoPtr = canvasPtr->psInfoPtr; + int width, height; char string[100]; + Window dummyRoot; + int dummyX, dummyY; + unsigned dummyBorderwidth, dummyDepth; if (psInfoPtr->prepass) { return TCL_OK; } - Tk_SizeOfBitmap(canvasPtr->display, bitmap, &width, &height); + /* + * The following call should probably be a call to Tk_SizeOfBitmap + * instead, but it seems that we are occasionally invoked by custom + * item types that create their own bitmaps without registering them + * with Tk. XGetGeometry is a bit slower than Tk_SizeOfBitmap, but + * it shouldn't matter here. + */ + + XGetGeometry(Tk_Display(Tk_CanvasTkwin(canvas)), bitmap, &dummyRoot, + (int *) &dummyX, (int *) &dummyY, (unsigned *) &width, + (unsigned *) &height, &dummyBorderwidth, &dummyDepth); sprintf(string, "%d %d ", width, height); - Tcl_AppendResult(canvasPtr->interp, string, (char *) NULL); - if (TkCanvPsBitmap(canvasPtr, handle, bitmap) != TCL_OK) { + Tcl_AppendResult(interp, string, (char *) NULL); + if (Tk_CanvasPsBitmap(interp, (Tk_Canvas) canvasPtr, bitmap, 0, 0, + width, height) != TCL_OK) { return TCL_ERROR; } - Tcl_AppendResult(canvasPtr->interp, filled ? " true" : " false", - " StippleFill\n", (char *) NULL); + Tcl_AppendResult(interp, " StippleFill\n", (char *) NULL); return TCL_OK; } /* *-------------------------------------------------------------- * - * TkCanvPsY -- + * Tk_CanvasPsY -- * * Given a y-coordinate in canvas coordinates, this procedure * returns a y-coordinate to use for Postscript output. @@ -980,19 +986,20 @@ TkCanvPsStipple(canvasPtr, handle, bitmap, filled) */ double -TkCanvPsY(handle, y) - Tk_PostscriptInfo *handle; /* Information about Postscript being - * generated. */ +Tk_CanvasPsY(canvas, y) + Tk_Canvas canvas; /* Token for canvas on whose behalf + * Postscript is being generated. */ double y; /* Y-coordinate in canvas coords. */ { - PostscriptInfo *psInfoPtr = (PostscriptInfo *) handle; + TkPostscriptInfo *psInfoPtr = ((TkCanvas *) canvas)->psInfoPtr; + return psInfoPtr->y2 - y; } /* *-------------------------------------------------------------- * - * TkCanvPsPath -- + * Tk_CanvasPsPath -- * * Given an array of points for a path, generate Postscript * commands to create the path. @@ -1007,30 +1014,29 @@ TkCanvPsY(handle, y) */ void -TkCanvPsPath(interp, coordPtr, numPoints, handle) +Tk_CanvasPsPath(interp, canvas, coordPtr, numPoints) Tcl_Interp *interp; /* Put generated Postscript in this * interpreter's result field. */ - register double *coordPtr; /* Pointer to first in array of + Tk_Canvas canvas; /* Canvas on whose behalf Postscript + * is being generated. */ + double *coordPtr; /* Pointer to first in array of * 2*numPoints coordinates giving * points for path. */ int numPoints; /* Number of points at *coordPtr. */ - Tk_PostscriptInfo *handle; /* Information about the Postscript; - * must be passed back to Postscript - * utility procedures. */ { - PostscriptInfo *psInfoPtr = (PostscriptInfo *) handle; + TkPostscriptInfo *psInfoPtr = ((TkCanvas *) canvas)->psInfoPtr; char buffer[200]; if (psInfoPtr->prepass) { return; } sprintf(buffer, "%.15g %.15g moveto\n", coordPtr[0], - TkCanvPsY(handle, coordPtr[1])); + Tk_CanvasPsY(canvas, coordPtr[1])); Tcl_AppendResult(interp, buffer, (char *) NULL); for (numPoints--, coordPtr += 2; numPoints > 0; numPoints--, coordPtr += 2) { sprintf(buffer, "%.15g %.15g lineto\n", coordPtr[0], - TkCanvPsY(handle, coordPtr[1])); + Tk_CanvasPsY(canvas, coordPtr[1])); Tcl_AppendResult(interp, buffer, (char *) NULL); } } @@ -1089,6 +1095,7 @@ GetPostscriptPoints(interp, string, doublePtr) end++; break; case 0: + break; case 'p': end++; break; @@ -1106,83 +1113,78 @@ GetPostscriptPoints(interp, string, doublePtr) } /* - *---------------------------------------------------------------------- + *-------------------------------------------------------------- * - * CaseCmp -- + * TkGetProlog -- * - * Compares two strings, ignoring case differences. + * Locate and load the postscript prolog. * * Results: - * Compares up to length chars of s1 and s2, returning -1, 0, or 1 - * if s1 is lexicographically less than, equal to, or greater - * than s2 over those characters. + * A standard Tcl Result. If everything is OK the prolog + * will be located in the result string of the interpreter. * * Side effects: * None. * - *---------------------------------------------------------------------- + *-------------------------------------------------------------- */ -static int -CaseCmp(s1, s2, length) - char *s1; /* First string. */ - char *s2; /* Second string. */ - int length; /* Maximum number of characters to compare - * (stop earlier if the end of either string - * is reached). */ +int +TkGetProlog(interp) + Tcl_Interp *interp; /* Places the prolog in the result. */ { - register unsigned char u1, u2; + char *libDir; + Tcl_Channel chan; + Tcl_DString buffer, buffer2; + char *prologPathParts[2]; + int bufferSize; + char *prologBuffer; + + libDir = Tcl_GetVar(interp, "tk_library", TCL_GLOBAL_ONLY); + if (libDir == NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "couldn't find library directory: ", + "tk_library variable doesn't exist", (char *) NULL); + return TCL_ERROR; + } + Tcl_TranslateFileName(interp, libDir, &buffer); + prologPathParts[0] = buffer.string; + prologPathParts[1] = "prolog.ps"; + Tcl_DStringInit(&buffer2); + Tcl_JoinPath(2, prologPathParts, &buffer2); + Tcl_DStringFree(&buffer); /* - * This array is designed for mapping upper and lower case letter - * together for a case independent comparison. The mappings are - * based upon ASCII character sequences. + * Compute size of file by seeking to the end of the file. This will + * overallocate if we are performing CRLF translation. */ - - static unsigned char charmap[] = { - '\000', '\001', '\002', '\003', '\004', '\005', '\006', '\007', - '\010', '\011', '\012', '\013', '\014', '\015', '\016', '\017', - '\020', '\021', '\022', '\023', '\024', '\025', '\026', '\027', - '\030', '\031', '\032', '\033', '\034', '\035', '\036', '\037', - '\040', '\041', '\042', '\043', '\044', '\045', '\046', '\047', - '\050', '\051', '\052', '\053', '\054', '\055', '\056', '\057', - '\060', '\061', '\062', '\063', '\064', '\065', '\066', '\067', - '\070', '\071', '\072', '\073', '\074', '\075', '\076', '\077', - '\100', '\141', '\142', '\143', '\144', '\145', '\146', '\147', - '\150', '\151', '\152', '\153', '\154', '\155', '\156', '\157', - '\160', '\161', '\162', '\163', '\164', '\165', '\166', '\167', - '\170', '\171', '\172', '\133', '\134', '\135', '\136', '\137', - '\140', '\141', '\142', '\143', '\144', '\145', '\146', '\147', - '\150', '\151', '\152', '\153', '\154', '\155', '\156', '\157', - '\160', '\161', '\162', '\163', '\164', '\165', '\166', '\167', - '\170', '\171', '\172', '\173', '\174', '\175', '\176', '\177', - '\200', '\201', '\202', '\203', '\204', '\205', '\206', '\207', - '\210', '\211', '\212', '\213', '\214', '\215', '\216', '\217', - '\220', '\221', '\222', '\223', '\224', '\225', '\226', '\227', - '\230', '\231', '\232', '\233', '\234', '\235', '\236', '\237', - '\240', '\241', '\242', '\243', '\244', '\245', '\246', '\247', - '\250', '\251', '\252', '\253', '\254', '\255', '\256', '\257', - '\260', '\261', '\262', '\263', '\264', '\265', '\266', '\267', - '\270', '\271', '\272', '\273', '\274', '\275', '\276', '\277', - '\300', '\341', '\342', '\343', '\344', '\345', '\346', '\347', - '\350', '\351', '\352', '\353', '\354', '\355', '\356', '\357', - '\360', '\361', '\362', '\363', '\364', '\365', '\366', '\367', - '\370', '\371', '\372', '\333', '\334', '\335', '\336', '\337', - '\340', '\341', '\342', '\343', '\344', '\345', '\346', '\347', - '\350', '\351', '\352', '\353', '\354', '\355', '\356', '\357', - '\360', '\361', '\362', '\363', '\364', '\365', '\366', '\367', - '\370', '\371', '\372', '\373', '\374', '\375', '\376', '\377', - }; - - for (; length != 0; length--, s1++, s2++) { - u1 = (unsigned char) *s1; - u2 = (unsigned char) *s2; - if (charmap[u1] != charmap[u2]) { - return charmap[u1] - charmap[u2]; - } - if (u1 == '\0') { - return 0; - } + + chan = Tcl_OpenFileChannel(interp, buffer2.string, "r", 0); + if (chan == NULL) { + Tcl_DStringFree(&buffer2); + return TCL_ERROR; } - return 0; + bufferSize = Tcl_Seek(chan, 0L, SEEK_END); + (void) Tcl_Seek(chan, 0L, SEEK_SET); + if (bufferSize < 0) { + Tcl_AppendResult(interp, "error seeking to end of file \"", + buffer2.string, "\":", Tcl_PosixError(interp), (char *) NULL); + Tcl_Close(NULL, chan); + Tcl_DStringFree(&buffer2); + return TCL_ERROR; + + } + prologBuffer = (char *) ckalloc((unsigned) bufferSize+1); + bufferSize = Tcl_Read(chan, prologBuffer, bufferSize); + Tcl_Close(NULL, chan); + if (bufferSize < 0) { + Tcl_AppendResult(interp, "error reading file \"", buffer2.string, + "\":", Tcl_PosixError(interp), (char *) NULL); + Tcl_DStringFree(&buffer2); + return TCL_ERROR; + } + Tcl_DStringFree(&buffer2); + prologBuffer[bufferSize] = 0; + Tcl_SetResult(interp, prologBuffer, TCL_DYNAMIC); + return TCL_OK; } diff --git a/tk3.6/tkCanvText.c b/tk4.2/generic/tkCanvText.c similarity index 69% rename from tk3.6/tkCanvText.c rename to tk4.2/generic/tkCanvText.c index 92dc24d..20533ab 100644 --- a/tk3.6/tkCanvText.c +++ b/tk4.2/generic/tkCanvText.c @@ -3,35 +3,19 @@ * * This file implements text items for canvas widgets. * - * Copyright (c) 1991-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tkCanvText.c 1.56 96/02/17 17:45:17 */ -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkCanvText.c,v 1.28 93/08/18 16:25:27 ouster Exp $ SPRITE (Berkeley)"; -#endif - #include #include "tkInt.h" #include "tkCanvas.h" -#include "tkConfig.h" +#include "tkPort.h" /* * One of the following structures is kept for each line of text @@ -67,6 +51,12 @@ typedef struct TextLine { typedef struct TextItem { Tk_Item header; /* Generic stuff that's the same for all * types. MUST BE FIRST IN STRUCTURE. */ + Tk_CanvasTextInfo *textInfoPtr; + /* Pointer to a structure containing + * information about the selection and + * insertion cursor. The structure is owned + * by (and shared with) the generic canvas + * code. */ char *text; /* Text for item (malloc-ed). */ int numChars; /* Number of non-NULL characters in text. */ double x, y; /* Positioning point for text. */ @@ -86,6 +76,10 @@ typedef struct TextItem { int numLines; /* Number of structs at *linePtr. */ int insertPos; /* Insertion cursor is displayed just to left * of character with this index. */ + GC cursorOffGC; /* If not None, this gives a graphics context + * to use to draw the insertion cursor when + * it's off. Usedif the selection and + * insertion cursor colors are the same. */ GC selTextGC; /* Graphics context for selected text. */ } TextItem; @@ -93,6 +87,10 @@ typedef struct TextItem { * Information used for parsing configuration specs: */ +static Tk_CustomOption tagsOption = {Tk_CanvasTagsParseProc, + Tk_CanvasTagsPrintProc, (ClientData) NULL +}; + static Tk_ConfigSpec configSpecs[] = { {TK_CONFIG_ANCHOR, "-anchor", (char *) NULL, (char *) NULL, "center", Tk_Offset(TextItem, anchor), @@ -100,7 +98,7 @@ static Tk_ConfigSpec configSpecs[] = { {TK_CONFIG_COLOR, "-fill", (char *) NULL, (char *) NULL, "black", Tk_Offset(TextItem, color), 0}, {TK_CONFIG_FONT, "-font", (char *) NULL, (char *) NULL, - "-Adobe-Helvetica-Bold-R-Normal--*-120-*", + "-Adobe-Helvetica-Bold-R-Normal--*-120-*-*-*-*-*-*", Tk_Offset(TextItem, fontPtr), 0}, {TK_CONFIG_JUSTIFY, "-justify", (char *) NULL, (char *) NULL, "left", Tk_Offset(TextItem, justify), @@ -108,7 +106,7 @@ static Tk_ConfigSpec configSpecs[] = { {TK_CONFIG_BITMAP, "-stipple", (char *) NULL, (char *) NULL, (char *) NULL, Tk_Offset(TextItem, stipple), TK_CONFIG_NULL_OK}, {TK_CONFIG_CUSTOM, "-tags", (char *) NULL, (char *) NULL, - (char *) NULL, 0, TK_CONFIG_NULL_OK, &tkCanvasTagsOption}, + (char *) NULL, 0, TK_CONFIG_NULL_OK, &tagsOption}, {TK_CONFIG_STRING, "-text", (char *) NULL, (char *) NULL, "", Tk_Offset(TextItem, text), 0}, {TK_CONFIG_PIXELS, "-width", (char *) NULL, (char *) NULL, @@ -121,43 +119,46 @@ static Tk_ConfigSpec configSpecs[] = { * Prototypes for procedures defined in this file: */ -static void ComputeTextBbox _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static void ComputeTextBbox _ANSI_ARGS_((Tk_Canvas canvas, TextItem *textPtr)); -static int ConfigureText _ANSI_ARGS_(( - Tk_Canvas *canvasPtr, Tk_Item *itemPtr, int argc, +static int ConfigureText _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int argc, char **argv, int flags)); -static int CreateText _ANSI_ARGS_((Tk_Canvas *canvasPtr, - struct Tk_Item *itemPtr, int argc, char **argv)); -static void DeleteText _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr)); -static void DisplayText _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, Drawable dst)); -static int GetSelText _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static int CreateText _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, struct Tk_Item *itemPtr, + int argc, char **argv)); +static void DeleteText _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, Display *display)); +static void DisplayText _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, Display *display, Drawable dst, + int x, int y, int width, int height)); +static int GetSelText _ANSI_ARGS_((Tk_Canvas canvas, Tk_Item *itemPtr, int offset, char *buffer, int maxBytes)); -static int GetTextIndex _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, char *indexString, - int *indexPtr)); +static int GetTextIndex _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, + char *indexString, int *indexPtr)); static void LineToPostscript _ANSI_ARGS_((Tcl_Interp *interp, char *string, int numChars)); -static void ScaleText _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static void ScaleText _ANSI_ARGS_((Tk_Canvas canvas, Tk_Item *itemPtr, double originX, double originY, double scaleX, double scaleY)); -static void SetTextCursor _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static void SetTextCursor _ANSI_ARGS_((Tk_Canvas canvas, Tk_Item *itemPtr, int index)); -static int TextCoords _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, int argc, char **argv)); -static int TextDeleteChars _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static int TextCoords _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, + int argc, char **argv)); +static void TextDeleteChars _ANSI_ARGS_((Tk_Canvas canvas, Tk_Item *itemPtr, int first, int last)); -static int TextInsert _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static void TextInsert _ANSI_ARGS_((Tk_Canvas canvas, Tk_Item *itemPtr, int beforeThis, char *string)); -static int TextToArea _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static int TextToArea _ANSI_ARGS_((Tk_Canvas canvas, Tk_Item *itemPtr, double *rectPtr)); -static double TextToPoint _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static double TextToPoint _ANSI_ARGS_((Tk_Canvas canvas, Tk_Item *itemPtr, double *pointPtr)); -static int TextToPostscript _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, Tk_PostscriptInfo *psInfoPtr)); -static void TranslateText _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static int TextToPostscript _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int prepass)); +static void TranslateText _ANSI_ARGS_((Tk_Canvas canvas, Tk_Item *itemPtr, double deltaX, double deltaY)); /* @@ -165,7 +166,7 @@ static void TranslateText _ANSI_ARGS_((Tk_Canvas *canvasPtr, * by means of procedures that can be invoked by generic item code. */ -Tk_ItemType TkTextType = { +Tk_ItemType tkTextType = { "text", /* name */ sizeof(TextItem), /* itemSize */ CreateText, /* createProc */ @@ -199,9 +200,8 @@ Tk_ItemType TkTextType = { * Results: * A standard Tcl return value. If an error occurred in * creating the item then an error message is left in - * canvasPtr->interp->result; in this case itemPtr is - * left uninitialized so it can be safely freed by the - * caller. + * interp->result; in this case itemPtr is left uninitialized + * so it can be safely freed by the caller. * * Side effects: * A new text item is created. @@ -210,19 +210,20 @@ Tk_ItemType TkTextType = { */ static int -CreateText(canvasPtr, itemPtr, argc, argv) - register Tk_Canvas *canvasPtr; /* Canvas to hold new item. */ +CreateText(interp, canvas, itemPtr, argc, argv) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + Tk_Canvas canvas; /* Canvas to hold new item. */ Tk_Item *itemPtr; /* Record to hold new item; header * has been initialized by caller. */ int argc; /* Number of arguments in argv. */ char **argv; /* Arguments describing rectangle. */ { - register TextItem *textPtr = (TextItem *) itemPtr; + TextItem *textPtr = (TextItem *) itemPtr; if (argc < 2) { - Tcl_AppendResult(canvasPtr->interp, "wrong # args: should be \"", - Tk_PathName(canvasPtr->tkwin), "\" create ", - itemPtr->typePtr->name, " x y [options]", (char *) NULL); + Tcl_AppendResult(interp, "wrong # args: should be \"", + Tk_PathName(Tk_CanvasTkwin(canvas)), " create ", + itemPtr->typePtr->name, " x y ?options?\"", (char *) NULL); return TCL_ERROR; } @@ -232,6 +233,7 @@ CreateText(canvasPtr, itemPtr, argc, argv) */ textPtr->text = NULL; + textPtr->textInfoPtr = Tk_CanvasGetTextInfo(canvas); textPtr->numChars = 0; textPtr->anchor = TK_ANCHOR_CENTER; textPtr->width = 0; @@ -244,19 +246,21 @@ CreateText(canvasPtr, itemPtr, argc, argv) textPtr->linePtr = NULL; textPtr->numLines = 0; textPtr->insertPos = 0; + textPtr->cursorOffGC = None; textPtr->selTextGC = None; /* * Process the arguments to fill in the item record. */ - if ((TkGetCanvasCoord(canvasPtr, argv[0], &textPtr->x) != TCL_OK) - || (TkGetCanvasCoord(canvasPtr, argv[1], &textPtr->y) != TCL_OK)) { + if ((Tk_CanvasGetCoord(interp, canvas, argv[0], &textPtr->x) != TCL_OK) + || (Tk_CanvasGetCoord(interp, canvas, argv[1], &textPtr->y) + != TCL_OK)) { return TCL_ERROR; } - if (ConfigureText(canvasPtr, itemPtr, argc-2, argv+2, 0) != TCL_OK) { - DeleteText(canvasPtr, itemPtr); + if (ConfigureText(interp, canvas, itemPtr, argc-2, argv+2, 0) != TCL_OK) { + DeleteText(canvas, itemPtr, Tk_Display(Tk_CanvasTkwin(canvas))); return TCL_ERROR; } return TCL_OK; @@ -272,7 +276,7 @@ CreateText(canvasPtr, itemPtr, argc, argv) * details on what it does. * * Results: - * Returns TCL_OK or TCL_ERROR, and sets canvasPtr->interp->result. + * Returns TCL_OK or TCL_ERROR, and sets interp->result. * * Side effects: * The coordinates for the given item may be changed. @@ -281,8 +285,9 @@ CreateText(canvasPtr, itemPtr, argc, argv) */ static int -TextCoords(canvasPtr, itemPtr, argc, argv) - register Tk_Canvas *canvasPtr; /* Canvas containing item. */ +TextCoords(interp, canvas, itemPtr, argc, argv) + Tcl_Interp *interp; /* Used for error reporting. */ + Tk_Canvas canvas; /* Canvas containing item. */ Tk_Item *itemPtr; /* Item whose coordinates are to be * read or modified. */ int argc; /* Number of coordinates supplied in @@ -290,24 +295,23 @@ TextCoords(canvasPtr, itemPtr, argc, argv) char **argv; /* Array of coordinates: x1, y1, * x2, y2, ... */ { - register TextItem *textPtr = (TextItem *) itemPtr; + TextItem *textPtr = (TextItem *) itemPtr; char x[TCL_DOUBLE_SPACE], y[TCL_DOUBLE_SPACE]; if (argc == 0) { - Tcl_PrintDouble(canvasPtr->interp, textPtr->x, x); - Tcl_PrintDouble(canvasPtr->interp, textPtr->y, y); - Tcl_AppendResult(canvasPtr->interp, x, " ", y, (char *) NULL); + Tcl_PrintDouble(interp, textPtr->x, x); + Tcl_PrintDouble(interp, textPtr->y, y); + Tcl_AppendResult(interp, x, " ", y, (char *) NULL); } else if (argc == 2) { - if ((TkGetCanvasCoord(canvasPtr, argv[0], &textPtr->x) != TCL_OK) - || (TkGetCanvasCoord(canvasPtr, argv[1], + if ((Tk_CanvasGetCoord(interp, canvas, argv[0], &textPtr->x) != TCL_OK) + || (Tk_CanvasGetCoord(interp, canvas, argv[1], &textPtr->y) != TCL_OK)) { return TCL_ERROR; } - ComputeTextBbox(canvasPtr, textPtr); + ComputeTextBbox(canvas, textPtr); } else { - sprintf(canvasPtr->interp->result, - "wrong # coordinates: expected 0 or 2, got %d", - argc); + sprintf(interp->result, + "wrong # coordinates: expected 0 or 2, got %d", argc); return TCL_ERROR; } return TCL_OK; @@ -323,7 +327,7 @@ TextCoords(canvasPtr, itemPtr, argc, argv) * * Results: * A standard Tcl result code. If an error occurs, then - * an error message is left in canvasPtr->interp->result. + * an error message is left in interp->result. * * Side effects: * Configuration information, such as colors and stipple @@ -333,20 +337,25 @@ TextCoords(canvasPtr, itemPtr, argc, argv) */ static int -ConfigureText(canvasPtr, itemPtr, argc, argv, flags) - Tk_Canvas *canvasPtr; /* Canvas containing itemPtr. */ +ConfigureText(interp, canvas, itemPtr, argc, argv, flags) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + Tk_Canvas canvas; /* Canvas containing itemPtr. */ Tk_Item *itemPtr; /* Rectangle item to reconfigure. */ int argc; /* Number of elements in argv. */ char **argv; /* Arguments describing things to configure. */ int flags; /* Flags to pass to Tk_ConfigureWidget. */ { - register TextItem *textPtr = (TextItem *) itemPtr; + TextItem *textPtr = (TextItem *) itemPtr; XGCValues gcValues; GC newGC, newSelGC; unsigned long mask; + Tk_Window tkwin; + Tk_CanvasTextInfo *textInfoPtr = textPtr->textInfoPtr; + XColor *selBgColorPtr; - if (Tk_ConfigureWidget(canvasPtr->interp, canvasPtr->tkwin, - configSpecs, argc, argv, (char *) textPtr, flags) != TCL_OK) { + tkwin = Tk_CanvasTkwin(canvas); + if (Tk_ConfigureWidget(interp, tkwin, configSpecs, argc, argv, + (char *) textPtr, flags) != TCL_OK) { return TCL_ERROR; } @@ -366,34 +375,51 @@ ConfigureText(canvasPtr, itemPtr, argc, argv, flags) gcValues.fill_style = FillStippled; mask |= GCForeground|GCStipple|GCFillStyle; } - newGC = Tk_GetGC(canvasPtr->tkwin, mask, &gcValues); - gcValues.foreground = canvasPtr->selFgColorPtr->pixel; - newSelGC = Tk_GetGC(canvasPtr->tkwin, mask, &gcValues); + newGC = Tk_GetGC(tkwin, mask, &gcValues); + gcValues.foreground = textInfoPtr->selFgColorPtr->pixel; + newSelGC = Tk_GetGC(tkwin, mask, &gcValues); } if (textPtr->gc != None) { - Tk_FreeGC(canvasPtr->display, textPtr->gc); + Tk_FreeGC(Tk_Display(tkwin), textPtr->gc); } textPtr->gc = newGC; if (textPtr->selTextGC != None) { - Tk_FreeGC(canvasPtr->display, textPtr->selTextGC); + Tk_FreeGC(Tk_Display(tkwin), textPtr->selTextGC); } textPtr->selTextGC = newSelGC; + selBgColorPtr = Tk_3DBorderColor(textInfoPtr->selBorder); + if (Tk_3DBorderColor(textInfoPtr->insertBorder)->pixel + == selBgColorPtr->pixel) { + if (selBgColorPtr->pixel == BlackPixelOfScreen(Tk_Screen(tkwin))) { + gcValues.foreground = WhitePixelOfScreen(Tk_Screen(tkwin)); + } else { + gcValues.foreground = BlackPixelOfScreen(Tk_Screen(tkwin)); + } + newGC = Tk_GetGC(tkwin, GCForeground, &gcValues); + } else { + newGC = None; + } + if (textPtr->cursorOffGC != None) { + Tk_FreeGC(Tk_Display(tkwin), textPtr->cursorOffGC); + } + textPtr->cursorOffGC = newGC; + /* * If the text was changed, move the selection and insertion indices * to keep them inside the item. */ - if (canvasPtr->selItemPtr == itemPtr) { - if (canvasPtr->selectFirst >= textPtr->numChars) { - canvasPtr->selItemPtr = NULL; + if (textInfoPtr->selItemPtr == itemPtr) { + if (textInfoPtr->selectFirst >= textPtr->numChars) { + textInfoPtr->selItemPtr = NULL; } else { - if (canvasPtr->selectLast >= textPtr->numChars) { - canvasPtr->selectLast = textPtr->numChars-1; + if (textInfoPtr->selectLast >= textPtr->numChars) { + textInfoPtr->selectLast = textPtr->numChars-1; } - if ((canvasPtr->anchorItemPtr == itemPtr) - && (canvasPtr->selectAnchor >= textPtr->numChars)) { - canvasPtr->selectAnchor = textPtr->numChars-1; + if ((textInfoPtr->anchorItemPtr == itemPtr) + && (textInfoPtr->selectAnchor >= textPtr->numChars)) { + textInfoPtr->selectAnchor = textPtr->numChars-1; } } } @@ -401,7 +427,7 @@ ConfigureText(canvasPtr, itemPtr, argc, argv, flags) textPtr->insertPos = textPtr->numChars; } - ComputeTextBbox(canvasPtr, textPtr); + ComputeTextBbox(canvas, textPtr); return TCL_OK; } @@ -423,11 +449,13 @@ ConfigureText(canvasPtr, itemPtr, argc, argv, flags) */ static void -DeleteText(canvasPtr, itemPtr) - Tk_Canvas *canvasPtr; /* Info about overall canvas widget. */ +DeleteText(canvas, itemPtr, display) + Tk_Canvas canvas; /* Info about overall canvas widget. */ Tk_Item *itemPtr; /* Item that is being deleted. */ + Display *display; /* Display containing window for + * canvas. */ { - register TextItem *textPtr = (TextItem *) itemPtr; + TextItem *textPtr = (TextItem *) itemPtr; if (textPtr->text != NULL) { ckfree(textPtr->text); @@ -439,16 +467,19 @@ DeleteText(canvasPtr, itemPtr) Tk_FreeColor(textPtr->color); } if (textPtr->stipple != None) { - Tk_FreeBitmap(canvasPtr->display, textPtr->stipple); + Tk_FreeBitmap(display, textPtr->stipple); } if (textPtr->gc != None) { - Tk_FreeGC(canvasPtr->display, textPtr->gc); + Tk_FreeGC(display, textPtr->gc); } if (textPtr->linePtr != NULL) { ckfree((char *) textPtr->linePtr); } + if (textPtr->cursorOffGC != None) { + Tk_FreeGC(display, textPtr->cursorOffGC); + } if (textPtr->selTextGC != None) { - Tk_FreeGC(canvasPtr->display, textPtr->selTextGC); + Tk_FreeGC(display, textPtr->selTextGC); } } @@ -474,12 +505,12 @@ DeleteText(canvasPtr, itemPtr) */ static void -ComputeTextBbox(canvasPtr, textPtr) - register Tk_Canvas *canvasPtr; /* Canvas that contains item. */ - register TextItem *textPtr; /* Item whose bbos is to be +ComputeTextBbox(canvas, textPtr) + Tk_Canvas canvas; /* Canvas that contains item. */ + TextItem *textPtr; /* Item whose bbos is to be * recomputed. */ { - register TextLine *linePtr; + TextLine *linePtr; #define MAX_LINES 100 char *lineStart[MAX_LINES]; int lineChars[MAX_LINES]; @@ -488,6 +519,7 @@ ComputeTextBbox(canvasPtr, textPtr) int lineHeight, i, fudge; char *p; XCharStruct *maxBoundsPtr = &textPtr->fontPtr->max_bounds; + Tk_CanvasTextInfo *textInfoPtr = textPtr->textInfoPtr; if (textPtr->linePtr != NULL) { ckfree((char *) textPtr->linePtr); @@ -500,17 +532,17 @@ ComputeTextBbox(canvasPtr, textPtr) */ p = textPtr->text; + maxLinePixels = 0; if (textPtr->width > 0) { - wrapPixels = maxLinePixels = textPtr->width; + wrapPixels = textPtr->width; } else { wrapPixels = 10000000; - maxLinePixels = 0; } for (numLines = 0; (numLines < MAX_LINES); numLines++) { int numChars, numPixels; numChars = TkMeasureChars(textPtr->fontPtr, p, (textPtr->text + textPtr->numChars) - p, 0, - wrapPixels, TK_WHOLE_WORDS|TK_AT_LEAST_ONE, &numPixels); + wrapPixels, 0, TK_WHOLE_WORDS|TK_AT_LEAST_ONE, &numPixels); if (numPixels > maxLinePixels) { maxLinePixels = numPixels; } @@ -612,7 +644,6 @@ ComputeTextBbox(canvasPtr, textPtr) } switch (textPtr->justify) { case TK_JUSTIFY_LEFT: - case TK_JUSTIFY_FILL: linePtr->x = leftX; break; case TK_JUSTIFY_CENTER: @@ -650,9 +681,9 @@ ComputeTextBbox(canvasPtr, textPtr) } } - fudge = (canvasPtr->insertWidth+1)/2; - if (canvasPtr->selBorderWidth > fudge) { - fudge = canvasPtr->selBorderWidth; + fudge = (textInfoPtr->insertWidth+1)/2; + if (textInfoPtr->selBorderWidth > fudge) { + fudge = textInfoPtr->selBorderWidth; } textPtr->header.x1 -= fudge; textPtr->header.x2 += fudge; @@ -671,23 +702,28 @@ ComputeTextBbox(canvasPtr, textPtr) * * Side effects: * ItemPtr is drawn in drawable using the transformation - * information in canvasPtr. + * information in canvas. * *-------------------------------------------------------------- */ static void -DisplayText(canvasPtr, itemPtr, drawable) - register Tk_Canvas *canvasPtr; /* Canvas that contains item. */ +DisplayText(canvas, itemPtr, display, drawable, x, y, width, height) + Tk_Canvas canvas; /* Canvas that contains item. */ Tk_Item *itemPtr; /* Item to be displayed. */ + Display *display; /* Display on which to draw item. */ Drawable drawable; /* Pixmap or window in which to draw * item. */ + int x, y, width, height; /* Describes region of canvas that + * must be redisplayed (not used). */ { - register TextItem *textPtr = (TextItem *) itemPtr; - Display *display = Tk_Display(canvasPtr->tkwin); - register TextLine *linePtr; - int i, focusHere, insertX, insertIndex, lineIndex; + TextItem *textPtr = (TextItem *) itemPtr; + TextLine *linePtr; + int i, focusHere, insertX, insertIndex, lineIndex, tabOrigin; int beforeSelect, inSelect, afterSelect, selStartX, selEndX; + short drawableX, drawableY; + Tk_CanvasTextInfo *textInfoPtr = textPtr->textInfoPtr; + Tk_Window tkwin = Tk_CanvasTkwin(canvas); if (textPtr->gc == None) { return; @@ -700,12 +736,11 @@ DisplayText(canvasPtr, itemPtr, drawable) */ if (textPtr->stipple != None) { - XSetTSOrigin(display, textPtr->gc, - -canvasPtr->drawableXOrigin, -canvasPtr->drawableYOrigin); + Tk_CanvasSetStippleOrigin(canvas, textPtr->gc); } - focusHere = (canvasPtr->focusItemPtr == itemPtr) && - (canvasPtr->flags & GOT_FOCUS); + focusHere = (textInfoPtr->focusItemPtr == itemPtr) && + (textInfoPtr->gotFocus); for (linePtr = textPtr->linePtr, i = textPtr->numLines; i > 0; linePtr++, i--) { @@ -715,24 +750,24 @@ DisplayText(canvasPtr, itemPtr, drawable) */ lineIndex = linePtr->firstChar - textPtr->text; - if ((canvasPtr->selItemPtr != itemPtr) - || (canvasPtr->selectLast < lineIndex) - || (canvasPtr->selectFirst >= (lineIndex + if ((textInfoPtr->selItemPtr != itemPtr) + || (textInfoPtr->selectLast < lineIndex) + || (textInfoPtr->selectFirst >= (lineIndex + linePtr->totalChars))) { beforeSelect = linePtr->numChars; inSelect = 0; } else { - beforeSelect = canvasPtr->selectFirst - lineIndex; + beforeSelect = textInfoPtr->selectFirst - lineIndex; if (beforeSelect <= 0) { beforeSelect = 0; selStartX = linePtr->x; } else { (void) TkMeasureChars(textPtr->fontPtr, linePtr->firstChar, beforeSelect, 0, - (int) 1000000, TK_PARTIAL_OK, &selStartX); + (int) 1000000, 0, TK_PARTIAL_OK, &selStartX); selStartX += linePtr->x; } - inSelect = canvasPtr->selectLast + 1 - (lineIndex + beforeSelect); + inSelect = textInfoPtr->selectLast + 1 - (lineIndex + beforeSelect); /* * If the selection spans the end of this line, then display @@ -751,18 +786,19 @@ DisplayText(canvasPtr, itemPtr, drawable) } (void) TkMeasureChars(textPtr->fontPtr, linePtr->firstChar + beforeSelect, inSelect, - selStartX-linePtr->x, (int) 1000000, TK_PARTIAL_OK, + selStartX-linePtr->x, (int) 1000000, 0, TK_PARTIAL_OK, &selEndX); selEndX += linePtr->x; fillSelectBackground: - Tk_Fill3DRectangle(display, drawable, canvasPtr->selBorder, - selStartX - canvasPtr->drawableXOrigin - - canvasPtr->selBorderWidth, - linePtr->y - canvasPtr->drawableYOrigin - - textPtr->fontPtr->ascent, - selEndX - selStartX + 2*canvasPtr->selBorderWidth, + Tk_CanvasDrawableCoords(canvas, + (double) (selStartX - textInfoPtr->selBorderWidth), + (double) (linePtr->y - textPtr->fontPtr->ascent), + &drawableX, &drawableY); + Tk_Fill3DRectangle(tkwin, drawable, textInfoPtr->selBorder, + drawableX, drawableY, + selEndX - selStartX + 2*textInfoPtr->selBorderWidth, textPtr->fontPtr->ascent + textPtr->fontPtr->descent, - canvasPtr->selBorderWidth, TK_RELIEF_RAISED); + textInfoPtr->selBorderWidth, TK_RELIEF_RAISED); } /* @@ -779,29 +815,32 @@ DisplayText(canvasPtr, itemPtr, drawable) - (linePtr->firstChar - textPtr->text); if ((insertIndex >= 0) && (insertIndex <= linePtr->numChars)) { (void) TkMeasureChars(textPtr->fontPtr, linePtr->firstChar, - insertIndex, 0, (int) 1000000, TK_PARTIAL_OK, &insertX); - if (canvasPtr->flags & CURSOR_ON) { - Tk_Fill3DRectangle(display, drawable, - canvasPtr->insertBorder, - linePtr->x - canvasPtr->drawableXOrigin - + insertX - (canvasPtr->insertWidth)/2, - linePtr->y - canvasPtr->drawableYOrigin - - textPtr->fontPtr->ascent, - canvasPtr->insertWidth, + insertIndex, 0, (int) 1000000, 0, TK_PARTIAL_OK, &insertX); + Tk_CanvasDrawableCoords(canvas, + (double) (linePtr->x + insertX + - (textInfoPtr->insertWidth)/2), + (double) (linePtr->y - textPtr->fontPtr->ascent), + &drawableX, &drawableY); + if (textInfoPtr->cursorOn) { + Tk_Fill3DRectangle(tkwin, drawable, + textInfoPtr->insertBorder, drawableX, drawableY, + textInfoPtr->insertWidth, textPtr->fontPtr->ascent + textPtr->fontPtr->descent, - canvasPtr->insertBorderWidth, TK_RELIEF_RAISED); - } else if (Tk_GetColorModel(canvasPtr->tkwin) != TK_COLOR){ - Tk_Fill3DRectangle(display, drawable, - canvasPtr->bgBorder, - linePtr->x - canvasPtr->drawableXOrigin - + insertX - (canvasPtr->insertWidth)/2, - linePtr->y - canvasPtr->drawableYOrigin - - textPtr->fontPtr->ascent, - canvasPtr->insertWidth, - textPtr->fontPtr->ascent - + textPtr->fontPtr->descent, - 0, TK_RELIEF_FLAT); + textInfoPtr->insertBorderWidth, TK_RELIEF_RAISED); + } else if (textPtr->cursorOffGC != None) { + /* Redraw the background over the area of the cursor, + * even though the cursor is turned off. This guarantees + * that the selection won't make the cursor invisible on + * mono displays, where both may be drawn in the same + * color. + */ + + XFillRectangle(display, drawable, textPtr->cursorOffGC, + drawableX, drawableY, + (unsigned) textInfoPtr->insertWidth, + (unsigned) (textPtr->fontPtr->ascent + + textPtr->fontPtr->descent)); } } } @@ -812,24 +851,28 @@ DisplayText(canvasPtr, itemPtr, drawable) * context), and the part after the selection. */ + Tk_CanvasDrawableCoords(canvas, (double) linePtr->x, + (double) linePtr->y, &drawableX, &drawableY); + tabOrigin = drawableX; if (beforeSelect != 0) { TkDisplayChars(display, drawable, textPtr->gc, textPtr->fontPtr, - linePtr->firstChar, beforeSelect, - linePtr->x - canvasPtr->drawableXOrigin, - linePtr->y - canvasPtr->drawableYOrigin, 0); + linePtr->firstChar, beforeSelect, drawableX, + drawableY, tabOrigin, 0); } if (inSelect != 0) { + Tk_CanvasDrawableCoords(canvas, (double) selStartX, + (double) linePtr->y, &drawableX, &drawableY); TkDisplayChars(display, drawable, textPtr->selTextGC, textPtr->fontPtr, linePtr->firstChar + beforeSelect, - inSelect, selStartX - canvasPtr->drawableXOrigin, - linePtr->y - canvasPtr->drawableYOrigin, 0); + inSelect, drawableX, drawableY, tabOrigin, 0); } afterSelect = linePtr->numChars - beforeSelect - inSelect; if (afterSelect > 0) { + Tk_CanvasDrawableCoords(canvas, (double) selEndX, + (double) linePtr->y, &drawableX, &drawableY); TkDisplayChars(display, drawable, textPtr->gc, textPtr->fontPtr, linePtr->firstChar + beforeSelect + inSelect, - afterSelect, selEndX - canvasPtr->drawableXOrigin, - linePtr->y - canvasPtr->drawableYOrigin, 0); + afterSelect, drawableX, drawableY, tabOrigin, 0); } } if (textPtr->stipple != None) { @@ -845,7 +888,7 @@ DisplayText(canvasPtr, itemPtr, drawable) * Insert characters into a text item at a given position. * * Results: - * Always returns TCL_OK. + * None. * * Side effects: * The text in the given item is modified. The cursor and @@ -855,21 +898,22 @@ DisplayText(canvasPtr, itemPtr, drawable) *-------------------------------------------------------------- */ -static int -TextInsert(canvasPtr, itemPtr, beforeThis, string) - Tk_Canvas *canvasPtr; /* Canvas containing text item. */ +static void +TextInsert(canvas, itemPtr, beforeThis, string) + Tk_Canvas canvas; /* Canvas containing text item. */ Tk_Item *itemPtr; /* Text item to be modified. */ int beforeThis; /* Index of character before which text is * to be inserted. */ char *string; /* New characters to be inserted. */ { - register TextItem *textPtr = (TextItem *) itemPtr; + TextItem *textPtr = (TextItem *) itemPtr; int length; char *new; + Tk_CanvasTextInfo *textInfoPtr = textPtr->textInfoPtr; length = strlen(string); if (length == 0) { - return TCL_OK; + return; } if (beforeThis < 0) { beforeThis = 0; @@ -879,7 +923,7 @@ TextInsert(canvasPtr, itemPtr, beforeThis, string) } new = (char *) ckalloc((unsigned) (textPtr->numChars + length + 1)); - strncpy(new, textPtr->text, beforeThis); + strncpy(new, textPtr->text, (size_t) beforeThis); strcpy(new+beforeThis, string); strcpy(new+beforeThis+length, textPtr->text+beforeThis); ckfree(textPtr->text); @@ -891,23 +935,22 @@ TextInsert(canvasPtr, itemPtr, beforeThis, string) * selection and cursor. Update the indices appropriately. */ - if (canvasPtr->selItemPtr == itemPtr) { - if (canvasPtr->selectFirst >= beforeThis) { - canvasPtr->selectFirst += length; + if (textInfoPtr->selItemPtr == itemPtr) { + if (textInfoPtr->selectFirst >= beforeThis) { + textInfoPtr->selectFirst += length; } - if (canvasPtr->selectLast >= beforeThis) { - canvasPtr->selectLast += length; + if (textInfoPtr->selectLast >= beforeThis) { + textInfoPtr->selectLast += length; } - if ((canvasPtr->anchorItemPtr == itemPtr) - && (canvasPtr->selectAnchor >= beforeThis)) { - canvasPtr->selectAnchor += length; + if ((textInfoPtr->anchorItemPtr == itemPtr) + && (textInfoPtr->selectAnchor >= beforeThis)) { + textInfoPtr->selectAnchor += length; } } if (textPtr->insertPos >= beforeThis) { textPtr->insertPos += length; } - ComputeTextBbox(canvasPtr, textPtr); - return TCL_OK; + ComputeTextBbox(canvas, textPtr); } /* @@ -918,7 +961,7 @@ TextInsert(canvasPtr, itemPtr, beforeThis, string) * Delete one or more characters from a text item. * * Results: - * Always returns TCL_OK. + * None. * * Side effects: * Characters between "first" and "last", inclusive, get @@ -928,16 +971,17 @@ TextInsert(canvasPtr, itemPtr, beforeThis, string) *-------------------------------------------------------------- */ -static int -TextDeleteChars(canvasPtr, itemPtr, first, last) - Tk_Canvas *canvasPtr; /* Canvas containing itemPtr. */ +static void +TextDeleteChars(canvas, itemPtr, first, last) + Tk_Canvas canvas; /* Canvas containing itemPtr. */ Tk_Item *itemPtr; /* Item in which to delete characters. */ int first; /* Index of first character to delete. */ int last; /* Index of last character to delete. */ { - register TextItem *textPtr = (TextItem *) itemPtr; + TextItem *textPtr = (TextItem *) itemPtr; int count; char *new; + Tk_CanvasTextInfo *textInfoPtr = textPtr->textInfoPtr; if (first < 0) { first = 0; @@ -946,12 +990,12 @@ TextDeleteChars(canvasPtr, itemPtr, first, last) last = textPtr->numChars-1; } if (first > last) { - return TCL_OK; + return; } count = last + 1 - first; - new = ckalloc((unsigned) (textPtr->numChars + 1 - count)); - strncpy(new, textPtr->text, first); + new = (char *) ckalloc((unsigned) (textPtr->numChars + 1 - count)); + strncpy(new, textPtr->text, (size_t) first); strcpy(new+first, textPtr->text+last+1); ckfree(textPtr->text); textPtr->text = new; @@ -962,27 +1006,27 @@ TextDeleteChars(canvasPtr, itemPtr, first, last) * renumbering of the remaining characters. */ - if (canvasPtr->selItemPtr == itemPtr) { - if (canvasPtr->selectFirst > first) { - canvasPtr->selectFirst -= count; - if (canvasPtr->selectFirst < first) { - canvasPtr->selectFirst = first; + if (textInfoPtr->selItemPtr == itemPtr) { + if (textInfoPtr->selectFirst > first) { + textInfoPtr->selectFirst -= count; + if (textInfoPtr->selectFirst < first) { + textInfoPtr->selectFirst = first; } } - if (canvasPtr->selectLast >= first) { - canvasPtr->selectLast -= count; - if (canvasPtr->selectLast < (first-1)) { - canvasPtr->selectLast = (first-1); + if (textInfoPtr->selectLast >= first) { + textInfoPtr->selectLast -= count; + if (textInfoPtr->selectLast < (first-1)) { + textInfoPtr->selectLast = (first-1); } } - if (canvasPtr->selectFirst > canvasPtr->selectLast) { - canvasPtr->selItemPtr = NULL; + if (textInfoPtr->selectFirst > textInfoPtr->selectLast) { + textInfoPtr->selItemPtr = NULL; } - if ((canvasPtr->anchorItemPtr == itemPtr) - && (canvasPtr->selectAnchor > first)) { - canvasPtr->selectAnchor -= count; - if (canvasPtr->selectAnchor < first) { - canvasPtr->selectAnchor = first; + if ((textInfoPtr->anchorItemPtr == itemPtr) + && (textInfoPtr->selectAnchor > first)) { + textInfoPtr->selectAnchor -= count; + if (textInfoPtr->selectAnchor < first) { + textInfoPtr->selectAnchor = first; } } } @@ -992,8 +1036,8 @@ TextDeleteChars(canvasPtr, itemPtr, first, last) textPtr->insertPos = first; } } - ComputeTextBbox(canvasPtr, textPtr); - return TCL_OK; + ComputeTextBbox(canvas, textPtr); + return; } /* @@ -1016,15 +1060,14 @@ TextDeleteChars(canvasPtr, itemPtr, first, last) *-------------------------------------------------------------- */ - /* ARGSUSED */ static double -TextToPoint(canvasPtr, itemPtr, pointPtr) - Tk_Canvas *canvasPtr; /* Canvas containing itemPtr. */ +TextToPoint(canvas, itemPtr, pointPtr) + Tk_Canvas canvas; /* Canvas containing itemPtr. */ Tk_Item *itemPtr; /* Item to check against point. */ double *pointPtr; /* Pointer to x and y coordinates. */ { TextItem *textPtr = (TextItem *) itemPtr; - register TextLine *linePtr; + TextLine *linePtr; int i; double xDiff, yDiff, dist, minDist; @@ -1100,17 +1143,16 @@ TextToPoint(canvasPtr, itemPtr, pointPtr) *-------------------------------------------------------------- */ - /* ARGSUSED */ static int -TextToArea(canvasPtr, itemPtr, rectPtr) - Tk_Canvas *canvasPtr; /* Canvas containing itemPtr. */ +TextToArea(canvas, itemPtr, rectPtr) + Tk_Canvas canvas; /* Canvas containing itemPtr. */ Tk_Item *itemPtr; /* Item to check against rectangle. */ double *rectPtr; /* Pointer to array of four coordinates * (x1, y1, x2, y2) describing rectangular * area. */ { TextItem *textPtr = (TextItem *) itemPtr; - register TextLine *linePtr; + TextLine *linePtr; int i, result; /* @@ -1163,18 +1205,18 @@ TextToArea(canvasPtr, itemPtr, rectPtr) /* ARGSUSED */ static void -ScaleText(canvasPtr, itemPtr, originX, originY, scaleX, scaleY) - Tk_Canvas *canvasPtr; /* Canvas containing rectangle. */ +ScaleText(canvas, itemPtr, originX, originY, scaleX, scaleY) + Tk_Canvas canvas; /* Canvas containing rectangle. */ Tk_Item *itemPtr; /* Rectangle to be scaled. */ double originX, originY; /* Origin about which to scale rect. */ double scaleX; /* Amount to scale in X direction. */ double scaleY; /* Amount to scale in Y direction. */ { - register TextItem *textPtr = (TextItem *) itemPtr; + TextItem *textPtr = (TextItem *) itemPtr; textPtr->x = originX + scaleX*(textPtr->x - originX); textPtr->y = originY + scaleY*(textPtr->y - originY); - ComputeTextBbox(canvasPtr, textPtr); + ComputeTextBbox(canvas, textPtr); return; } @@ -1198,17 +1240,17 @@ ScaleText(canvasPtr, itemPtr, originX, originY, scaleX, scaleY) */ static void -TranslateText(canvasPtr, itemPtr, deltaX, deltaY) - Tk_Canvas *canvasPtr; /* Canvas containing item. */ +TranslateText(canvas, itemPtr, deltaX, deltaY) + Tk_Canvas canvas; /* Canvas containing item. */ Tk_Item *itemPtr; /* Item that is being moved. */ double deltaX, deltaY; /* Amount by which item is to be * moved. */ { - register TextItem *textPtr = (TextItem *) itemPtr; + TextItem *textPtr = (TextItem *) itemPtr; textPtr->x += deltaX; textPtr->y += deltaY; - ComputeTextBbox(canvasPtr, textPtr); + ComputeTextBbox(canvas, textPtr); } /* @@ -1223,7 +1265,7 @@ TranslateText(canvasPtr, itemPtr, deltaX, deltaY) * A standard Tcl result. If all went well, then *indexPtr is * filled in with the index (into itemPtr) corresponding to * string. Otherwise an error message is left in - * canvasPtr->interp->result. + * interp->result. * * Side effects: * None. @@ -1232,16 +1274,18 @@ TranslateText(canvasPtr, itemPtr, deltaX, deltaY) */ static int -GetTextIndex(canvasPtr, itemPtr, string, indexPtr) - Tk_Canvas *canvasPtr; /* Canvas containing item. */ +GetTextIndex(interp, canvas, itemPtr, string, indexPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tk_Canvas canvas; /* Canvas containing item. */ Tk_Item *itemPtr; /* Item for which the index is being * specified. */ char *string; /* Specification of a particular character * in itemPtr's text. */ int *indexPtr; /* Where to store converted index. */ { - register TextItem *textPtr = (TextItem *) itemPtr; - int length; + TextItem *textPtr = (TextItem *) itemPtr; + size_t length; + Tk_CanvasTextInfo *textInfoPtr = textPtr->textInfoPtr; length = strlen(string); @@ -1252,14 +1296,13 @@ GetTextIndex(canvasPtr, itemPtr, string, indexPtr) badIndex: /* - * Some of the paths here leave messages in - * canvasPtr->interp->result, so we have to clear it out - * before storing our own message. + * Some of the paths here leave messages in interp->result, + * so we have to clear it out before storing our own message. */ - Tcl_SetResult(canvasPtr->interp, (char *) NULL, TCL_STATIC); - Tcl_AppendResult(canvasPtr->interp, "bad index \"", string, - "\"", (char *) NULL); + Tcl_SetResult(interp, (char *) NULL, TCL_STATIC); + Tcl_AppendResult(interp, "bad index \"", string, "\"", + (char *) NULL); return TCL_ERROR; } } else if (string[0] == 'i') { @@ -1269,35 +1312,38 @@ GetTextIndex(canvasPtr, itemPtr, string, indexPtr) goto badIndex; } } else if (string[0] == 's') { - if (canvasPtr->selItemPtr != itemPtr) { - canvasPtr->interp->result = "selection isn't in item"; + if (textInfoPtr->selItemPtr != itemPtr) { + interp->result = "selection isn't in item"; return TCL_ERROR; } if (length < 5) { goto badIndex; } if (strncmp(string, "sel.first", length) == 0) { - *indexPtr = canvasPtr->selectFirst; + *indexPtr = textInfoPtr->selectFirst; } else if (strncmp(string, "sel.last", length) == 0) { - *indexPtr = canvasPtr->selectLast; + *indexPtr = textInfoPtr->selectLast; } else { goto badIndex; } } else if (string[0] == '@') { int x, y, dummy, i; + double tmp; char *end, *p; - register TextLine *linePtr; + TextLine *linePtr; p = string+1; - x = strtol(p, &end, 0); + tmp = strtod(p, &end); if ((end == p) || (*end != ',')) { goto badIndex; } + x = (tmp < 0) ? tmp - 0.5 : tmp + 0.5; p = end+1; - y = strtol(p, &end, 0); + tmp = strtod(p, &end); if ((end == p) || (*end != 0)) { goto badIndex; } + y = (tmp < 0) ? tmp - 0.5 : tmp + 0.5; if ((textPtr->numChars == 0) || (y < textPtr->linePtr[0].y1)) { *indexPtr = 0; return TCL_OK; @@ -1312,10 +1358,10 @@ GetTextIndex(canvasPtr, itemPtr, string, indexPtr) } } *indexPtr = TkMeasureChars(textPtr->fontPtr, linePtr->firstChar, - linePtr->numChars, linePtr->x, x, 0, &dummy); + linePtr->numChars, linePtr->x, x, linePtr->x, 0, &dummy); *indexPtr += linePtr->firstChar - textPtr->text; } else { - if (Tcl_GetInt(canvasPtr->interp, string, indexPtr) != TCL_OK) { + if (Tcl_GetInt(interp, string, indexPtr) != TCL_OK) { goto badIndex; } if (*indexPtr < 0){ @@ -1345,14 +1391,14 @@ GetTextIndex(canvasPtr, itemPtr, string, indexPtr) /* ARGSUSED */ static void -SetTextCursor(canvasPtr, itemPtr, index) - Tk_Canvas *canvasPtr; /* Record describing canvas widget. */ +SetTextCursor(canvas, itemPtr, index) + Tk_Canvas canvas; /* Record describing canvas widget. */ Tk_Item *itemPtr; /* Text item in which cursor position * is to be set. */ int index; /* Index of character just before which * cursor is to be positioned. */ { - register TextItem *textPtr = (TextItem *) itemPtr; + TextItem *textPtr = (TextItem *) itemPtr; if (index < 0) { textPtr->insertPos = 0; @@ -1385,8 +1431,8 @@ SetTextCursor(canvasPtr, itemPtr, index) */ static int -GetSelText(canvasPtr, itemPtr, offset, buffer, maxBytes) - Tk_Canvas *canvasPtr; /* Canvas containing selection. */ +GetSelText(canvas, itemPtr, offset, buffer, maxBytes) + Tk_Canvas canvas; /* Canvas containing selection. */ Tk_Item *itemPtr; /* Text item containing selection. */ int offset; /* Offset within selection of first * character to be returned. */ @@ -1398,9 +1444,10 @@ GetSelText(canvasPtr, itemPtr, offset, buffer, maxBytes) { TextItem *textPtr = (TextItem *) itemPtr; int count; + Tk_CanvasTextInfo *textInfoPtr = textPtr->textInfoPtr; - count = canvasPtr->selectLast + 1 - canvasPtr->selectFirst - offset; - if (canvasPtr->selectLast == textPtr->numChars) { + count = textInfoPtr->selectLast + 1 - textInfoPtr->selectFirst - offset; + if (textInfoPtr->selectLast == textPtr->numChars) { count -= 1; } if (count > maxBytes) { @@ -1409,7 +1456,8 @@ GetSelText(canvasPtr, itemPtr, offset, buffer, maxBytes) if (count <= 0) { return 0; } - strncpy(buffer, textPtr->text + canvasPtr->selectFirst + offset, count); + strncpy(buffer, textPtr->text + textInfoPtr->selectFirst + offset, + (size_t) count); buffer[count] = '\0'; return count; } @@ -1425,7 +1473,7 @@ GetSelText(canvasPtr, itemPtr, offset, buffer, maxBytes) * Results: * The return value is a standard Tcl result. If an error * occurs in generating Postscript then an error message is - * left in canvasPtr->interp->result, replacing whatever used + * left in interp->result, replacing whatever used * to be there. If no error occurs, then Postscript for the * item is appended to the result. * @@ -1436,16 +1484,18 @@ GetSelText(canvasPtr, itemPtr, offset, buffer, maxBytes) */ static int -TextToPostscript(canvasPtr, itemPtr, psInfoPtr) - Tk_Canvas *canvasPtr; /* Information about overall canvas. */ +TextToPostscript(interp, canvas, itemPtr, prepass) + Tcl_Interp *interp; /* Leave Postscript or error message + * here. */ + Tk_Canvas canvas; /* Information about overall canvas. */ Tk_Item *itemPtr; /* Item for which Postscript is * wanted. */ - Tk_PostscriptInfo *psInfoPtr; /* Information about the Postscript; - * must be passed back to Postscript - * utility procedures. */ + int prepass; /* 1 means this is a prepass to + * collect font information; 0 means + * final Postscript is being created. */ { - register TextItem *textPtr = (TextItem *) itemPtr; - register TextLine *linePtr; + TextItem *textPtr = (TextItem *) itemPtr; + TextLine *linePtr; int i; char *xoffset = NULL, *yoffset = NULL; /* Initializations needed */ char *justify = NULL; /* only to stop compiler @@ -1456,21 +1506,27 @@ TextToPostscript(canvasPtr, itemPtr, psInfoPtr) return TCL_OK; } - if (TkCanvPsFont(canvasPtr, psInfoPtr, textPtr->fontPtr) != TCL_OK) { + if (Tk_CanvasPsFont(interp, canvas, textPtr->fontPtr) != TCL_OK) { return TCL_ERROR; } - if (TkCanvPsColor(canvasPtr, psInfoPtr, textPtr->color) != TCL_OK) { + if (Tk_CanvasPsColor(interp, canvas, textPtr->color) != TCL_OK) { return TCL_ERROR; } + if (textPtr->stipple != None) { + Tcl_AppendResult(interp, "/StippleText {\n ", + (char *) NULL); + Tk_CanvasPsStipple(interp, canvas, textPtr->stipple); + Tcl_AppendResult(interp, "} bind def\n", (char *) NULL); + } sprintf(buffer, "%.15g %.15g [\n", textPtr->x, - TkCanvPsY(psInfoPtr, textPtr->y)); - Tcl_AppendResult(canvasPtr->interp, buffer, (char *) NULL); + Tk_CanvasPsY(canvas, textPtr->y)); + Tcl_AppendResult(interp, buffer, (char *) NULL); for (i = textPtr->numLines, linePtr = textPtr->linePtr; i > 0; i--, linePtr++) { - Tcl_AppendResult(canvasPtr->interp, " ", (char *) NULL); - LineToPostscript(canvasPtr->interp, linePtr->firstChar, + Tcl_AppendResult(interp, " ", (char *) NULL); + LineToPostscript(interp, linePtr->firstChar, linePtr->numChars); - Tcl_AppendResult(canvasPtr->interp, "\n", (char *) NULL); + Tcl_AppendResult(interp, "\n", (char *) NULL); } switch (textPtr->anchor) { case TK_ANCHOR_NW: xoffset = "0"; yoffset = "0"; break; @@ -1485,14 +1541,14 @@ TextToPostscript(canvasPtr, itemPtr, psInfoPtr) } switch (textPtr->justify) { case TK_JUSTIFY_LEFT: justify = "0"; break; - case TK_JUSTIFY_FILL: case TK_JUSTIFY_CENTER: justify = "0.5"; break; case TK_JUSTIFY_RIGHT: justify = "1"; break; } - sprintf(buffer, "] %d %s %s %s () false DrawText\n", + sprintf(buffer, "] %d %s %s %s %s DrawText\n", textPtr->fontPtr->ascent + textPtr->fontPtr->descent, - xoffset, yoffset, justify); - Tcl_AppendResult(canvasPtr->interp, buffer, (char *) NULL); + xoffset, yoffset, justify, + (textPtr->stipple == None) ? "false" : "true"); + Tcl_AppendResult(interp, buffer, (char *) NULL); return TCL_OK; } @@ -1518,7 +1574,7 @@ TextToPostscript(canvasPtr, itemPtr, psInfoPtr) static void LineToPostscript(interp, string, numChars) Tcl_Interp *interp; /* Interp whose result is to be appended to. */ - register char *string; /* String to Postscript-ify. */ + char *string; /* String to Postscript-ify. */ int numChars; /* Number of characters in the string. */ { #define BUFFER_SIZE 100 diff --git a/tk4.2/generic/tkCanvUtil.c b/tk4.2/generic/tkCanvUtil.c new file mode 100644 index 0000000..7f0ba70 --- /dev/null +++ b/tk4.2/generic/tkCanvUtil.c @@ -0,0 +1,376 @@ +/* + * tkCanvUtil.c -- + * + * This procedure contains a collection of utility procedures + * used by the implementations of various canvas item types. + * + * Copyright (c) 1994 Sun Microsystems, Inc. + * Copyright (c) 1994 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkCanvUtil.c 1.6 96/02/15 18:53:10 + */ + +#include "tk.h" +#include "tkCanvas.h" +#include "tkPort.h" + + +/* + *---------------------------------------------------------------------- + * + * Tk_CanvasTkwin -- + * + * Given a token for a canvas, this procedure returns the + * widget that represents the canvas. + * + * Results: + * The return value is a handle for the widget. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tk_Window +Tk_CanvasTkwin(canvas) + Tk_Canvas canvas; /* Token for the canvas. */ +{ + TkCanvas *canvasPtr = (TkCanvas *) canvas; + return canvasPtr->tkwin; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_CanvasDrawableCoords -- + * + * Given an (x,y) coordinate pair within a canvas, this procedure + * returns the corresponding coordinates at which the point should + * be drawn in the drawable used for display. + * + * Results: + * There is no return value. The values at *drawableXPtr and + * *drawableYPtr are filled in with the coordinates at which + * x and y should be drawn. These coordinates are clipped + * to fit within a "short", since this is what X uses in + * most cases for drawing. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tk_CanvasDrawableCoords(canvas, x, y, drawableXPtr, drawableYPtr) + Tk_Canvas canvas; /* Token for the canvas. */ + double x, y; /* Coordinates in canvas space. */ + short *drawableXPtr, *drawableYPtr; /* Screen coordinates are stored + * here. */ +{ + TkCanvas *canvasPtr = (TkCanvas *) canvas; + double tmp; + + tmp = x - canvasPtr->drawableXOrigin; + if (tmp > 0) { + tmp += 0.5; + } else { + tmp -= 0.5; + } + if (tmp > 32767) { + *drawableXPtr = 32767; + } else if (tmp < -32768) { + *drawableXPtr = -32768; + } else { + *drawableXPtr = tmp; + } + + tmp = y - canvasPtr->drawableYOrigin; + if (tmp > 0) { + tmp += 0.5; + } else { + tmp -= 0.5; + } + if (tmp > 32767) { + *drawableYPtr = 32767; + } else if (tmp < -32768) { + *drawableYPtr = -32768; + } else { + *drawableYPtr = tmp; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tk_CanvasWindowCoords -- + * + * Given an (x,y) coordinate pair within a canvas, this procedure + * returns the corresponding coordinates in the canvas's window. + * + * Results: + * There is no return value. The values at *screenXPtr and + * *screenYPtr are filled in with the coordinates at which + * (x,y) appears in the canvas's window. These coordinates + * are clipped to fit within a "short", since this is what X + * uses in most cases for drawing. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tk_CanvasWindowCoords(canvas, x, y, screenXPtr, screenYPtr) + Tk_Canvas canvas; /* Token for the canvas. */ + double x, y; /* Coordinates in canvas space. */ + short *screenXPtr, *screenYPtr; /* Screen coordinates are stored + * here. */ +{ + TkCanvas *canvasPtr = (TkCanvas *) canvas; + double tmp; + + tmp = x - canvasPtr->xOrigin; + if (tmp > 0) { + tmp += 0.5; + } else { + tmp -= 0.5; + } + if (tmp > 32767) { + *screenXPtr = 32767; + } else if (tmp < -32768) { + *screenXPtr = -32768; + } else { + *screenXPtr = tmp; + } + + tmp = y - canvasPtr->yOrigin; + if (tmp > 0) { + tmp += 0.5; + } else { + tmp -= 0.5; + } + if (tmp > 32767) { + *screenYPtr = 32767; + } else if (tmp < -32768) { + *screenYPtr = -32768; + } else { + *screenYPtr = tmp; + } +} + +/* + *-------------------------------------------------------------- + * + * Tk_CanvasGetCoord -- + * + * Given a string, returns a floating-point canvas coordinate + * corresponding to that string. + * + * Results: + * The return value is a standard Tcl return result. If + * TCL_OK is returned, then everything went well and the + * canvas coordinate is stored at *doublePtr; otherwise + * TCL_ERROR is returned and an error message is left in + * interp->result. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +Tk_CanvasGetCoord(interp, canvas, string, doublePtr) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + Tk_Canvas canvas; /* Canvas to which coordinate applies. */ + char *string; /* Describes coordinate (any screen + * coordinate form may be used here). */ + double *doublePtr; /* Place to store converted coordinate. */ +{ + TkCanvas *canvasPtr = (TkCanvas *) canvas; + if (Tk_GetScreenMM(canvasPtr->interp, canvasPtr->tkwin, string, + doublePtr) != TCL_OK) { + return TCL_ERROR; + } + *doublePtr *= canvasPtr->pixelsPerMM; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_CanvasSetStippleOrigin -- + * + * This procedure sets the stipple origin in a graphics context + * so that stipples drawn with the GC will line up with other + * stipples previously drawn in the canvas. + * + * Results: + * None. + * + * Side effects: + * The graphics context is modified. + * + *---------------------------------------------------------------------- + */ + +void +Tk_CanvasSetStippleOrigin(canvas, gc) + Tk_Canvas canvas; /* Token for a canvas. */ + GC gc; /* Graphics context that is about to be + * used to draw a stippled pattern as + * part of redisplaying the canvas. */ + +{ + TkCanvas *canvasPtr = (TkCanvas *) canvas; + + XSetTSOrigin(canvasPtr->display, gc, -canvasPtr->drawableXOrigin, + -canvasPtr->drawableYOrigin); +} + +/* + *---------------------------------------------------------------------- + * + * Tk_CanvasGetTextInfo -- + * + * This procedure returns a pointer to a structure containing + * information about the selection and insertion cursor for + * a canvas widget. Items such as text items save the pointer + * and use it to share access to the information with the generic + * canvas code. + * + * Results: + * The return value is a pointer to the structure holding text + * information for the canvas. Most of the fields should not + * be modified outside the generic canvas code; see the user + * documentation for details. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tk_CanvasTextInfo * +Tk_CanvasGetTextInfo(canvas) + Tk_Canvas canvas; /* Token for the canvas widget. */ +{ + return &((TkCanvas *) canvas)->textInfo; +} + +/* + *-------------------------------------------------------------- + * + * Tk_CanvasTagsParseProc -- + * + * This procedure is invoked during option processing to handle + * "-tags" options for canvas items. + * + * Results: + * A standard Tcl return value. + * + * Side effects: + * The tags for a given item get replaced by those indicated + * in the value argument. + * + *-------------------------------------------------------------- + */ + +int +Tk_CanvasTagsParseProc(clientData, interp, tkwin, value, widgRec, offset) + ClientData clientData; /* Not used.*/ + Tcl_Interp *interp; /* Used for reporting errors. */ + Tk_Window tkwin; /* Window containing canvas widget. */ + char *value; /* Value of option (list of tag + * names). */ + char *widgRec; /* Pointer to record for item. */ + int offset; /* Offset into item (ignored). */ +{ + register Tk_Item *itemPtr = (Tk_Item *) widgRec; + int argc, i; + char **argv; + Tk_Uid *newPtr; + + /* + * Break the value up into the individual tag names. + */ + + if (Tcl_SplitList(interp, value, &argc, &argv) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Make sure that there's enough space in the item to hold the + * tag names. + */ + + if (itemPtr->tagSpace < argc) { + newPtr = (Tk_Uid *) ckalloc((unsigned) (argc * sizeof(Tk_Uid))); + for (i = itemPtr->numTags-1; i >= 0; i--) { + newPtr[i] = itemPtr->tagPtr[i]; + } + if (itemPtr->tagPtr != itemPtr->staticTagSpace) { + ckfree((char *) itemPtr->tagPtr); + } + itemPtr->tagPtr = newPtr; + itemPtr->tagSpace = argc; + } + itemPtr->numTags = argc; + for (i = 0; i < argc; i++) { + itemPtr->tagPtr[i] = Tk_GetUid(argv[i]); + } + ckfree((char *) argv); + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * Tk_CanvasTagsPrintProc -- + * + * This procedure is invoked by the Tk configuration code + * to produce a printable string for the "-tags" configuration + * option for canvas items. + * + * Results: + * The return value is a string describing all the tags for + * the item referred to by "widgRec". In addition, *freeProcPtr + * is filled in with the address of a procedure to call to free + * the result string when it's no longer needed (or NULL to + * indicate that the string doesn't need to be freed). + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +char * +Tk_CanvasTagsPrintProc(clientData, tkwin, widgRec, offset, freeProcPtr) + ClientData clientData; /* Ignored. */ + Tk_Window tkwin; /* Window containing canvas widget. */ + char *widgRec; /* Pointer to record for item. */ + int offset; /* Ignored. */ + Tcl_FreeProc **freeProcPtr; /* Pointer to variable to fill in with + * information about how to reclaim + * storage for return string. */ +{ + register Tk_Item *itemPtr = (Tk_Item *) widgRec; + + if (itemPtr->numTags == 0) { + *freeProcPtr = (Tcl_FreeProc *) NULL; + return ""; + } + if (itemPtr->numTags == 1) { + *freeProcPtr = (Tcl_FreeProc *) NULL; + return (char *) itemPtr->tagPtr[0]; + } + *freeProcPtr = TCL_DYNAMIC; + return Tcl_Merge(itemPtr->numTags, (char **) itemPtr->tagPtr); +} diff --git a/tk3.6/tkCanvWind.c b/tk4.2/generic/tkCanvWind.c similarity index 65% rename from tk3.6/tkCanvWind.c rename to tk4.2/generic/tkCanvWind.c index 7d0967f..1bd491d 100644 --- a/tk3.6/tkCanvWind.c +++ b/tk4.2/generic/tkCanvWind.c @@ -3,34 +3,18 @@ * * This file implements window items for canvas widgets. * - * Copyright (c) 1992-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1992-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tkCanvWind.c 1.26 96/09/06 08:41:52 */ -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkCanvWind.c,v 1.10 93/10/06 16:27:45 ouster Exp $ SPRITE (Berkeley)"; -#endif - #include #include "tkInt.h" -#include "tkConfig.h" +#include "tkPort.h" #include "tkCanvas.h" /* @@ -50,20 +34,24 @@ typedef struct WindowItem { * window's requested width). */ Tk_Anchor anchor; /* Where to anchor window relative to * (x,y). */ - Tk_Canvas *canvasPtr; /* Canvas containing this item. */ + Tk_Canvas canvas; /* Canvas containing this item. */ } WindowItem; /* * Information used for parsing configuration specs: */ +static Tk_CustomOption tagsOption = {Tk_CanvasTagsParseProc, + Tk_CanvasTagsPrintProc, (ClientData) NULL +}; + static Tk_ConfigSpec configSpecs[] = { {TK_CONFIG_ANCHOR, "-anchor", (char *) NULL, (char *) NULL, "center", Tk_Offset(WindowItem, anchor), TK_CONFIG_DONT_SET_DEFAULT}, {TK_CONFIG_PIXELS, "-height", (char *) NULL, (char *) NULL, "0", Tk_Offset(WindowItem, height), TK_CONFIG_DONT_SET_DEFAULT}, {TK_CONFIG_CUSTOM, "-tags", (char *) NULL, (char *) NULL, - (char *) NULL, 0, TK_CONFIG_NULL_OK, &tkCanvasTagsOption}, + (char *) NULL, 0, TK_CONFIG_NULL_OK, &tagsOption}, {TK_CONFIG_PIXELS, "-width", (char *) NULL, (char *) NULL, "0", Tk_Offset(WindowItem, width), TK_CONFIG_DONT_SET_DEFAULT}, {TK_CONFIG_WINDOW, "-window", (char *) NULL, (char *) NULL, @@ -76,39 +64,44 @@ static Tk_ConfigSpec configSpecs[] = { * Prototypes for procedures defined in this file: */ -static void ComputeWindowBbox _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static void ComputeWindowBbox _ANSI_ARGS_((Tk_Canvas canvas, WindowItem *winItemPtr)); -static int ConfigureWinItem _ANSI_ARGS_(( - Tk_Canvas *canvasPtr, Tk_Item *itemPtr, int argc, +static int ConfigureWinItem _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int argc, char **argv, int flags)); -static int CreateWinItem _ANSI_ARGS_((Tk_Canvas *canvasPtr, - struct Tk_Item *itemPtr, int argc, char **argv)); -static void DeleteWinItem _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr)); -static void DisplayWinItem _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, Drawable dst)); -static void ScaleWinItem _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static int CreateWinItem _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, struct Tk_Item *itemPtr, + int argc, char **argv)); +static void DeleteWinItem _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, Display *display)); +static void DisplayWinItem _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, Display *display, Drawable dst, + int x, int y, int width, int height)); +static void ScaleWinItem _ANSI_ARGS_((Tk_Canvas canvas, Tk_Item *itemPtr, double originX, double originY, double scaleX, double scaleY)); -static void TranslateWinItem _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static void TranslateWinItem _ANSI_ARGS_((Tk_Canvas canvas, Tk_Item *itemPtr, double deltaX, double deltaY)); -static int WinItemCoords _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, int argc, char **argv)); +static int WinItemCoords _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int argc, + char **argv)); +static void WinItemLostSlaveProc _ANSI_ARGS_(( + ClientData clientData, Tk_Window tkwin)); static void WinItemRequestProc _ANSI_ARGS_((ClientData clientData, Tk_Window tkwin)); static void WinItemStructureProc _ANSI_ARGS_(( ClientData clientData, XEvent *eventPtr)); -static int WinItemToArea _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static int WinItemToArea _ANSI_ARGS_((Tk_Canvas canvas, Tk_Item *itemPtr, double *rectPtr)); -static double WinItemToPoint _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static double WinItemToPoint _ANSI_ARGS_((Tk_Canvas canvas, Tk_Item *itemPtr, double *pointPtr)); /* - * The structures below defines the rectangle and oval item types - * by means of procedures that can be invoked by generic item code. + * The structure below defines the window item type by means of procedures + * that can be invoked by generic item code. */ -Tk_ItemType TkWindowType = { +Tk_ItemType tkWindowType = { "window", /* name */ sizeof(WindowItem), /* itemSize */ CreateWinItem, /* createProc */ @@ -130,6 +123,18 @@ Tk_ItemType TkWindowType = { (Tk_ItemDCharsProc *) NULL, /* dTextProc */ (Tk_ItemType *) NULL /* nextPtr */ }; + + +/* + * The structure below defines the official type record for the + * placer: + */ + +static Tk_GeomMgr canvasGeomType = { + "canvas", /* name */ + WinItemRequestProc, /* requestProc */ + WinItemLostSlaveProc, /* lostSlaveProc */ +}; /* *-------------------------------------------------------------- @@ -142,7 +147,7 @@ Tk_ItemType TkWindowType = { * Results: * A standard Tcl return value. If an error occurred in * creating the item, then an error message is left in - * canvasPtr->interp->result; in this case itemPtr is + * interp->result; in this case itemPtr is * left uninitialized, so it can be safely freed by the * caller. * @@ -153,19 +158,20 @@ Tk_ItemType TkWindowType = { */ static int -CreateWinItem(canvasPtr, itemPtr, argc, argv) - register Tk_Canvas *canvasPtr; /* Canvas to hold new item. */ +CreateWinItem(interp, canvas, itemPtr, argc, argv) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + Tk_Canvas canvas; /* Canvas to hold new item. */ Tk_Item *itemPtr; /* Record to hold new item; header * has been initialized by caller. */ int argc; /* Number of arguments in argv. */ char **argv; /* Arguments describing rectangle. */ { - register WindowItem *winItemPtr = (WindowItem *) itemPtr; + WindowItem *winItemPtr = (WindowItem *) itemPtr; if (argc < 2) { - Tcl_AppendResult(canvasPtr->interp, "wrong # args: should be \"", - Tk_PathName(canvasPtr->tkwin), "\" create ", - itemPtr->typePtr->name, " x y ?options?", + Tcl_AppendResult(interp, "wrong # args: should be \"", + Tk_PathName(Tk_CanvasTkwin(canvas)), " create ", + itemPtr->typePtr->name, " x y ?options?\"", (char *) NULL); return TCL_ERROR; } @@ -178,20 +184,21 @@ CreateWinItem(canvasPtr, itemPtr, argc, argv) winItemPtr->width = 0; winItemPtr->height = 0; winItemPtr->anchor = TK_ANCHOR_CENTER; - winItemPtr->canvasPtr = canvasPtr; + winItemPtr->canvas = canvas; /* * Process the arguments to fill in the item record. */ - if ((TkGetCanvasCoord(canvasPtr, argv[0], &winItemPtr->x) != TCL_OK) - || (TkGetCanvasCoord(canvasPtr, argv[1], + if ((Tk_CanvasGetCoord(interp, canvas, argv[0], &winItemPtr->x) != TCL_OK) + || (Tk_CanvasGetCoord(interp, canvas, argv[1], &winItemPtr->y) != TCL_OK)) { return TCL_ERROR; } - if (ConfigureWinItem(canvasPtr, itemPtr, argc-2, argv+2, 0) != TCL_OK) { - DeleteWinItem(canvasPtr, itemPtr); + if (ConfigureWinItem(interp, canvas, itemPtr, argc-2, argv+2, 0) + != TCL_OK) { + DeleteWinItem(canvas, itemPtr, Tk_Display(Tk_CanvasTkwin(canvas))); return TCL_ERROR; } return TCL_OK; @@ -207,7 +214,7 @@ CreateWinItem(canvasPtr, itemPtr, argc, argv) * details on what it does. * * Results: - * Returns TCL_OK or TCL_ERROR, and sets canvasPtr->interp->result. + * Returns TCL_OK or TCL_ERROR, and sets interp->result. * * Side effects: * The coordinates for the given item may be changed. @@ -216,8 +223,9 @@ CreateWinItem(canvasPtr, itemPtr, argc, argv) */ static int -WinItemCoords(canvasPtr, itemPtr, argc, argv) - register Tk_Canvas *canvasPtr; /* Canvas containing item. */ +WinItemCoords(interp, canvas, itemPtr, argc, argv) + Tcl_Interp *interp; /* Used for error reporting. */ + Tk_Canvas canvas; /* Canvas containing item. */ Tk_Item *itemPtr; /* Item whose coordinates are to be * read or modified. */ int argc; /* Number of coordinates supplied in @@ -225,24 +233,23 @@ WinItemCoords(canvasPtr, itemPtr, argc, argv) char **argv; /* Array of coordinates: x1, y1, * x2, y2, ... */ { - register WindowItem *winItemPtr = (WindowItem *) itemPtr; + WindowItem *winItemPtr = (WindowItem *) itemPtr; char x[TCL_DOUBLE_SPACE], y[TCL_DOUBLE_SPACE]; if (argc == 0) { - Tcl_PrintDouble(canvasPtr->interp, winItemPtr->x, x); - Tcl_PrintDouble(canvasPtr->interp, winItemPtr->y, y); - Tcl_AppendResult(canvasPtr->interp, x, " ", y, (char *) NULL); + Tcl_PrintDouble(interp, winItemPtr->x, x); + Tcl_PrintDouble(interp, winItemPtr->y, y); + Tcl_AppendResult(interp, x, " ", y, (char *) NULL); } else if (argc == 2) { - if ((TkGetCanvasCoord(canvasPtr, argv[0], &winItemPtr->x) != TCL_OK) - || (TkGetCanvasCoord(canvasPtr, argv[1], - &winItemPtr->y) != TCL_OK)) { + if ((Tk_CanvasGetCoord(interp, canvas, argv[0], &winItemPtr->x) + != TCL_OK) || (Tk_CanvasGetCoord(interp, canvas, argv[1], + &winItemPtr->y) != TCL_OK)) { return TCL_ERROR; } - ComputeWindowBbox(canvasPtr, winItemPtr); + ComputeWindowBbox(canvas, winItemPtr); } else { - sprintf(canvasPtr->interp->result, - "wrong # coordinates: expected 0 or 2, got %d", - argc); + sprintf(interp->result, + "wrong # coordinates: expected 0 or 2, got %d", argc); return TCL_ERROR; } return TCL_OK; @@ -258,7 +265,7 @@ WinItemCoords(canvasPtr, itemPtr, argc, argv) * * Results: * A standard Tcl result code. If an error occurs, then - * an error message is left in canvasPtr->interp->result. + * an error message is left in interp->result. * * Side effects: * Configuration information may be set for itemPtr. @@ -267,19 +274,22 @@ WinItemCoords(canvasPtr, itemPtr, argc, argv) */ static int -ConfigureWinItem(canvasPtr, itemPtr, argc, argv, flags) - Tk_Canvas *canvasPtr; /* Canvas containing itemPtr. */ +ConfigureWinItem(interp, canvas, itemPtr, argc, argv, flags) + Tcl_Interp *interp; /* Used for error reporting. */ + Tk_Canvas canvas; /* Canvas containing itemPtr. */ Tk_Item *itemPtr; /* Window item to reconfigure. */ int argc; /* Number of elements in argv. */ char **argv; /* Arguments describing things to configure. */ int flags; /* Flags to pass to Tk_ConfigureWidget. */ { - register WindowItem *winItemPtr = (WindowItem *) itemPtr; + WindowItem *winItemPtr = (WindowItem *) itemPtr; Tk_Window oldWindow; + Tk_Window canvasTkwin; oldWindow = winItemPtr->tkwin; - if (Tk_ConfigureWidget(canvasPtr->interp, canvasPtr->tkwin, - configSpecs, argc, argv, (char *) winItemPtr, flags) != TCL_OK) { + canvasTkwin = Tk_CanvasTkwin(canvas); + if (Tk_ConfigureWidget(interp, canvasTkwin, configSpecs, argc, argv, + (char *) winItemPtr, flags) != TCL_OK) { return TCL_ERROR; } @@ -291,8 +301,9 @@ ConfigureWinItem(canvasPtr, itemPtr, argc, argv, flags) if (oldWindow != NULL) { Tk_DeleteEventHandler(oldWindow, StructureNotifyMask, WinItemStructureProc, (ClientData) winItemPtr); - Tk_ManageGeometry(oldWindow, (Tk_GeometryProc *) NULL, + Tk_ManageGeometry(oldWindow, (Tk_GeomMgr *) NULL, (ClientData) NULL); + Tk_UnmaintainGeometry(oldWindow, canvasTkwin); Tk_UnmapWindow(oldWindow); } if (winItemPtr->tkwin != NULL) { @@ -306,14 +317,14 @@ ConfigureWinItem(canvasPtr, itemPtr, argc, argv, flags) */ parent = Tk_Parent(winItemPtr->tkwin); - for (ancestor = canvasPtr->tkwin; ; + for (ancestor = canvasTkwin; ; ancestor = Tk_Parent(ancestor)) { if (ancestor == parent) { break; } if (((Tk_FakeWin *) (ancestor))->flags & TK_TOP_LEVEL) { badWindow: - Tcl_AppendResult(canvasPtr->interp, "can't use ", + Tcl_AppendResult(interp, "can't use ", Tk_PathName(winItemPtr->tkwin), " in a window item of this canvas", (char *) NULL); winItemPtr->tkwin = NULL; @@ -323,17 +334,17 @@ ConfigureWinItem(canvasPtr, itemPtr, argc, argv, flags) if (((Tk_FakeWin *) (winItemPtr->tkwin))->flags & TK_TOP_LEVEL) { goto badWindow; } - if (winItemPtr->tkwin == canvasPtr->tkwin) { + if (winItemPtr->tkwin == canvasTkwin) { goto badWindow; } Tk_CreateEventHandler(winItemPtr->tkwin, StructureNotifyMask, WinItemStructureProc, (ClientData) winItemPtr); - Tk_ManageGeometry(winItemPtr->tkwin, WinItemRequestProc, + Tk_ManageGeometry(winItemPtr->tkwin, &canvasGeomType, (ClientData) winItemPtr); } } - ComputeWindowBbox(canvasPtr, winItemPtr); + ComputeWindowBbox(canvas, winItemPtr); return TCL_OK; } @@ -355,19 +366,24 @@ ConfigureWinItem(canvasPtr, itemPtr, argc, argv, flags) *-------------------------------------------------------------- */ - /* ARGSUSED */ static void -DeleteWinItem(canvasPtr, itemPtr) - Tk_Canvas *canvasPtr; /* Overall info about widget. */ +DeleteWinItem(canvas, itemPtr, display) + Tk_Canvas canvas; /* Overall info about widget. */ Tk_Item *itemPtr; /* Item that is being deleted. */ + Display *display; /* Display containing window for + * canvas. */ { - register WindowItem *winItemPtr = (WindowItem *) itemPtr; + WindowItem *winItemPtr = (WindowItem *) itemPtr; + Tk_Window canvasTkwin = Tk_CanvasTkwin(canvas); if (winItemPtr->tkwin != NULL) { Tk_DeleteEventHandler(winItemPtr->tkwin, StructureNotifyMask, WinItemStructureProc, (ClientData) winItemPtr); - Tk_ManageGeometry(winItemPtr->tkwin, (Tk_GeometryProc *) NULL, + Tk_ManageGeometry(winItemPtr->tkwin, (Tk_GeomMgr *) NULL, (ClientData) NULL); + if (canvasTkwin != Tk_Parent(winItemPtr->tkwin)) { + Tk_UnmaintainGeometry(winItemPtr->tkwin, canvasTkwin); + } Tk_UnmapWindow(winItemPtr->tkwin); } } @@ -392,17 +408,16 @@ DeleteWinItem(canvasPtr, itemPtr) *-------------------------------------------------------------- */ - /* ARGSUSED */ static void -ComputeWindowBbox(canvasPtr, winItemPtr) - Tk_Canvas *canvasPtr; /* Canvas that contains item. */ - register WindowItem *winItemPtr; /* Item whose bbox is to be +ComputeWindowBbox(canvas, winItemPtr) + Tk_Canvas canvas; /* Canvas that contains item. */ + WindowItem *winItemPtr; /* Item whose bbox is to be * recomputed. */ { int width, height, x, y; - x = winItemPtr->x + 0.5; - y = winItemPtr->y + 0.5; + x = winItemPtr->x + ((winItemPtr->x >= 0) ? 0.5 : - 0.5); + y = winItemPtr->y + ((winItemPtr->y >= 0) ? 0.5 : - 0.5); if (winItemPtr->tkwin == NULL) { winItemPtr->header.x1 = winItemPtr->header.x2 = x; @@ -491,72 +506,56 @@ ComputeWindowBbox(canvasPtr, winItemPtr) * None. * * Side effects: - * The child window's position may get changed. + * The child window's position may get changed. Note: this + * procedure gets called both when a window needs to be displayed + * and when it ceases to be visible on the screen (e.g. it was + * scrolled or moved off-screen or the enclosing canvas is + * unmapped). * *-------------------------------------------------------------- */ - /* ARGSUSED */ static void -DisplayWinItem(canvasPtr, itemPtr, drawable) - register Tk_Canvas *canvasPtr; /* Canvas that contains item. */ +DisplayWinItem(canvas, itemPtr, display, drawable, regionX, regionY, + regionWidth, regionHeight) + Tk_Canvas canvas; /* Canvas that contains item. */ Tk_Item *itemPtr; /* Item to be displayed. */ + Display *display; /* Display on which to draw item. */ Drawable drawable; /* Pixmap or window in which to draw * item. */ + int regionX, regionY, regionWidth, regionHeight; + /* Describes region of canvas that + * must be redisplayed (not used). */ { - register WindowItem *winItemPtr = (WindowItem *) itemPtr; - int x,y, width, height; - Tk_Window ancestor, parent; + WindowItem *winItemPtr = (WindowItem *) itemPtr; + int width, height; + short x, y; + Tk_Window canvasTkwin = Tk_CanvasTkwin(canvas); if (winItemPtr->tkwin == NULL) { return; } - /* - * Note: this procedure gets called both when a window needs to - * be displayed and when it ceases to be visible on the screen - * (e.g. it was scrolled or moved off-screen or the enclosing - * canvas is unmapped). - */ - - if (!Tk_IsMapped(canvasPtr->tkwin)) { - /* - * Enclosing canvas just became unmapped; unmap the child window - * too. - */ - Tk_UnmapWindow(winItemPtr->tkwin); - return; - } - x = winItemPtr->header.x1 - canvasPtr->xOrigin; - y = winItemPtr->header.y1 - canvasPtr->yOrigin; + Tk_CanvasWindowCoords(canvas, (double) winItemPtr->header.x1, + (double) winItemPtr->header.y1, &x, &y); width = winItemPtr->header.x2 - winItemPtr->header.x1; height = winItemPtr->header.y2 - winItemPtr->header.y1; /* - * If the canvas isn't the parent of the window, then translate the - * coordinates from those of the canvas to those of the window's - * parent. + * Reposition and map the window (but in different ways depending + * on whether the canvas is the window's parent). */ - parent = Tk_Parent(winItemPtr->tkwin); - for (ancestor = canvasPtr->tkwin; ancestor != parent; - ancestor = Tk_Parent(ancestor)) { - x += Tk_X(ancestor) + Tk_Changes(ancestor)->border_width; - y += Tk_Y(ancestor) + Tk_Changes(ancestor)->border_width; - } - - /* - * Reconfigure the window if it isn't already in the correct place. - */ - - if ((x != Tk_X(winItemPtr->tkwin)) || (y != Tk_Y(winItemPtr->tkwin)) - || (width != Tk_Width(winItemPtr->tkwin)) - || (height != Tk_Height(winItemPtr->tkwin))) { - Tk_MoveResizeWindow(winItemPtr->tkwin, x, y, (unsigned int) width, - (unsigned int) height); - } - if (!Tk_IsMapped(winItemPtr->tkwin)) { + if (canvasTkwin == Tk_Parent(winItemPtr->tkwin)) { + if ((x != Tk_X(winItemPtr->tkwin)) || (y != Tk_Y(winItemPtr->tkwin)) + || (width != Tk_Width(winItemPtr->tkwin)) + || (height != Tk_Height(winItemPtr->tkwin))) { + Tk_MoveResizeWindow(winItemPtr->tkwin, x, y, width, height); + } Tk_MapWindow(winItemPtr->tkwin); + } else { + Tk_MaintainGeometry(winItemPtr->tkwin, canvasTkwin, x, y, + width, height); } } @@ -580,14 +579,13 @@ DisplayWinItem(canvasPtr, itemPtr, drawable) *-------------------------------------------------------------- */ - /* ARGSUSED */ static double -WinItemToPoint(canvasPtr, itemPtr, pointPtr) - Tk_Canvas *canvasPtr; /* Canvas containing item. */ +WinItemToPoint(canvas, itemPtr, pointPtr) + Tk_Canvas canvas; /* Canvas containing item. */ Tk_Item *itemPtr; /* Item to check against point. */ double *pointPtr; /* Pointer to x and y coordinates. */ { - register WindowItem *winItemPtr = (WindowItem *) itemPtr; + WindowItem *winItemPtr = (WindowItem *) itemPtr; double x1, x2, y1, y2, xDiff, yDiff; x1 = winItemPtr->header.x1; @@ -638,16 +636,15 @@ WinItemToPoint(canvasPtr, itemPtr, pointPtr) *-------------------------------------------------------------- */ - /* ARGSUSED */ static int -WinItemToArea(canvasPtr, itemPtr, rectPtr) - Tk_Canvas *canvasPtr; /* Canvas containing item. */ +WinItemToArea(canvas, itemPtr, rectPtr) + Tk_Canvas canvas; /* Canvas containing item. */ Tk_Item *itemPtr; /* Item to check against rectangle. */ double *rectPtr; /* Pointer to array of four coordinates * (x1, y1, x2, y2) describing rectangular * area. */ { - register WindowItem *winItemPtr = (WindowItem *) itemPtr; + WindowItem *winItemPtr = (WindowItem *) itemPtr; if ((rectPtr[2] <= winItemPtr->header.x1) || (rectPtr[0] >= winItemPtr->header.x2) @@ -686,24 +683,24 @@ WinItemToArea(canvasPtr, itemPtr, rectPtr) */ static void -ScaleWinItem(canvasPtr, itemPtr, originX, originY, scaleX, scaleY) - Tk_Canvas *canvasPtr; /* Canvas containing rectangle. */ +ScaleWinItem(canvas, itemPtr, originX, originY, scaleX, scaleY) + Tk_Canvas canvas; /* Canvas containing rectangle. */ Tk_Item *itemPtr; /* Rectangle to be scaled. */ double originX, originY; /* Origin about which to scale rect. */ double scaleX; /* Amount to scale in X direction. */ double scaleY; /* Amount to scale in Y direction. */ { - register WindowItem *winItemPtr = (WindowItem *) itemPtr; + WindowItem *winItemPtr = (WindowItem *) itemPtr; winItemPtr->x = originX + scaleX*(winItemPtr->x - originX); winItemPtr->y = originY + scaleY*(winItemPtr->y - originY); if (winItemPtr->width > 0) { - winItemPtr->width = scaleY*winItemPtr->width; + winItemPtr->width = scaleX*winItemPtr->width; } if (winItemPtr->height > 0) { winItemPtr->height = scaleY*winItemPtr->height; } - ComputeWindowBbox(canvasPtr, winItemPtr); + ComputeWindowBbox(canvas, winItemPtr); } /* @@ -726,17 +723,17 @@ ScaleWinItem(canvasPtr, itemPtr, originX, originY, scaleX, scaleY) */ static void -TranslateWinItem(canvasPtr, itemPtr, deltaX, deltaY) - Tk_Canvas *canvasPtr; /* Canvas containing item. */ +TranslateWinItem(canvas, itemPtr, deltaX, deltaY) + Tk_Canvas canvas; /* Canvas containing item. */ Tk_Item *itemPtr; /* Item that is being moved. */ double deltaX, deltaY; /* Amount by which item is to be * moved. */ { - register WindowItem *winItemPtr = (WindowItem *) itemPtr; + WindowItem *winItemPtr = (WindowItem *) itemPtr; winItemPtr->x += deltaX; winItemPtr->y += deltaY; - ComputeWindowBbox(canvasPtr, winItemPtr); + ComputeWindowBbox(canvas, winItemPtr); } /* @@ -764,7 +761,7 @@ WinItemStructureProc(clientData, eventPtr) ClientData clientData; /* Pointer to record describing window item. */ XEvent *eventPtr; /* Describes what just happened. */ { - register WindowItem *winItemPtr = (WindowItem *) clientData; + WindowItem *winItemPtr = (WindowItem *) clientData; if (eventPtr->type == DestroyNotify) { winItemPtr->tkwin = NULL; @@ -789,7 +786,6 @@ WinItemStructureProc(clientData, eventPtr) *-------------------------------------------------------------- */ - /* ARGSUSED */ static void WinItemRequestProc(clientData, tkwin) ClientData clientData; /* Pointer to record for window item. */ @@ -798,7 +794,43 @@ WinItemRequestProc(clientData, tkwin) { WindowItem *winItemPtr = (WindowItem *) clientData; - ComputeWindowBbox(winItemPtr->canvasPtr, winItemPtr); - DisplayWinItem(winItemPtr->canvasPtr, (Tk_Item *) winItemPtr, - (Drawable) None); + ComputeWindowBbox(winItemPtr->canvas, winItemPtr); + DisplayWinItem(winItemPtr->canvas, (Tk_Item *) winItemPtr, + (Display *) NULL, (Drawable) None, 0, 0, 0, 0); +} + +/* + *-------------------------------------------------------------- + * + * WinItemLostSlaveProc -- + * + * This procedure is invoked by Tk whenever some other geometry + * claims control over a slave that used to be managed by us. + * + * Results: + * None. + * + * Side effects: + * Forgets all canvas-related information about the slave. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +WinItemLostSlaveProc(clientData, tkwin) + ClientData clientData; /* WindowItem structure for slave window that + * was stolen away. */ + Tk_Window tkwin; /* Tk's handle for the slave window. */ +{ + WindowItem *winItemPtr = (WindowItem *) clientData; + Tk_Window canvasTkwin = Tk_CanvasTkwin(winItemPtr->canvas); + + Tk_DeleteEventHandler(winItemPtr->tkwin, StructureNotifyMask, + WinItemStructureProc, (ClientData) winItemPtr); + if (canvasTkwin != Tk_Parent(winItemPtr->tkwin)) { + Tk_UnmaintainGeometry(winItemPtr->tkwin, canvasTkwin); + } + Tk_UnmapWindow(winItemPtr->tkwin); + winItemPtr->tkwin = NULL; } diff --git a/tk3.6/tkCanvas.c b/tk4.2/generic/tkCanvas.c similarity index 63% rename from tk3.6/tkCanvas.c rename to tk4.2/generic/tkCanvas.c index 3cb23de..3864741 100644 --- a/tk3.6/tkCanvas.c +++ b/tk4.2/generic/tkCanvas.c @@ -1,4 +1,3 @@ - /* * tkCanvas.c -- * @@ -6,34 +5,18 @@ * A canvas displays a background and a collection of graphical * objects such as rectangles, lines, and texts. * - * Copyright (c) 1991-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tkCanvas.c 1.119 96/03/21 11:26:39 */ -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkCanvas.c,v 1.55 93/10/23 15:06:48 ouster Exp $ SPRITE (Berkeley)"; -#endif - #include "default.h" #include "tkInt.h" -#include "tkConfig.h" +#include "tkPort.h" #include "tkCanvas.h" /* @@ -47,7 +30,7 @@ static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkCanvas.c,v 1.55 93/10/2 */ typedef struct TagSearch { - Tk_Canvas *canvasPtr; /* Canvas widget being searched. */ + TkCanvas *canvasPtr; /* Canvas widget being searched. */ Tk_Uid tag; /* Tag to search for. 0 means return * all items. */ Tk_Item *prevPtr; /* Item just before last one found (or NULL @@ -62,75 +45,91 @@ typedef struct TagSearch { * Information used for argv parsing. */ - static Tk_ConfigSpec configSpecs[] = { {TK_CONFIG_BORDER, "-background", "background", "Background", - DEF_CANVAS_BG_COLOR, Tk_Offset(Tk_Canvas, bgBorder), + DEF_CANVAS_BG_COLOR, Tk_Offset(TkCanvas, bgBorder), TK_CONFIG_COLOR_ONLY}, {TK_CONFIG_BORDER, "-background", "background", "Background", - DEF_CANVAS_BG_MONO, Tk_Offset(Tk_Canvas, bgBorder), + DEF_CANVAS_BG_MONO, Tk_Offset(TkCanvas, bgBorder), TK_CONFIG_MONO_ONLY}, {TK_CONFIG_SYNONYM, "-bd", "borderWidth", (char *) NULL, (char *) NULL, 0, 0}, {TK_CONFIG_SYNONYM, "-bg", "background", (char *) NULL, (char *) NULL, 0, 0}, {TK_CONFIG_PIXELS, "-borderwidth", "borderWidth", "BorderWidth", - DEF_CANVAS_BORDER_WIDTH, Tk_Offset(Tk_Canvas, borderWidth), 0}, + DEF_CANVAS_BORDER_WIDTH, Tk_Offset(TkCanvas, borderWidth), 0}, {TK_CONFIG_DOUBLE, "-closeenough", "closeEnough", "CloseEnough", - DEF_CANVAS_CLOSE_ENOUGH, Tk_Offset(Tk_Canvas, closeEnough), 0}, + DEF_CANVAS_CLOSE_ENOUGH, Tk_Offset(TkCanvas, closeEnough), 0}, {TK_CONFIG_BOOLEAN, "-confine", "confine", "Confine", - DEF_CANVAS_CONFINE, Tk_Offset(Tk_Canvas, confine), 0}, + DEF_CANVAS_CONFINE, Tk_Offset(TkCanvas, confine), 0}, {TK_CONFIG_ACTIVE_CURSOR, "-cursor", "cursor", "Cursor", - DEF_CANVAS_CURSOR, Tk_Offset(Tk_Canvas, cursor), TK_CONFIG_NULL_OK}, + DEF_CANVAS_CURSOR, Tk_Offset(TkCanvas, cursor), TK_CONFIG_NULL_OK}, {TK_CONFIG_PIXELS, "-height", "height", "Height", - DEF_CANVAS_HEIGHT, Tk_Offset(Tk_Canvas, height), 0}, + DEF_CANVAS_HEIGHT, Tk_Offset(TkCanvas, height), 0}, + {TK_CONFIG_COLOR, "-highlightbackground", "highlightBackground", + "HighlightBackground", DEF_CANVAS_HIGHLIGHT_BG, + Tk_Offset(TkCanvas, highlightBgColorPtr), 0}, + {TK_CONFIG_COLOR, "-highlightcolor", "highlightColor", "HighlightColor", + DEF_CANVAS_HIGHLIGHT, Tk_Offset(TkCanvas, highlightColorPtr), 0}, + {TK_CONFIG_PIXELS, "-highlightthickness", "highlightThickness", + "HighlightThickness", + DEF_CANVAS_HIGHLIGHT_WIDTH, Tk_Offset(TkCanvas, highlightWidth), 0}, {TK_CONFIG_BORDER, "-insertbackground", "insertBackground", "Foreground", - DEF_CANVAS_INSERT_BG, Tk_Offset(Tk_Canvas, insertBorder), 0}, + DEF_CANVAS_INSERT_BG, Tk_Offset(TkCanvas, textInfo.insertBorder), 0}, {TK_CONFIG_PIXELS, "-insertborderwidth", "insertBorderWidth", "BorderWidth", - DEF_CANVAS_INSERT_BD_COLOR, Tk_Offset(Tk_Canvas, insertBorderWidth), - TK_CONFIG_COLOR_ONLY}, + DEF_CANVAS_INSERT_BD_COLOR, + Tk_Offset(TkCanvas, textInfo.insertBorderWidth), TK_CONFIG_COLOR_ONLY}, {TK_CONFIG_PIXELS, "-insertborderwidth", "insertBorderWidth", "BorderWidth", - DEF_CANVAS_INSERT_BD_MONO, Tk_Offset(Tk_Canvas, insertBorderWidth), - TK_CONFIG_MONO_ONLY}, + DEF_CANVAS_INSERT_BD_MONO, + Tk_Offset(TkCanvas, textInfo.insertBorderWidth), TK_CONFIG_MONO_ONLY}, {TK_CONFIG_INT, "-insertofftime", "insertOffTime", "OffTime", - DEF_CANVAS_INSERT_OFF_TIME, Tk_Offset(Tk_Canvas, insertOffTime), 0}, - {TK_CONFIG_INT, "-insertontime", "insertOffTime", "OnTime", - DEF_CANVAS_INSERT_ON_TIME, Tk_Offset(Tk_Canvas, insertOffTime), 0}, + DEF_CANVAS_INSERT_OFF_TIME, Tk_Offset(TkCanvas, insertOffTime), 0}, + {TK_CONFIG_INT, "-insertontime", "insertOnTime", "OnTime", + DEF_CANVAS_INSERT_ON_TIME, Tk_Offset(TkCanvas, insertOnTime), 0}, {TK_CONFIG_PIXELS, "-insertwidth", "insertWidth", "InsertWidth", - DEF_CANVAS_INSERT_WIDTH, Tk_Offset(Tk_Canvas, insertWidth), 0}, + DEF_CANVAS_INSERT_WIDTH, Tk_Offset(TkCanvas, textInfo.insertWidth), 0}, {TK_CONFIG_RELIEF, "-relief", "relief", "Relief", - DEF_CANVAS_RELIEF, Tk_Offset(Tk_Canvas, relief), 0}, - {TK_CONFIG_PIXELS, "-scrollincrement", "scrollIncrement", "ScrollIncrement", - DEF_CANVAS_SCROLL_INCREMENT, Tk_Offset(Tk_Canvas, scrollIncrement), 0}, + DEF_CANVAS_RELIEF, Tk_Offset(TkCanvas, relief), 0}, {TK_CONFIG_STRING, "-scrollregion", "scrollRegion", "ScrollRegion", - DEF_CANVAS_SCROLL_REGION, Tk_Offset(Tk_Canvas, regionString), + DEF_CANVAS_SCROLL_REGION, Tk_Offset(TkCanvas, regionString), TK_CONFIG_NULL_OK}, {TK_CONFIG_BORDER, "-selectbackground", "selectBackground", "Foreground", - DEF_CANVAS_SELECT_COLOR, Tk_Offset(Tk_Canvas, selBorder), + DEF_CANVAS_SELECT_COLOR, Tk_Offset(TkCanvas, textInfo.selBorder), TK_CONFIG_COLOR_ONLY}, {TK_CONFIG_BORDER, "-selectbackground", "selectBackground", "Foreground", - DEF_CANVAS_SELECT_MONO, Tk_Offset(Tk_Canvas, selBorder), + DEF_CANVAS_SELECT_MONO, Tk_Offset(TkCanvas, textInfo.selBorder), TK_CONFIG_MONO_ONLY}, {TK_CONFIG_PIXELS, "-selectborderwidth", "selectBorderWidth", "BorderWidth", - DEF_CANVAS_SELECT_BD_COLOR, Tk_Offset(Tk_Canvas, selBorderWidth), - TK_CONFIG_COLOR_ONLY}, + DEF_CANVAS_SELECT_BD_COLOR, + Tk_Offset(TkCanvas, textInfo.selBorderWidth), TK_CONFIG_COLOR_ONLY}, {TK_CONFIG_PIXELS, "-selectborderwidth", "selectBorderWidth", "BorderWidth", - DEF_CANVAS_SELECT_BD_MONO, Tk_Offset(Tk_Canvas, selBorderWidth), + DEF_CANVAS_SELECT_BD_MONO, Tk_Offset(TkCanvas, textInfo.selBorderWidth), TK_CONFIG_MONO_ONLY}, {TK_CONFIG_COLOR, "-selectforeground", "selectForeground", "Background", - DEF_CANVAS_SELECT_FG_COLOR, Tk_Offset(Tk_Canvas, selFgColorPtr), + DEF_CANVAS_SELECT_FG_COLOR, Tk_Offset(TkCanvas, textInfo.selFgColorPtr), TK_CONFIG_COLOR_ONLY}, {TK_CONFIG_COLOR, "-selectforeground", "selectForeground", "Background", - DEF_CANVAS_SELECT_FG_MONO, Tk_Offset(Tk_Canvas, selFgColorPtr), + DEF_CANVAS_SELECT_FG_MONO, Tk_Offset(TkCanvas, textInfo.selFgColorPtr), TK_CONFIG_MONO_ONLY}, + {TK_CONFIG_STRING, "-takefocus", "takeFocus", "TakeFocus", + DEF_CANVAS_TAKE_FOCUS, Tk_Offset(TkCanvas, takeFocus), + TK_CONFIG_NULL_OK}, {TK_CONFIG_PIXELS, "-width", "width", "Width", - DEF_CANVAS_WIDTH, Tk_Offset(Tk_Canvas, width), 0}, + DEF_CANVAS_WIDTH, Tk_Offset(TkCanvas, width), 0}, {TK_CONFIG_STRING, "-xscrollcommand", "xScrollCommand", "ScrollCommand", - DEF_CANVAS_X_SCROLL_CMD, Tk_Offset(Tk_Canvas, xScrollCmd), + DEF_CANVAS_X_SCROLL_CMD, Tk_Offset(TkCanvas, xScrollCmd), TK_CONFIG_NULL_OK}, + {TK_CONFIG_PIXELS, "-xscrollincrement", "xScrollIncrement", + "ScrollIncrement", + DEF_CANVAS_X_SCROLL_INCREMENT, Tk_Offset(TkCanvas, xScrollIncrement), + 0}, {TK_CONFIG_STRING, "-yscrollcommand", "yScrollCommand", "ScrollCommand", - DEF_CANVAS_Y_SCROLL_CMD, Tk_Offset(Tk_Canvas, yScrollCmd), + DEF_CANVAS_Y_SCROLL_CMD, Tk_Offset(TkCanvas, yScrollCmd), TK_CONFIG_NULL_OK}, + {TK_CONFIG_PIXELS, "-yscrollincrement", "yScrollIncrement", + "ScrollIncrement", + DEF_CANVAS_Y_SCROLL_INCREMENT, Tk_Offset(TkCanvas, yScrollIncrement), + 0}, {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, (char *) NULL, 0, 0} }; @@ -146,9 +145,9 @@ static Tk_ItemType *typeList = NULL; /* NULL means initialization hasn't * Standard item types provided by Tk: */ -extern Tk_ItemType TkArcType, TkBitmapType, TkLineType; -extern Tk_ItemType TkOvalType, TkPolygonType; -extern Tk_ItemType TkRectangleType, TkTextType, TkWindowType; +extern Tk_ItemType tkArcType, tkBitmapType, tkImageType, tkLineType; +extern Tk_ItemType tkOvalType, tkPolygonType; +extern Tk_ItemType tkRectangleType, tkTextType, tkWindowType; /* * Various Tk_Uid's used by this module (set up during initialization): @@ -171,65 +170,54 @@ static int numSlowSearches; static void CanvasBindProc _ANSI_ARGS_((ClientData clientData, XEvent *eventPtr)); static void CanvasBlinkProc _ANSI_ARGS_((ClientData clientData)); -static void CanvasDoEvent _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static void CanvasCmdDeletedProc _ANSI_ARGS_(( + ClientData clientData)); +static void CanvasDoEvent _ANSI_ARGS_((TkCanvas *canvasPtr, XEvent *eventPtr)); static void CanvasEventProc _ANSI_ARGS_((ClientData clientData, XEvent *eventPtr)); static int CanvasFetchSelection _ANSI_ARGS_(( ClientData clientData, int offset, char *buffer, int maxBytes)); -static void CanvasFocusProc _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static Tk_Item * CanvasFindClosest _ANSI_ARGS_((TkCanvas *canvasPtr, + double coords[2])); +static void CanvasFocusProc _ANSI_ARGS_((TkCanvas *canvasPtr, int gotFocus)); static void CanvasLostSelection _ANSI_ARGS_(( ClientData clientData)); -static void CanvasSelectTo _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static void CanvasSelectTo _ANSI_ARGS_((TkCanvas *canvasPtr, Tk_Item *itemPtr, int index)); -static void CanvasSetOrigin _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static void CanvasSetOrigin _ANSI_ARGS_((TkCanvas *canvasPtr, int xOrigin, int yOrigin)); -static int CanvasTagsParseProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, Tk_Window tkwin, char *value, - char *widgRec, int offset)); -static char * CanvasTagsPrintProc _ANSI_ARGS_((ClientData clientData, - Tk_Window tkwin, char *widgRec, int offset, - Tcl_FreeProc **freeProcPtr)); static void CanvasUpdateScrollbars _ANSI_ARGS_(( - Tk_Canvas *canvasPtr)); + TkCanvas *canvasPtr)); static int CanvasWidgetCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); static int ConfigureCanvas _ANSI_ARGS_((Tcl_Interp *interp, - Tk_Canvas *canvasPtr, int argc, char **argv, + TkCanvas *canvasPtr, int argc, char **argv, int flags)); -static void DestroyCanvas _ANSI_ARGS_((ClientData clientData)); +static void DestroyCanvas _ANSI_ARGS_((char *memPtr)); static void DisplayCanvas _ANSI_ARGS_((ClientData clientData)); static void DoItem _ANSI_ARGS_((Tcl_Interp *interp, Tk_Item *itemPtr, Tk_Uid tag)); -static void EventuallyRedrawArea _ANSI_ARGS_((Tk_Canvas *canvasPtr, - int x1, int y1, int x2, int y2)); static int FindItems _ANSI_ARGS_((Tcl_Interp *interp, - Tk_Canvas *canvasPtr, int argc, char **argv, + TkCanvas *canvasPtr, int argc, char **argv, char *newTag, char *cmdName, char *option)); static int FindArea _ANSI_ARGS_((Tcl_Interp *interp, - Tk_Canvas *canvasPtr, char **argv, Tk_Uid uid, + TkCanvas *canvasPtr, char **argv, Tk_Uid uid, int enclosed)); static double GridAlign _ANSI_ARGS_((double coord, double spacing)); static void InitCanvas _ANSI_ARGS_((void)); static Tk_Item * NextItem _ANSI_ARGS_((TagSearch *searchPtr)); -static void PickCurrentItem _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static void PickCurrentItem _ANSI_ARGS_((TkCanvas *canvasPtr, XEvent *eventPtr)); -static void RelinkItems _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static void PrintScrollFractions _ANSI_ARGS_((int screen1, + int screen2, int object1, int object2, + char *string)); +static void RelinkItems _ANSI_ARGS_((TkCanvas *canvasPtr, char *tag, Tk_Item *prevPtr)); -static Tk_Item * StartTagSearch _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static Tk_Item * StartTagSearch _ANSI_ARGS_((TkCanvas *canvasPtr, char *tag, TagSearch *searchPtr)); - -/* - * Custom option for handling "-tags" options for canvas items: - */ - -Tk_CustomOption tkCanvasTagsOption = { - CanvasTagsParseProc, - CanvasTagsPrintProc, - (ClientData) NULL -}; /* *-------------------------------------------------------------- @@ -258,7 +246,7 @@ Tk_CanvasCmd(clientData, interp, argc, argv) char **argv; /* Argument strings. */ { Tk_Window tkwin = (Tk_Window) clientData; - register Tk_Canvas *canvasPtr; + TkCanvas *canvasPtr; Tk_Window new; if (typeList == NULL) { @@ -266,7 +254,7 @@ Tk_CanvasCmd(clientData, interp, argc, argv) } if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " pathName ?options?\"", (char *) NULL); return TCL_ERROR; } @@ -282,40 +270,52 @@ Tk_CanvasCmd(clientData, interp, argc, argv) * (e.g. resource pointers). */ - canvasPtr = (Tk_Canvas *) ckalloc(sizeof(Tk_Canvas)); + canvasPtr = (TkCanvas *) ckalloc(sizeof(TkCanvas)); canvasPtr->tkwin = new; canvasPtr->display = Tk_Display(new); canvasPtr->interp = interp; + canvasPtr->widgetCmd = Tcl_CreateCommand(interp, + Tk_PathName(canvasPtr->tkwin), CanvasWidgetCmd, + (ClientData) canvasPtr, CanvasCmdDeletedProc); canvasPtr->firstItemPtr = NULL; canvasPtr->lastItemPtr = NULL; canvasPtr->borderWidth = 0; canvasPtr->bgBorder = NULL; canvasPtr->relief = TK_RELIEF_FLAT; + canvasPtr->highlightWidth = 0; + canvasPtr->highlightBgColorPtr = NULL; + canvasPtr->highlightColorPtr = NULL; + canvasPtr->inset = 0; canvasPtr->pixmapGC = None; canvasPtr->width = None; canvasPtr->height = None; canvasPtr->confine = 0; - canvasPtr->selBorder = NULL; - canvasPtr->selBorderWidth = 0; - canvasPtr->selFgColorPtr = NULL; - canvasPtr->selItemPtr = NULL; - canvasPtr->selectFirst = -1; - canvasPtr->selectLast = -1; - canvasPtr->anchorItemPtr = NULL; - canvasPtr->selectAnchor = 0; - canvasPtr->insertBorder = NULL; - canvasPtr->insertWidth = 0; - canvasPtr->insertBorderWidth = 0; + canvasPtr->textInfo.selBorder = NULL; + canvasPtr->textInfo.selBorderWidth = 0; + canvasPtr->textInfo.selFgColorPtr = NULL; + canvasPtr->textInfo.selItemPtr = NULL; + canvasPtr->textInfo.selectFirst = -1; + canvasPtr->textInfo.selectLast = -1; + canvasPtr->textInfo.anchorItemPtr = NULL; + canvasPtr->textInfo.selectAnchor = 0; + canvasPtr->textInfo.insertBorder = NULL; + canvasPtr->textInfo.insertWidth = 0; + canvasPtr->textInfo.insertBorderWidth = 0; + canvasPtr->textInfo.focusItemPtr = NULL; + canvasPtr->textInfo.gotFocus = 0; + canvasPtr->textInfo.cursorOn = 0; canvasPtr->insertOnTime = 0; canvasPtr->insertOffTime = 0; - canvasPtr->insertBlinkHandler = (Tk_TimerToken) NULL; - canvasPtr->focusItemPtr = NULL; + canvasPtr->insertBlinkHandler = (Tcl_TimerToken) NULL; canvasPtr->xOrigin = canvasPtr->yOrigin = 0; canvasPtr->drawableXOrigin = canvasPtr->drawableYOrigin = 0; canvasPtr->bindingTable = NULL; canvasPtr->currentItemPtr = NULL; + canvasPtr->newCurrentPtr = NULL; canvasPtr->closeEnough = 0.0; canvasPtr->pickEvent.type = LeaveNotify; + canvasPtr->pickEvent.xcrossing.x = 0; + canvasPtr->pickEvent.xcrossing.y = 0; canvasPtr->state = 0; canvasPtr->xScrollCmd = NULL; canvasPtr->yScrollCmd = NULL; @@ -324,7 +324,8 @@ Tk_CanvasCmd(clientData, interp, argc, argv) canvasPtr->scrollX2 = 0; canvasPtr->scrollY2 = 0; canvasPtr->regionString = NULL; - canvasPtr->scrollIncrement = 1; + canvasPtr->xScrollIncrement = 0; + canvasPtr->yScrollIncrement = 0; canvasPtr->scanX = 0; canvasPtr->scanXOrigin = 0; canvasPtr->scanY = 0; @@ -332,10 +333,12 @@ Tk_CanvasCmd(clientData, interp, argc, argv) canvasPtr->hotPtr = NULL; canvasPtr->hotPrevPtr = NULL; canvasPtr->cursor = None; + canvasPtr->takeFocus = NULL; canvasPtr->pixelsPerMM = WidthOfScreen(Tk_Screen(new)); canvasPtr->pixelsPerMM /= WidthMMOfScreen(Tk_Screen(new)); canvasPtr->flags = 0; canvasPtr->nextId = 1; + canvasPtr->psInfoPtr = NULL; Tk_SetClass(canvasPtr->tkwin, "Canvas"); Tk_CreateEventHandler(canvasPtr->tkwin, @@ -345,10 +348,8 @@ Tk_CanvasCmd(clientData, interp, argc, argv) |ButtonPressMask|ButtonReleaseMask|EnterWindowMask |LeaveWindowMask|PointerMotionMask, CanvasBindProc, (ClientData) canvasPtr); - Tk_CreateSelHandler(canvasPtr->tkwin, XA_STRING, CanvasFetchSelection, - (ClientData) canvasPtr, XA_STRING); - Tcl_CreateCommand(interp, Tk_PathName(canvasPtr->tkwin), CanvasWidgetCmd, - (ClientData) canvasPtr, (void (*)()) NULL); + Tk_CreateSelHandler(canvasPtr->tkwin, XA_PRIMARY, XA_STRING, + CanvasFetchSelection, (ClientData) canvasPtr, XA_STRING); if (ConfigureCanvas(interp, canvasPtr, argc-2, argv+2, 0) != TCL_OK) { goto error; } @@ -387,9 +388,9 @@ CanvasWidgetCmd(clientData, interp, argc, argv) int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { - register Tk_Canvas *canvasPtr = (Tk_Canvas *) clientData; - int length, result; - char c; + TkCanvas *canvasPtr = (TkCanvas *) clientData; + size_t length; + int c, result; Tk_Item *itemPtr = NULL; /* Initialization needed only to * prevent compiler warning. */ TagSearch search; @@ -399,7 +400,7 @@ CanvasWidgetCmd(clientData, interp, argc, argv) argv[0], " option ?arg arg ...?\"", (char *) NULL); return TCL_ERROR; } - Tk_Preserve((ClientData) canvasPtr); + Tcl_Preserve((ClientData) canvasPtr); result = TCL_OK; c = argv[1][0]; length = strlen(argv[1]); @@ -429,6 +430,10 @@ CanvasWidgetCmd(clientData, interp, argc, argv) for (i = 2; i < argc; i++) { for (itemPtr = StartTagSearch(canvasPtr, argv[i], &search); itemPtr != NULL; itemPtr = NextItem(&search)) { + if ((itemPtr->x1 >= itemPtr->x2) + || (itemPtr->y1 >= itemPtr->y2)) { + continue; + } if (!gotAny) { x1 = itemPtr->x1; y1 = itemPtr->y1; @@ -523,11 +528,11 @@ CanvasWidgetCmd(clientData, interp, argc, argv) if (mask == 0) { goto error; } - if (mask & ~(ButtonMotionMask|Button1MotionMask|Button2MotionMask - |Button3MotionMask|Button4MotionMask|Button5MotionMask - |ButtonPressMask|ButtonReleaseMask|EnterWindowMask - |LeaveWindowMask|KeyPressMask|KeyReleaseMask - |PointerMotionMask)) { + if (mask & (unsigned) ~(ButtonMotionMask|Button1MotionMask + |Button2MotionMask|Button3MotionMask|Button4MotionMask + |Button5MotionMask|ButtonPressMask|ButtonReleaseMask + |EnterWindowMask|LeaveWindowMask|KeyPressMask + |KeyReleaseMask|PointerMotionMask)) { Tk_DeleteBinding(interp, canvasPtr->bindingTable, object, argv[3]); Tcl_ResetResult(interp); @@ -562,7 +567,8 @@ CanvasWidgetCmd(clientData, interp, argc, argv) goto error; } if (argc == 4) { - if (TkGetCanvasCoord(canvasPtr, argv[3], &grid) != TCL_OK) { + if (Tk_CanvasGetCoord(interp, (Tk_Canvas) canvasPtr, argv[3], + &grid) != TCL_OK) { goto error; } } else { @@ -584,7 +590,8 @@ CanvasWidgetCmd(clientData, interp, argc, argv) goto error; } if (argc == 4) { - if (TkGetCanvasCoord(canvasPtr, argv[3], &grid) != TCL_OK) { + if (Tk_CanvasGetCoord(interp, (Tk_Canvas) canvasPtr, + argv[3], &grid) != TCL_OK) { goto error; } } else { @@ -592,6 +599,16 @@ CanvasWidgetCmd(clientData, interp, argc, argv) } y += canvasPtr->yOrigin; Tcl_PrintDouble(interp, GridAlign((double) y, grid), interp->result); + } else if ((c == 'c') && (strncmp(argv[1], "cget", length) == 0) + && (length >= 2)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " cget option\"", + (char *) NULL); + goto error; + } + result = Tk_ConfigureValue(interp, canvasPtr->tkwin, configSpecs, + (char *) canvasPtr, argv[2], 0); } else if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0) && (length >= 3)) { if (argc == 2) { @@ -615,23 +632,23 @@ CanvasWidgetCmd(clientData, interp, argc, argv) itemPtr = StartTagSearch(canvasPtr, argv[2], &search); if (itemPtr != NULL) { if (argc != 3) { - EventuallyRedrawArea(canvasPtr, itemPtr->x1, itemPtr->y1, - itemPtr->x2, itemPtr->y2); + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + itemPtr->x1, itemPtr->y1, itemPtr->x2, itemPtr->y2); } if (itemPtr->typePtr->coordProc != NULL) { - result = (*itemPtr->typePtr->coordProc)(canvasPtr, itemPtr, - argc-3, argv+3); + result = (*itemPtr->typePtr->coordProc)(interp, + (Tk_Canvas) canvasPtr, itemPtr, argc-3, argv+3); } if (argc != 3) { - EventuallyRedrawArea(canvasPtr, itemPtr->x1, itemPtr->y1, - itemPtr->x2, itemPtr->y2); + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + itemPtr->x1, itemPtr->y1, itemPtr->x2, itemPtr->y2); } } } else if ((c == 'c') && (strncmp(argv[1], "create", length) == 0) && (length >= 2)) { - register Tk_ItemType *typePtr; + Tk_ItemType *typePtr; Tk_ItemType *matchPtr = NULL; - register Tk_Item *itemPtr; + Tk_Item *itemPtr; if (argc < 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", @@ -664,8 +681,8 @@ CanvasWidgetCmd(clientData, interp, argc, argv) itemPtr->tagSpace = TK_TAG_SPACE; itemPtr->numTags = 0; itemPtr->typePtr = typePtr; - if ((*typePtr->createProc)(canvasPtr, itemPtr, argc-3, argv+3) - != TCL_OK) { + if ((*typePtr->createProc)(interp, (Tk_Canvas) canvasPtr, + itemPtr, argc-3, argv+3) != TCL_OK) { ckfree((char *) itemPtr); goto error; } @@ -678,8 +695,8 @@ CanvasWidgetCmd(clientData, interp, argc, argv) canvasPtr->lastItemPtr->nextPtr = itemPtr; } canvasPtr->lastItemPtr = itemPtr; - EventuallyRedrawArea(canvasPtr, itemPtr->x1, itemPtr->y1, - itemPtr->x2, itemPtr->y2); + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + itemPtr->x1, itemPtr->y1, itemPtr->x2, itemPtr->y2); canvasPtr->flags |= REPICK_NEEDED; sprintf(interp->result, "%d", itemPtr->id); } else if ((c == 'd') && (strncmp(argv[1], "dchars", length) == 0) @@ -698,13 +715,14 @@ CanvasWidgetCmd(clientData, interp, argc, argv) || (itemPtr->typePtr->dCharsProc == NULL)) { continue; } - if ((*itemPtr->typePtr->indexProc)(canvasPtr, itemPtr, - argv[3], &first) != TCL_OK) { + if ((*itemPtr->typePtr->indexProc)(interp, (Tk_Canvas) canvasPtr, + itemPtr, argv[3], &first) != TCL_OK) { goto error; } if (argc == 5) { - if ((*itemPtr->typePtr->indexProc)(canvasPtr, itemPtr, - argv[4], &last) != TCL_OK) { + if ((*itemPtr->typePtr->indexProc)(interp, + (Tk_Canvas) canvasPtr, itemPtr, argv[4], &last) + != TCL_OK) { goto error; } } else { @@ -717,15 +735,12 @@ CanvasWidgetCmd(clientData, interp, argc, argv) * the old area. */ - EventuallyRedrawArea(canvasPtr, itemPtr->x1, itemPtr->y1, - itemPtr->x2, itemPtr->y2); - result = (*itemPtr->typePtr->dCharsProc)(canvasPtr, itemPtr, - first, last); - EventuallyRedrawArea(canvasPtr, itemPtr->x1, itemPtr->y1, - itemPtr->x2, itemPtr->y2); - if (result != TCL_OK) { - goto error; - } + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + itemPtr->x1, itemPtr->y1, itemPtr->x2, itemPtr->y2); + (*itemPtr->typePtr->dCharsProc)((Tk_Canvas) canvasPtr, + itemPtr, first, last); + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + itemPtr->x1, itemPtr->y1, itemPtr->x2, itemPtr->y2); } } else if ((c == 'd') && (strncmp(argv[1], "delete", length) == 0) && (length >= 2)) { @@ -734,13 +749,14 @@ CanvasWidgetCmd(clientData, interp, argc, argv) for (i = 2; i < argc; i++) { for (itemPtr = StartTagSearch(canvasPtr, argv[i], &search); itemPtr != NULL; itemPtr = NextItem(&search)) { - EventuallyRedrawArea(canvasPtr, itemPtr->x1, itemPtr->y1, - itemPtr->x2, itemPtr->y2); + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + itemPtr->x1, itemPtr->y1, itemPtr->x2, itemPtr->y2); if (canvasPtr->bindingTable != NULL) { Tk_DeleteAllBindings(canvasPtr->bindingTable, (ClientData) itemPtr); } - (*itemPtr->typePtr->deleteProc)(canvasPtr, itemPtr); + (*itemPtr->typePtr->deleteProc)((Tk_Canvas) canvasPtr, itemPtr, + canvasPtr->display); if (itemPtr->tagPtr != itemPtr->staticTagSpace) { ckfree((char *) itemPtr->tagPtr); } @@ -760,14 +776,18 @@ CanvasWidgetCmd(clientData, interp, argc, argv) canvasPtr->currentItemPtr = NULL; canvasPtr->flags |= REPICK_NEEDED; } - if (itemPtr == canvasPtr->focusItemPtr) { - canvasPtr->focusItemPtr = NULL; + if (itemPtr == canvasPtr->newCurrentPtr) { + canvasPtr->newCurrentPtr = NULL; + canvasPtr->flags |= REPICK_NEEDED; } - if (itemPtr == canvasPtr->selItemPtr) { - canvasPtr->selItemPtr = NULL; + if (itemPtr == canvasPtr->textInfo.focusItemPtr) { + canvasPtr->textInfo.focusItemPtr = NULL; + } + if (itemPtr == canvasPtr->textInfo.selItemPtr) { + canvasPtr->textInfo.selItemPtr = NULL; } if ((itemPtr == canvasPtr->hotPtr) - || (itemPtr = canvasPtr->hotPrevPtr)) { + || (itemPtr == canvasPtr->hotPrevPtr)) { canvasPtr->hotPtr = NULL; } } @@ -815,19 +835,19 @@ CanvasWidgetCmd(clientData, interp, argc, argv) (char *) NULL); goto error; } - itemPtr = canvasPtr->focusItemPtr; + itemPtr = canvasPtr->textInfo.focusItemPtr; if (argc == 2) { if (itemPtr != NULL) { sprintf(interp->result, "%d", itemPtr->id); } goto done; } - if ((itemPtr != NULL) && (canvasPtr->flags & GOT_FOCUS)) { - EventuallyRedrawArea(canvasPtr, itemPtr->x1, itemPtr->y1, - itemPtr->x2, itemPtr->y2); + if ((itemPtr != NULL) && (canvasPtr->textInfo.gotFocus)) { + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + itemPtr->x1, itemPtr->y1, itemPtr->x2, itemPtr->y2); } if (argv[2][0] == 0) { - canvasPtr->focusItemPtr = NULL; + canvasPtr->textInfo.focusItemPtr = NULL; goto done; } for (itemPtr = StartTagSearch(canvasPtr, argv[2], &search); @@ -839,10 +859,10 @@ CanvasWidgetCmd(clientData, interp, argc, argv) if (itemPtr == NULL) { goto done; } - canvasPtr->focusItemPtr = itemPtr; - if (canvasPtr->flags & GOT_FOCUS) { - EventuallyRedrawArea(canvasPtr, itemPtr->x1, itemPtr->y1, - itemPtr->x2, itemPtr->y2); + canvasPtr->textInfo.focusItemPtr = itemPtr; + if (canvasPtr->textInfo.gotFocus) { + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + itemPtr->x1, itemPtr->y1, itemPtr->x2, itemPtr->y2); } } else if ((c == 'g') && (strncmp(argv[1], "gettags", length) == 0)) { if (argc != 3) { @@ -873,15 +893,16 @@ CanvasWidgetCmd(clientData, interp, argc, argv) || (itemPtr->typePtr->icursorProc == NULL)) { goto done; } - if ((*itemPtr->typePtr->indexProc)(canvasPtr, itemPtr, - argv[3], &index) != TCL_OK) { + if ((*itemPtr->typePtr->indexProc)(interp, (Tk_Canvas) canvasPtr, + itemPtr, argv[3], &index) != TCL_OK) { goto error; } - (*itemPtr->typePtr->icursorProc)(canvasPtr, itemPtr, index); - if ((itemPtr == canvasPtr->focusItemPtr) - && (canvasPtr->flags & CURSOR_ON)) { - EventuallyRedrawArea(canvasPtr, itemPtr->x1, itemPtr->y1, - itemPtr->x2, itemPtr->y2); + (*itemPtr->typePtr->icursorProc)((Tk_Canvas) canvasPtr, itemPtr, + index); + if ((itemPtr == canvasPtr->textInfo.focusItemPtr) + && (canvasPtr->textInfo.cursorOn)) { + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + itemPtr->x1, itemPtr->y1, itemPtr->x2, itemPtr->y2); } } } else if ((c == 'i') && (strncmp(argv[1], "index", length) == 0) @@ -905,8 +926,8 @@ CanvasWidgetCmd(clientData, interp, argc, argv) argv[2], "\"", (char *) NULL); goto error; } - if ((*itemPtr->typePtr->indexProc)(canvasPtr, itemPtr, - argv[3], &index) != TCL_OK) { + if ((*itemPtr->typePtr->indexProc)(interp, (Tk_Canvas) canvasPtr, + itemPtr, argv[3], &index) != TCL_OK) { goto error; } sprintf(interp->result, "%d", index); @@ -926,8 +947,8 @@ CanvasWidgetCmd(clientData, interp, argc, argv) || (itemPtr->typePtr->insertProc == NULL)) { continue; } - if ((*itemPtr->typePtr->indexProc)(canvasPtr, itemPtr, - argv[3], &beforeThis) != TCL_OK) { + if ((*itemPtr->typePtr->indexProc)(interp, (Tk_Canvas) canvasPtr, + itemPtr, argv[3], &beforeThis) != TCL_OK) { goto error; } @@ -937,18 +958,29 @@ CanvasWidgetCmd(clientData, interp, argc, argv) * larger or smaller than the old area. */ - EventuallyRedrawArea(canvasPtr, itemPtr->x1, itemPtr->y1, - itemPtr->x2, itemPtr->y2); - result = (*itemPtr->typePtr->insertProc)(canvasPtr, itemPtr, - beforeThis, argv[4]); - EventuallyRedrawArea(canvasPtr, itemPtr->x1, itemPtr->y1, - itemPtr->x2, itemPtr->y2); - if (result != TCL_OK) { - goto error; - } + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + itemPtr->x1, itemPtr->y1, itemPtr->x2, itemPtr->y2); + (*itemPtr->typePtr->insertProc)((Tk_Canvas) canvasPtr, + itemPtr, beforeThis, argv[4]); + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, itemPtr->x1, + itemPtr->y1, itemPtr->x2, itemPtr->y2); + } + } else if ((c == 'i') && (strncmp(argv[1], "itemcget", length) == 0) + && (length >= 6)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " itemcget tagOrId option\"", + (char *) NULL); + return TCL_ERROR; + } + itemPtr = StartTagSearch(canvasPtr, argv[2], &search); + if (itemPtr != NULL) { + result = Tk_ConfigureValue(canvasPtr->interp, canvasPtr->tkwin, + itemPtr->typePtr->configSpecs, (char *) itemPtr, + argv[3], 0); } } else if ((c == 'i') && (strncmp(argv[1], "itemconfigure", length) == 0) - && (length >= 2)) { + && (length >= 6)) { if (argc < 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " itemconfigure tagOrId ?option value ...?\"", @@ -966,12 +998,13 @@ CanvasWidgetCmd(clientData, interp, argc, argv) itemPtr->typePtr->configSpecs, (char *) itemPtr, argv[3], 0); } else { - EventuallyRedrawArea(canvasPtr, itemPtr->x1, itemPtr->y1, - itemPtr->x2, itemPtr->y2); - result = (*itemPtr->typePtr->configProc)(canvasPtr, itemPtr, - argc-3, argv+3, TK_CONFIG_ARGV_ONLY); - EventuallyRedrawArea(canvasPtr, itemPtr->x1, itemPtr->y1, - itemPtr->x2, itemPtr->y2); + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + itemPtr->x1, itemPtr->y1, itemPtr->x2, itemPtr->y2); + result = (*itemPtr->typePtr->configProc)(interp, + (Tk_Canvas) canvasPtr, itemPtr, argc-3, argv+3, + TK_CONFIG_ARGV_ONLY); + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + itemPtr->x1, itemPtr->y1, itemPtr->x2, itemPtr->y2); canvasPtr->flags |= REPICK_NEEDED; } if ((result != TCL_OK) || (argc < 5)) { @@ -1015,18 +1048,19 @@ CanvasWidgetCmd(clientData, interp, argc, argv) (char *) NULL); goto error; } - if ((TkGetCanvasCoord(canvasPtr, argv[3], &xAmount) != TCL_OK) - || (TkGetCanvasCoord(canvasPtr, argv[4], &yAmount) != TCL_OK)) { + if ((Tk_CanvasGetCoord(interp, (Tk_Canvas) canvasPtr, argv[3], + &xAmount) != TCL_OK) || (Tk_CanvasGetCoord(interp, + (Tk_Canvas) canvasPtr, argv[4], &yAmount) != TCL_OK)) { goto error; } for (itemPtr = StartTagSearch(canvasPtr, argv[2], &search); itemPtr != NULL; itemPtr = NextItem(&search)) { - EventuallyRedrawArea(canvasPtr, itemPtr->x1, itemPtr->y1, - itemPtr->x2, itemPtr->y2); - (void) (*itemPtr->typePtr->translateProc)(canvasPtr, itemPtr, - xAmount, yAmount); - EventuallyRedrawArea(canvasPtr, itemPtr->x1, itemPtr->y1, - itemPtr->x2, itemPtr->y2); + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + itemPtr->x1, itemPtr->y1, itemPtr->x2, itemPtr->y2); + (void) (*itemPtr->typePtr->translateProc)((Tk_Canvas) canvasPtr, + itemPtr, xAmount, yAmount); + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + itemPtr->x1, itemPtr->y1, itemPtr->x2, itemPtr->y2); canvasPtr->flags |= REPICK_NEEDED; } } else if ((c == 'p') && (strncmp(argv[1], "postscript", length) == 0)) { @@ -1071,8 +1105,10 @@ CanvasWidgetCmd(clientData, interp, argc, argv) (char *) NULL); goto error; } - if ((TkGetCanvasCoord(canvasPtr, argv[3], &xOrigin) != TCL_OK) - || (TkGetCanvasCoord(canvasPtr, argv[4], &yOrigin) != TCL_OK) + if ((Tk_CanvasGetCoord(interp, (Tk_Canvas) canvasPtr, + argv[3], &xOrigin) != TCL_OK) + || (Tk_CanvasGetCoord(interp, (Tk_Canvas) canvasPtr, + argv[4], &yOrigin) != TCL_OK) || (Tcl_GetDouble(interp, argv[5], &xScale) != TCL_OK) || (Tcl_GetDouble(interp, argv[6], &yScale) != TCL_OK)) { goto error; @@ -1083,12 +1119,12 @@ CanvasWidgetCmd(clientData, interp, argc, argv) } for (itemPtr = StartTagSearch(canvasPtr, argv[2], &search); itemPtr != NULL; itemPtr = NextItem(&search)) { - EventuallyRedrawArea(canvasPtr, itemPtr->x1, itemPtr->y1, - itemPtr->x2, itemPtr->y2); - (void) (*itemPtr->typePtr->scaleProc)(canvasPtr, itemPtr, - xOrigin, yOrigin, xScale, yScale); - EventuallyRedrawArea(canvasPtr, itemPtr->x1, itemPtr->y1, - itemPtr->x2, itemPtr->y2); + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + itemPtr->x1, itemPtr->y1, itemPtr->x2, itemPtr->y2); + (void) (*itemPtr->typePtr->scaleProc)((Tk_Canvas) canvasPtr, + itemPtr, xOrigin, yOrigin, xScale, yScale); + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + itemPtr->x1, itemPtr->y1, itemPtr->x2, itemPtr->y2); canvasPtr->flags |= REPICK_NEEDED; } } else if ((c == 's') && (strncmp(argv[1], "scan", length) == 0) @@ -1116,34 +1152,19 @@ CanvasWidgetCmd(clientData, interp, argc, argv) /* * Compute a new view origin for the canvas, amplifying the - * mouse motion and rounding to the nearest multiple of the - * scroll increment. + * mouse motion. */ tmp = canvasPtr->scanXOrigin - 10*(x - canvasPtr->scanX) - canvasPtr->scrollX1; - if (tmp >= 0) { - tmp = (tmp + canvasPtr->scrollIncrement/2) - /canvasPtr->scrollIncrement; - } else { - tmp = -(((-tmp) + canvasPtr->scrollIncrement/2) - /canvasPtr->scrollIncrement); - } - newXOrigin = canvasPtr->scrollX1 + tmp*canvasPtr->scrollIncrement; + newXOrigin = canvasPtr->scrollX1 + tmp; tmp = canvasPtr->scanYOrigin - 10*(y - canvasPtr->scanY) - canvasPtr->scrollY1; - if (tmp >= 0) { - tmp = (tmp + canvasPtr->scrollIncrement/2) - /canvasPtr->scrollIncrement; - } else { - tmp = -(((-tmp) + canvasPtr->scrollIncrement/2) - /canvasPtr->scrollIncrement); - } - newYOrigin = canvasPtr->scrollY1 + tmp*canvasPtr->scrollIncrement; + newYOrigin = canvasPtr->scrollY1 + tmp; CanvasSetOrigin(canvasPtr, newXOrigin, newYOrigin); } else { Tcl_AppendResult(interp, "bad scan option \"", argv[2], - "\": must be mark or dragto", (char *) NULL); + "\": must be mark or dragto", (char *) NULL); goto error; } } else if ((c == 's') && (strncmp(argv[1], "select", length) == 0) @@ -1171,8 +1192,8 @@ CanvasWidgetCmd(clientData, interp, argc, argv) } } if (argc == 5) { - if ((*itemPtr->typePtr->indexProc)(canvasPtr, itemPtr, - argv[4], &index) != TCL_OK) { + if ((*itemPtr->typePtr->indexProc)(interp, (Tk_Canvas) canvasPtr, + itemPtr, argv[4], &index) != TCL_OK) { goto error; } } @@ -1185,12 +1206,14 @@ CanvasWidgetCmd(clientData, interp, argc, argv) (char *) NULL); goto error; } - if (canvasPtr->selItemPtr == itemPtr) { - if (index < (canvasPtr->selectFirst - + canvasPtr->selectLast)/2) { - canvasPtr->selectAnchor = canvasPtr->selectLast + 1; + if (canvasPtr->textInfo.selItemPtr == itemPtr) { + if (index < (canvasPtr->textInfo.selectFirst + + canvasPtr->textInfo.selectLast)/2) { + canvasPtr->textInfo.selectAnchor = + canvasPtr->textInfo.selectLast + 1; } else { - canvasPtr->selectAnchor = canvasPtr->selectFirst; + canvasPtr->textInfo.selectAnchor = + canvasPtr->textInfo.selectFirst; } } CanvasSelectTo(canvasPtr, itemPtr, index); @@ -1201,11 +1224,13 @@ CanvasWidgetCmd(clientData, interp, argc, argv) argv[0], " select clear\"", (char *) NULL); goto error; } - if (canvasPtr->selItemPtr != NULL) { - EventuallyRedrawArea(canvasPtr, canvasPtr->selItemPtr->x1, - canvasPtr->selItemPtr->y1, canvasPtr->selItemPtr->x2, - canvasPtr->selItemPtr->y2); - canvasPtr->selItemPtr = NULL; + if (canvasPtr->textInfo.selItemPtr != NULL) { + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + canvasPtr->textInfo.selItemPtr->x1, + canvasPtr->textInfo.selItemPtr->y1, + canvasPtr->textInfo.selItemPtr->x2, + canvasPtr->textInfo.selItemPtr->y2); + canvasPtr->textInfo.selItemPtr = NULL; } goto done; } else if ((c == 'f') && (strncmp(argv[2], "from", length) == 0)) { @@ -1215,16 +1240,17 @@ CanvasWidgetCmd(clientData, interp, argc, argv) (char *) NULL); goto error; } - canvasPtr->anchorItemPtr = itemPtr; - canvasPtr->selectAnchor = index; + canvasPtr->textInfo.anchorItemPtr = itemPtr; + canvasPtr->textInfo.selectAnchor = index; } else if ((c == 'i') && (strncmp(argv[2], "item", length) == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " select item\"", (char *) NULL); goto error; } - if (canvasPtr->selItemPtr != NULL) { - sprintf(interp->result, "%d", canvasPtr->selItemPtr->id); + if (canvasPtr->textInfo.selItemPtr != NULL) { + sprintf(interp->result, "%d", + canvasPtr->textInfo.selItemPtr->id); } } else if ((c == 't') && (strncmp(argv[2], "to", length) == 0)) { if (argc != 5) { @@ -1251,49 +1277,99 @@ CanvasWidgetCmd(clientData, interp, argc, argv) interp->result = itemPtr->typePtr->name; } } else if ((c == 'x') && (strncmp(argv[1], "xview", length) == 0)) { - int index; + int count, type; + int newX = 0; /* Initialization needed only to prevent + * gcc warnings. */ + double fraction; - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " xview index\"", (char *) NULL); - goto error; + if (argc == 2) { + PrintScrollFractions(canvasPtr->xOrigin + canvasPtr->inset, + canvasPtr->xOrigin + Tk_Width(canvasPtr->tkwin) + - canvasPtr->inset, canvasPtr->scrollX1, + canvasPtr->scrollX2, interp->result); + } else { + type = Tk_GetScrollInfo(interp, argc, argv, &fraction, &count); + switch (type) { + case TK_SCROLL_ERROR: + goto error; + case TK_SCROLL_MOVETO: + newX = canvasPtr->scrollX1 - canvasPtr->inset + + (int) (fraction * (canvasPtr->scrollX2 + - canvasPtr->scrollX1) + 0.5); + break; + case TK_SCROLL_PAGES: + newX = canvasPtr->xOrigin + count * .9 + * (Tk_Width(canvasPtr->tkwin) - 2*canvasPtr->inset); + break; + case TK_SCROLL_UNITS: + if (canvasPtr->xScrollIncrement > 0) { + newX = canvasPtr->xOrigin + + count*canvasPtr->xScrollIncrement; + } else { + newX = canvasPtr->xOrigin + count * .1 + * (Tk_Width(canvasPtr->tkwin) + - 2*canvasPtr->inset); + } + break; + } + CanvasSetOrigin(canvasPtr, newX, canvasPtr->yOrigin); } - if (Tcl_GetInt(canvasPtr->interp, argv[2], &index) != TCL_OK) { - goto error; - } - CanvasSetOrigin(canvasPtr, - (canvasPtr->scrollX1 + index*canvasPtr->scrollIncrement), - canvasPtr->yOrigin); } else if ((c == 'y') && (strncmp(argv[1], "yview", length) == 0)) { - int index; + int count, type; + int newY = 0; /* Initialization needed only to prevent + * gcc warnings. */ + double fraction; - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " yview index\"", (char *) NULL); - goto error; + if (argc == 2) { + PrintScrollFractions(canvasPtr->yOrigin + canvasPtr->inset, + canvasPtr->yOrigin + Tk_Height(canvasPtr->tkwin) + - canvasPtr->inset, canvasPtr->scrollY1, + canvasPtr->scrollY2, interp->result); + } else { + type = Tk_GetScrollInfo(interp, argc, argv, &fraction, &count); + switch (type) { + case TK_SCROLL_ERROR: + goto error; + case TK_SCROLL_MOVETO: + newY = canvasPtr->scrollY1 - canvasPtr->inset + + (int) (fraction*(canvasPtr->scrollY2 + - canvasPtr->scrollY1) + 0.5); + break; + case TK_SCROLL_PAGES: + newY = canvasPtr->yOrigin + count * .9 + * (Tk_Height(canvasPtr->tkwin) + - 2*canvasPtr->inset); + break; + case TK_SCROLL_UNITS: + if (canvasPtr->yScrollIncrement > 0) { + newY = canvasPtr->yOrigin + + count*canvasPtr->yScrollIncrement; + } else { + newY = canvasPtr->yOrigin + count * .1 + * (Tk_Height(canvasPtr->tkwin) + - 2*canvasPtr->inset); + } + break; + } + CanvasSetOrigin(canvasPtr, canvasPtr->xOrigin, newY); } - if (Tcl_GetInt(canvasPtr->interp, argv[2], &index) != TCL_OK) { - goto error; - } - CanvasSetOrigin(canvasPtr, canvasPtr->xOrigin, - (canvasPtr->scrollY1 + index*canvasPtr->scrollIncrement)); } else { Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be addtag, bbox, bind, ", - "canvasx, canvasy, configure, coords, create, ", + "\": must be addtag, bbox, bind, ", + "canvasx, canvasy, cget, configure, coords, create, ", "dchars, delete, dtag, find, focus, ", - "gettags, icursor, index, insert, itemconfigure, lower, ", - "move, postscript, raise, scale, scan, ", + "gettags, icursor, index, insert, itemcget, itemconfigure, ", + "lower, move, postscript, raise, scale, scan, ", "select, type, xview, or yview", (char *) NULL); goto error; } done: - Tk_Release((ClientData) canvasPtr); + Tcl_Release((ClientData) canvasPtr); return result; error: - Tk_Release((ClientData) canvasPtr); + Tcl_Release((ClientData) canvasPtr); return TCL_ERROR; } @@ -1302,7 +1378,7 @@ CanvasWidgetCmd(clientData, interp, argc, argv) * * DestroyCanvas -- * - * This procedure is invoked by Tk_EventuallyFree or Tk_Release + * This procedure is invoked by Tcl_EventuallyFree or Tcl_Release * to clean up the internal structure of a canvas at a safe time * (when no-one is using it anymore). * @@ -1316,11 +1392,11 @@ CanvasWidgetCmd(clientData, interp, argc, argv) */ static void -DestroyCanvas(clientData) - ClientData clientData; /* Info about canvas widget. */ +DestroyCanvas(memPtr) + char *memPtr; /* Info about canvas widget. */ { - register Tk_Canvas *canvasPtr = (Tk_Canvas *) clientData; - register Tk_Item *itemPtr; + TkCanvas *canvasPtr = (TkCanvas *) memPtr; + Tk_Item *itemPtr; /* * Free up all of the items in the canvas. @@ -1329,7 +1405,8 @@ DestroyCanvas(clientData) for (itemPtr = canvasPtr->firstItemPtr; itemPtr != NULL; itemPtr = canvasPtr->firstItemPtr) { canvasPtr->firstItemPtr = itemPtr->nextPtr; - (*itemPtr->typePtr->deleteProc)(canvasPtr, itemPtr); + (*itemPtr->typePtr->deleteProc)((Tk_Canvas) canvasPtr, itemPtr, + canvasPtr->display); if (itemPtr->tagPtr != itemPtr->staticTagSpace) { ckfree((char *) itemPtr->tagPtr); } @@ -1345,7 +1422,7 @@ DestroyCanvas(clientData) if (canvasPtr->pixmapGC != None) { Tk_FreeGC(canvasPtr->display, canvasPtr->pixmapGC); } - Tk_DeleteTimerHandler(canvasPtr->insertBlinkHandler); + Tcl_DeleteTimerHandler(canvasPtr->insertBlinkHandler); if (canvasPtr->bindingTable != NULL) { Tk_DeleteBindingTable(canvasPtr->bindingTable); } @@ -1377,7 +1454,7 @@ DestroyCanvas(clientData) static int ConfigureCanvas(interp, canvasPtr, argc, argv, flags) Tcl_Interp *interp; /* Used for error reporting. */ - register Tk_Canvas *canvasPtr; /* Information about widget; may or may + TkCanvas *canvasPtr; /* Information about widget; may or may * not already have values for some fields. */ int argc; /* Number of valid entries in argv. */ char **argv; /* Arguments. */ @@ -1399,6 +1476,11 @@ ConfigureCanvas(interp, canvasPtr, argc, argv, flags) Tk_SetBackgroundFromBorder(canvasPtr->tkwin, canvasPtr->bgBorder); + if (canvasPtr->highlightWidth < 0) { + canvasPtr->highlightWidth = 0; + } + canvasPtr->inset = canvasPtr->borderWidth + canvasPtr->highlightWidth; + gcValues.function = GXcopy; gcValues.foreground = Tk_3DBorderColor(canvasPtr->bgBorder)->pixel; gcValues.graphics_exposures = False; @@ -1413,14 +1495,15 @@ ConfigureCanvas(interp, canvasPtr, argc, argv, flags) * Reset the desired dimensions for the window. */ - Tk_GeometryRequest(canvasPtr->tkwin, canvasPtr->width, canvasPtr->height); + Tk_GeometryRequest(canvasPtr->tkwin, canvasPtr->width + 2*canvasPtr->inset, + canvasPtr->height + 2*canvasPtr->inset); /* * Restart the cursor timing sequence in case the on-time or off-time * just changed. */ - if (canvasPtr->flags & GOT_FOCUS) { + if (canvasPtr->textInfo.gotFocus) { CanvasFocusProc(canvasPtr, 1); } @@ -1441,9 +1524,9 @@ ConfigureCanvas(interp, canvasPtr, argc, argv, flags) return TCL_ERROR; } if (argc2 != 4) { - badRegion: Tcl_AppendResult(interp, "bad scrollRegion \"", canvasPtr->regionString, "\"", (char *) NULL); + badRegion: ckfree(canvasPtr->regionString); ckfree((char *) argv2); canvasPtr->regionString = NULL; @@ -1463,13 +1546,14 @@ ConfigureCanvas(interp, canvasPtr, argc, argv, flags) } /* - * Reset the canvases origin (this is a no-op unless confine + * Reset the canvas's origin (this is a no-op unless confine * mode has just been turned on or the scroll region has changed). */ CanvasSetOrigin(canvasPtr, canvasPtr->xOrigin, canvasPtr->yOrigin); - canvasPtr->flags |= UPDATE_SCROLLBARS; - EventuallyRedrawArea(canvasPtr, canvasPtr->xOrigin, canvasPtr->yOrigin, + canvasPtr->flags |= UPDATE_SCROLLBARS|REDRAW_BORDERS; + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + canvasPtr->xOrigin, canvasPtr->yOrigin, canvasPtr->xOrigin + Tk_Width(canvasPtr->tkwin), canvasPtr->yOrigin + Tk_Height(canvasPtr->tkwin)); return TCL_OK; @@ -1497,11 +1581,11 @@ static void DisplayCanvas(clientData) ClientData clientData; /* Information about widget. */ { - register Tk_Canvas *canvasPtr = (Tk_Canvas *) clientData; - register Tk_Window tkwin = canvasPtr->tkwin; - register Tk_Item *itemPtr; + TkCanvas *canvasPtr = (TkCanvas *) clientData; + Tk_Window tkwin = canvasPtr->tkwin; + Tk_Item *itemPtr; Pixmap pixmap; - int screenX1, screenX2, screenY1, screenY2; + int screenX1, screenX2, screenY1, screenY2, width, height; if (canvasPtr->tkwin == NULL) { return; @@ -1516,11 +1600,11 @@ DisplayCanvas(clientData) */ while (canvasPtr->flags & REPICK_NEEDED) { - Tk_Preserve((ClientData) canvasPtr); + Tcl_Preserve((ClientData) canvasPtr); canvasPtr->flags &= ~REPICK_NEEDED; PickCurrentItem(canvasPtr, &canvasPtr->pickEvent); tkwin = canvasPtr->tkwin; - Tk_Release((ClientData) canvasPtr); + Tcl_Release((ClientData) canvasPtr); if (tkwin == NULL) { return; } @@ -1531,128 +1615,155 @@ DisplayCanvas(clientData) * and the area that's visible on the screen. */ - screenX1 = canvasPtr->xOrigin; - screenY1 = canvasPtr->yOrigin; - screenX2 = screenX1 + Tk_Width(tkwin); - screenY2 = screenY1 + Tk_Height(tkwin); - if (canvasPtr->redrawX1 > screenX1) { - screenX1 = canvasPtr->redrawX1; - } - if (canvasPtr->redrawY1 > screenY1) { - screenY1 = canvasPtr->redrawY1; - } - if (canvasPtr->redrawX2 < screenX2) { - screenX2 = canvasPtr->redrawX2; - } - if (canvasPtr->redrawY2 < screenY2) { - screenY2 = canvasPtr->redrawY2; - } - if ((screenX1 >= screenX2) || (screenY1 >= screenY2)) { - goto done; - } - - /* - * Redrawing is done in a temporary pixmap that is allocated - * here and freed at the end of the procedure. All drawing - * is done to the pixmap, and the pixmap is copied to the - * screen at the end of the procedure. The temporary pixmap - * serves two purposes: - * - * 1. It provides a smoother visual effect (no clearing and - * gradual redraw will be visible to users). - * 2. It allows us to redraw only the objects that overlap - * the redraw area. Otherwise incorrect results could - * occur from redrawing things that stick outside of - * the redraw area (we'd have to redraw everything in - * order to make the overlaps look right). - * - * Some tricky points about the pixmap: - * - * 1. We only allocate a large enough pixmap to hold the - * area that has to be redisplayed. This saves time in - * in the X server for large objects that cover much - * more than the area being redisplayed: only the area - * of the pixmap will actually have to be redrawn. - * 2. Some X servers (e.g. the one for DECstations) have troubles - * with characters that overlap an edge of the pixmap (on the - * DEC servers, as of 8/18/92, such characters are drawn one - * pixel too far to the right). To handle this problem, - * make the pixmap a bit larger than is absolutely needed - * so that for normal-sized fonts the characters that overlap - * the edge of the pixmap will be outside the area we care - * about. - */ - - canvasPtr->drawableXOrigin = screenX1 - 30; - canvasPtr->drawableYOrigin = screenY1 - 30; - pixmap = XCreatePixmap(Tk_Display(tkwin), Tk_WindowId(tkwin), - screenX2 + 30 - canvasPtr->drawableXOrigin, - screenY2 + 30 - canvasPtr->drawableYOrigin, - Tk_Depth(tkwin)); - - /* - * Clear the area to be redrawn. - */ - - XFillRectangle(Tk_Display(tkwin), pixmap, canvasPtr->pixmapGC, - screenX1 - canvasPtr->drawableXOrigin, - screenY1 - canvasPtr->drawableYOrigin, - (unsigned int) (screenX2 - screenX1), - (unsigned int) (screenY2 - screenY1)); - - /* - * Scan through the item list, redrawing those items that need it. - * An item must be redraw if either (a) it intersects the smaller - * on-screen area or (b) it intersects the full canvas area and its - * type requests that it be redrawn always (e.g. so subwindows can - * be unmapped when they move off-screen). - */ - - for (itemPtr = canvasPtr->firstItemPtr; itemPtr != NULL; - itemPtr = itemPtr->nextPtr) { - if ((itemPtr->x1 >= screenX2) - || (itemPtr->y1 >= screenY2) - || (itemPtr->x2 < screenX1) - || (itemPtr->y2 < screenY1)) { - if (!itemPtr->typePtr->alwaysRedraw - || (itemPtr->x1 >= canvasPtr->redrawX2) - || (itemPtr->y1 >= canvasPtr->redrawY2) - || (itemPtr->x2 < canvasPtr->redrawX1) - || (itemPtr->y2 < canvasPtr->redrawY1)) { - continue; - } + if ((canvasPtr->redrawX1 < canvasPtr->redrawX2) + && (canvasPtr->redrawY1 < canvasPtr->redrawY2)) { + screenX1 = canvasPtr->xOrigin + canvasPtr->inset; + screenY1 = canvasPtr->yOrigin + canvasPtr->inset; + screenX2 = canvasPtr->xOrigin + Tk_Width(tkwin) - canvasPtr->inset; + screenY2 = canvasPtr->yOrigin + Tk_Height(tkwin) - canvasPtr->inset; + if (canvasPtr->redrawX1 > screenX1) { + screenX1 = canvasPtr->redrawX1; } - (*itemPtr->typePtr->displayProc)(canvasPtr, itemPtr, pixmap); + if (canvasPtr->redrawY1 > screenY1) { + screenY1 = canvasPtr->redrawY1; + } + if (canvasPtr->redrawX2 < screenX2) { + screenX2 = canvasPtr->redrawX2; + } + if (canvasPtr->redrawY2 < screenY2) { + screenY2 = canvasPtr->redrawY2; + } + if ((screenX1 >= screenX2) || (screenY1 >= screenY2)) { + goto borders; + } + + /* + * Redrawing is done in a temporary pixmap that is allocated + * here and freed at the end of the procedure. All drawing + * is done to the pixmap, and the pixmap is copied to the + * screen at the end of the procedure. The temporary pixmap + * serves two purposes: + * + * 1. It provides a smoother visual effect (no clearing and + * gradual redraw will be visible to users). + * 2. It allows us to redraw only the objects that overlap + * the redraw area. Otherwise incorrect results could + * occur from redrawing things that stick outside of + * the redraw area (we'd have to redraw everything in + * order to make the overlaps look right). + * + * Some tricky points about the pixmap: + * + * 1. We only allocate a large enough pixmap to hold the + * area that has to be redisplayed. This saves time in + * in the X server for large objects that cover much + * more than the area being redisplayed: only the area + * of the pixmap will actually have to be redrawn. + * 2. Some X servers (e.g. the one for DECstations) have troubles + * with characters that overlap an edge of the pixmap (on the + * DEC servers, as of 8/18/92, such characters are drawn one + * pixel too far to the right). To handle this problem, + * make the pixmap a bit larger than is absolutely needed + * so that for normal-sized fonts the characters that overlap + * the edge of the pixmap will be outside the area we care + * about. + */ + + canvasPtr->drawableXOrigin = screenX1 - 30; + canvasPtr->drawableYOrigin = screenY1 - 30; + pixmap = Tk_GetPixmap(Tk_Display(tkwin), Tk_WindowId(tkwin), + (screenX2 + 30 - canvasPtr->drawableXOrigin), + (screenY2 + 30 - canvasPtr->drawableYOrigin), + Tk_Depth(tkwin)); + + /* + * Clear the area to be redrawn. + */ + + width = screenX2 - screenX1; + height = screenY2 - screenY1; + + XFillRectangle(Tk_Display(tkwin), pixmap, canvasPtr->pixmapGC, + screenX1 - canvasPtr->drawableXOrigin, + screenY1 - canvasPtr->drawableYOrigin, (unsigned int) width, + (unsigned int) height); + + /* + * Scan through the item list, redrawing those items that need it. + * An item must be redraw if either (a) it intersects the smaller + * on-screen area or (b) it intersects the full canvas area and its + * type requests that it be redrawn always (e.g. so subwindows can + * be unmapped when they move off-screen). + */ + + for (itemPtr = canvasPtr->firstItemPtr; itemPtr != NULL; + itemPtr = itemPtr->nextPtr) { + if ((itemPtr->x1 >= screenX2) + || (itemPtr->y1 >= screenY2) + || (itemPtr->x2 < screenX1) + || (itemPtr->y2 < screenY1)) { + if (!itemPtr->typePtr->alwaysRedraw + || (itemPtr->x1 >= canvasPtr->redrawX2) + || (itemPtr->y1 >= canvasPtr->redrawY2) + || (itemPtr->x2 < canvasPtr->redrawX1) + || (itemPtr->y2 < canvasPtr->redrawY1)) { + continue; + } + } + (*itemPtr->typePtr->displayProc)((Tk_Canvas) canvasPtr, itemPtr, + canvasPtr->display, pixmap, screenX1, screenY1, width, + height); + } + + /* + * Copy from the temporary pixmap to the screen, then free up + * the temporary pixmap. + */ + + XCopyArea(Tk_Display(tkwin), pixmap, Tk_WindowId(tkwin), + canvasPtr->pixmapGC, + screenX1 - canvasPtr->drawableXOrigin, + screenY1 - canvasPtr->drawableYOrigin, + (unsigned) (screenX2 - screenX1), + (unsigned) (screenY2 - screenY1), + screenX1 - canvasPtr->xOrigin, screenY1 - canvasPtr->yOrigin); + Tk_FreePixmap(Tk_Display(tkwin), pixmap); } /* - * Draw the window border. + * Draw the window borders, if needed. */ - if (canvasPtr->relief != TK_RELIEF_FLAT) { - Tk_Draw3DRectangle(Tk_Display(tkwin), pixmap, - canvasPtr->bgBorder, - canvasPtr->xOrigin - canvasPtr->drawableXOrigin, - canvasPtr->yOrigin - canvasPtr->drawableYOrigin, - Tk_Width(tkwin), Tk_Height(tkwin), - canvasPtr->borderWidth, canvasPtr->relief); + borders: + if (canvasPtr->flags & REDRAW_BORDERS) { + canvasPtr->flags &= ~REDRAW_BORDERS; + if (canvasPtr->borderWidth > 0) { + Tk_Draw3DRectangle(tkwin, Tk_WindowId(tkwin), + canvasPtr->bgBorder, canvasPtr->highlightWidth, + canvasPtr->highlightWidth, + Tk_Width(tkwin) - 2*canvasPtr->highlightWidth, + Tk_Height(tkwin) - 2*canvasPtr->highlightWidth, + canvasPtr->borderWidth, canvasPtr->relief); + } + if (canvasPtr->highlightWidth != 0) { + GC gc; + + if (canvasPtr->textInfo.gotFocus) { + gc = Tk_GCForColor(canvasPtr->highlightColorPtr, + Tk_WindowId(tkwin)); + } else { + gc = Tk_GCForColor(canvasPtr->highlightBgColorPtr, + Tk_WindowId(tkwin)); + } + Tk_DrawFocusHighlight(tkwin, gc, canvasPtr->highlightWidth, + Tk_WindowId(tkwin)); + } } - /* - * Copy from the temporary pixmap to the screen, then free up - * the temporary pixmap. - */ - - XCopyArea(Tk_Display(tkwin), pixmap, Tk_WindowId(tkwin), - canvasPtr->pixmapGC, - screenX1 - canvasPtr->drawableXOrigin, - screenY1 - canvasPtr->drawableYOrigin, - screenX2 - screenX1, screenY2 - screenY1, - screenX1 - canvasPtr->xOrigin, screenY1 - canvasPtr->yOrigin); - XFreePixmap(Tk_Display(tkwin), pixmap); - done: canvasPtr->flags &= ~REDRAW_PENDING; + canvasPtr->redrawX1 = canvasPtr->redrawX2 = 0; + canvasPtr->redrawY1 = canvasPtr->redrawY2 = 0; if (canvasPtr->flags & UPDATE_SCROLLBARS) { CanvasUpdateScrollbars(canvasPtr); } @@ -1681,22 +1792,35 @@ CanvasEventProc(clientData, eventPtr) ClientData clientData; /* Information about window. */ XEvent *eventPtr; /* Information about event. */ { - Tk_Canvas *canvasPtr = (Tk_Canvas *) clientData; + TkCanvas *canvasPtr = (TkCanvas *) clientData; if (eventPtr->type == Expose) { int x, y; x = eventPtr->xexpose.x + canvasPtr->xOrigin; y = eventPtr->xexpose.y + canvasPtr->yOrigin; - EventuallyRedrawArea(canvasPtr, x, y, x + eventPtr->xexpose.width, + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, x, y, + x + eventPtr->xexpose.width, y + eventPtr->xexpose.height); - } else if (eventPtr->type == DestroyNotify) { - Tcl_DeleteCommand(canvasPtr->interp, Tk_PathName(canvasPtr->tkwin)); - canvasPtr->tkwin = NULL; - if (canvasPtr->flags & REDRAW_PENDING) { - Tk_CancelIdleCall(DisplayCanvas, (ClientData) canvasPtr); + if ((eventPtr->xexpose.x < canvasPtr->inset) + || (eventPtr->xexpose.y < canvasPtr->inset) + || ((eventPtr->xexpose.x + eventPtr->xexpose.width) + > (Tk_Width(canvasPtr->tkwin) - canvasPtr->inset)) + || ((eventPtr->xexpose.y + eventPtr->xexpose.height) + > (Tk_Height(canvasPtr->tkwin) - canvasPtr->inset))) { + canvasPtr->flags |= REDRAW_BORDERS; } - Tk_EventuallyFree((ClientData) canvasPtr, DestroyCanvas); + } else if (eventPtr->type == DestroyNotify) { + if (canvasPtr->tkwin != NULL) { + canvasPtr->tkwin = NULL; + Tcl_DeleteCommand(canvasPtr->interp, + Tcl_GetCommandName(canvasPtr->interp, + canvasPtr->widgetCmd)); + } + if (canvasPtr->flags & REDRAW_PENDING) { + Tcl_CancelIdleCall(DisplayCanvas, (ClientData) canvasPtr); + } + Tcl_EventuallyFree((ClientData) canvasPtr, DestroyCanvas); } else if (eventPtr->type == ConfigureNotify) { canvasPtr->flags |= UPDATE_SCROLLBARS; @@ -1706,14 +1830,21 @@ CanvasEventProc(clientData, eventPtr) */ CanvasSetOrigin(canvasPtr, canvasPtr->xOrigin, canvasPtr->yOrigin); - EventuallyRedrawArea(canvasPtr, 0, 0, Tk_Width(canvasPtr->tkwin), - Tk_Height(canvasPtr->tkwin)); + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, canvasPtr->xOrigin, + canvasPtr->yOrigin, + canvasPtr->xOrigin + Tk_Width(canvasPtr->tkwin), + canvasPtr->yOrigin + Tk_Height(canvasPtr->tkwin)); + canvasPtr->flags |= REDRAW_BORDERS; } else if (eventPtr->type == FocusIn) { - CanvasFocusProc(canvasPtr, 1); + if (eventPtr->xfocus.detail != NotifyInferior) { + CanvasFocusProc(canvasPtr, 1); + } } else if (eventPtr->type == FocusOut) { - CanvasFocusProc(canvasPtr, 0); + if (eventPtr->xfocus.detail != NotifyInferior) { + CanvasFocusProc(canvasPtr, 0); + } } else if (eventPtr->type == UnmapNotify) { - register Tk_Item *itemPtr; + Tk_Item *itemPtr; /* * Special hack: if the canvas is unmapped, then must notify @@ -1724,19 +1855,58 @@ CanvasEventProc(clientData, eventPtr) for (itemPtr = canvasPtr->firstItemPtr; itemPtr != NULL; itemPtr = itemPtr->nextPtr) { if (itemPtr->typePtr->alwaysRedraw) { - (*itemPtr->typePtr->displayProc)(canvasPtr, itemPtr, None); + (*itemPtr->typePtr->displayProc)((Tk_Canvas) canvasPtr, + itemPtr, canvasPtr->display, None, 0, 0, 0, 0); } } } } +/* + *---------------------------------------------------------------------- + * + * CanvasCmdDeletedProc -- + * + * This procedure is invoked when a widget command is deleted. If + * the widget isn't already in the process of being destroyed, + * this command destroys it. + * + * Results: + * None. + * + * Side effects: + * The widget is destroyed. + * + *---------------------------------------------------------------------- + */ + +static void +CanvasCmdDeletedProc(clientData) + ClientData clientData; /* Pointer to widget record for widget. */ +{ + TkCanvas *canvasPtr = (TkCanvas *) clientData; + Tk_Window tkwin = canvasPtr->tkwin; + + /* + * This procedure could be invoked either because the window was + * destroyed and the command was then deleted (in which case tkwin + * is NULL) or because the command was deleted, and then this procedure + * destroys the widget. + */ + + if (tkwin != NULL) { + canvasPtr->tkwin = NULL; + Tk_DestroyWindow(tkwin); + } +} + /* *-------------------------------------------------------------- * - * EventuallyRedrawArea -- + * Tk_CanvasEventuallyRedraw -- * * Arrange for part or all of a canvas widget to redrawn at - * the next convenient time in the future. + * some convenient time in the future. * * Results: * None. @@ -1747,17 +1917,16 @@ CanvasEventProc(clientData, eventPtr) *-------------------------------------------------------------- */ -static void -EventuallyRedrawArea(canvasPtr, x1, y1, x2, y2) - register Tk_Canvas *canvasPtr; /* Information about widget. */ - int x1, y1; /* Upper left corner of area to - * redraw. Pixels on edge are - * redrawn. */ - int x2, y2; /* Lower right corner of area to - * redraw. Pixels on edge are - * not redrawn. */ +void +Tk_CanvasEventuallyRedraw(canvas, x1, y1, x2, y2) + Tk_Canvas canvas; /* Information about widget. */ + int x1, y1; /* Upper left corner of area to redraw. + * Pixels on edge are redrawn. */ + int x2, y2; /* Lower right corner of area to redraw. + * Pixels on edge are not redrawn. */ { - if ((canvasPtr->tkwin == NULL) || !Tk_IsMapped(canvasPtr->tkwin)) { + TkCanvas *canvasPtr = (TkCanvas *) canvas; + if ((x1 == x2) || (y1 == y2)) { return; } if (canvasPtr->flags & REDRAW_PENDING) { @@ -1778,7 +1947,7 @@ EventuallyRedrawArea(canvasPtr, x1, y1, x2, y2) canvasPtr->redrawY1 = y1; canvasPtr->redrawX2 = x2; canvasPtr->redrawY2 = y2; - Tk_DoWhenIdle(DisplayCanvas, (ClientData) canvasPtr); + Tcl_DoWhenIdle(DisplayCanvas, (ClientData) canvasPtr); canvasPtr->flags |= REDRAW_PENDING; } } @@ -1810,13 +1979,58 @@ Tk_CreateItemType(typePtr) * storage must be statically * allocated (must live forever). */ { + Tk_ItemType *typePtr2, *prevPtr; + if (typeList == NULL) { InitCanvas(); } + + /* + * If there's already an item type with the given name, remove it. + */ + + for (typePtr2 = typeList, prevPtr = NULL; typePtr2 != NULL; + prevPtr = typePtr2, typePtr2 = typePtr2->nextPtr) { + if (strcmp(typePtr2->name, typePtr->name) == 0) { + if (prevPtr == NULL) { + typeList = typePtr2->nextPtr; + } else { + prevPtr->nextPtr = typePtr2->nextPtr; + } + break; + } + } typePtr->nextPtr = typeList; typeList = typePtr; } +/* + *---------------------------------------------------------------------- + * + * Tk_GetItemTypes -- + * + * This procedure returns a pointer to the list of all item + * types. + * + * Results: + * The return value is a pointer to the first in the list + * of item types currently supported by canvases. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tk_ItemType * +Tk_GetItemTypes() +{ + if (typeList == NULL) { + InitCanvas(); + } + return typeList; +} + /* *-------------------------------------------------------------- * @@ -1841,15 +2055,16 @@ InitCanvas() if (typeList != NULL) { return; } - typeList = &TkRectangleType; - TkRectangleType.nextPtr = &TkTextType; - TkTextType.nextPtr = &TkPolygonType; - TkPolygonType.nextPtr = &TkOvalType; - TkOvalType.nextPtr = &TkLineType; - TkLineType.nextPtr = &TkWindowType; - TkWindowType.nextPtr = &TkBitmapType; - TkBitmapType.nextPtr = &TkArcType; - TkArcType.nextPtr = NULL; + typeList = &tkRectangleType; + tkRectangleType.nextPtr = &tkTextType; + tkTextType.nextPtr = &tkLineType; + tkLineType.nextPtr = &tkPolygonType; + tkPolygonType.nextPtr = &tkImageType; + tkImageType.nextPtr = &tkOvalType; + tkOvalType.nextPtr = &tkBitmapType; + tkBitmapType.nextPtr = &tkArcType; + tkArcType.nextPtr = &tkWindowType; + tkWindowType.nextPtr = NULL; allUid = Tk_GetUid("all"); currentUid = Tk_GetUid("current"); } @@ -1881,17 +2096,17 @@ InitCanvas() static Tk_Item * StartTagSearch(canvasPtr, tag, searchPtr) - Tk_Canvas *canvasPtr; /* Canvas whose items are to be + TkCanvas *canvasPtr; /* Canvas whose items are to be * searched. */ char *tag; /* String giving tag value. */ TagSearch *searchPtr; /* Record describing tag search; * will be initialized here. */ { int id; - register Tk_Item *itemPtr, *prevPtr; - register Tk_Uid *tagPtr; - register Tk_Uid uid; - register int count; + Tk_Item *itemPtr, *prevPtr; + Tk_Uid *tagPtr; + Tk_Uid uid; + int count; /* * Initialize the search. @@ -1993,10 +2208,10 @@ NextItem(searchPtr) TagSearch *searchPtr; /* Record describing search in * progress. */ { - register Tk_Item *itemPtr, *prevPtr; - register int count; - register Tk_Uid uid; - register Tk_Uid *tagPtr; + Tk_Item *itemPtr, *prevPtr; + int count; + Tk_Uid uid; + Tk_Uid *tagPtr; /* * Find next item in list (this may not actually be a suitable @@ -2080,12 +2295,12 @@ static void DoItem(interp, itemPtr, tag) Tcl_Interp *interp; /* Interpreter in which to (possibly) * record item id. */ - register Tk_Item *itemPtr; /* Item to (possibly) modify. */ + Tk_Item *itemPtr; /* Item to (possibly) modify. */ Tk_Uid tag; /* Tag to add to those already * present for item, or NULL. */ { - register Tk_Uid *tagPtr; - register int count; + Tk_Uid *tagPtr; + int count; /* * Handle the "add-to-result" case and return, if appropriate. @@ -2161,7 +2376,7 @@ DoItem(interp, itemPtr, tag) static int FindItems(interp, canvasPtr, argc, argv, newTag, cmdName, option) Tcl_Interp *interp; /* Interpreter for error reporting. */ - Tk_Canvas *canvasPtr; /* Canvas whose items are to be + TkCanvas *canvasPtr; /* Canvas whose items are to be * searched. */ int argc; /* Number of entries in argv. Must be * greater than zero. */ @@ -2178,10 +2393,10 @@ FindItems(interp, canvasPtr, argc, argv, newTag, cmdName, option) * from Tcl command and other stuff * up to what's in argc/argv. */ { - char c; - int length; + int c; + size_t length; TagSearch search; - register Tk_Item *itemPtr; + Tk_Item *itemPtr; Tk_Uid uid; if (newTag != NULL) { @@ -2195,7 +2410,7 @@ FindItems(interp, canvasPtr, argc, argv, newTag, cmdName, option) && (length >= 2)) { Tk_Item *lastPtr = NULL; if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: must be \"", + Tcl_AppendResult(interp, "wrong # args: should be \"", cmdName, option, " above tagOrId", (char *) NULL); return TCL_ERROR; } @@ -2209,7 +2424,7 @@ FindItems(interp, canvasPtr, argc, argv, newTag, cmdName, option) } else if ((c == 'a') && (strncmp(argv[0], "all", length) == 0) && (length >= 2)) { if (argc != 1) { - Tcl_AppendResult(interp, "wrong # args: must be \"", + Tcl_AppendResult(interp, "wrong # args: should be \"", cmdName, option, " all", (char *) NULL); return TCL_ERROR; } @@ -2220,7 +2435,7 @@ FindItems(interp, canvasPtr, argc, argv, newTag, cmdName, option) } } else if ((c == 'b') && (strncmp(argv[0], "below", length) == 0)) { if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: must be \"", + Tcl_AppendResult(interp, "wrong # args: should be \"", cmdName, option, " below tagOrId", (char *) NULL); return TCL_ERROR; } @@ -2235,18 +2450,19 @@ FindItems(interp, canvasPtr, argc, argv, newTag, cmdName, option) int x1, y1, x2, y2; if ((argc < 3) || (argc > 5)) { - Tcl_AppendResult(interp, "wrong # args: must be \"", + Tcl_AppendResult(interp, "wrong # args: should be \"", cmdName, option, " closest x y ?halo? ?start?", (char *) NULL); return TCL_ERROR; } - if ((TkGetCanvasCoord(canvasPtr, argv[1], &coords[0]) != TCL_OK) - || (TkGetCanvasCoord(canvasPtr, argv[2], &coords[1]) - != TCL_OK)) { + if ((Tk_CanvasGetCoord(interp, (Tk_Canvas) canvasPtr, argv[1], + &coords[0]) != TCL_OK) || (Tk_CanvasGetCoord(interp, + (Tk_Canvas) canvasPtr, argv[2], &coords[1]) != TCL_OK)) { return TCL_ERROR; } if (argc > 3) { - if (TkGetCanvasCoord(canvasPtr, argv[3], &halo) != TCL_OK) { + if (Tk_CanvasGetCoord(interp, (Tk_Canvas) canvasPtr, argv[3], + &halo) != TCL_OK) { return TCL_ERROR; } if (halo < 0.0) { @@ -2282,7 +2498,7 @@ FindItems(interp, canvasPtr, argc, argv, newTag, cmdName, option) if (itemPtr == NULL) { return TCL_OK; } - closestDist = (*itemPtr->typePtr->pointProc)(canvasPtr, + closestDist = (*itemPtr->typePtr->pointProc)((Tk_Canvas) canvasPtr, itemPtr, coords) - halo; if (closestDist < 0.0) { closestDist = 0.0; @@ -2320,7 +2536,7 @@ FindItems(interp, canvasPtr, argc, argv, newTag, cmdName, option) || (itemPtr->y1 >= y2) || (itemPtr->y2 <= y1)) { continue; } - newDist = (*itemPtr->typePtr->pointProc)(canvasPtr, + newDist = (*itemPtr->typePtr->pointProc)((Tk_Canvas) canvasPtr, itemPtr, coords) - halo; if (newDist < 0.0) { newDist = 0.0; @@ -2333,22 +2549,22 @@ FindItems(interp, canvasPtr, argc, argv, newTag, cmdName, option) } } else if ((c == 'e') && (strncmp(argv[0], "enclosed", length) == 0)) { if (argc != 5) { - Tcl_AppendResult(interp, "wrong # args: must be \"", + Tcl_AppendResult(interp, "wrong # args: should be \"", cmdName, option, " enclosed x1 y1 x2 y2", (char *) NULL); return TCL_ERROR; } return FindArea(interp, canvasPtr, argv+1, uid, 1); } else if ((c == 'o') && (strncmp(argv[0], "overlapping", length) == 0)) { if (argc != 5) { - Tcl_AppendResult(interp, "wrong # args: must be \"", + Tcl_AppendResult(interp, "wrong # args: should be \"", cmdName, option, " overlapping x1 y1 x2 y2", (char *) NULL); return TCL_ERROR; } return FindArea(interp, canvasPtr, argv+1, uid, 0); } else if ((c == 'w') && (strncmp(argv[0], "withtag", length) == 0)) { - if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: must be \"", + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", cmdName, option, " withtag tagOrId", (char *) NULL); return TCL_ERROR; } @@ -2393,7 +2609,7 @@ static int FindArea(interp, canvasPtr, argv, uid, enclosed) Tcl_Interp *interp; /* Interpreter for error reporting * and result storing. */ - Tk_Canvas *canvasPtr; /* Canvas whose items are to be + TkCanvas *canvasPtr; /* Canvas whose items are to be * searched. */ char **argv; /* Array of four arguments that * give the coordinates of the @@ -2408,12 +2624,16 @@ FindArea(interp, canvasPtr, argv, uid, enclosed) { double rect[4], tmp; int x1, y1, x2, y2; - register Tk_Item *itemPtr; + Tk_Item *itemPtr; - if ((TkGetCanvasCoord(canvasPtr, argv[0], &rect[0]) != TCL_OK) - || (TkGetCanvasCoord(canvasPtr, argv[1], &rect[1]) != TCL_OK) - || (TkGetCanvasCoord(canvasPtr, argv[2], &rect[2]) != TCL_OK) - || (TkGetCanvasCoord(canvasPtr, argv[3], &rect[3]) != TCL_OK)) { + if ((Tk_CanvasGetCoord(interp, (Tk_Canvas) canvasPtr, argv[0], + &rect[0]) != TCL_OK) + || (Tk_CanvasGetCoord(interp, (Tk_Canvas) canvasPtr, argv[1], + &rect[1]) != TCL_OK) + || (Tk_CanvasGetCoord(interp, (Tk_Canvas) canvasPtr, argv[2], + &rect[2]) != TCL_OK) + || (Tk_CanvasGetCoord(interp, (Tk_Canvas) canvasPtr, argv[3], + &rect[3]) != TCL_OK)) { return TCL_ERROR; } if (rect[0] > rect[2]) { @@ -2438,7 +2658,7 @@ FindArea(interp, canvasPtr, argv, uid, enclosed) || (itemPtr->y1 >= y2) || (itemPtr->y2 <= y1)) { continue; } - if ((*itemPtr->typePtr->areaProc)(canvasPtr, itemPtr, rect) + if ((*itemPtr->typePtr->areaProc)((Tk_Canvas) canvasPtr, itemPtr, rect) >= enclosed) { DoItem(interp, itemPtr, uid); } @@ -2468,14 +2688,14 @@ FindArea(interp, canvasPtr, argv, uid, enclosed) static void RelinkItems(canvasPtr, tag, prevPtr) - Tk_Canvas *canvasPtr; /* Canvas to be modified. */ + TkCanvas *canvasPtr; /* Canvas to be modified. */ char *tag; /* Tag identifying items to be moved * in the redisplay list. */ Tk_Item *prevPtr; /* Reposition the items so that they * go just after this item (NULL means * put at beginning of list). */ { - register Tk_Item *itemPtr; + Tk_Item *itemPtr; TagSearch search; Tk_Item *firstMovePtr, *lastMovePtr; @@ -2510,7 +2730,7 @@ RelinkItems(canvasPtr, tag, prevPtr) lastMovePtr->nextPtr = itemPtr; } lastMovePtr = itemPtr; - EventuallyRedrawArea(canvasPtr, itemPtr->x1, itemPtr->y1, + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, itemPtr->x1, itemPtr->y1, itemPtr->x2, itemPtr->y2); canvasPtr->flags |= REPICK_NEEDED; } @@ -2559,9 +2779,9 @@ CanvasBindProc(clientData, eventPtr) XEvent *eventPtr; /* Pointer to X event that just * happened. */ { - Tk_Canvas *canvasPtr = (Tk_Canvas *) clientData; + TkCanvas *canvasPtr = (TkCanvas *) clientData; - Tk_Preserve((ClientData) canvasPtr); + Tcl_Preserve((ClientData) canvasPtr); /* * This code below keeps track of the current modifier state in @@ -2592,11 +2812,40 @@ CanvasBindProc(clientData, eventPtr) mask = 0; break; } - CanvasDoEvent(canvasPtr, eventPtr); - eventPtr->xbutton.state ^= mask; - canvasPtr->state = eventPtr->xbutton.state; - PickCurrentItem(canvasPtr, eventPtr); - eventPtr->xbutton.state ^= mask; + + /* + * For button press events, repick the current item using the + * button state before the event, then process the event. For + * button release events, first process the event, then repick + * the current item using the button state *after* the event + * (the button has logically gone up before we change the + * current item). + */ + + if (eventPtr->type == ButtonPress) { + /* + * On a button press, first repick the current item using + * the button state before the event, the process the event. + */ + + canvasPtr->state = eventPtr->xbutton.state; + PickCurrentItem(canvasPtr, eventPtr); + canvasPtr->state ^= mask; + CanvasDoEvent(canvasPtr, eventPtr); + } else { + /* + * Button release: first process the event, with the button + * still considered to be down. Then repick the current + * item under the assumption that the button is no longer down. + */ + + canvasPtr->state = eventPtr->xbutton.state; + CanvasDoEvent(canvasPtr, eventPtr); + eventPtr->xbutton.state ^= mask; + canvasPtr->state = eventPtr->xbutton.state; + PickCurrentItem(canvasPtr, eventPtr); + eventPtr->xbutton.state ^= mask; + } goto done; } else if ((eventPtr->type == EnterNotify) || (eventPtr->type == LeaveNotify)) { @@ -2610,7 +2859,7 @@ CanvasBindProc(clientData, eventPtr) CanvasDoEvent(canvasPtr, eventPtr); done: - Tk_Release((ClientData) canvasPtr); + Tcl_Release((ClientData) canvasPtr); } /* @@ -2630,31 +2879,36 @@ CanvasBindProc(clientData, eventPtr) * Side effects: * The current item for canvasPtr may change. If it does, * then the commands associated with item entry and exit - * could do just about anything. + * could do just about anything. A binding script could + * delete the canvas, so callers should protect themselves + * with Tcl_Preserve and Tcl_Release. * *-------------------------------------------------------------- */ static void PickCurrentItem(canvasPtr, eventPtr) - register Tk_Canvas *canvasPtr; /* Canvas pointer in which to select + TkCanvas *canvasPtr; /* Canvas widget in which to select * current item. */ XEvent *eventPtr; /* Event describing location of * mouse cursor. Must be EnterWindow, * LeaveWindow, ButtonRelease, or * MotionNotify. */ { - Tk_Item *closestPtr = NULL; + double coords[2]; + int buttonDown; /* - * If a button is down, then don't do anything at all; we'll be - * called again when all buttons are up, and we can repick then. - * This implements a form of mouse grabbing for canvases. + * Check whether or not a button is down. If so, we'll log entry + * and exit into and out of the current item, but not entry into + * any other item. This implements a form of grabbing equivalent + * to what the X server does for windows. */ - if (canvasPtr->state - & (Button1Mask|Button2Mask|Button3Mask|Button4Mask|Button5Mask)) { - return; + buttonDown = canvasPtr->state + & (Button1Mask|Button2Mask|Button3Mask|Button4Mask|Button5Mask); + if (!buttonDown) { + canvasPtr->flags &= ~LEFT_GRABBED_ITEM; } /* @@ -2697,33 +2951,36 @@ PickCurrentItem(canvasPtr, eventPtr) } /* - * A LeaveNotify event automatically means that there's no current - * object, so the rest of the code below can be skipped. + * If this is a recursive call (there's already a partially completed + * call pending on the stack; it's in the middle of processing a + * Leave event handler for the old current item) then just return; + * the pending call will do everything that's needed. */ + if (canvasPtr->flags & REPICK_IN_PROGRESS) { + return; + } + + /* + * A LeaveNotify event automatically means that there's no current + * object, so the check for closest item can be skipped. + */ + + coords[0] = canvasPtr->pickEvent.xcrossing.x + canvasPtr->xOrigin; + coords[1] = canvasPtr->pickEvent.xcrossing.y + canvasPtr->yOrigin; if (canvasPtr->pickEvent.type != LeaveNotify) { - int x1, y1, x2, y2; - double coords[2]; - register Tk_Item *itemPtr; + canvasPtr->newCurrentPtr = CanvasFindClosest(canvasPtr, coords); + } else { + canvasPtr->newCurrentPtr = NULL; + } - coords[0] = canvasPtr->pickEvent.xcrossing.x + canvasPtr->xOrigin; - coords[1] = canvasPtr->pickEvent.xcrossing.y + canvasPtr->yOrigin; - x1 = coords[0] - canvasPtr->closeEnough; - y1 = coords[1] - canvasPtr->closeEnough; - x2 = coords[0] + canvasPtr->closeEnough; - y2 = coords[1] + canvasPtr->closeEnough; + if ((canvasPtr->newCurrentPtr == canvasPtr->currentItemPtr) + && !(canvasPtr->flags & LEFT_GRABBED_ITEM)) { + /* + * Nothing to do: the current item hasn't changed. + */ - for (itemPtr = canvasPtr->firstItemPtr; itemPtr != NULL; - itemPtr = itemPtr->nextPtr) { - if ((itemPtr->x1 > x2) || (itemPtr->x2 < x1) - || (itemPtr->y1 > y2) || (itemPtr->y2 < y1)) { - continue; - } - if ((*itemPtr->typePtr->pointProc)(canvasPtr, - itemPtr, coords) <= canvasPtr->closeEnough) { - closestPtr = itemPtr; - } - } + return; } /* @@ -2733,24 +2990,33 @@ PickCurrentItem(canvasPtr, eventPtr) * item. */ - if (closestPtr == canvasPtr->currentItemPtr) { - return; - } - if (canvasPtr->currentItemPtr != NULL) { + if ((canvasPtr->newCurrentPtr != canvasPtr->currentItemPtr) + && (canvasPtr->currentItemPtr != NULL) + && !(canvasPtr->flags & LEFT_GRABBED_ITEM)) { XEvent event; Tk_Item *itemPtr = canvasPtr->currentItemPtr; int i; event = canvasPtr->pickEvent; event.type = LeaveNotify; + + /* + * If the event's detail happens to be NotifyInferior the + * binding mechanism will discard the event. To be consistent, + * always use NotifyAncestor. + */ + + event.xcrossing.detail = NotifyAncestor; + canvasPtr->flags |= REPICK_IN_PROGRESS; CanvasDoEvent(canvasPtr, &event); + canvasPtr->flags &= ~REPICK_IN_PROGRESS; /* * The check below is needed because there could be an event * handler for that deletes the current item. */ - if (itemPtr == canvasPtr->currentItemPtr) { + if ((itemPtr == canvasPtr->currentItemPtr) && !buttonDown) { for (i = itemPtr->numTags-1; i >= 0; i--) { if (itemPtr->tagPtr[i] == currentUid) { itemPtr->tagPtr[i] = itemPtr->tagPtr[itemPtr->numTags-1]; @@ -2759,18 +3025,85 @@ PickCurrentItem(canvasPtr, eventPtr) } } } + + /* + * Note: during CanvasDoEvent above, it's possible that + * canvasPtr->newCurrentPtr got reset to NULL because the + * item was deleted. + */ } - canvasPtr->currentItemPtr = closestPtr; + if ((canvasPtr->newCurrentPtr != canvasPtr->currentItemPtr) && buttonDown) { + canvasPtr->flags |= LEFT_GRABBED_ITEM; + return; + } + + /* + * Special note: it's possible that canvasPtr->newCurrentPtr == + * canvasPtr->currentItemPtr here. This can happen, for example, + * if LEFT_GRABBED_ITEM was set. + */ + + canvasPtr->flags &= ~LEFT_GRABBED_ITEM; + canvasPtr->currentItemPtr = canvasPtr->newCurrentPtr; if (canvasPtr->currentItemPtr != NULL) { XEvent event; - DoItem((Tcl_Interp *) NULL, closestPtr, currentUid); + DoItem((Tcl_Interp *) NULL, canvasPtr->currentItemPtr, currentUid); event = canvasPtr->pickEvent; event.type = EnterNotify; + event.xcrossing.detail = NotifyAncestor; CanvasDoEvent(canvasPtr, &event); } } +/* + *---------------------------------------------------------------------- + * + * CanvasFindClosest -- + * + * Given x and y coordinates, find the topmost canvas item that + * is "close" to the coordinates. + * + * Results: + * The return value is a pointer to the topmost item that is + * close to (x,y), or NULL if no item is close. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tk_Item * +CanvasFindClosest(canvasPtr, coords) + TkCanvas *canvasPtr; /* Canvas widget to search. */ + double coords[2]; /* Desired x,y position in canvas, + * not screen, coordinates.) */ +{ + Tk_Item *itemPtr; + Tk_Item *bestPtr; + int x1, y1, x2, y2; + + x1 = coords[0] - canvasPtr->closeEnough; + y1 = coords[1] - canvasPtr->closeEnough; + x2 = coords[0] + canvasPtr->closeEnough; + y2 = coords[1] + canvasPtr->closeEnough; + + bestPtr = NULL; + for (itemPtr = canvasPtr->firstItemPtr; itemPtr != NULL; + itemPtr = itemPtr->nextPtr) { + if ((itemPtr->x1 > x2) || (itemPtr->x2 < x1) + || (itemPtr->y1 > y2) || (itemPtr->y2 < y1)) { + continue; + } + if ((*itemPtr->typePtr->pointProc)((Tk_Canvas) canvasPtr, + itemPtr, coords) <= canvasPtr->closeEnough) { + bestPtr = itemPtr; + } + } + return bestPtr; +} + /* *-------------------------------------------------------------- * @@ -2784,14 +3117,16 @@ PickCurrentItem(canvasPtr, eventPtr) * None. * * Side effects: - * Depends on the bindings for the canvas. + * Depends on the bindings for the canvas. A binding script + * could delete the canvas, so callers should protect themselves + * with Tcl_Preserve and Tcl_Release. * *-------------------------------------------------------------- */ static void CanvasDoEvent(canvasPtr, eventPtr) - Tk_Canvas *canvasPtr; /* Canvas widget in which event + TkCanvas *canvasPtr; /* Canvas widget in which event * occurred. */ XEvent *eventPtr; /* Real or simulated X event that * is to be processed. */ @@ -2800,7 +3135,7 @@ CanvasDoEvent(canvasPtr, eventPtr) ClientData staticObjects[NUM_STATIC]; ClientData *objectPtr; int numObjects, i; - register Tk_Item *itemPtr; + Tk_Item *itemPtr; if (canvasPtr->bindingTable == NULL) { return; @@ -2808,7 +3143,7 @@ CanvasDoEvent(canvasPtr, eventPtr) itemPtr = canvasPtr->currentItemPtr; if ((eventPtr->type == KeyPress) || (eventPtr->type == KeyRelease)) { - itemPtr = canvasPtr->focusItemPtr; + itemPtr = canvasPtr->textInfo.focusItemPtr; } if (itemPtr == NULL) { return; @@ -2829,19 +3164,21 @@ CanvasDoEvent(canvasPtr, eventPtr) objectPtr = (ClientData *) ckalloc((unsigned) (numObjects * sizeof(ClientData))); } - objectPtr[0] = (ClientData) itemPtr; + objectPtr[0] = (ClientData) allUid; for (i = itemPtr->numTags-1; i >= 0; i--) { objectPtr[i+1] = (ClientData) itemPtr->tagPtr[i]; } - objectPtr[itemPtr->numTags+1] = (ClientData) allUid; + objectPtr[itemPtr->numTags+1] = (ClientData) itemPtr; /* * Invoke the binding system, then free up the object array if * it was malloc-ed. */ - Tk_BindEvent(canvasPtr->bindingTable, eventPtr, canvasPtr->tkwin, - numObjects, objectPtr); + if (canvasPtr->tkwin != NULL) { + Tk_BindEvent(canvasPtr->bindingTable, eventPtr, canvasPtr->tkwin, + numObjects, objectPtr); + } if (objectPtr != staticObjects) { ckfree((char *) objectPtr); } @@ -2869,26 +3206,28 @@ static void CanvasBlinkProc(clientData) ClientData clientData; /* Pointer to record describing entry. */ { - register Tk_Canvas *canvasPtr = (Tk_Canvas *) clientData; + TkCanvas *canvasPtr = (TkCanvas *) clientData; - if (!(canvasPtr->flags & GOT_FOCUS) || (canvasPtr->insertOffTime == 0)) { + if (!canvasPtr->textInfo.gotFocus || (canvasPtr->insertOffTime == 0)) { return; } - if (canvasPtr->flags & CURSOR_ON) { - canvasPtr->flags &= ~CURSOR_ON; - canvasPtr->insertBlinkHandler = Tk_CreateTimerHandler( + if (canvasPtr->textInfo.cursorOn) { + canvasPtr->textInfo.cursorOn = 0; + canvasPtr->insertBlinkHandler = Tcl_CreateTimerHandler( canvasPtr->insertOffTime, CanvasBlinkProc, (ClientData) canvasPtr); } else { - canvasPtr->flags |= CURSOR_ON; - canvasPtr->insertBlinkHandler = Tk_CreateTimerHandler( - canvasPtr->insertOffTime, CanvasBlinkProc, + canvasPtr->textInfo.cursorOn = 1; + canvasPtr->insertBlinkHandler = Tcl_CreateTimerHandler( + canvasPtr->insertOnTime, CanvasBlinkProc, (ClientData) canvasPtr); } - if (canvasPtr->focusItemPtr != NULL) { - EventuallyRedrawArea(canvasPtr, canvasPtr->focusItemPtr->x1, - canvasPtr->focusItemPtr->y1, canvasPtr->focusItemPtr->x2, - canvasPtr->focusItemPtr->y2); + if (canvasPtr->textInfo.focusItemPtr != NULL) { + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + canvasPtr->textInfo.focusItemPtr->x1, + canvasPtr->textInfo.focusItemPtr->y1, + canvasPtr->textInfo.focusItemPtr->x2, + canvasPtr->textInfo.focusItemPtr->y2); } } @@ -2912,26 +3251,37 @@ CanvasBlinkProc(clientData) static void CanvasFocusProc(canvasPtr, gotFocus) - Tk_Canvas *canvasPtr; /* Canvas that just got or lost focus. */ + TkCanvas *canvasPtr; /* Canvas that just got or lost focus. */ int gotFocus; /* 1 means window is getting focus, 0 means * it's losing it. */ { - Tk_DeleteTimerHandler(canvasPtr->insertBlinkHandler); + Tcl_DeleteTimerHandler(canvasPtr->insertBlinkHandler); if (gotFocus) { - canvasPtr->flags |= GOT_FOCUS | CURSOR_ON; + canvasPtr->textInfo.gotFocus = 1; + canvasPtr->textInfo.cursorOn = 1; if (canvasPtr->insertOffTime != 0) { - canvasPtr->insertBlinkHandler = Tk_CreateTimerHandler( + canvasPtr->insertBlinkHandler = Tcl_CreateTimerHandler( canvasPtr->insertOffTime, CanvasBlinkProc, (ClientData) canvasPtr); } } else { - canvasPtr->flags &= ~(GOT_FOCUS | CURSOR_ON); - canvasPtr->insertBlinkHandler = (Tk_TimerToken) NULL; + canvasPtr->textInfo.gotFocus = 0; + canvasPtr->textInfo.cursorOn = 0; + canvasPtr->insertBlinkHandler = (Tcl_TimerToken) NULL; } - if (canvasPtr->focusItemPtr != NULL) { - EventuallyRedrawArea(canvasPtr, canvasPtr->focusItemPtr->x1, - canvasPtr->focusItemPtr->y1, canvasPtr->focusItemPtr->x2, - canvasPtr->focusItemPtr->y2); + if (canvasPtr->textInfo.focusItemPtr != NULL) { + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + canvasPtr->textInfo.focusItemPtr->x1, + canvasPtr->textInfo.focusItemPtr->y1, + canvasPtr->textInfo.focusItemPtr->x2, + canvasPtr->textInfo.focusItemPtr->y2); + } + if (canvasPtr->highlightWidth > 0) { + canvasPtr->flags |= REDRAW_BORDERS; + if (!(canvasPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(DisplayCanvas, (ClientData) canvasPtr); + canvasPtr->flags |= REDRAW_PENDING; + } } } @@ -2954,49 +3304,50 @@ CanvasFocusProc(canvasPtr, gotFocus) static void CanvasSelectTo(canvasPtr, itemPtr, index) - register Tk_Canvas *canvasPtr; /* Information about widget. */ - register Tk_Item *itemPtr; /* Item that is to hold selection. */ - int index; /* Index of element that is to - * become the "other" end of the - * selection. */ + TkCanvas *canvasPtr; /* Information about widget. */ + Tk_Item *itemPtr; /* Item that is to hold selection. */ + int index; /* Index of element that is to become the + * "other" end of the selection. */ { int oldFirst, oldLast; Tk_Item *oldSelPtr; - oldFirst = canvasPtr->selectFirst; - oldLast = canvasPtr->selectLast; - oldSelPtr = canvasPtr->selItemPtr; + oldFirst = canvasPtr->textInfo.selectFirst; + oldLast = canvasPtr->textInfo.selectLast; + oldSelPtr = canvasPtr->textInfo.selItemPtr; /* * Grab the selection if we don't own it already. */ - if (canvasPtr->selItemPtr == NULL) { - Tk_OwnSelection(canvasPtr->tkwin, CanvasLostSelection, + if (canvasPtr->textInfo.selItemPtr == NULL) { + Tk_OwnSelection(canvasPtr->tkwin, XA_PRIMARY, CanvasLostSelection, (ClientData) canvasPtr); - } else if (canvasPtr->selItemPtr != itemPtr) { - EventuallyRedrawArea(canvasPtr, canvasPtr->selItemPtr->x1, - canvasPtr->selItemPtr->y1, canvasPtr->selItemPtr->x2, - canvasPtr->selItemPtr->y2); + } else if (canvasPtr->textInfo.selItemPtr != itemPtr) { + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + canvasPtr->textInfo.selItemPtr->x1, + canvasPtr->textInfo.selItemPtr->y1, + canvasPtr->textInfo.selItemPtr->x2, + canvasPtr->textInfo.selItemPtr->y2); } - canvasPtr->selItemPtr = itemPtr; + canvasPtr->textInfo.selItemPtr = itemPtr; - if (canvasPtr->anchorItemPtr != itemPtr) { - canvasPtr->anchorItemPtr = itemPtr; - canvasPtr->selectAnchor = index; + if (canvasPtr->textInfo.anchorItemPtr != itemPtr) { + canvasPtr->textInfo.anchorItemPtr = itemPtr; + canvasPtr->textInfo.selectAnchor = index; } - if (canvasPtr->selectAnchor <= index) { - canvasPtr->selectFirst = canvasPtr->selectAnchor; - canvasPtr->selectLast = index; + if (canvasPtr->textInfo.selectAnchor <= index) { + canvasPtr->textInfo.selectFirst = canvasPtr->textInfo.selectAnchor; + canvasPtr->textInfo.selectLast = index; } else { - canvasPtr->selectFirst = index; - canvasPtr->selectLast = canvasPtr->selectAnchor - 1; + canvasPtr->textInfo.selectFirst = index; + canvasPtr->textInfo.selectLast = canvasPtr->textInfo.selectAnchor - 1; } - if ((canvasPtr->selectFirst != oldFirst) - || (canvasPtr->selectLast != oldLast) + if ((canvasPtr->textInfo.selectFirst != oldFirst) + || (canvasPtr->textInfo.selectLast != oldLast) || (itemPtr != oldSelPtr)) { - EventuallyRedrawArea(canvasPtr, itemPtr->x1, itemPtr->y1, - itemPtr->x2, itemPtr->y2); + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + itemPtr->x1, itemPtr->y1, itemPtr->x2, itemPtr->y2); } } @@ -3032,16 +3383,17 @@ CanvasFetchSelection(clientData, offset, buffer, maxBytes) * at buffer, not including terminating * NULL character. */ { - register Tk_Canvas *canvasPtr = (Tk_Canvas *) clientData; + TkCanvas *canvasPtr = (TkCanvas *) clientData; - if (canvasPtr->selItemPtr == NULL) { + if (canvasPtr->textInfo.selItemPtr == NULL) { return -1; } - if (canvasPtr->selItemPtr->typePtr->selectionProc == NULL) { + if (canvasPtr->textInfo.selItemPtr->typePtr->selectionProc == NULL) { return -1; } - return (*canvasPtr->selItemPtr->typePtr->selectionProc)( - canvasPtr, canvasPtr->selItemPtr, offset, buffer, maxBytes); + return (*canvasPtr->textInfo.selItemPtr->typePtr->selectionProc)( + (Tk_Canvas) canvasPtr, canvasPtr->textInfo.selItemPtr, offset, + buffer, maxBytes); } /* @@ -3066,50 +3418,16 @@ static void CanvasLostSelection(clientData) ClientData clientData; /* Information about entry widget. */ { - Tk_Canvas *canvasPtr = (Tk_Canvas *) clientData; + TkCanvas *canvasPtr = (TkCanvas *) clientData; - if (canvasPtr->selItemPtr != NULL) { - EventuallyRedrawArea(canvasPtr, canvasPtr->selItemPtr->x1, - canvasPtr->selItemPtr->y1, canvasPtr->selItemPtr->x2, - canvasPtr->selItemPtr->y2); + if (canvasPtr->textInfo.selItemPtr != NULL) { + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + canvasPtr->textInfo.selItemPtr->x1, + canvasPtr->textInfo.selItemPtr->y1, + canvasPtr->textInfo.selItemPtr->x2, + canvasPtr->textInfo.selItemPtr->y2); } - canvasPtr->selItemPtr = NULL; -} - -/* - *-------------------------------------------------------------- - * - * TkGetCanvasCoord -- - * - * Given a string, returns a floating-point canvas coordinate - * corresponding to that string. - * - * Results: - * The return value is a standard Tcl return result. If - * TCL_OK is returned, then everything went well and the - * canvas coordinate is stored at *doublePtr; otherwise - * TCL_ERROR is returned and an error message is left in - * canvasPtr->interp->result. - * - * Side effects: - * None. - * - *-------------------------------------------------------------- - */ - -int -TkGetCanvasCoord(canvasPtr, string, doublePtr) - Tk_Canvas *canvasPtr; /* Canvas to which coordinate applies. */ - char *string; /* Describes coordinate (any screen - * coordinate form may be used here). */ - double *doublePtr; /* Place to store converted coordinate. */ -{ - if (Tk_GetScreenMM(canvasPtr->interp, canvasPtr->tkwin, string, - doublePtr) != TCL_OK) { - return TCL_ERROR; - } - *doublePtr *= canvasPtr->pixelsPerMM; - return TCL_OK; + canvasPtr->textInfo.selItemPtr = NULL; } /* @@ -3146,6 +3464,59 @@ GridAlign(coord, spacing) return ((int) (coord/spacing + 0.5)) * spacing; } +/* + *---------------------------------------------------------------------- + * + * PrintScrollFractions -- + * + * Given the range that's visible in the window and the "100% + * range" for what's in the canvas, print a string containing + * the scroll fractions. This procedure is used for both x + * and y scrolling. + * + * Results: + * The memory pointed to by string is modified to hold + * two real numbers containing the scroll fractions (between + * 0 and 1) corresponding to the other arguments. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +PrintScrollFractions(screen1, screen2, object1, object2, string) + int screen1; /* Lowest coordinate visible in the window. */ + int screen2; /* Highest coordinate visible in the window. */ + int object1; /* Lowest coordinate in the object. */ + int object2; /* Highest coordinate in the object. */ + char *string; /* Two real numbers get printed here. Must + * have enough storage for two %g + * conversions. */ +{ + double range, f1, f2; + + range = object2 - object1; + if (range <= 0) { + f1 = 0; + f2 = 1.0; + } else { + f1 = (screen1 - object1)/range; + if (f1 < 0) { + f1 = 0.0; + } + f2 = (screen2 - object1)/range; + if (f2 > 1.0) { + f2 = 1.0; + } + if (f2 < f1) { + f2 = f1; + } + } + sprintf(string, "%g %g", f1, f2); +} + /* *-------------------------------------------------------------- * @@ -3169,62 +3540,62 @@ GridAlign(coord, spacing) static void CanvasUpdateScrollbars(canvasPtr) - register Tk_Canvas *canvasPtr; /* Information about canvas. */ + TkCanvas *canvasPtr; /* Information about canvas. */ { - int result, size, first, last, page; - char args[200]; + int result; + char buffer[200]; + Tcl_Interp *interp; + int xOrigin, yOrigin, inset, width, height, scrollX1, scrollX2, + scrollY1, scrollY2; + char *xScrollCmd, *yScrollCmd; -#define ROUND(number) \ - if (number >= 0) { \ - number = (number + canvasPtr->scrollIncrement/2) \ - /canvasPtr->scrollIncrement; \ - } else { \ - number = -(((-number) + canvasPtr->scrollIncrement/2) \ - /canvasPtr->scrollIncrement); \ + /* + * Save all the relevant values from the canvasPtr, because it might be + * deleted as part of either of the two calls to Tcl_VarEval below. + */ + + interp = canvasPtr->interp; + Tcl_Preserve((ClientData) interp); + xScrollCmd = canvasPtr->xScrollCmd; + if (xScrollCmd != (char *) NULL) { + Tcl_Preserve((ClientData) xScrollCmd); } - + yScrollCmd = canvasPtr->yScrollCmd; + if (yScrollCmd != (char *) NULL) { + Tcl_Preserve((ClientData) yScrollCmd); + } + xOrigin = canvasPtr->xOrigin; + yOrigin = canvasPtr->yOrigin; + inset = canvasPtr->inset; + width = Tk_Width(canvasPtr->tkwin); + height = Tk_Height(canvasPtr->tkwin); + scrollX1 = canvasPtr->scrollX1; + scrollX2 = canvasPtr->scrollX2; + scrollY1 = canvasPtr->scrollY1; + scrollY2 = canvasPtr->scrollY2; canvasPtr->flags &= ~UPDATE_SCROLLBARS; if (canvasPtr->xScrollCmd != NULL) { - size = ((canvasPtr->scrollX2 - canvasPtr->scrollX1) - /canvasPtr->scrollIncrement) + 1; - first = canvasPtr->xOrigin - canvasPtr->scrollX1; - ROUND(first); - last = canvasPtr->xOrigin + Tk_Width(canvasPtr->tkwin) - - 1 - canvasPtr->scrollX1; - ROUND(last); - page = last - first - 1; - if (page <= 0) { - page = 1; - } - sprintf(args, " %d %d %d %d", size, page, first, last); - result = Tcl_VarEval(canvasPtr->interp, canvasPtr->xScrollCmd, args, - (char *) NULL); + PrintScrollFractions(xOrigin + inset, xOrigin + width - inset, + scrollX1, scrollX2, buffer); + result = Tcl_VarEval(interp, xScrollCmd, " ", buffer, (char *) NULL); if (result != TCL_OK) { - Tk_BackgroundError(canvasPtr->interp); + Tcl_BackgroundError(interp); } - Tcl_ResetResult(canvasPtr->interp); + Tcl_ResetResult(interp); + Tcl_Release((ClientData) xScrollCmd); } - if (canvasPtr->yScrollCmd != NULL) { - size = ((canvasPtr->scrollY2 - canvasPtr->scrollY1) - /canvasPtr->scrollIncrement) + 1; - first = canvasPtr->yOrigin - canvasPtr->scrollY1; - ROUND(first); - last = canvasPtr->yOrigin + Tk_Height(canvasPtr->tkwin) - - 1 - canvasPtr->scrollY1; - ROUND(last); - page = last - first - 1; - if (page <= 0) { - page = 1; - } - sprintf(args, " %d %d %d %d", size, page, first, last); - result = Tcl_VarEval(canvasPtr->interp, canvasPtr->yScrollCmd, args, - (char *) NULL); + if (yScrollCmd != NULL) { + PrintScrollFractions(yOrigin + inset, yOrigin + height - inset, + scrollY1, scrollY2, buffer); + result = Tcl_VarEval(interp, yScrollCmd, " ", buffer, (char *) NULL); if (result != TCL_OK) { - Tk_BackgroundError(canvasPtr->interp); + Tcl_BackgroundError(interp); } - Tcl_ResetResult(canvasPtr->interp); + Tcl_ResetResult(interp); + Tcl_Release((ClientData) yScrollCmd); } + Tcl_Release((ClientData) interp); } /* @@ -3249,15 +3620,45 @@ CanvasUpdateScrollbars(canvasPtr) static void CanvasSetOrigin(canvasPtr, xOrigin, yOrigin) - register Tk_Canvas *canvasPtr; /* Information about canvas. */ - int xOrigin; /* New X origin for canvas (canvas - * x-coord corresponding to left edge - * of canvas window). */ - int yOrigin; /* New Y origin for canvas (canvas - * y-coord corresponding to top edge - * of canvas window). */ + TkCanvas *canvasPtr; /* Information about canvas. */ + int xOrigin; /* New X origin for canvas (canvas x-coord + * corresponding to left edge of canvas + * window). */ + int yOrigin; /* New Y origin for canvas (canvas y-coord + * corresponding to top edge of canvas + * window). */ { - int left, right, top, bottom; + int left, right, top, bottom, delta; + + /* + * If scroll increments have been set, round the window origin + * to the nearest multiple of the increments. Remember, the + * origin is the place just inside the borders, not the upper + * left corner. + */ + + if (canvasPtr->xScrollIncrement > 0) { + if (xOrigin >= 0) { + xOrigin += canvasPtr->xScrollIncrement/2; + xOrigin -= (xOrigin + canvasPtr->inset) + % canvasPtr->xScrollIncrement; + } else { + xOrigin = (-xOrigin) + canvasPtr->xScrollIncrement/2; + xOrigin = -(xOrigin - (xOrigin - canvasPtr->inset) + % canvasPtr->xScrollIncrement); + } + } + if (canvasPtr->yScrollIncrement > 0) { + if (yOrigin >= 0) { + yOrigin += canvasPtr->yScrollIncrement/2; + yOrigin -= (yOrigin + canvasPtr->inset) + % canvasPtr->yScrollIncrement; + } else { + yOrigin = (-yOrigin) + canvasPtr->yScrollIncrement/2; + yOrigin = -(yOrigin - (yOrigin - canvasPtr->inset) + % canvasPtr->yScrollIncrement); + } + } /* * Adjust the origin if necessary to keep as much as possible of the @@ -3266,23 +3667,42 @@ CanvasSetOrigin(canvasPtr, xOrigin, yOrigin) * will stick out past the scroll region. If one side sticks out past * the edge of the scroll region, adjust the view to bring that side * back to the edge of the scrollregion (but don't move it so much that - * the other side sticks out now). + * the other side sticks out now). If scroll increments are in effect, + * be sure to adjust only by full increments. */ if ((canvasPtr->confine) && (canvasPtr->regionString != NULL)) { - left = xOrigin - canvasPtr->scrollX1; - right = canvasPtr->scrollX2 - (xOrigin + Tk_Width(canvasPtr->tkwin)); - top = yOrigin - canvasPtr->scrollY1; - bottom = canvasPtr->scrollY2 - (yOrigin + Tk_Height(canvasPtr->tkwin)); + left = xOrigin + canvasPtr->inset - canvasPtr->scrollX1; + right = canvasPtr->scrollX2 + - (xOrigin + Tk_Width(canvasPtr->tkwin) - canvasPtr->inset); + top = yOrigin + canvasPtr->inset - canvasPtr->scrollY1; + bottom = canvasPtr->scrollY2 + - (yOrigin + Tk_Height(canvasPtr->tkwin) - canvasPtr->inset); if ((left < 0) && (right > 0)) { - xOrigin += (right > -left) ? -left : right; + delta = (right > -left) ? -left : right; + if (canvasPtr->xScrollIncrement > 0) { + delta -= delta % canvasPtr->xScrollIncrement; + } + xOrigin += delta; } else if ((right < 0) && (left > 0)) { - xOrigin -= (left > -right) ? -right : left; + delta = (left > -right) ? -right : left; + if (canvasPtr->xScrollIncrement > 0) { + delta -= delta % canvasPtr->xScrollIncrement; + } + xOrigin -= delta; } if ((top < 0) && (bottom > 0)) { - yOrigin += (bottom > -top) ? -top : bottom; + delta = (bottom > -top) ? -top : bottom; + if (canvasPtr->yScrollIncrement > 0) { + delta -= delta % canvasPtr->yScrollIncrement; + } + yOrigin += delta; } else if ((bottom < 0) && (top > 0)) { - yOrigin -= (top > -bottom) ? -bottom : top; + delta = (top > -bottom) ? -bottom : top; + if (canvasPtr->yScrollIncrement > 0) { + delta -= delta % canvasPtr->yScrollIncrement; + } + yOrigin -= delta; } } @@ -3291,133 +3711,22 @@ CanvasSetOrigin(canvasPtr, xOrigin, yOrigin) } /* - * Tricky point: must redisplay not only everything that's visible + * Tricky point: must redisplay not only everything that's visible * in the window's final configuration, but also everything that was * visible in the initial configuration. This is needed because some * item types, like windows, need to know when they move off-screen * so they can explicitly undisplay themselves. */ - EventuallyRedrawArea(canvasPtr, canvasPtr->xOrigin, canvasPtr->yOrigin, + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + canvasPtr->xOrigin, canvasPtr->yOrigin, canvasPtr->xOrigin + Tk_Width(canvasPtr->tkwin), canvasPtr->yOrigin + Tk_Height(canvasPtr->tkwin)); canvasPtr->xOrigin = xOrigin; canvasPtr->yOrigin = yOrigin; canvasPtr->flags |= UPDATE_SCROLLBARS; - EventuallyRedrawArea(canvasPtr, canvasPtr->xOrigin, canvasPtr->yOrigin, + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + canvasPtr->xOrigin, canvasPtr->yOrigin, canvasPtr->xOrigin + Tk_Width(canvasPtr->tkwin), canvasPtr->yOrigin + Tk_Height(canvasPtr->tkwin)); } - -/* - *-------------------------------------------------------------- - * - * CanvasTagsParseProc -- - * - * This procedure is invoked during option processing to handle - * "-tags" options for canvas items. - * - * Results: - * A standard Tcl return value. - * - * Side effects: - * The tags for a given item get replaced by those indicated - * in the value argument. - * - *-------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -CanvasTagsParseProc(clientData, interp, tkwin, value, widgRec, offset) - ClientData clientData; /* Not used.*/ - Tcl_Interp *interp; /* Used for reporting errors. */ - Tk_Window tkwin; /* Window containing canvas widget. */ - char *value; /* Value of option (list of tag - * names). */ - char *widgRec; /* Pointer to record for item. */ - int offset; /* Offset into item (ignored). */ -{ - register Tk_Item *itemPtr = (Tk_Item *) widgRec; - int argc, i; - char **argv; - Tk_Uid *newPtr; - - /* - * Break the value up into the individual tag names. - */ - - if (Tcl_SplitList(interp, value, &argc, &argv) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Make sure that there's enough space in the item to hold the - * tag names. - */ - - if (itemPtr->tagSpace < argc) { - newPtr = (Tk_Uid *) ckalloc((unsigned) (argc * sizeof(Tk_Uid))); - for (i = itemPtr->numTags-1; i >= 0; i--) { - newPtr[i] = itemPtr->tagPtr[i]; - } - if (itemPtr->tagPtr != itemPtr->staticTagSpace) { - ckfree((char *) itemPtr->tagPtr); - } - itemPtr->tagPtr = newPtr; - itemPtr->tagSpace = argc; - } - itemPtr->numTags = argc; - for (i = 0; i < argc; i++) { - itemPtr->tagPtr[i] = Tk_GetUid(argv[i]); - } - ckfree((char *) argv); - return TCL_OK; -} - -/* - *-------------------------------------------------------------- - * - * CanvasTagsPrintProc -- - * - * This procedure is invoked by the Tk configuration code - * to produce a printable string for the "-tags" configuration - * option for canvas items. - * - * Results: - * The return value is a string describing all the tags for - * the item referred to by "widgRec". In addition, *freeProcPtr - * is filled in with the address of a procedure to call to free - * the result string when it's no longer needed (or NULL to - * indicate that the string doesn't need to be freed). - * - * Side effects: - * None. - * - *-------------------------------------------------------------- - */ - - /* ARGSUSED */ -static char * -CanvasTagsPrintProc(clientData, tkwin, widgRec, offset, freeProcPtr) - ClientData clientData; /* Ignored. */ - Tk_Window tkwin; /* Window containing canvas widget. */ - char *widgRec; /* Pointer to record for item. */ - int offset; /* Ignored. */ - Tcl_FreeProc **freeProcPtr; /* Pointer to variable to fill in with - * information about how to reclaim - * storage for return string. */ -{ - register Tk_Item *itemPtr = (Tk_Item *) widgRec; - - if (itemPtr->numTags == 0) { - *freeProcPtr = (Tcl_FreeProc *) NULL; - return ""; - } - if (itemPtr->numTags == 1) { - *freeProcPtr = (Tcl_FreeProc *) NULL; - return (char *) itemPtr->tagPtr[0]; - } - *freeProcPtr = (Tcl_FreeProc *) free; - return Tcl_Merge(itemPtr->numTags, (char **) itemPtr->tagPtr); -} diff --git a/tk4.2/generic/tkCanvas.h b/tk4.2/generic/tkCanvas.h new file mode 100644 index 0000000..52b3a51 --- /dev/null +++ b/tk4.2/generic/tkCanvas.h @@ -0,0 +1,257 @@ +/* + * tkCanvas.h -- + * + * Declarations shared among all the files that implement + * canvas widgets. + * + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkCanvas.h 1.41 96/02/15 18:51:28 + */ + +#ifndef _TKCANVAS +#define _TKCANVAS + +#ifndef _TK +#include "tk.h" +#endif + +/* + * The record below describes a canvas widget. It is made available + * to the item procedures so they can access certain shared fields such + * as the overall displacement and scale factor for the canvas. + */ + +typedef struct TkCanvas { + Tk_Window tkwin; /* Window that embodies the canvas. NULL + * means that the window has been destroyed + * but the data structures haven't yet been + * cleaned up.*/ + Display *display; /* Display containing widget; needed, among + * other things, to release resources after + * tkwin has already gone away. */ + Tcl_Interp *interp; /* Interpreter associated with canvas. */ + Tcl_Command widgetCmd; /* Token for canvas's widget command. */ + Tk_Item *firstItemPtr; /* First in list of all items in canvas, + * or NULL if canvas empty. */ + Tk_Item *lastItemPtr; /* Last in list of all items in canvas, + * or NULL if canvas empty. */ + + /* + * Information used when displaying widget: + */ + + int borderWidth; /* Width of 3-D border around window. */ + Tk_3DBorder bgBorder; /* Used for canvas background. */ + int relief; /* Indicates whether window as a whole is + * raised, sunken, or flat. */ + int highlightWidth; /* Width in pixels of highlight to draw + * around widget when it has the focus. + * <= 0 means don't draw a highlight. */ + XColor *highlightBgColorPtr; + /* Color for drawing traversal highlight + * area when highlight is off. */ + XColor *highlightColorPtr; /* Color for drawing traversal highlight. */ + int inset; /* Total width of all borders, including + * traversal highlight and 3-D border. + * Indicates how much interior stuff must + * be offset from outside edges to leave + * room for borders. */ + GC pixmapGC; /* Used to copy bits from a pixmap to the + * screen and also to clear the pixmap. */ + int width, height; /* Dimensions to request for canvas window, + * specified in pixels. */ + int redrawX1, redrawY1; /* Upper left corner of area to redraw, + * in pixel coordinates. Border pixels + * are included. Only valid if + * REDRAW_PENDING flag is set. */ + int redrawX2, redrawY2; /* Lower right corner of area to redraw, + * in integer canvas coordinates. Border + * pixels will *not* be redrawn. */ + int confine; /* Non-zero means constrain view to keep + * as much of canvas visible as possible. */ + + /* + * Information used to manage the selection and insertion cursor: + */ + + Tk_CanvasTextInfo textInfo; /* Contains lots of fields; see tk.h for + * details. This structure is shared with + * the code that implements individual items. */ + int insertOnTime; /* Number of milliseconds cursor should spend + * in "on" state for each blink. */ + int insertOffTime; /* Number of milliseconds cursor should spend + * in "off" state for each blink. */ + Tcl_TimerToken insertBlinkHandler; + /* Timer handler used to blink cursor on and + * off. */ + + /* + * Transformation applied to canvas as a whole: to compute screen + * coordinates (X,Y) from canvas coordinates (x,y), do the following: + * + * X = x - xOrigin; + * Y = y - yOrigin; + */ + + int xOrigin, yOrigin; /* Canvas coordinates corresponding to + * upper-left corner of window, given in + * canvas pixel units. */ + int drawableXOrigin, drawableYOrigin; + /* During redisplay, these fields give the + * canvas coordinates corresponding to + * the upper-left corner of the drawable + * where items are actually being drawn + * (typically a pixmap smaller than the + * whole window). */ + + /* + * Information used for event bindings associated with items. + */ + + Tk_BindingTable bindingTable; + /* Table of all bindings currently defined + * for this canvas. NULL means that no + * bindings exist, so the table hasn't been + * created. Each "object" used for this + * table is either a Tk_Uid for a tag or + * the address of an item named by id. */ + Tk_Item *currentItemPtr; /* The item currently containing the mouse + * pointer, or NULL if none. */ + Tk_Item *newCurrentPtr; /* The item that is about to become the + * current one, or NULL. This field is + * used to detect deletions of the new + * current item pointer that occur during + * Leave processing of the previous current + * item. */ + double closeEnough; /* The mouse is assumed to be inside an + * item if it is this close to it. */ + XEvent pickEvent; /* The event upon which the current choice + * of currentItem is based. Must be saved + * so that if the currentItem is deleted, + * can pick another. */ + int state; /* Last known modifier state. Used to + * defer picking a new current object + * while buttons are down. */ + + /* + * Information used for managing scrollbars: + */ + + char *xScrollCmd; /* Command prefix for communicating with + * horizontal scrollbar. NULL means no + * horizontal scrollbar. Malloc'ed*/ + char *yScrollCmd; /* Command prefix for communicating with + * vertical scrollbar. NULL means no + * vertical scrollbar. Malloc'ed*/ + int scrollX1, scrollY1, scrollX2, scrollY2; + /* These four coordinates define the region + * that is the 100% area for scrolling (i.e. + * these numbers determine the size and + * location of the sliders on scrollbars). + * Units are pixels in canvas coords. */ + char *regionString; /* The option string from which scrollX1 + * etc. are derived. Malloc'ed. */ + int xScrollIncrement; /* If >0, defines a grid for horizontal + * scrolling. This is the size of the "unit", + * and the left edge of the screen will always + * lie on an even unit boundary. */ + int yScrollIncrement; /* If >0, defines a grid for horizontal + * scrolling. This is the size of the "unit", + * and the left edge of the screen will always + * lie on an even unit boundary. */ + + /* + * Information used for scanning: + */ + + int scanX; /* X-position at which scan started (e.g. + * button was pressed here). */ + int scanXOrigin; /* Value of xOrigin field when scan started. */ + int scanY; /* Y-position at which scan started (e.g. + * button was pressed here). */ + int scanYOrigin; /* Value of yOrigin field when scan started. */ + + /* + * Information used to speed up searches by remembering the last item + * created or found with an item id search. + */ + + Tk_Item *hotPtr; /* Pointer to "hot" item (one that's been + * recently used. NULL means there's no + * hot item. */ + Tk_Item *hotPrevPtr; /* Pointer to predecessor to hotPtr (NULL + * means item is first in list). This is + * only a hint and may not really be hotPtr's + * predecessor. */ + + /* + * Miscellaneous information: + */ + + Tk_Cursor cursor; /* Current cursor for window, or None. */ + char *takeFocus; /* Value of -takefocus option; not used in + * the C code, but used by keyboard traversal + * scripts. Malloc'ed, but may be NULL. */ + double pixelsPerMM; /* Scale factor between MM and pixels; + * used when converting coordinates. */ + int flags; /* Various flags; see below for + * definitions. */ + int nextId; /* Number to use as id for next item + * created in widget. */ + struct TkPostscriptInfo *psInfoPtr; + /* Pointer to information used for generating + * Postscript for the canvas. NULL means + * no Postscript is currently being + * generated. */ +} TkCanvas; + +/* + * Flag bits for canvases: + * + * REDRAW_PENDING - 1 means a DoWhenIdle handler has already + * been created to redraw some or all of the + * canvas. + * REDRAW_BORDERS - 1 means that the borders need to be redrawn + * during the next redisplay operation. + * REPICK_NEEDED - 1 means DisplayCanvas should pick a new + * current item before redrawing the canvas. + * GOT_FOCUS - 1 means the focus is currently in this + * widget, so should draw the insertion cursor + * and traversal highlight. + * CURSOR_ON - 1 means the insertion cursor is in the "on" + * phase of its blink cycle. 0 means either + * we don't have the focus or the cursor is in + * the "off" phase of its cycle. + * UPDATE_SCROLLBARS - 1 means the scrollbars should get updated + * as part of the next display operation. + * LEFT_GRABBED_ITEM - 1 means that the mouse left the current + * item while a grab was in effect, so we + * didn't change canvasPtr->currentItemPtr. + * REPICK_IN_PROGRESS - 1 means PickCurrentItem is currently + * executing. If it should be called recursively, + * it should simply return immediately. + */ + +#define REDRAW_PENDING 1 +#define REDRAW_BORDERS 2 +#define REPICK_NEEDED 4 +#define GOT_FOCUS 8 +#define CURSOR_ON 0x10 +#define UPDATE_SCROLLBARS 0x20 +#define LEFT_GRABBED_ITEM 0x40 +#define REPICK_IN_PROGRESS 0x100 + +/* + * Canvas-related procedures that are shared among Tk modules but not + * exported to the outside world: + */ + +extern int TkCanvPostscriptCmd _ANSI_ARGS_((TkCanvas *canvasPtr, + Tcl_Interp *interp, int argc, char **argv)); + +#endif /* _TKCANVAS */ diff --git a/tk4.2/generic/tkClipboard.c b/tk4.2/generic/tkClipboard.c new file mode 100644 index 0000000..6166363 --- /dev/null +++ b/tk4.2/generic/tkClipboard.c @@ -0,0 +1,606 @@ +/* + * tkClipboard.c -- + * + * This file manages the clipboard for the Tk toolkit, + * maintaining a collection of data buffers that will be + * supplied on demand to requesting applications. + * + * Copyright (c) 1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkClipboard.c 1.14 96/02/15 18:52:37 + */ + +#include "tkInt.h" +#include "tkPort.h" +#include "tkSelect.h" + +/* + * Prototypes for procedures used only in this file: + */ + +static int ClipboardAppHandler _ANSI_ARGS_((ClientData clientData, + int offset, char *buffer, int maxBytes)); +static int ClipboardHandler _ANSI_ARGS_((ClientData clientData, + int offset, char *buffer, int maxBytes)); +static int ClipboardWindowHandler _ANSI_ARGS_(( + ClientData clientData, int offset, char *buffer, + int maxBytes)); +static void ClipboardLostSel _ANSI_ARGS_((ClientData clientData)); + +/* + *---------------------------------------------------------------------- + * + * ClipboardHandler -- + * + * This procedure acts as selection handler for the + * clipboard manager. It extracts the required chunk of + * data from the buffer chain for a given selection target. + * + * Results: + * The return value is a count of the number of bytes + * actually stored at buffer. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ClipboardHandler(clientData, offset, buffer, maxBytes) + ClientData clientData; /* Information about data to fetch. */ + int offset; /* Return selection bytes starting at this + * offset. */ + char *buffer; /* Place to store converted selection. */ + int maxBytes; /* Maximum # of bytes to store at buffer. */ +{ + TkClipboardTarget *targetPtr = (TkClipboardTarget*) clientData; + TkClipboardBuffer *cbPtr; + char *srcPtr, *destPtr; + int count = 0; + int scanned = 0; + size_t length, freeCount; + + /* + * Skip to buffer containing offset byte + */ + + for (cbPtr = targetPtr->firstBufferPtr; ; cbPtr = cbPtr->nextPtr) { + if (cbPtr == NULL) { + return 0; + } + if (scanned + cbPtr->length > offset) { + break; + } + scanned += cbPtr->length; + } + + /* + * Copy up to maxBytes or end of list, switching buffers as needed. + */ + + freeCount = maxBytes; + srcPtr = cbPtr->buffer + (offset - scanned); + destPtr = buffer; + length = cbPtr->length - (offset - scanned); + while (1) { + if (length > freeCount) { + strncpy(destPtr, srcPtr, freeCount); + return maxBytes; + } else { + strncpy(destPtr, srcPtr, length); + destPtr += length; + count += length; + freeCount -= length; + } + cbPtr = cbPtr->nextPtr; + if (cbPtr == NULL) { + break; + } + srcPtr = cbPtr->buffer; + length = cbPtr->length; + } + return count; +} + +/* + *---------------------------------------------------------------------- + * + * ClipboardAppHandler -- + * + * This procedure acts as selection handler for retrievals of type + * TK_APPLICATION. It returns the name of the application that + * owns the clipboard. Note: we can't use the default Tk + * selection handler for this selection type, because the clipboard + * window isn't a "real" window and doesn't have the necessary + * information. + * + * Results: + * The return value is a count of the number of bytes + * actually stored at buffer. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ClipboardAppHandler(clientData, offset, buffer, maxBytes) + ClientData clientData; /* Pointer to TkDisplay structure. */ + int offset; /* Return selection bytes starting at this + * offset. */ + char *buffer; /* Place to store converted selection. */ + int maxBytes; /* Maximum # of bytes to store at buffer. */ +{ + TkDisplay *dispPtr = (TkDisplay *) clientData; + size_t length; + char *p; + + p = dispPtr->clipboardAppPtr->winPtr->nameUid; + length = strlen(p); + length -= offset; + if (length <= 0) { + return 0; + } + if (length > maxBytes) { + length = maxBytes; + } + strncpy(buffer, p, length); + return length; +} + +/* + *---------------------------------------------------------------------- + * + * ClipboardWindowHandler -- + * + * This procedure acts as selection handler for retrievals of + * type TK_WINDOW. Since the clipboard doesn't correspond to + * any particular window, we just return ".". We can't use Tk's + * default handler for this selection type, because the clipboard + * window isn't a valid window. + * + * Results: + * The return value is 1, the number of non-null bytes stored + * at buffer. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ClipboardWindowHandler(clientData, offset, buffer, maxBytes) + ClientData clientData; /* Not used. */ + int offset; /* Return selection bytes starting at this + * offset. */ + char *buffer; /* Place to store converted selection. */ + int maxBytes; /* Maximum # of bytes to store at buffer. */ +{ + buffer[0] = '.'; + buffer[1] = 0; + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * ClipboardLostSel -- + * + * This procedure is invoked whenever clipboard ownership is + * claimed by another window. It just sets a flag so that we + * know the clipboard was taken away. + * + * Results: + * None. + * + * Side effects: + * The clipboard is marked as inactive. + * + *---------------------------------------------------------------------- + */ + +static void +ClipboardLostSel(clientData) + ClientData clientData; /* Pointer to TkDisplay structure. */ +{ + TkDisplay *dispPtr = (TkDisplay*) clientData; + + dispPtr->clipboardActive = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_ClipboardClear -- + * + * Take control of the clipboard and clear out the previous + * contents. This procedure must be invoked before any + * calls to Tk_AppendToClipboard. + * + * Results: + * A standard Tcl result. If an error occurs, an error message is + * left in interp->result. + * + * Side effects: + * From now on, requests for the CLIPBOARD selection will be + * directed to the clipboard manager routines associated with + * clipWindow for the display of tkwin. In order to guarantee + * atomicity, no event handling should occur between + * Tk_ClipboardClear and the following Tk_AppendToClipboard + * calls. This procedure may cause a user-defined LostSel command + * to be invoked when the CLIPBOARD is claimed, so any calling + * function should be reentrant at the point Tk_ClipboardClear is + * invoked. + * + *---------------------------------------------------------------------- + */ + +int +Tk_ClipboardClear(interp, tkwin) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + Tk_Window tkwin; /* Window in application that is clearing + * clipboard; identifies application and + * display. */ +{ + TkWindow *winPtr = (TkWindow *) tkwin; + TkDisplay *dispPtr = winPtr->dispPtr; + TkClipboardTarget *targetPtr, *nextTargetPtr; + TkClipboardBuffer *cbPtr, *nextCbPtr; + + if (dispPtr->clipWindow == NULL) { + int result; + + result = TkClipInit(interp, dispPtr); + if (result != TCL_OK) { + return result; + } + } + + /* + * Discard any existing clipboard data and delete the selection + * handler(s) associated with that data. + */ + + for (targetPtr = dispPtr->clipTargetPtr; targetPtr != NULL; + targetPtr = nextTargetPtr) { + for (cbPtr = targetPtr->firstBufferPtr; cbPtr != NULL; + cbPtr = nextCbPtr) { + ckfree(cbPtr->buffer); + nextCbPtr = cbPtr->nextPtr; + ckfree((char *) cbPtr); + } + nextTargetPtr = targetPtr->nextPtr; + Tk_DeleteSelHandler(dispPtr->clipWindow, dispPtr->clipboardAtom, + targetPtr->type); + ckfree((char *) targetPtr); + } + dispPtr->clipTargetPtr = NULL; + + /* + * Reclaim the clipboard selection if we lost it. + */ + + if (!dispPtr->clipboardActive) { + Tk_OwnSelection(dispPtr->clipWindow, dispPtr->clipboardAtom, + ClipboardLostSel, (ClientData) dispPtr); + dispPtr->clipboardActive = 1; + } + dispPtr->clipboardAppPtr = winPtr->mainPtr; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_ClipboardAppend -- + * + * Append a buffer of data to the clipboard. The first buffer of + * a given type determines the format for that type. Any successive + * appends to that type must have the same format or an error will + * be returned. Tk_ClipboardClear must be called before a sequence + * of Tk_ClipboardAppend calls can be issued. In order to guarantee + * atomicity, no event handling should occur between Tk_ClipboardClear + * and the following Tk_AppendToClipboard calls. + * + * Results: + * A standard Tcl result. If an error is returned, an error message + * is left in interp->result. + * + * Side effects: + * The specified buffer will be copied onto the end of the clipboard. + * The clipboard maintains a list of buffers which will be used to + * supply the data for a selection get request. The first time a given + * type is appended, Tk_ClipboardAppend will register a selection + * handler of the appropriate type. + * + *---------------------------------------------------------------------- + */ + +int +Tk_ClipboardAppend(interp, tkwin, type, format, buffer) + Tcl_Interp *interp; /* Used for error reporting. */ + Tk_Window tkwin; /* Window that selects a display. */ + Atom type; /* The desired conversion type for this + * clipboard item, e.g. STRING or LENGTH. */ + Atom format; /* Format in which the selection + * information should be returned to + * the requestor. */ + char* buffer; /* NULL terminated string containing the data + * to be added to the clipboard. */ +{ + TkWindow *winPtr = (TkWindow *) tkwin; + TkDisplay *dispPtr = winPtr->dispPtr; + TkClipboardTarget *targetPtr; + TkClipboardBuffer *cbPtr; + + /* + * If this application doesn't already own the clipboard, clear + * the clipboard. If we don't own the clipboard selection, claim it. + */ + + if (dispPtr->clipboardAppPtr != winPtr->mainPtr) { + Tk_ClipboardClear(interp, tkwin); + } else if (!dispPtr->clipboardActive) { + Tk_OwnSelection(dispPtr->clipWindow, dispPtr->clipboardAtom, + ClipboardLostSel, (ClientData) dispPtr); + dispPtr->clipboardActive = 1; + } + + /* + * Check to see if the specified target is already present on the + * clipboard. If it isn't, we need to create a new target; otherwise, + * we just append the new buffer to the clipboard list. + */ + + for (targetPtr = dispPtr->clipTargetPtr; targetPtr != NULL; + targetPtr = targetPtr->nextPtr) { + if (targetPtr->type == type) + break; + } + if (targetPtr == NULL) { + targetPtr = (TkClipboardTarget*) ckalloc(sizeof(TkClipboardTarget)); + targetPtr->type = type; + targetPtr->format = format; + targetPtr->firstBufferPtr = targetPtr->lastBufferPtr = NULL; + targetPtr->nextPtr = dispPtr->clipTargetPtr; + dispPtr->clipTargetPtr = targetPtr; + Tk_CreateSelHandler(dispPtr->clipWindow, dispPtr->clipboardAtom, + type, ClipboardHandler, (ClientData) targetPtr, format); + } else if (targetPtr->format != format) { + Tcl_AppendResult(interp, "format \"", Tk_GetAtomName(tkwin, format), + "\" does not match current format \"", + Tk_GetAtomName(tkwin, targetPtr->format),"\" for ", + Tk_GetAtomName(tkwin, type), (char *) NULL); + return TCL_ERROR; + } + + /* + * Append a new buffer to the buffer chain. + */ + + cbPtr = (TkClipboardBuffer*) ckalloc(sizeof(TkClipboardBuffer)); + cbPtr->nextPtr = NULL; + if (targetPtr->lastBufferPtr != NULL) { + targetPtr->lastBufferPtr->nextPtr = cbPtr; + } else { + targetPtr->firstBufferPtr = cbPtr; + } + targetPtr->lastBufferPtr = cbPtr; + + cbPtr->length = strlen(buffer); + cbPtr->buffer = (char *) ckalloc((unsigned) (cbPtr->length + 1)); + strcpy(cbPtr->buffer, buffer); + + TkSelUpdateClipboard((TkWindow*)(dispPtr->clipWindow), targetPtr); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_ClipboardCmd -- + * + * This procedure is invoked to process the "clipboard" Tcl + * command. See the user documentation for details on what + * it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tk_ClipboardCmd(clientData, interp, argc, argv) + ClientData clientData; /* Main window associated with + * interpreter. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tk_Window tkwin = (Tk_Window) clientData; + char *path = NULL; + size_t length; + int count; + char c; + char **args; + + 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], "append", length) == 0)) { + Atom target, format; + char *targetName = NULL; + char *formatName = NULL; + + for (count = argc-2, args = argv+2; count > 1; count -= 2, args += 2) { + if (args[0][0] != '-') { + break; + } + c = args[0][1]; + length = strlen(args[0]); + if ((c == '-') && (length == 2)) { + args++; + count--; + break; + } + if ((c == 'd') && (strncmp(args[0], "-displayof", length) == 0)) { + path = args[1]; + } else if ((c == 'f') + && (strncmp(args[0], "-format", length) == 0)) { + formatName = args[1]; + } else if ((c == 't') + && (strncmp(args[0], "-type", length) == 0)) { + targetName = args[1]; + } else { + Tcl_AppendResult(interp, "unknown option \"", args[0], + "\"", (char *) NULL); + return TCL_ERROR; + } + } + if (count != 1) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " append ?options? data\"", (char *) NULL); + return TCL_ERROR; + } + if (path != NULL) { + tkwin = Tk_NameToWindow(interp, path, tkwin); + } + if (tkwin == NULL) { + return TCL_ERROR; + } + if (targetName != NULL) { + target = Tk_InternAtom(tkwin, targetName); + } else { + target = XA_STRING; + } + if (formatName != NULL) { + format = Tk_InternAtom(tkwin, formatName); + } else { + format = XA_STRING; + } + return Tk_ClipboardAppend(interp, tkwin, target, format, args[0]); + } else if ((c == 'c') && (strncmp(argv[1], "clear", length) == 0)) { + for (count = argc-2, args = argv+2; count > 0; count -= 2, args += 2) { + if (args[0][0] != '-') { + break; + } + if (count < 2) { + Tcl_AppendResult(interp, "value for \"", *args, + "\" missing", (char *) NULL); + return TCL_ERROR; + } + c = args[0][1]; + length = strlen(args[0]); + if ((c == 'd') && (strncmp(args[0], "-displayof", length) == 0)) { + path = args[1]; + } else { + Tcl_AppendResult(interp, "unknown option \"", args[0], + "\"", (char *) NULL); + return TCL_ERROR; + } + } + if (count > 0) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " clear ?options?\"", (char *) NULL); + return TCL_ERROR; + } + if (path != NULL) { + tkwin = Tk_NameToWindow(interp, path, tkwin); + } + if (tkwin == NULL) { + return TCL_ERROR; + } + return Tk_ClipboardClear(interp, tkwin); + } else { + sprintf(interp->result, + "bad option \"%.50s\": must be clear or append", + argv[1]); + return TCL_ERROR; + } +} + +/* + *---------------------------------------------------------------------- + * + * TkClipInit -- + * + * This procedure is called to initialize the window for claiming + * clipboard ownership and for receiving selection get results. This + * function is called from tkSelect.c as well as tkClipboard.c. + * + * Results: + * The result is a standard Tcl return value, which is normally TCL_OK. + * If an error occurs then an error message is left in interp->result + * and TCL_ERROR is returned. + * + * Side effects: + * Sets up the clipWindow and related data structures. + * + *---------------------------------------------------------------------- + */ + +int +TkClipInit(interp, dispPtr) + Tcl_Interp *interp; /* Interpreter to use for error + * reporting. */ + register TkDisplay *dispPtr;/* Display to initialize. */ +{ + XSetWindowAttributes atts; + + dispPtr->clipTargetPtr = NULL; + dispPtr->clipboardActive = 0; + dispPtr->clipboardAppPtr = NULL; + + /* + * Create the window used for clipboard ownership and selection retrieval, + * and set up an event handler for it. + */ + + dispPtr->clipWindow = Tk_CreateWindow(interp, (Tk_Window) NULL, + "_clip", DisplayString(dispPtr->display)); + if (dispPtr->clipWindow == NULL) { + return TCL_ERROR; + } + atts.override_redirect = True; + Tk_ChangeWindowAttributes(dispPtr->clipWindow, CWOverrideRedirect, &atts); + Tk_MakeWindowExist(dispPtr->clipWindow); + + if (dispPtr->multipleAtom == None) { + /* + * Need to invoke selection initialization to make sure that + * atoms we depend on below are defined. + */ + + TkSelInit(dispPtr->clipWindow); + } + + /* + * Create selection handlers for types TK_APPLICATION and TK_WINDOW + * on this window. Can't use the default handlers for these types + * because this isn't a full-fledged window. + */ + + Tk_CreateSelHandler(dispPtr->clipWindow, dispPtr->clipboardAtom, + dispPtr->applicationAtom, ClipboardAppHandler, + (ClientData) dispPtr, XA_STRING); + Tk_CreateSelHandler(dispPtr->clipWindow, dispPtr->clipboardAtom, + dispPtr->windowAtom, ClipboardWindowHandler, + (ClientData) dispPtr, XA_STRING); + return TCL_OK; +} diff --git a/tk3.6/tkCmds.c b/tk4.2/generic/tkCmds.c similarity index 62% rename from tk3.6/tkCmds.c rename to tk4.2/generic/tkCmds.c index 00580e1..765df59 100644 --- a/tk3.6/tkCmds.c +++ b/tk4.2/generic/tkCmds.c @@ -4,51 +4,26 @@ * This file contains a collection of Tk-related Tcl commands * that didn't fit in any particular file of the toolkit. * - * Copyright (c) 1990-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tkCmds.c 1.110 96/04/03 15:54:47 */ -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkCmds.c,v 1.53 93/07/08 10:47:04 ouster Exp $ SPRITE (Berkeley)"; -#endif /* not lint */ - -#include "tkConfig.h" +#include "tkPort.h" #include "tkInt.h" #include -/* - * The data structure below is used by the "after" command to remember - * the command to be executed later. - */ - -typedef struct { - Tcl_Interp *interp; /* Interpreter in which to execute command. */ - char *command; /* Command to execute. Malloc'ed, so must - * be freed when structure is deallocated. */ -} AfterInfo; - /* * Forward declarations for procedures defined later in this file: */ -static void AfterProc _ANSI_ARGS_((ClientData clientData)); +static Tk_Window GetDisplayOf _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, char **argv)); +static TkWindow * GetToplevel _ANSI_ARGS_((Tk_Window tkwin)); static char * WaitVariableProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, char *name1, char *name2, int flags)); @@ -60,9 +35,9 @@ static void WaitWindowProc _ANSI_ARGS_((ClientData clientData, /* *---------------------------------------------------------------------- * - * Tk_AfterCmd -- + * Tk_BellCmd -- * - * This procedure is invoked to process the "after" Tcl command. + * This procedure is invoked to process the "bell" Tcl command. * See the user documentation for details on what it does. * * Results: @@ -74,84 +49,38 @@ static void WaitWindowProc _ANSI_ARGS_((ClientData clientData, *---------------------------------------------------------------------- */ - /* ARGSUSED */ int -Tk_AfterCmd(clientData, interp, argc, argv) - ClientData clientData; /* Main window associated with - * interpreter. Not used.*/ +Tk_BellCmd(clientData, interp, argc, argv) + ClientData clientData; /* Main window associated with interpreter. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { - int ms; - AfterInfo *afterPtr; + Tk_Window tkwin = (Tk_Window) clientData; + size_t length; - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " milliseconds ?command? ?arg arg ...?\"", - (char *) NULL); + if ((argc != 1) && (argc != 3)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?-displayof window?\"", (char *) NULL); return TCL_ERROR; } - if (Tcl_GetInt(interp, argv[1], &ms) != TCL_OK) { - Tcl_AppendResult(interp, "bad milliseconds value \"", - argv[1], "\"", (char *) NULL); - return TCL_ERROR; - } - if (ms < 0) { - ms = 0; - } - if (argc == 2) { - Tk_Sleep(ms); - return TCL_OK; - } - afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo))); - afterPtr->interp = interp; if (argc == 3) { - afterPtr->command = (char *) ckalloc((unsigned) (strlen(argv[2]) + 1)); - strcpy(afterPtr->command, argv[2]); - } else { - afterPtr->command = Tcl_Concat(argc-2, argv+2); - } - Tk_CreateTimerHandler(ms, AfterProc, (ClientData) afterPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * AfterProc -- - * - * Timer callback to execute commands registered with the - * "after" command. - * - * Results: - * None. - * - * Side effects: - * Executes whatever command was specified. If the command - * returns an error, then the command "tkerror" is invoked - * to process the error; if tkerror fails then information - * about the error is output on stderr. - * - *---------------------------------------------------------------------- - */ - -static void -AfterProc(clientData) - ClientData clientData; /* Describes command to execute. */ -{ - AfterInfo *afterPtr = (AfterInfo *) clientData; - int result; - - if (afterPtr->command != NULL) { - result = Tcl_GlobalEval(afterPtr->interp, afterPtr->command); - if (result != TCL_OK) { - Tk_BackgroundError(afterPtr->interp); + length = strlen(argv[1]); + if ((length < 2) || (strncmp(argv[1], "-displayof", length) != 0)) { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be -displayof", (char *) NULL); + return TCL_ERROR; + } + tkwin = Tk_NameToWindow(interp, argv[2], tkwin); + if (tkwin == NULL) { + return TCL_ERROR; } - ckfree(afterPtr->command); } - ckfree((char *) afterPtr); + XBell(Tk_Display(tkwin), 0); + XForceScreenSaver(Tk_Display(tkwin), ScreenSaverReset); + XFlush(Tk_Display(tkwin)); + return TCL_OK; } /* @@ -173,8 +102,7 @@ AfterProc(clientData) int Tk_BindCmd(clientData, interp, argc, argv) - ClientData clientData; /* Main window associated with - * interpreter. */ + ClientData clientData; /* Main window associated with interpreter. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ @@ -255,20 +183,200 @@ TkBindEventProc(winPtr, eventPtr) TkWindow *winPtr; /* Pointer to info about window. */ XEvent *eventPtr; /* Information about event. */ { - ClientData objects[3]; +#define MAX_OBJS 20 + ClientData objects[MAX_OBJS], *objPtr; static Tk_Uid allUid = NULL; + TkWindow *topLevPtr; + int i, count; + char *p; + Tcl_HashEntry *hPtr; if ((winPtr->mainPtr == NULL) || (winPtr->mainPtr->bindingTable == NULL)) { return; } - objects[0] = (ClientData) winPtr->pathName; - objects[1] = (ClientData) winPtr->classUid; - if (allUid == NULL) { - allUid = Tk_GetUid("all"); + + objPtr = objects; + if (winPtr->numTags != 0) { + /* + * Make a copy of the tags for the window, replacing window names + * with pointers to the pathName from the appropriate window. + */ + + if (winPtr->numTags > MAX_OBJS) { + objPtr = (ClientData *) ckalloc((unsigned) + (winPtr->numTags * sizeof(ClientData))); + } + for (i = 0; i < winPtr->numTags; i++) { + p = (char *) winPtr->tagPtr[i]; + if (*p == '.') { + hPtr = Tcl_FindHashEntry(&winPtr->mainPtr->nameTable, p); + if (hPtr != NULL) { + p = ((TkWindow *) Tcl_GetHashValue(hPtr))->pathName; + } else { + p = NULL; + } + } + objPtr[i] = (ClientData) p; + } + count = winPtr->numTags; + } else { + objPtr[0] = (ClientData) winPtr->pathName; + objPtr[1] = (ClientData) winPtr->classUid; + for (topLevPtr = winPtr; + (topLevPtr != NULL) && !(topLevPtr->flags & TK_TOP_LEVEL); + topLevPtr = topLevPtr->parentPtr) { + /* Empty loop body. */ + } + if ((winPtr != topLevPtr) && (topLevPtr != NULL)) { + count = 4; + objPtr[2] = (ClientData) topLevPtr->pathName; + } else { + count = 3; + } + if (allUid == NULL) { + allUid = Tk_GetUid("all"); + } + objPtr[count-1] = (ClientData) allUid; } - objects[2] = (ClientData) allUid; - Tk_BindEvent(winPtr->mainPtr->bindingTable, eventPtr, - (Tk_Window) winPtr, 3, objects); + Tk_BindEvent(winPtr->mainPtr->bindingTable, eventPtr, (Tk_Window) winPtr, + count, objPtr); + if (objPtr != objects) { + ckfree((char *) objPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tk_BindtagsCmd -- + * + * This procedure is invoked to process the "bindtags" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tk_BindtagsCmd(clientData, interp, argc, argv) + ClientData clientData; /* Main window associated with interpreter. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tk_Window tkwin = (Tk_Window) clientData; + TkWindow *winPtr, *winPtr2; + int i, tagArgc; + char *p, **tagArgv; + + if ((argc < 2) || (argc > 3)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " window ?tags?\"", (char *) NULL); + return TCL_ERROR; + } + winPtr = (TkWindow *) Tk_NameToWindow(interp, argv[1], tkwin); + if (winPtr == NULL) { + return TCL_ERROR; + } + if (argc == 2) { + if (winPtr->numTags == 0) { + Tcl_AppendElement(interp, winPtr->pathName); + Tcl_AppendElement(interp, winPtr->classUid); + for (winPtr2 = winPtr; + (winPtr2 != NULL) && !(winPtr2->flags & TK_TOP_LEVEL); + winPtr2 = winPtr2->parentPtr) { + /* Empty loop body. */ + } + if ((winPtr != winPtr2) && (winPtr2 != NULL)) { + Tcl_AppendElement(interp, winPtr2->pathName); + } + Tcl_AppendElement(interp, "all"); + } else { + for (i = 0; i < winPtr->numTags; i++) { + Tcl_AppendElement(interp, (char *) winPtr->tagPtr[i]); + } + } + return TCL_OK; + } + if (winPtr->tagPtr != NULL) { + TkFreeBindingTags(winPtr); + } + if (argv[2][0] == 0) { + return TCL_OK; + } + if (Tcl_SplitList(interp, argv[2], &tagArgc, &tagArgv) != TCL_OK) { + return TCL_ERROR; + } + winPtr->numTags = tagArgc; + winPtr->tagPtr = (ClientData *) ckalloc((unsigned) + (tagArgc * sizeof(ClientData))); + for (i = 0; i < tagArgc; i++) { + p = tagArgv[i]; + if (p[0] == '.') { + char *copy; + + /* + * Handle names starting with "." specially: store a malloc'ed + * string, rather than a Uid; at event time we'll look up the + * name in the window table and use the corresponding window, + * if there is one. + */ + + copy = (char *) ckalloc((unsigned) (strlen(p) + 1)); + strcpy(copy, p); + winPtr->tagPtr[i] = (ClientData) copy; + } else { + winPtr->tagPtr[i] = (ClientData) Tk_GetUid(p); + } + } + ckfree((char *) tagArgv); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TkFreeBindingTags -- + * + * This procedure is called to free all of the binding tags + * associated with a window; typically it is only invoked where + * there are window-specific tags. + * + * Results: + * None. + * + * Side effects: + * Any binding tags for winPtr are freed. + * + *---------------------------------------------------------------------- + */ + +void +TkFreeBindingTags(winPtr) + TkWindow *winPtr; /* Window whose tags are to be released. */ +{ + int i; + char *p; + + for (i = 0; i < winPtr->numTags; i++) { + p = (char *) (winPtr->tagPtr[i]); + if (*p == '.') { + /* + * Names starting with "." are malloced rather than Uids, so + * they have to be freed. + */ + + ckfree(p); + } + } + ckfree((char *) winPtr->tagPtr); + winPtr->numTags = 0; + winPtr->tagPtr = NULL; } /* @@ -310,57 +418,6 @@ Tk_DestroyCmd(clientData, interp, argc, argv) return TCL_OK; } -/* - *---------------------------------------------------------------------- - * - * Tk_ExitCmd -- - * - * This procedure is invoked to process the "exit" Tcl command. - * See the user documentation for details on what it does. - * Note: this command replaces the Tcl "exit" command in order - * to properly destroy all windows. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - - /*ARGSUSED*/ -int -Tk_ExitCmd(clientData, interp, argc, argv) - ClientData clientData; /* Main window associated with - * interpreter. */ - 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) { - value = 0; - } else { - if (Tcl_GetInt(interp, argv[1], &value) != TCL_OK) { - return TCL_ERROR; - } - } - - while (tkMainWindowList != NULL) { - Tk_DestroyWindow((Tk_Window) tkMainWindowList->winPtr); - } - exit(value); - /* NOTREACHED */ - return TCL_OK; -} - /* *---------------------------------------------------------------------- * @@ -498,7 +555,7 @@ Tk_TkCmd(clientData, interp, argc, argv) char **argv; /* Argument strings. */ { char c; - int length; + size_t length; Tk_Window tkwin = (Tk_Window) clientData; TkWindow *winPtr; @@ -509,48 +566,20 @@ Tk_TkCmd(clientData, interp, argc, argv) } c = argv[1][0]; length = strlen(argv[1]); - if ((c == 'c') && (strncmp(argv[1], "colormodel", length) == 0)) { - if ((argc != 3) && (argc != 4)) { + if ((c == 'a') && (strncmp(argv[1], "appname", length) == 0)) { + winPtr = ((TkWindow *) tkwin)->mainPtr->winPtr; + if (argc > 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " colormodel window ?mono|color?\"", (char *) NULL); - return TCL_ERROR; - } - winPtr = (TkWindow *) Tk_NameToWindow(interp, argv[2], tkwin); - if (winPtr == NULL) { + " appname ?newName?\"", (char *) NULL); return TCL_ERROR; } if (argc == 3) { - switch (winPtr->dispPtr->colorModels[winPtr->screenNum]) { - case TK_MONO: - interp->result = "monochrome"; - break; - case TK_COLOR: - interp->result = "color"; - break; - } - } else { - int valueLength; - - valueLength = strlen(argv[3]); - if ((argv[3][0] == 'c') - && (strncmp(argv[3], "color", valueLength) == 0)) { - if (DisplayPlanes(winPtr->display, winPtr->screenNum) == 1) { - interp->result = - "can't treat screen as color: only 1 bit plane"; - return TCL_ERROR; - } - winPtr->dispPtr->colorModels[winPtr->screenNum] = TK_COLOR; - } else if ((argv[3][0] == 'm') - && (strncmp(argv[3], "monochrome", valueLength) == 0)) { - winPtr->dispPtr->colorModels[winPtr->screenNum] = TK_MONO; - } else { - Tcl_AppendResult(interp, "bad color model \"", argv[3], - "\": must be color or monochrome", (char *) NULL); - } + winPtr->nameUid = Tk_GetUid(Tk_SetAppName(tkwin, argv[2])); } + interp->result = winPtr->nameUid; } else { Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be colormodel", (char *) NULL); + "\": must be appname", (char *) NULL); return TCL_ERROR; } return TCL_OK; @@ -583,24 +612,26 @@ Tk_TkwaitCmd(clientData, interp, argc, argv) char **argv; /* Argument strings. */ { Tk_Window tkwin = (Tk_Window) clientData; - int c, length; - int done; + int c, done; + size_t length; if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " variable|visible|window name\"", (char *) NULL); + argv[0], " variable|visibility|window name\"", (char *) NULL); return TCL_ERROR; } c = argv[1][0]; length = strlen(argv[1]); if ((c == 'v') && (strncmp(argv[1], "variable", length) == 0) && (length >= 2)) { - Tcl_TraceVar(interp, argv[2], + if (Tcl_TraceVar(interp, argv[2], TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - WaitVariableProc, (ClientData) &done); + WaitVariableProc, (ClientData) &done) != TCL_OK) { + return TCL_ERROR; + } done = 0; while (!done) { - Tk_DoOneEvent(0); + Tcl_DoOneEvent(0); } Tcl_UntraceVar(interp, argv[2], TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, @@ -613,13 +644,25 @@ Tk_TkwaitCmd(clientData, interp, argc, argv) if (window == NULL) { return TCL_ERROR; } - Tk_CreateEventHandler(window, VisibilityChangeMask, + Tk_CreateEventHandler(window, VisibilityChangeMask|StructureNotifyMask, WaitVisibilityProc, (ClientData) &done); done = 0; while (!done) { - Tk_DoOneEvent(0); + Tcl_DoOneEvent(0); } - Tk_DeleteEventHandler(window, VisibilityChangeMask, + if (done != 1) { + /* + * Note that we do not delete the event handler because it + * was deleted automatically when the window was destroyed. + */ + + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "window \"", argv[2], + "\" was deleted before its visibility changed", + (char *) NULL); + return TCL_ERROR; + } + Tk_DeleteEventHandler(window, VisibilityChangeMask|StructureNotifyMask, WaitVisibilityProc, (ClientData) &done); } else if ((c == 'w') && (strncmp(argv[1], "window", length) == 0)) { Tk_Window window; @@ -632,7 +675,7 @@ Tk_TkwaitCmd(clientData, interp, argc, argv) WaitWindowProc, (ClientData) &done); done = 0; while (!done) { - Tk_DoOneEvent(0); + Tcl_DoOneEvent(0); } /* * Note: there's no need to delete the event handler. It was @@ -675,7 +718,13 @@ WaitVisibilityProc(clientData, eventPtr) XEvent *eventPtr; /* Information about event (not used). */ { int *donePtr = (int *) clientData; - *donePtr = 1; + + if (eventPtr->type == VisibilityNotify) { + *donePtr = 1; + } + if (eventPtr->type == DestroyNotify) { + *donePtr = 2; + } } static void @@ -718,16 +767,17 @@ Tk_UpdateCmd(clientData, interp, argc, argv) { Tk_Window tkwin = (Tk_Window) clientData; int flags; + Display *display; if (argc == 1) { - flags = TK_DONT_WAIT; + flags = TCL_DONT_WAIT; } else if (argc == 2) { if (strncmp(argv[1], "idletasks", strlen(argv[1])) != 0) { - Tcl_AppendResult(interp, "bad argument \"", argv[1], + Tcl_AppendResult(interp, "bad option \"", argv[1], "\": must be idletasks", (char *) NULL); return TCL_ERROR; } - flags = TK_IDLE_EVENTS; + flags = TCL_IDLE_EVENTS; } else { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ?idletasks?\"", (char *) NULL); @@ -737,14 +787,19 @@ Tk_UpdateCmd(clientData, interp, argc, argv) /* * Handle all pending events, sync the display, and repeat over * and over again until all pending events have been handled. + * Special note: it's possible that the entire application could + * be destroyed by an event handler that occurs during the update. + * Thus, don't use any information from tkwin after calling + * Tcl_DoOneEvent. */ + display = Tk_Display(tkwin); while (1) { - while (Tk_DoOneEvent(flags) != 0) { + while (Tcl_DoOneEvent(flags) != 0) { /* Empty loop body */ } - XSync(Tk_Display(tkwin), False); - if (Tk_DoOneEvent(flags) == 0) { + XSync(display, False); + if (Tcl_DoOneEvent(flags) == 0) { break; } } @@ -784,7 +839,7 @@ Tk_WinfoCmd(clientData, interp, argc, argv) char **argv; /* Argument strings. */ { Tk_Window tkwin = (Tk_Window) clientData; - int length; + size_t length; char c, *argName; Tk_Window window; register TkWindow *winPtr; @@ -807,23 +862,43 @@ Tk_WinfoCmd(clientData, interp, argc, argv) c = argv[1][0]; length = strlen(argv[1]); if ((c == 'a') && (strcmp(argv[1], "atom") == 0)) { - if (argc != 3) { + char *atomName; + + if (argc == 3) { + atomName = argv[2]; + } else if (argc == 5) { + atomName = argv[4]; + tkwin = GetDisplayOf(interp, tkwin, argv+2); + if (tkwin == NULL) { + return TCL_ERROR; + } + } else { Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " atom name\"", (char *) NULL); + argv[0], " atom ?-displayof window? name\"", + (char *) NULL); return TCL_ERROR; } - sprintf(interp->result, "%d", Tk_InternAtom(tkwin, argv[2])); + sprintf(interp->result, "%ld", Tk_InternAtom(tkwin, atomName)); } else if ((c == 'a') && (strncmp(argv[1], "atomname", length) == 0) && (length >= 5)) { Atom atom; - char *name; + char *name, *id; - if (argc != 3) { + if (argc == 3) { + id = argv[2]; + } else if (argc == 5) { + id = argv[4]; + tkwin = GetDisplayOf(interp, tkwin, argv+2); + if (tkwin == NULL) { + return TCL_ERROR; + } + } else { Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " atomname id\"", (char *) NULL); + argv[0], " atomname ?-displayof window? id\"", + (char *) NULL); return TCL_ERROR; } - if (Tcl_GetInt(interp, argv[2], (int *) &atom) != TCL_OK) { + if (Tcl_GetInt(interp, id, (int *) &atom) != TCL_OK) { return TCL_ERROR; } name = Tk_GetAtomName(tkwin, atom); @@ -836,7 +911,7 @@ Tk_WinfoCmd(clientData, interp, argc, argv) } else if ((c == 'c') && (strncmp(argv[1], "cells", length) == 0) && (length >= 2)) { SETUP("cells"); - sprintf(interp->result, "%d", 1<result, "%d", Tk_Visual(window)->map_entries); } else if ((c == 'c') && (strncmp(argv[1], "children", length) == 0) && (length >= 2)) { SETUP("children"); @@ -848,17 +923,32 @@ Tk_WinfoCmd(clientData, interp, argc, argv) && (length >= 2)) { SETUP("class"); interp->result = Tk_Class(window); + } else if ((c == 'c') && (strncmp(argv[1], "colormapfull", length) == 0) + && (length >= 3)) { + SETUP("colormapfull"); + interp->result = (TkCmapStressed(window, Tk_Colormap(window))) + ? "1" : "0"; } else if ((c == 'c') && (strncmp(argv[1], "containing", length) == 0) - && (length >= 2)) { - int rootX, rootY; + && (length >= 3)) { + int rootX, rootY, index; - if (argc != 4) { + if (argc == 4) { + index = 2; + } else if (argc == 6) { + index = 4; + tkwin = GetDisplayOf(interp, tkwin, argv+2); + if (tkwin == NULL) { + return TCL_ERROR; + } + } else { Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " containing rootX rootY\"", (char *) NULL); + argv[0], " containing ?-displayof window? rootX rootY\"", + (char *) NULL); return TCL_ERROR; } - if ((Tk_GetPixels(interp, tkwin, argv[2], &rootX) != TCL_OK) - || (Tk_GetPixels(interp, tkwin, argv[3], &rootY) != TCL_OK)) { + if ((Tk_GetPixels(interp, tkwin, argv[index], &rootX) != TCL_OK) + || (Tk_GetPixels(interp, tkwin, argv[index+1], &rootY) + != TCL_OK)) { return TCL_ERROR; } window = Tk_CoordsToWindow(rootX, rootY, tkwin); @@ -873,7 +963,9 @@ Tk_WinfoCmd(clientData, interp, argc, argv) argName = "exists"; goto wrongArgs; } - if (Tk_NameToWindow(interp, argv[2], tkwin) == NULL) { + window = Tk_NameToWindow(interp, argv[2], tkwin); + if ((window == NULL) + || (((TkWindow *) window)->flags & TK_ALREADY_DEAD)) { interp->result = "0"; } else { interp->result = "1"; @@ -906,12 +998,19 @@ Tk_WinfoCmd(clientData, interp, argc, argv) sprintf(interp->result, "%d", Tk_Height(window)); } else if ((c == 'i') && (strcmp(argv[1], "id") == 0)) { SETUP("id"); - sprintf(interp->result, "0x%x", Tk_WindowId(window)); + Tk_MakeWindowExist(window); + sprintf(interp->result, "0x%x", (unsigned int) Tk_WindowId(window)); } else if ((c == 'i') && (strncmp(argv[1], "interps", length) == 0) && (length >= 2)) { - if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " interps\"", (char *) NULL); + if (argc == 4) { + tkwin = GetDisplayOf(interp, tkwin, argv+2); + if (tkwin == NULL) { + return TCL_ERROR; + } + } else if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " interps ?-displayof window?\"", + (char *) NULL); return TCL_ERROR; } return TkGetInterpNames(interp, tkwin); @@ -919,6 +1018,12 @@ Tk_WinfoCmd(clientData, interp, argc, argv) && (length >= 2)) { SETUP("ismapped"); interp->result = Tk_IsMapped(window) ? "1" : "0"; + } else if ((c == 'm') && (strncmp(argv[1], "manager", length) == 0)) { + SETUP("manager"); + winPtr = (TkWindow *) window; + if (winPtr->geomMgrPtr != NULL) { + interp->result = winPtr->geomMgrPtr->name; + } } else if ((c == 'n') && (strncmp(argv[1], "name", length) == 0)) { SETUP("name"); interp->result = Tk_Name(window); @@ -930,19 +1035,29 @@ Tk_WinfoCmd(clientData, interp, argc, argv) } } else if ((c == 'p') && (strncmp(argv[1], "pathname", length) == 0) && (length >= 2)) { - Window id; + int index, id; - if (argc != 3) { - argName = "pathname"; - goto wrongArgs; - } - if (Tcl_GetInt(interp, argv[2], (int *) &id) != TCL_OK) { + if (argc == 3) { + index = 2; + } else if (argc == 5) { + index = 4; + tkwin = GetDisplayOf(interp, tkwin, argv+2); + if (tkwin == NULL) { + return TCL_ERROR; + } + } else { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " pathname ?-displayof window? id\"", + (char *) NULL); return TCL_ERROR; } - if ((XFindContext(Tk_Display(tkwin), id, tkWindowContext, - (caddr_t *) &window) != 0) || (((TkWindow *) window)->mainPtr + if (Tcl_GetInt(interp, argv[index], &id) != TCL_OK) { + return TCL_ERROR; + } + window = Tk_IdToWindow(Tk_Display(tkwin), (Window) id); + if ((window == NULL) || (((TkWindow *) window)->mainPtr != ((TkWindow *) tkwin)->mainPtr)) { - Tcl_AppendResult(interp, "window id \"", argv[2], + Tcl_AppendResult(interp, "window id \"", argv[index], "\" doesn't exist in this application", (char *) NULL); return TCL_ERROR; } @@ -964,6 +1079,39 @@ Tk_WinfoCmd(clientData, interp, argc, argv) return TCL_ERROR; } sprintf(interp->result, "%d", pixels); + } else if ((c == 'p') && (strcmp(argv[1], "pointerx") == 0)) { + int x, y; + + SETUP("pointerx"); + winPtr = GetToplevel(window); + if (winPtr == NULL) { + x = -1; + } else { + TkGetPointerCoords((Tk_Window)winPtr, &x, &y); + } + sprintf(interp->result, "%d", x); + } else if ((c == 'p') && (strcmp(argv[1], "pointerxy") == 0)) { + int x, y; + + SETUP("pointerxy"); + winPtr = GetToplevel(window); + if (winPtr == NULL) { + x = -1; + } else { + TkGetPointerCoords((Tk_Window)winPtr, &x, &y); + } + sprintf(interp->result, "%d %d", x, y); + } else if ((c == 'p') && (strcmp(argv[1], "pointery") == 0)) { + int x, y; + + SETUP("pointery"); + winPtr = GetToplevel(window); + if (winPtr == NULL) { + y = -1; + } else { + TkGetPointerCoords((Tk_Window)winPtr, &x, &y); + } + sprintf(interp->result, "%d", y); } else if ((c == 'r') && (strncmp(argv[1], "reqheight", length) == 0) && (length >= 4)) { SETUP("reqheight"); @@ -985,7 +1133,7 @@ Tk_WinfoCmd(clientData, interp, argc, argv) if (window == NULL) { return TCL_ERROR; } - colorPtr = Tk_GetColor(interp, window, (Colormap) None, argv[3]); + colorPtr = Tk_GetColor(interp, window, argv[3]); if (colorPtr == NULL) { return TCL_ERROR; } @@ -1047,15 +1195,30 @@ Tk_WinfoCmd(clientData, interp, argc, argv) && (length >= 7)) { SETUP("screenwidth"); sprintf(interp->result, "%d", WidthOfScreen(Tk_Screen(window))); + } else if ((c == 's') && (strncmp(argv[1], "server", length) == 0) + && (length >= 2)) { + SETUP("server"); + TkGetServerInfo(interp, window); } else if ((c == 't') && (strncmp(argv[1], "toplevel", length) == 0)) { SETUP("toplevel"); - for (winPtr = (TkWindow *) window; !(winPtr->flags & TK_TOP_LEVEL); - winPtr = winPtr->parentPtr) { - /* Empty loop body. */ + winPtr = GetToplevel(window); + if (winPtr != NULL) { + interp->result = winPtr->pathName; } - interp->result = winPtr->pathName; - } else if ((c == 'v') && (strncmp(argv[1], "visual", length) == 0) - && (length >= 2)) { + } else if ((c == 'v') && (strncmp(argv[1], "viewable", length) == 0) + && (length >= 3)) { + SETUP("viewable"); + for (winPtr = (TkWindow *) window; ; winPtr = winPtr->parentPtr) { + if ((winPtr == NULL) || !(winPtr->flags & TK_MAPPED)) { + interp->result = "0"; + break; + } + if (winPtr->flags & TK_TOP_LEVEL) { + interp->result = "1"; + break; + } + } + } else if ((c == 'v') && (strcmp(argv[1], "visual") == 0)) { SETUP("visual"); switch (Tk_Visual(window)->class) { case PseudoColor: interp->result = "pseudocolor"; break; @@ -1066,10 +1229,65 @@ Tk_WinfoCmd(clientData, interp, argc, argv) case StaticGray: interp->result = "staticgray"; break; default: interp->result = "unknown"; break; } + } else if ((c == 'v') && (strncmp(argv[1], "visualid", length) == 0) + && (length >= 7)) { + SETUP("visualid"); + sprintf(interp->result, "0x%x", (unsigned int) + XVisualIDFromVisual(Tk_Visual(window))); + } else if ((c == 'v') && (strncmp(argv[1], "visualsavailable", length) == 0) + && (length >= 7)) { + XVisualInfo template, *visInfoPtr; + int count, i; + char string[70], visualIdString[16], *fmt; + int includeVisualId; + + if (argc == 3) { + includeVisualId = 0; + } else if ((argc == 4) + && (strncmp(argv[3], "includeids", strlen(argv[3])) == 0)) { + includeVisualId = 1; + } else { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " visualsavailable window ?includeids?\"", + (char *) NULL); + return TCL_ERROR; + } + + window = Tk_NameToWindow(interp, argv[2], tkwin); + if (window == NULL) { + return TCL_ERROR; + } + + template.screen = Tk_ScreenNumber(window); + visInfoPtr = XGetVisualInfo(Tk_Display(window), VisualScreenMask, + &template, &count); + if (visInfoPtr == NULL) { + interp->result = "can't find any visuals for screen"; + return TCL_ERROR; + } + for (i = 0; i < count; i++) { + switch (visInfoPtr[i].class) { + case PseudoColor: fmt = "pseudocolor %d"; break; + case GrayScale: fmt = "grayscale %d"; break; + case DirectColor: fmt = "directcolor %d"; break; + case TrueColor: fmt = "truecolor %d"; break; + case StaticColor: fmt = "staticcolor %d"; break; + case StaticGray: fmt = "staticgray %d"; break; + default: fmt = "unknown"; break; + } + sprintf(string, fmt, visInfoPtr[i].depth); + if (includeVisualId) { + sprintf(visualIdString, " 0x%x", + (unsigned int) visInfoPtr[i].visualid); + strcat(string, visualIdString); + } + Tcl_AppendElement(interp, string); + } + XFree((char *) visInfoPtr); } else if ((c == 'v') && (strncmp(argv[1], "vrootheight", length) == 0) && (length >= 6)) { int x, y; - unsigned int width, height; + int width, height; SETUP("vrootheight"); Tk_GetVRootGeometry(window, &x, &y, &width, &height); @@ -1077,21 +1295,21 @@ Tk_WinfoCmd(clientData, interp, argc, argv) } else if ((c == 'v') && (strncmp(argv[1], "vrootwidth", length) == 0) && (length >= 6)) { int x, y; - unsigned int width, height; + int width, height; SETUP("vrootwidth"); Tk_GetVRootGeometry(window, &x, &y, &width, &height); sprintf(interp->result, "%d", width); } else if ((c == 'v') && (strcmp(argv[1], "vrootx") == 0)) { int x, y; - unsigned int width, height; + int width, height; SETUP("vrootx"); Tk_GetVRootGeometry(window, &x, &y, &width, &height); sprintf(interp->result, "%d", x); } else if ((c == 'v') && (strcmp(argv[1], "vrooty") == 0)) { int x, y; - unsigned int width, height; + int width, height; SETUP("vrooty"); Tk_GetVRootGeometry(window, &x, &y, &width, &height); @@ -1107,14 +1325,19 @@ Tk_WinfoCmd(clientData, interp, argc, argv) sprintf(interp->result, "%d", Tk_Y(window)); } else { Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be atom, atomname, cells, children, class, ", - "depth, exists, fpixels, geometry, height, ", - "id, interps, ismapped, name, parent, pathname, ", - "pixels, reqheight, reqwidth, rgb, rootx, rooty, ", + "\": must be atom, atomname, cells, children, ", + "class, colormapfull, containing, depth, exists, fpixels, ", + "geometry, height, ", + "id, interps, ismapped, manager, name, parent, pathname, ", + "pixels, pointerx, pointerxy, pointery, reqheight, ", + "reqwidth, rgb, ", + "rootx, rooty, ", "screen, screencells, screendepth, screenheight, ", "screenmmheight, screenmmwidth, screenvisual, ", - "screenwidth, toplevel, visual, vrootheight, vrootwidth, ", - "vrootx, vrooty, width, x, or y", (char *) NULL); + "screenwidth, server, ", + "toplevel, viewable, visual, visualid, visualsavailable, ", + "vrootheight, vrootwidth, vrootx, vrooty, ", + "width, x, or y", (char *) NULL); return TCL_ERROR; } return TCL_OK; @@ -1125,6 +1348,44 @@ Tk_WinfoCmd(clientData, interp, argc, argv) return TCL_ERROR; } +/* + *---------------------------------------------------------------------- + * + * GetDisplayOf -- + * + * Parses a "-displayof" option for the "winfo" command. + * + * Results: + * The return value is a token for the window specified in + * argv[1]. If argv[0] and argv[1] couldn't be parsed, NULL + * is returned and an error is left in interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tk_Window +GetDisplayOf(interp, tkwin, argv) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + Tk_Window tkwin; /* Window to use for looking up window + * given in argv[1]. */ + char **argv; /* Array of two strings. First must be + * "-displayof" or an abbreviation, second + * must be window name. */ +{ + size_t length; + + length = strlen(argv[0]); + if ((length < 2) || (strncmp(argv[0], "-displayof", length) != 0)) { + Tcl_AppendResult(interp, "bad argument \"", argv[0], + "\": must be -displayof", (char *) NULL); + return (Tk_Window) NULL; + } + return Tk_NameToWindow(interp, argv[1], tkwin); +} + /* *---------------------------------------------------------------------- * @@ -1155,3 +1416,37 @@ TkDeadAppCmd(clientData, interp, argc, argv) "\" command: application has been destroyed", (char *) NULL); return TCL_ERROR; } + +/* + *---------------------------------------------------------------------- + * + * GetToplevel -- + * + * Retrieves the toplevel window which is the nearest ancestor of + * of the specified window. + * + * Results: + * Returns the toplevel window or NULL if the window has no + * ancestor which is a toplevel. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static TkWindow * +GetToplevel(tkwin) + Tk_Window tkwin; /* Window for which the toplevel should be + * deterined. */ +{ + TkWindow *winPtr = (TkWindow *) tkwin; + + while (!(winPtr->flags & TK_TOP_LEVEL)) { + winPtr = winPtr->parentPtr; + if (winPtr == NULL) { + return NULL; + } + } + return winPtr; +} diff --git a/tk4.2/generic/tkColor.c b/tk4.2/generic/tkColor.c new file mode 100644 index 0000000..8f8d1fe --- /dev/null +++ b/tk4.2/generic/tkColor.c @@ -0,0 +1,721 @@ +/* + * tkColor.c -- + * + * This file maintains a database of color values for the Tk + * toolkit, in order to avoid round-trips to the server to + * map color names to pixel values. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkColor.c 1.40 96/03/28 09:12:20 + */ + +#include "tkPort.h" +#include "tk.h" +#include "tkInt.h" + +/* + * A two-level data structure is used to manage the color database. + * The top level consists of one entry for each color name that is + * currently active, and the bottom level contains one entry for each + * pixel value that is still in use. The distinction between + * levels is necessary because the same pixel may have several + * different names. There are two hash tables, one used to index into + * each of the data structures. The name hash table is used when + * allocating colors, and the pixel hash table is used when freeing + * colors. + */ + +/* + * One of the following data structures is used to keep track of + * each color that this module has allocated from the X display + * server. These entries are indexed by two hash tables defined + * below: nameTable and valueTable. + */ + +#define COLOR_MAGIC ((unsigned int) 0x46140277) + +typedef struct TkColor { + XColor color; /* Information about this color. */ + unsigned int magic; /* Used for quick integrity check on this + * structure. Must always have the + * value COLOR_MAGIC. */ + GC gc; /* Simple gc with this color as foreground + * color and all other fields defaulted. + * May be None. */ + Screen *screen; /* Screen where this color is valid. Used + * to delete it, and to find its display. */ + Colormap colormap; /* Colormap from which this entry was + * allocated. */ + Visual *visual; /* Visual associated with colormap. */ + int refCount; /* Number of uses of this structure. */ + Tcl_HashTable *tablePtr; /* Hash table that indexes this structure + * (needed when deleting structure). */ + Tcl_HashEntry *hashPtr; /* Pointer to hash table entry for this + * structure. (for use in deleting entry). */ +} TkColor; + +/* + * Hash table for name -> TkColor mapping, and key structure used to + * index into that table: + */ + +static Tcl_HashTable nameTable; +typedef struct { + Tk_Uid name; /* Name of desired color. */ + Colormap colormap; /* Colormap from which color will be + * allocated. */ + Display *display; /* Display for colormap. */ +} NameKey; + +/* + * Hash table for value -> TkColor mapping, and key structure used to + * index into that table: + */ + +static Tcl_HashTable valueTable; +typedef struct { + int red, green, blue; /* Values for desired color. */ + Colormap colormap; /* Colormap from which color will be + * allocated. */ + Display *display; /* Display for colormap. */ +} ValueKey; + +static int initialized = 0; /* 0 means static structures haven't been + * initialized yet. */ + +/* + * If a colormap fills up, attempts to allocate new colors from that + * colormap will fail. When that happens, we'll just choose the + * closest color from those that are available in the colormap. + * One of the following structures will be created for each "stressed" + * colormap to keep track of the colors that are available in the + * colormap (otherwise we would have to re-query from the server on + * each allocation, which would be very slow). These entries are + * flushed after a few seconds, since other clients may release or + * reallocate colors over time. + */ + +struct TkStressedCmap { + Colormap colormap; /* X's token for the colormap. */ + int numColors; /* Number of entries currently active + * at *colorPtr. */ + XColor *colorPtr; /* Pointer to malloc'ed array of all + * colors that seem to be available in + * the colormap. Some may not actually + * be available, e.g. because they are + * read-write for another client; when + * we find this out, we remove them + * from the array. */ + struct TkStressedCmap *nextPtr; /* Next in list of all stressed + * colormaps for the display. */ +}; + +/* + * Forward declarations for procedures defined in this file: + */ + +static void ColorInit _ANSI_ARGS_((void)); +static void DeleteStressedCmap _ANSI_ARGS_((Display *display, + Colormap colormap)); +static void FindClosestColor _ANSI_ARGS_((Tk_Window tkwin, + XColor *desiredColorPtr, XColor *actualColorPtr)); + +/* + *---------------------------------------------------------------------- + * + * Tk_GetColor -- + * + * Given a string name for a color, map the name to a corresponding + * XColor structure. + * + * Results: + * The return value is a pointer to an XColor structure that + * indicates the red, blue, and green intensities for the color + * given by "name", and also specifies a pixel value to use to + * draw in that color. If an error occurs, NULL is returned and + * an error message will be left in interp->result. + * + * Side effects: + * The color is added to an internal database with a reference count. + * For each call to this procedure, there should eventually be a call + * to Tk_FreeColor so that the database is cleaned up when colors + * aren't in use anymore. + * + *---------------------------------------------------------------------- + */ + +XColor * +Tk_GetColor(interp, tkwin, name) + Tcl_Interp *interp; /* Place to leave error message if + * color can't be found. */ + Tk_Window tkwin; /* Window in which color will be used. */ + Tk_Uid name; /* Name of color to allocated (in form + * suitable for passing to XParseColor). */ +{ + NameKey nameKey; + Tcl_HashEntry *nameHashPtr; + int new; + TkColor *tkColPtr; + XColor color; + Display *display = Tk_Display(tkwin); + + if (!initialized) { + ColorInit(); + } + + /* + * First, check to see if there's already a mapping for this color + * name. + */ + + nameKey.name = name; + nameKey.colormap = Tk_Colormap(tkwin); + nameKey.display = display; + nameHashPtr = Tcl_CreateHashEntry(&nameTable, (char *) &nameKey, &new); + if (!new) { + tkColPtr = (TkColor *) Tcl_GetHashValue(nameHashPtr); + tkColPtr->refCount++; + return &tkColPtr->color; + } + + /* + * The name isn't currently known. Map from the name to a pixel + * value. Call XAllocNamedColor rather than XParseColor for non-# names: + * this saves a server round-trip for those names. + */ + + if (*name != '#') { + XColor screen; + + if (XAllocNamedColor(display, nameKey.colormap, name, &screen, + &color) != 0) { + DeleteStressedCmap(display, nameKey.colormap); + } else { + /* + * Couldn't allocate the color. Try translating the name to + * a color value, to see whether the problem is a bad color + * name or a full colormap. If the colormap is full, then + * pick an approximation to the desired color. + */ + + if (XLookupColor(display, nameKey.colormap, name, &color, + &screen) == 0) { + Tcl_AppendResult(interp, "unknown color name \"", + name, "\"", (char *) NULL); + Tcl_DeleteHashEntry(nameHashPtr); + return (XColor *) NULL; + } + FindClosestColor(tkwin, &screen, &color); + } + } else { + if (XParseColor(display, nameKey.colormap, name, &color) == 0) { + Tcl_AppendResult(interp, "invalid color name \"", name, + "\"", (char *) NULL); + Tcl_DeleteHashEntry(nameHashPtr); + return (XColor *) NULL; + } + if (XAllocColor(display, nameKey.colormap, &color) != 0) { + DeleteStressedCmap(display, nameKey.colormap); + } else { + FindClosestColor(tkwin, &color, &color); + } + } + + /* + * Now create a new TkColor structure and add it to nameTable. + */ + + tkColPtr = (TkColor *) ckalloc(sizeof(TkColor)); + tkColPtr->color = color; + tkColPtr->magic = COLOR_MAGIC; + tkColPtr->gc = None; + tkColPtr->screen = Tk_Screen(tkwin); + tkColPtr->colormap = nameKey.colormap; + tkColPtr->visual = Tk_Visual(tkwin); + tkColPtr->refCount = 1; + tkColPtr->tablePtr = &nameTable; + tkColPtr->hashPtr = nameHashPtr; + Tcl_SetHashValue(nameHashPtr, tkColPtr); + + return &tkColPtr->color; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_GetColorByValue -- + * + * Given a desired set of red-green-blue intensities for a color, + * locate a pixel value to use to draw that color in a given + * window. + * + * Results: + * The return value is a pointer to an XColor structure that + * indicates the closest red, blue, and green intensities available + * to those specified in colorPtr, and also specifies a pixel + * value to use to draw in that color. + * + * Side effects: + * The color is added to an internal database with a reference count. + * For each call to this procedure, there should eventually be a call + * to Tk_FreeColor, so that the database is cleaned up when colors + * aren't in use anymore. + * + *---------------------------------------------------------------------- + */ + +XColor * +Tk_GetColorByValue(tkwin, colorPtr) + Tk_Window tkwin; /* Window where color will be used. */ + XColor *colorPtr; /* Red, green, and blue fields indicate + * desired color. */ +{ + ValueKey valueKey; + Tcl_HashEntry *valueHashPtr; + int new; + TkColor *tkColPtr; + Display *display = Tk_Display(tkwin); + + if (!initialized) { + ColorInit(); + } + + /* + * First, check to see if there's already a mapping for this color + * name. + */ + + valueKey.red = colorPtr->red; + valueKey.green = colorPtr->green; + valueKey.blue = colorPtr->blue; + valueKey.colormap = Tk_Colormap(tkwin); + valueKey.display = display; + valueHashPtr = Tcl_CreateHashEntry(&valueTable, (char *) &valueKey, &new); + if (!new) { + tkColPtr = (TkColor *) Tcl_GetHashValue(valueHashPtr); + tkColPtr->refCount++; + return &tkColPtr->color; + } + + /* + * The name isn't currently known. Find a pixel value for this + * color and add a new structure to valueTable. + */ + + tkColPtr = (TkColor *) ckalloc(sizeof(TkColor)); + tkColPtr->color.red = valueKey.red; + tkColPtr->color.green = valueKey.green; + tkColPtr->color.blue = valueKey.blue; + if (XAllocColor(display, valueKey.colormap, &tkColPtr->color) != 0) { + DeleteStressedCmap(display, valueKey.colormap); + } else { + FindClosestColor(tkwin, &tkColPtr->color, &tkColPtr->color); + } + tkColPtr->magic = COLOR_MAGIC; + tkColPtr->gc = None; + tkColPtr->screen = Tk_Screen(tkwin); + tkColPtr->colormap = valueKey.colormap; + tkColPtr->visual = Tk_Visual(tkwin); + tkColPtr->refCount = 1; + tkColPtr->tablePtr = &valueTable; + tkColPtr->hashPtr = valueHashPtr; + Tcl_SetHashValue(valueHashPtr, tkColPtr); + return &tkColPtr->color; +} + +/* + *-------------------------------------------------------------- + * + * Tk_NameOfColor -- + * + * Given a color, return a textual string identifying + * the color. + * + * Results: + * If colorPtr was created by Tk_GetColor, then the return + * value is the "string" that was used to create it. + * Otherwise the return value is a string that could have + * been passed to Tk_GetColor to allocate that color. The + * storage for the returned string is only guaranteed to + * persist up until the next call to this procedure. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +char * +Tk_NameOfColor(colorPtr) + XColor *colorPtr; /* Color whose name is desired. */ +{ + register TkColor *tkColPtr = (TkColor *) colorPtr; + static char string[20]; + + if ((tkColPtr->magic == COLOR_MAGIC) + && (tkColPtr->tablePtr == &nameTable)) { + return ((NameKey *) tkColPtr->hashPtr->key.words)->name; + } + sprintf(string, "#%04x%04x%04x", colorPtr->red, colorPtr->green, + colorPtr->blue); + return string; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_GCForColor -- + * + * Given a color allocated from this module, this procedure + * returns a GC that can be used for simple drawing with that + * color. + * + * Results: + * The return value is a GC with color set as its foreground + * color and all other fields defaulted. This GC is only valid + * as long as the color exists; it is freed automatically when + * the last reference to the color is freed. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +GC +Tk_GCForColor(colorPtr, drawable) + XColor *colorPtr; /* Color for which a GC is desired. Must + * have been allocated by Tk_GetColor or + * Tk_GetColorByName. */ + Drawable drawable; /* Drawable in which the color will be + * used (must have same screen and depth + * as the one for which the color was + * allocated). */ +{ + TkColor *tkColPtr = (TkColor *) colorPtr; + XGCValues gcValues; + + /* + * Do a quick sanity check to make sure this color was really + * allocated by Tk_GetColor. + */ + + if (tkColPtr->magic != COLOR_MAGIC) { + panic("Tk_GCForColor called with bogus color"); + } + + if (tkColPtr->gc == None) { + gcValues.foreground = tkColPtr->color.pixel; + tkColPtr->gc = XCreateGC(DisplayOfScreen(tkColPtr->screen), + drawable, GCForeground, &gcValues); + } + return tkColPtr->gc; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_FreeColor -- + * + * This procedure is called to release a color allocated by + * Tk_GetColor. + * + * Results: + * None. + * + * Side effects: + * The reference count associated with colorPtr is deleted, and + * the color is released to X if there are no remaining uses + * for it. + * + *---------------------------------------------------------------------- + */ + +void +Tk_FreeColor(colorPtr) + XColor *colorPtr; /* Color to be released. Must have been + * allocated by Tk_GetColor or + * Tk_GetColorByValue. */ +{ + register TkColor *tkColPtr = (TkColor *) colorPtr; + Visual *visual; + Screen *screen = tkColPtr->screen; + + /* + * Do a quick sanity check to make sure this color was really + * allocated by Tk_GetColor. + */ + + if (tkColPtr->magic != COLOR_MAGIC) { + panic("Tk_FreeColor called with bogus color"); + } + + tkColPtr->refCount--; + if (tkColPtr->refCount == 0) { + + /* + * Careful! Don't free black or white, since this will + * make some servers very unhappy. Also, there is a bug in + * some servers (such Sun's X11/NeWS server) where reference + * counting is performed incorrectly, so that if a color is + * allocated twice in different places and then freed twice, + * the second free generates an error (this bug existed as of + * 10/1/92). To get around this problem, ignore errors that + * occur during the free operation. + */ + + visual = tkColPtr->visual; + if ((visual->class != StaticGray) && (visual->class != StaticColor) + && (tkColPtr->color.pixel != BlackPixelOfScreen(screen)) + && (tkColPtr->color.pixel != WhitePixelOfScreen(screen))) { + Tk_ErrorHandler handler; + + handler = Tk_CreateErrorHandler(DisplayOfScreen(screen), + -1, -1, -1, (Tk_ErrorProc *) NULL, (ClientData) NULL); + XFreeColors(DisplayOfScreen(screen), tkColPtr->colormap, + &tkColPtr->color.pixel, 1, 0L); + Tk_DeleteErrorHandler(handler); + } + if (tkColPtr->gc != None) { + XFreeGC(DisplayOfScreen(screen), tkColPtr->gc); + } + DeleteStressedCmap(DisplayOfScreen(screen), tkColPtr->colormap); + Tcl_DeleteHashEntry(tkColPtr->hashPtr); + tkColPtr->magic = 0; + ckfree((char *) tkColPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * ColorInit -- + * + * Initialize the structure used for color management. + * + * Results: + * None. + * + * Side effects: + * Read the code. + * + *---------------------------------------------------------------------- + */ + +static void +ColorInit() +{ + initialized = 1; + Tcl_InitHashTable(&nameTable, sizeof(NameKey)/sizeof(int)); + Tcl_InitHashTable(&valueTable, sizeof(ValueKey)/sizeof(int)); +} + +/* + *---------------------------------------------------------------------- + * + * FindClosestColor -- + * + * When Tk can't allocate a color because a colormap has filled + * up, this procedure is called to find and allocate the closest + * available color in the colormap. + * + * Results: + * There is no return value, but *actualColorPtr is filled in + * with information about the closest available color in tkwin's + * colormap. This color has been allocated via X, so it must + * be released by the caller when the caller is done with it. + * + * Side effects: + * A color is allocated. + * + *---------------------------------------------------------------------- + */ + +static void +FindClosestColor(tkwin, desiredColorPtr, actualColorPtr) + Tk_Window tkwin; /* Window where color will be used. */ + XColor *desiredColorPtr; /* RGB values of color that was + * wanted (but unavailable). */ + XColor *actualColorPtr; /* Structure to fill in with RGB and + * pixel for closest available + * color. */ +{ + TkStressedCmap *stressPtr; + float tmp, distance, closestDistance; + int i, closest, numFound; + XColor *colorPtr; + TkDisplay *dispPtr = ((TkWindow *) tkwin)->dispPtr; + Colormap colormap = Tk_Colormap(tkwin); + XVisualInfo template, *visInfoPtr; + + /* + * Find the TkStressedCmap structure for this colormap, or create + * a new one if needed. + */ + + for (stressPtr = dispPtr->stressPtr; ; stressPtr = stressPtr->nextPtr) { + if (stressPtr == NULL) { + stressPtr = (TkStressedCmap *) ckalloc(sizeof(TkStressedCmap)); + stressPtr->colormap = colormap; + template.visualid = XVisualIDFromVisual(Tk_Visual(tkwin)); + visInfoPtr = XGetVisualInfo(Tk_Display(tkwin), + VisualIDMask, &template, &numFound); + if (numFound < 1) { + panic("FindClosestColor couldn't lookup visual"); + } + stressPtr->numColors = visInfoPtr->colormap_size; + XFree((char *) visInfoPtr); + stressPtr->colorPtr = (XColor *) ckalloc((unsigned) + (stressPtr->numColors * sizeof(XColor))); + for (i = 0; i < stressPtr->numColors; i++) { + stressPtr->colorPtr[i].pixel = (unsigned long) i; + } + XQueryColors(dispPtr->display, colormap, stressPtr->colorPtr, + stressPtr->numColors); + stressPtr->nextPtr = dispPtr->stressPtr; + dispPtr->stressPtr = stressPtr; + break; + } + if (stressPtr->colormap == colormap) { + break; + } + } + + /* + * Find the color that best approximates the desired one, then + * try to allocate that color. If that fails, it must mean that + * the color was read-write (so we can't use it, since it's owner + * might change it) or else it was already freed. Try again, + * over and over again, until something succeeds. + */ + + while (1) { + if (stressPtr->numColors == 0) { + panic("FindClosestColor ran out of colors"); + } + closestDistance = 1e30; + closest = 0; + for (colorPtr = stressPtr->colorPtr, i = 0; i < stressPtr->numColors; + colorPtr++, i++) { + /* + * Use Euclidean distance in RGB space, weighted by Y (of YIQ) + * as the objective function; this accounts for differences + * in the color sensitivity of the eye. + */ + + tmp = .30*(((int) desiredColorPtr->red) - (int) colorPtr->red); + distance = tmp*tmp; + tmp = .61*(((int) desiredColorPtr->green) - (int) colorPtr->green); + distance += tmp*tmp; + tmp = .11*(((int) desiredColorPtr->blue) - (int) colorPtr->blue); + distance += tmp*tmp; + if (distance < closestDistance) { + closest = i; + closestDistance = distance; + } + } + if (XAllocColor(dispPtr->display, colormap, + &stressPtr->colorPtr[closest]) != 0) { + *actualColorPtr = stressPtr->colorPtr[closest]; + return; + } + + /* + * Couldn't allocate the color. Remove it from the table and + * go back to look for the next best color. + */ + + stressPtr->colorPtr[closest] = + stressPtr->colorPtr[stressPtr->numColors-1]; + stressPtr->numColors -= 1; + } +} + +/* + *---------------------------------------------------------------------- + * + * TkCmapStressed -- + * + * Check to see whether a given colormap is known to be out + * of entries. + * + * Results: + * 1 is returned if "colormap" is stressed (i.e. it has run out + * of entries recently), 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TkCmapStressed(tkwin, colormap) + Tk_Window tkwin; /* Window that identifies the display + * containing the colormap. */ + Colormap colormap; /* Colormap to check for stress. */ +{ + TkStressedCmap *stressPtr; + + for (stressPtr = ((TkWindow *) tkwin)->dispPtr->stressPtr; + stressPtr != NULL; stressPtr = stressPtr->nextPtr) { + if (stressPtr->colormap == colormap) { + return 1; + } + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteStressedCmap -- + * + * This procedure releases the information cached for "colormap" + * so that it will be refetched from the X server the next time + * it is needed. + * + * Results: + * None. + * + * Side effects: + * The TkStressedCmap structure for colormap is deleted; the + * colormap is no longer considered to be "stressed". + * + * Note: + * This procedure is invoked whenever a color in a colormap is + * freed, and whenever a color allocation in a colormap succeeds. + * This guarantees that TkStressedCmap structures are always + * deleted before the corresponding Colormap is freed. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteStressedCmap(display, colormap) + Display *display; /* Xlib's handle for the display + * containing the colormap. */ + Colormap colormap; /* Colormap to flush. */ +{ + TkStressedCmap *prevPtr, *stressPtr; + TkDisplay *dispPtr = TkGetDisplay(display); + + for (prevPtr = NULL, stressPtr = dispPtr->stressPtr; stressPtr != NULL; + prevPtr = stressPtr, stressPtr = stressPtr->nextPtr) { + if (stressPtr->colormap == colormap) { + if (prevPtr == NULL) { + dispPtr->stressPtr = stressPtr->nextPtr; + } else { + prevPtr->nextPtr = stressPtr->nextPtr; + } + ckfree((char *) stressPtr->colorPtr); + ckfree((char *) stressPtr); + return; + } + } +} diff --git a/tk3.6/tkConfig.c b/tk4.2/generic/tkConfig.c similarity index 81% rename from tk3.6/tkConfig.c rename to tk4.2/generic/tkConfig.c index d93e315..b728459 100644 --- a/tk3.6/tkConfig.c +++ b/tk4.2/generic/tkConfig.c @@ -3,32 +3,16 @@ * * This file contains the Tk_ConfigureWidget procedure. * - * Copyright (c) 1990-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tkConfig.c 1.52 96/02/15 18:52:39 */ -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkConfig.c,v 1.37 93/10/14 11:10:05 ouster Exp $ SPRITE (Berkeley)"; -#endif - -#include "tkConfig.h" +#include "tkPort.h" #include "tk.h" /* @@ -49,12 +33,16 @@ static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkConfig.c,v 1.37 93/10/1 static int DoConfig _ANSI_ARGS_((Tcl_Interp *interp, Tk_Window tkwin, Tk_ConfigSpec *specPtr, Tk_Uid value, int valueIsUid, char *widgRec)); -static Tk_ConfigSpec * FindConfigSpec _ANSI_ARGS_ ((Tcl_Interp *interp, +static Tk_ConfigSpec * FindConfigSpec _ANSI_ARGS_((Tcl_Interp *interp, Tk_ConfigSpec *specs, char *argvName, int needFlags, int hateFlags)); -static char * FormatConfigInfo _ANSI_ARGS_ ((Tcl_Interp *interp, +static char * FormatConfigInfo _ANSI_ARGS_((Tcl_Interp *interp, Tk_Window tkwin, Tk_ConfigSpec *specPtr, char *widgRec)); +static char * FormatConfigValue _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, Tk_ConfigSpec *specPtr, + char *widgRec, char *buffer, + Tcl_FreeProc **freeProcPtr)); /* *-------------------------------------------------------------- @@ -101,7 +89,7 @@ Tk_ConfigureWidget(interp, tkwin, specs, argc, argv, widgRec, flags) * not considered. */ needFlags = flags & ~(TK_CONFIG_USER_BIT - 1); - if (Tk_GetColorModel(tkwin) != TK_COLOR) { + if (Tk_Depth(tkwin) <= 1) { hateFlags = TK_CONFIG_COLOR_ONLY; } else { hateFlags = TK_CONFIG_MONO_ONLY; @@ -250,7 +238,7 @@ FindConfigSpec(interp, specs, argvName, needFlags, hateFlags) register Tk_ConfigSpec *specPtr; register char c; /* First character of current argument. */ Tk_ConfigSpec *matchPtr; /* Matching spec, or NULL. */ - int length; + size_t length; c = argvName[1]; length = strlen(argvName); @@ -401,7 +389,7 @@ DoConfig(interp, tkwin, specPtr, value, valueIsUid, widgRec) newPtr = NULL; } else { uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value); - newPtr = Tk_GetColor(interp, tkwin, (Colormap) None, uid); + newPtr = Tk_GetColor(interp, tkwin, uid); if (newPtr == NULL) { return TCL_ERROR; } @@ -458,7 +446,7 @@ DoConfig(interp, tkwin, specPtr, value, valueIsUid, widgRec) new = NULL; } else { uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value); - new = Tk_Get3DBorder(interp, tkwin, (Colormap) None, uid); + new = Tk_Get3DBorder(interp, tkwin, uid); if (new == NULL) { return TCL_ERROR; } @@ -478,7 +466,7 @@ DoConfig(interp, tkwin, specPtr, value, valueIsUid, widgRec) break; case TK_CONFIG_CURSOR: case TK_CONFIG_ACTIVE_CURSOR: { - Cursor new, old; + Tk_Cursor new, old; if (nullValue) { new = None; @@ -489,11 +477,11 @@ DoConfig(interp, tkwin, specPtr, value, valueIsUid, widgRec) return TCL_ERROR; } } - old = *((Cursor *) ptr); + old = *((Tk_Cursor *) ptr); if (old != None) { Tk_FreeCursor(Tk_Display(tkwin), old); } - *((Cursor *) ptr) = new; + *((Tk_Cursor *) ptr) = new; if (specPtr->type == TK_CONFIG_ACTIVE_CURSOR) { Tk_DefineCursor(tkwin, new); } @@ -617,7 +605,7 @@ Tk_ConfigureInfo(interp, tkwin, specs, widgRec, argvName, flags) char *leader = "{"; needFlags = flags & ~(TK_CONFIG_USER_BIT - 1); - if (Tk_GetColorModel(tkwin) != TK_COLOR) { + if (Tk_Depth(tkwin) <= 1) { hateFlags = TK_CONFIG_COLOR_ONLY; } else { hateFlags = TK_CONFIG_MONO_ONLY; @@ -692,7 +680,7 @@ FormatConfigInfo(interp, tkwin, specPtr, widgRec) char *widgRec; /* Pointer to record holding current * values of info for widget. */ { - char *argv[6], *ptr, *result; + char *argv[6], *result; char buffer[200]; Tcl_FreeProc *freeProc = (Tcl_FreeProc *) NULL; @@ -703,110 +691,8 @@ FormatConfigInfo(interp, tkwin, specPtr, widgRec) if (specPtr->type == TK_CONFIG_SYNONYM) { return Tcl_Merge(2, argv); } - ptr = widgRec + specPtr->offset; - argv[4] = ""; - switch (specPtr->type) { - case TK_CONFIG_BOOLEAN: - if (*((int *) ptr) == 0) { - argv[4] = "0"; - } else { - argv[4] = "1"; - } - break; - case TK_CONFIG_INT: - sprintf(buffer, "%d", *((int *) ptr)); - argv[4] = buffer; - break; - case TK_CONFIG_DOUBLE: - Tcl_PrintDouble(interp, *((double *) ptr), buffer); - argv[4] = buffer; - break; - case TK_CONFIG_STRING: - argv[4] = (*(char **) ptr); - break; - case TK_CONFIG_UID: { - Tk_Uid uid = *((Tk_Uid *) ptr); - if (uid != NULL) { - argv[4] = uid; - } - break; - } - case TK_CONFIG_COLOR: { - XColor *colorPtr = *((XColor **) ptr); - if (colorPtr != NULL) { - argv[4] = Tk_NameOfColor(colorPtr); - } - break; - } - case TK_CONFIG_FONT: { - XFontStruct *fontStructPtr = *((XFontStruct **) ptr); - if (fontStructPtr != NULL) { - argv[4] = Tk_NameOfFontStruct(fontStructPtr); - } - break; - } - case TK_CONFIG_BITMAP: { - Pixmap pixmap = *((Pixmap *) ptr); - if (pixmap != None) { - argv[4] = Tk_NameOfBitmap(Tk_Display(tkwin), pixmap); - } - break; - } - case TK_CONFIG_BORDER: { - Tk_3DBorder border = *((Tk_3DBorder *) ptr); - if (border != NULL) { - argv[4] = Tk_NameOf3DBorder(border); - } - break; - } - case TK_CONFIG_RELIEF: - argv[4] = Tk_NameOfRelief(*((int *) ptr)); - break; - case TK_CONFIG_CURSOR: - case TK_CONFIG_ACTIVE_CURSOR: { - Cursor cursor = *((Cursor *) ptr); - if (cursor != None) { - argv[4] = Tk_NameOfCursor(Tk_Display(tkwin), cursor); - } - break; - } - case TK_CONFIG_JUSTIFY: - argv[4] = Tk_NameOfJustify(*((Tk_Justify *) ptr)); - break; - case TK_CONFIG_ANCHOR: - argv[4] = Tk_NameOfAnchor(*((Tk_Anchor *) ptr)); - break; - case TK_CONFIG_CAP_STYLE: - argv[4] = Tk_NameOfCapStyle(*((int *) ptr)); - break; - case TK_CONFIG_JOIN_STYLE: - argv[4] = Tk_NameOfJoinStyle(*((int *) ptr)); - break; - case TK_CONFIG_PIXELS: - sprintf(buffer, "%d", *((int *) ptr)); - argv[4] = buffer; - break; - case TK_CONFIG_MM: - Tcl_PrintDouble(interp, *((double *) ptr), buffer); - argv[4] = buffer; - break; - case TK_CONFIG_WINDOW: { - Tk_Window tkwin; - - tkwin = *((Tk_Window *) ptr); - if (tkwin != NULL) { - argv[4] = Tk_PathName(tkwin); - } - break; - } - case TK_CONFIG_CUSTOM: - argv[4] = (*specPtr->customPtr->printProc)( - specPtr->customPtr->clientData, tkwin, widgRec, - specPtr->offset, &freeProc); - break; - default: - argv[4] = "?? unknown type ??"; - } + argv[4] = FormatConfigValue(interp, tkwin, specPtr, widgRec, buffer, + &freeProc); if (argv[1] == NULL) { argv[1] = ""; } @@ -821,7 +707,7 @@ FormatConfigInfo(interp, tkwin, specPtr, widgRec) } result = Tcl_Merge(5, argv); if (freeProc != NULL) { - if (freeProc == (Tcl_FreeProc *) free) { + if ((freeProc == TCL_DYNAMIC) || (freeProc == (Tcl_FreeProc *) free)) { ckfree(argv[4]); } else { (*freeProc)(argv[4]); @@ -830,6 +716,206 @@ FormatConfigInfo(interp, tkwin, specPtr, widgRec) return result; } +/* + *---------------------------------------------------------------------- + * + * FormatConfigValue -- + * + * This procedure formats the current value of a configuration + * option. + * + * Results: + * The return value is the formatted value of the option given + * by specPtr and widgRec. If the value is static, so that it + * need not be freed, *freeProcPtr will be set to NULL; otherwise + * *freeProcPtr will be set to the address of a procedure to + * free the result, and the caller must invoke this procedure + * when it is finished with the result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +FormatConfigValue(interp, tkwin, specPtr, widgRec, buffer, freeProcPtr) + Tcl_Interp *interp; /* Interpreter for use in real conversions. */ + Tk_Window tkwin; /* Window corresponding to widget. */ + Tk_ConfigSpec *specPtr; /* Pointer to information describing option. + * Must not point to a synonym option. */ + char *widgRec; /* Pointer to record holding current + * values of info for widget. */ + char *buffer; /* Static buffer to use for small values. + * Must have at least 200 bytes of storage. */ + Tcl_FreeProc **freeProcPtr; /* Pointer to word to fill in with address + * of procedure to free the result, or NULL + * if result is static. */ +{ + char *ptr, *result; + + *freeProcPtr = NULL; + ptr = widgRec + specPtr->offset; + result = ""; + switch (specPtr->type) { + case TK_CONFIG_BOOLEAN: + if (*((int *) ptr) == 0) { + result = "0"; + } else { + result = "1"; + } + break; + case TK_CONFIG_INT: + sprintf(buffer, "%d", *((int *) ptr)); + result = buffer; + break; + case TK_CONFIG_DOUBLE: + Tcl_PrintDouble(interp, *((double *) ptr), buffer); + result = buffer; + break; + case TK_CONFIG_STRING: + result = (*(char **) ptr); + if (result == NULL) { + result = ""; + } + break; + case TK_CONFIG_UID: { + Tk_Uid uid = *((Tk_Uid *) ptr); + if (uid != NULL) { + result = uid; + } + break; + } + case TK_CONFIG_COLOR: { + XColor *colorPtr = *((XColor **) ptr); + if (colorPtr != NULL) { + result = Tk_NameOfColor(colorPtr); + } + break; + } + case TK_CONFIG_FONT: { + XFontStruct *fontStructPtr = *((XFontStruct **) ptr); + if (fontStructPtr != NULL) { + result = Tk_NameOfFontStruct(fontStructPtr); + } + break; + } + case TK_CONFIG_BITMAP: { + Pixmap pixmap = *((Pixmap *) ptr); + if (pixmap != None) { + result = Tk_NameOfBitmap(Tk_Display(tkwin), pixmap); + } + break; + } + case TK_CONFIG_BORDER: { + Tk_3DBorder border = *((Tk_3DBorder *) ptr); + if (border != NULL) { + result = Tk_NameOf3DBorder(border); + } + break; + } + case TK_CONFIG_RELIEF: + result = Tk_NameOfRelief(*((int *) ptr)); + break; + case TK_CONFIG_CURSOR: + case TK_CONFIG_ACTIVE_CURSOR: { + Tk_Cursor cursor = *((Tk_Cursor *) ptr); + if (cursor != None) { + result = Tk_NameOfCursor(Tk_Display(tkwin), cursor); + } + break; + } + case TK_CONFIG_JUSTIFY: + result = Tk_NameOfJustify(*((Tk_Justify *) ptr)); + break; + case TK_CONFIG_ANCHOR: + result = Tk_NameOfAnchor(*((Tk_Anchor *) ptr)); + break; + case TK_CONFIG_CAP_STYLE: + result = Tk_NameOfCapStyle(*((int *) ptr)); + break; + case TK_CONFIG_JOIN_STYLE: + result = Tk_NameOfJoinStyle(*((int *) ptr)); + break; + case TK_CONFIG_PIXELS: + sprintf(buffer, "%d", *((int *) ptr)); + result = buffer; + break; + case TK_CONFIG_MM: + Tcl_PrintDouble(interp, *((double *) ptr), buffer); + result = buffer; + break; + case TK_CONFIG_WINDOW: { + Tk_Window tkwin; + + tkwin = *((Tk_Window *) ptr); + if (tkwin != NULL) { + result = Tk_PathName(tkwin); + } + break; + } + case TK_CONFIG_CUSTOM: + result = (*specPtr->customPtr->printProc)( + specPtr->customPtr->clientData, tkwin, widgRec, + specPtr->offset, freeProcPtr); + break; + default: + result = "?? unknown type ??"; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_ConfigureValue -- + * + * This procedure returns the current value of a configuration + * option for a widget. + * + * Results: + * The return value is a standard Tcl completion code (TCL_OK or + * TCL_ERROR). Interp->result will be set to hold either the value + * of the option given by argvName (if TCL_OK is returned) or + * an error message (if TCL_ERROR is returned). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tk_ConfigureValue(interp, tkwin, specs, widgRec, argvName, flags) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + Tk_Window tkwin; /* Window corresponding to widgRec. */ + Tk_ConfigSpec *specs; /* Describes legal options. */ + char *widgRec; /* Record whose fields contain current + * values for options. */ + char *argvName; /* Gives the command-line name for the + * option whose value is to be returned. */ + int flags; /* Used to specify additional flags + * that must be present in config specs + * for them to be considered. */ +{ + Tk_ConfigSpec *specPtr; + int needFlags, hateFlags; + + needFlags = flags & ~(TK_CONFIG_USER_BIT - 1); + if (Tk_Depth(tkwin) <= 1) { + hateFlags = TK_CONFIG_COLOR_ONLY; + } else { + hateFlags = TK_CONFIG_MONO_ONLY; + } + specPtr = FindConfigSpec(interp, specs, argvName, needFlags, hateFlags); + if (specPtr == NULL) { + return TCL_ERROR; + } + interp->result = FormatConfigValue(interp, tkwin, specPtr, widgRec, + interp->result, &interp->freeProc); + return TCL_OK; +} + /* *---------------------------------------------------------------------- * @@ -901,9 +987,9 @@ Tk_FreeOptions(specs, widgRec, display, needFlags) break; case TK_CONFIG_CURSOR: case TK_CONFIG_ACTIVE_CURSOR: - if (*((Cursor *) ptr) != None) { - Tk_FreeCursor(display, *((Cursor *) ptr)); - *((Cursor *) ptr) = None; + if (*((Tk_Cursor *) ptr) != None) { + Tk_FreeCursor(display, *((Tk_Cursor *) ptr)); + *((Tk_Cursor *) ptr) = None; } } } diff --git a/tk4.2/generic/tkConsole.c b/tk4.2/generic/tkConsole.c new file mode 100644 index 0000000..6f0cf84 --- /dev/null +++ b/tk4.2/generic/tkConsole.c @@ -0,0 +1,624 @@ +/* + * tkConsole.c -- + * + * This file implements a Tcl console for systems that may not + * otherwise have access to a console. It uses the Text widget + * and provides special access via a console command. + * + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkConsole.c 1.43 96/08/26 19:42:51 + */ + +#include "tkInt.h" + +/* + * A data structure of the following type holds information for each console + * which a handler (i.e. a Tcl command) has been defined for a particular + * top-level window. + */ + +typedef struct ConsoleInfo { + Tcl_Interp *consoleInterp; /* Interpreter for the console. */ + Tcl_Interp *interp; /* Interpreter to send console commands. */ +} ConsoleInfo; + +static Tcl_Interp *gStdoutInterp = NULL; + +/* + * Forward declarations for procedures defined later in this file: + */ + +static int ConsoleCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static void ConsoleDeleteProc _ANSI_ARGS_((ClientData clientData)); +static void ConsoleEventProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +static int InterpreterCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +static int ConsoleInput _ANSI_ARGS_((ClientData instanceData, + char *buf, int toRead, int *errorCode)); +static int ConsoleOutput _ANSI_ARGS_((ClientData instanceData, + char *buf, int toWrite, int *errorCode)); +static int ConsoleClose _ANSI_ARGS_((ClientData instanceData, + Tcl_Interp *interp)); +static void ConsoleWatch _ANSI_ARGS_((ClientData instanceData, + int mask)); +static int ConsoleReady _ANSI_ARGS_((ClientData instanceData, + int mask)); +static Tcl_File ConsoleFile _ANSI_ARGS_((ClientData instanceData, + int direction)); + +/* + * This structure describes the channel type structure for file based IO: + */ + +static Tcl_ChannelType consoleChannelType = { + "console", /* Type name. */ + NULL, /* Always non-blocking.*/ + ConsoleClose, /* Close proc. */ + ConsoleInput, /* Input proc. */ + ConsoleOutput, /* Output proc. */ + NULL, /* Seek proc. */ + NULL, /* Set option proc. */ + NULL, /* Get option proc. */ + ConsoleWatch, /* Watch for events on console. */ + ConsoleReady, /* Are events present? */ + ConsoleFile, /* Get a Tcl_File from the device. */ +}; + +/* + *---------------------------------------------------------------------- + * + * TkConsoleCreate -- + * + * Create the console channels and install them as the standard + * channels. All I/O will be discarded until TkConsoleInit is + * called to attach the console to a text widget. + * + * Results: + * None. + * + * Side effects: + * Creates the console channel and installs it as the standard + * channels. + * + *---------------------------------------------------------------------- + */ + +void +TkConsoleCreate() +{ + Tcl_Channel consoleChannel; + + consoleChannel = Tcl_CreateChannel(&consoleChannelType, "console0", + (ClientData) TCL_STDIN, TCL_READABLE); + if (consoleChannel != NULL) { + Tcl_SetChannelOption(NULL, consoleChannel, "-translation", "lf"); + Tcl_SetChannelOption(NULL, consoleChannel, "-buffering", "none"); + } + Tcl_SetStdChannel(consoleChannel, TCL_STDIN); + consoleChannel = Tcl_CreateChannel(&consoleChannelType, "console1", + (ClientData) TCL_STDOUT, TCL_WRITABLE); + if (consoleChannel != NULL) { + Tcl_SetChannelOption(NULL, consoleChannel, "-translation", "lf"); + Tcl_SetChannelOption(NULL, consoleChannel, "-buffering", "none"); + } + Tcl_SetStdChannel(consoleChannel, TCL_STDOUT); + consoleChannel = Tcl_CreateChannel(&consoleChannelType, "console2", + (ClientData) TCL_STDERR, TCL_WRITABLE); + if (consoleChannel != NULL) { + Tcl_SetChannelOption(NULL, consoleChannel, "-translation", "lf"); + Tcl_SetChannelOption(NULL, consoleChannel, "-buffering", "none"); + } + Tcl_SetStdChannel(consoleChannel, TCL_STDERR); +} + +/* + *---------------------------------------------------------------------- + * + * TkConsoleInit -- + * + * Initialize the console. This code actually creates a new + * application and associated interpreter. This effectivly hides + * the implementation from the main application. + * + * Results: + * None. + * + * Side effects: + * A new console it created. + * + *---------------------------------------------------------------------- + */ + +int +TkConsoleInit(interp) + Tcl_Interp *interp; /* Interpreter to use for prompting. */ +{ + Tcl_Interp *consoleInterp; + ConsoleInfo *info; + Tk_Window mainWindow = Tk_MainWindow(interp); +#ifdef MAC_TCL + static char initCmd[] = "source -rsrc {Console}"; +#else + static char initCmd[] = "source $tk_library/console.tcl"; +#endif + + consoleInterp = Tcl_CreateInterp(); + if (consoleInterp == NULL) { + goto error; + } + + /* + * Initialized Tcl and Tk. + */ + + if (Tcl_Init(consoleInterp) != TCL_OK) { + goto error; + } + if (Tk_Init(consoleInterp) != TCL_OK) { + goto error; + } + gStdoutInterp = interp; + + /* + * Add console commands to the interp + */ + info = (ConsoleInfo *) ckalloc(sizeof(ConsoleInfo)); + info->interp = interp; + info->consoleInterp = consoleInterp; + Tcl_CreateCommand(interp, "console", ConsoleCmd, (ClientData) info, + (Tcl_CmdDeleteProc *) ConsoleDeleteProc); + Tcl_CreateCommand(consoleInterp, "interp", InterpreterCmd, + (ClientData) info, (Tcl_CmdDeleteProc *) NULL); + + Tk_CreateEventHandler(mainWindow, StructureNotifyMask, ConsoleEventProc, + (ClientData) info); + + Tcl_Preserve((ClientData) consoleInterp); + if (Tcl_Eval(consoleInterp, initCmd) == TCL_ERROR) { + /* goto error; -- no problem for now... */ + printf("Eval error: %s", consoleInterp->result); + } + Tcl_Release((ClientData) consoleInterp); + return TCL_OK; + + error: + if (consoleInterp != NULL) { + Tcl_DeleteInterp(consoleInterp); + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * ConsoleOutput-- + * + * Writes the given output on the IO channel. Returns count of how + * many characters were actually written, and an error indication. + * + * Results: + * A count of how many characters were written is returned and an + * error indication is returned in an output argument. + * + * Side effects: + * Writes output on the actual channel. + * + *---------------------------------------------------------------------- + */ + +static int +ConsoleOutput(instanceData, buf, toWrite, errorCode) + ClientData instanceData; /* Indicates which device to use. */ + char *buf; /* The data buffer. */ + int toWrite; /* How many bytes to write? */ + int *errorCode; /* Where to store error code. */ +{ + *errorCode = 0; + Tcl_SetErrno(0); + + if (gStdoutInterp != NULL) { + TkConsolePrint(gStdoutInterp, (int) instanceData, buf, toWrite); + } + + return toWrite; +} + +/* + *---------------------------------------------------------------------- + * + * ConsoleInput -- + * + * Read input from the console. Not currently implemented. + * + * Results: + * Always returns EOF. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +ConsoleInput(instanceData, buf, bufSize, errorCode) + ClientData instanceData; /* Unused. */ + char *buf; /* Where to store data read. */ + int bufSize; /* How much space is available + * in the buffer? */ + int *errorCode; /* Where to store error code. */ +{ + return 0; /* Always return EOF. */ +} + +/* + *---------------------------------------------------------------------- + * + * ConsoleClose -- + * + * Closes the IO channel. + * + * Results: + * Always returns 0 (success). + * + * Side effects: + * Frees the dummy file associated with the channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +ConsoleClose(instanceData, interp) + ClientData instanceData; /* Unused. */ + Tcl_Interp *interp; /* Unused. */ +{ + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * ConsoleWatch -- + * + * Called by the notifier to set up the console device so that + * events will be noticed. Since there are no events on the + * console, this routine just returns without doing anything. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +ConsoleWatch(instanceData, mask) + ClientData instanceData; /* Device ID for the channel. */ + int mask; /* OR-ed combination of + * TCL_READABLE, TCL_WRITABLE and + * TCL_EXCEPTION, for the events + * we are interested in. */ +{ +} + +/* + *---------------------------------------------------------------------- + * + * ConsoleReady -- + * + * Invoked by the notifier to notice whether any events are present + * on the console. Since there are no events on the console, this + * routine always returns zero. + * + * Results: + * Always 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +ConsoleReady(instanceData, mask) + ClientData instanceData; /* Device ID for the channel. */ + int mask; /* OR-ed combination of + * TCL_READABLE, TCL_WRITABLE and + * TCL_EXCEPTION, for the events + * we are interested in. */ +{ + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * ConsoleFile -- + * + * Invoked by the generic IO layer to get a Tcl_File from a channel. + * Because console channels do not use Tcl_Files, this function always + * returns NULL. + * + * Results: + * Always NULL. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static Tcl_File +ConsoleFile(instanceData, direction) + ClientData instanceData; /* Device ID for the channel. */ + int direction; /* TCL_READABLE or TCL_WRITABLE + * to indicate which direction of + * the channel is being requested. */ +{ + return (Tcl_File) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * ConsoleCmd -- + * + * The console command implements a Tcl interface to the various console + * options. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ConsoleCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + ConsoleInfo *info = (ConsoleInfo *) clientData; + char c; + int length; + int result; + Tcl_Interp *consoleInterp; + + 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]); + result = TCL_OK; + consoleInterp = info->consoleInterp; + Tcl_Preserve((ClientData) consoleInterp); + if ((c == 't') && (strncmp(argv[1], "title", length)) == 0) { + Tcl_DString dString; + char *wmCmd = "wm title . {"; + + Tcl_DStringInit(&dString); + Tcl_DStringAppend(&dString, wmCmd, strlen(wmCmd)); + Tcl_DStringAppend(&dString, argv[2], strlen(argv[2])); + Tcl_DStringAppend(&dString, "}", strlen("}")); + Tcl_Eval(consoleInterp, dString.string); + Tcl_DStringFree(&dString); + } else if ((c == 'h') && (strncmp(argv[1], "hide", length)) == 0) { + Tcl_Eval(info->consoleInterp, "wm withdraw ."); + } else if ((c == 's') && (strncmp(argv[1], "show", length)) == 0) { + Tcl_Eval(info->consoleInterp, "wm deiconify ."); + } else if ((c == 'e') && (strncmp(argv[1], "eval", length)) == 0) { + Tcl_Eval(info->consoleInterp, argv[2]); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be hide, show, or title", + (char *) NULL); + result = TCL_ERROR; + } + Tcl_Release((ClientData) consoleInterp); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * InterpreterCmd -- + * + * This command allows the console interp to communicate with the + * main interpreter. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +InterpreterCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + ConsoleInfo *info = (ConsoleInfo *) clientData; + char c; + int length; + int result; + Tcl_Interp *otherInterp; + + 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]); + result = TCL_OK; + otherInterp = info->interp; + Tcl_Preserve((ClientData) otherInterp); + if ((c == 'e') && (strncmp(argv[1], "eval", length)) == 0) { + result = Tcl_GlobalEval(otherInterp, argv[2]); + Tcl_AppendResult(interp, otherInterp->result, (char *) NULL); + } else if ((c == 'r') && (strncmp(argv[1], "record", length)) == 0) { + Tcl_RecordAndEval(otherInterp, argv[2], TCL_EVAL_GLOBAL); + result = TCL_OK; + Tcl_AppendResult(interp, otherInterp->result, (char *) NULL); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be eval or record", + (char *) NULL); + result = TCL_ERROR; + } + Tcl_Release((ClientData) otherInterp); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * ConsoleDeleteProc -- + * + * If the console command is deleted we destroy the console window + * and all associated data structures. + * + * Results: + * None. + * + * Side effects: + * A new console it created. + * + *---------------------------------------------------------------------- + */ + +void +ConsoleDeleteProc(clientData) + ClientData clientData; +{ + ConsoleInfo *info = (ConsoleInfo *) clientData; + + Tcl_DeleteInterp(info->consoleInterp); + info->consoleInterp = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * ConsoleEventProc -- + * + * This event procedure is registered on the main window of the + * slave interpreter. If the user or a running script causes the + * main window to be destroyed, then we need to inform the console + * interpreter by invoking "tkConsoleExit". + * + * Results: + * None. + * + * Side effects: + * Invokes the "tkConsoleExit" procedure in the console interp. + * + *---------------------------------------------------------------------- + */ + +static void +ConsoleEventProc(clientData, eventPtr) + ClientData clientData; + XEvent *eventPtr; +{ + ConsoleInfo *info = (ConsoleInfo *) clientData; + Tcl_Interp *consoleInterp; + + if (eventPtr->type == DestroyNotify) { + consoleInterp = info->consoleInterp; + Tcl_Preserve((ClientData) consoleInterp); + Tcl_Eval(consoleInterp, "tkConsoleExit"); + Tcl_Release((ClientData) consoleInterp); + } +} + +/* + *---------------------------------------------------------------------- + * + * TkConsolePrint -- + * + * Prints to the give text to the console. Given the main interp + * this functions find the appropiate console interp and forwards + * the text to be added to that console. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TkConsolePrint(interp, devId, buffer, size) + Tcl_Interp *interp; /* Main interpreter. */ + int devId; /* TCL_STDOUT for stdout, TCL_STDERR for + * stderr. */ + char *buffer; /* Text buffer. */ + long size; /* Size of text buffer. */ +{ + Tcl_DString command, output; + Tcl_CmdInfo cmdInfo; + char *cmd; + ConsoleInfo *info; + Tcl_Interp *consoleInterp; + int result; + + if (interp == NULL) { + return; + } + + if (devId == TCL_STDERR) { + cmd = "tkConsoleOutput stderr "; + } else { + cmd = "tkConsoleOutput stdout "; + } + + result = Tcl_GetCommandInfo(interp, "console", &cmdInfo); + if (result == 0) { + return; + } + info = (ConsoleInfo *) cmdInfo.clientData; + + Tcl_DStringInit(&output); + Tcl_DStringAppend(&output, buffer, size); + + Tcl_DStringInit(&command); + Tcl_DStringAppend(&command, cmd, strlen(cmd)); + Tcl_DStringAppendElement(&command, output.string); + + consoleInterp = info->consoleInterp; + Tcl_Preserve((ClientData) consoleInterp); + Tcl_Eval(consoleInterp, command.string); + Tcl_Release((ClientData) consoleInterp); + + Tcl_DStringFree(&command); + Tcl_DStringFree(&output); +} diff --git a/tk4.2/generic/tkCursor.c b/tk4.2/generic/tkCursor.c new file mode 100644 index 0000000..e185109 --- /dev/null +++ b/tk4.2/generic/tkCursor.c @@ -0,0 +1,384 @@ +/* + * tkCursor.c -- + * + * This file maintains a database of read-only cursors for the Tk + * toolkit. This allows cursors to be shared between widgets and + * also avoids round-trips to the X server. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkCursor.c 1.27 96/02/15 18:52:40 + */ + +#include "tkPort.h" +#include "tkInt.h" + +/* + * A TkCursor structure exists for each cursor that is currently + * active. Each structure is indexed with two hash tables defined + * below. One of the tables is idTable, and the other is either + * nameTable or dataTable, also defined below. + */ + +/* + * Hash table to map from a textual description of a cursor to the + * TkCursor record for the cursor, and key structure used in that + * hash table: + */ + +static Tcl_HashTable nameTable; +typedef struct { + Tk_Uid name; /* Textual name for desired cursor. */ + Display *display; /* Display for which cursor will be used. */ +} NameKey; + +/* + * Hash table to map from a collection of in-core data about a + * cursor (bitmap contents, etc.) to a TkCursor structure: + */ + +static Tcl_HashTable dataTable; +typedef struct { + char *source; /* Cursor bits. */ + char *mask; /* Mask bits. */ + int width, height; /* Dimensions of cursor (and data + * and mask). */ + int xHot, yHot; /* Location of cursor hot-spot. */ + Tk_Uid fg, bg; /* Colors for cursor. */ + Display *display; /* Display on which cursor will be used. */ +} DataKey; + +/* + * Hash table that maps from to the TkCursor structure + * for the cursor. This table is used by Tk_FreeCursor. + */ + +static Tcl_HashTable idTable; +typedef struct { + Display *display; /* Display for which cursor was allocated. */ + Tk_Cursor cursor; /* Cursor identifier. */ +} IdKey; + +static int initialized = 0; /* 0 means static structures haven't been + * initialized yet. */ + +/* + * Forward declarations for procedures defined in this file: + */ + +static void CursorInit _ANSI_ARGS_((void)); + +/* + *---------------------------------------------------------------------- + * + * Tk_GetCursor -- + * + * Given a string describing a cursor, locate (or create if necessary) + * a cursor that fits the description. + * + * Results: + * The return value is the X identifer for the desired cursor, + * unless string couldn't be parsed correctly. In this case, + * None is returned and an error message is left in interp->result. + * The caller should never modify the cursor that is returned, and + * should eventually call Tk_FreeCursor when the cursor is no longer + * needed. + * + * Side effects: + * The cursor is added to an internal database with a reference count. + * For each call to this procedure, there should eventually be a call + * to Tk_FreeCursor, so that the database can be cleaned up when cursors + * aren't needed anymore. + * + *---------------------------------------------------------------------- + */ + +Tk_Cursor +Tk_GetCursor(interp, tkwin, string) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + Tk_Window tkwin; /* Window in which cursor will be used. */ + Tk_Uid string; /* Description of cursor. See manual entry + * for details on legal syntax. */ +{ + NameKey nameKey; + IdKey idKey; + Tcl_HashEntry *nameHashPtr, *idHashPtr; + register TkCursor *cursorPtr; + int new; + + if (!initialized) { + CursorInit(); + } + + nameKey.name = string; + nameKey.display = Tk_Display(tkwin); + nameHashPtr = Tcl_CreateHashEntry(&nameTable, (char *) &nameKey, &new); + if (!new) { + cursorPtr = (TkCursor *) Tcl_GetHashValue(nameHashPtr); + cursorPtr->refCount++; + return cursorPtr->cursor; + } + + cursorPtr = TkGetCursorByName(interp, tkwin, string); + + if (cursorPtr == NULL) { + Tcl_DeleteHashEntry(nameHashPtr); + return None; + } + + /* + * Add information about this cursor to our database. + */ + + cursorPtr->refCount = 1; + cursorPtr->otherTable = &nameTable; + cursorPtr->hashPtr = nameHashPtr; + idKey.display = nameKey.display; + idKey.cursor = cursorPtr->cursor; + idHashPtr = Tcl_CreateHashEntry(&idTable, (char *) &idKey, &new); + if (!new) { + panic("cursor already registered in Tk_GetCursor"); + } + Tcl_SetHashValue(nameHashPtr, cursorPtr); + Tcl_SetHashValue(idHashPtr, cursorPtr); + + return cursorPtr->cursor; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_GetCursorFromData -- + * + * Given a description of the bits and colors for a cursor, + * make a cursor that has the given properties. + * + * Results: + * The return value is the X identifer for the desired cursor, + * unless it couldn't be created properly. In this case, None is + * returned and an error message is left in interp->result. The + * caller should never modify the cursor that is returned, and + * should eventually call Tk_FreeCursor when the cursor is no + * longer needed. + * + * Side effects: + * The cursor is added to an internal database with a reference count. + * For each call to this procedure, there should eventually be a call + * to Tk_FreeCursor, so that the database can be cleaned up when cursors + * aren't needed anymore. + * + *---------------------------------------------------------------------- + */ + +Tk_Cursor +Tk_GetCursorFromData(interp, tkwin, source, mask, width, height, + xHot, yHot, fg, bg) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + Tk_Window tkwin; /* Window in which cursor will be used. */ + char *source; /* Bitmap data for cursor shape. */ + char *mask; /* Bitmap data for cursor mask. */ + int width, height; /* Dimensions of cursor. */ + int xHot, yHot; /* Location of hot-spot in cursor. */ + Tk_Uid fg; /* Foreground color for cursor. */ + Tk_Uid bg; /* Background color for cursor. */ +{ + DataKey dataKey; + IdKey idKey; + Tcl_HashEntry *dataHashPtr, *idHashPtr; + register TkCursor *cursorPtr; + int new; + XColor fgColor, bgColor; + + if (!initialized) { + CursorInit(); + } + + dataKey.source = source; + dataKey.mask = mask; + dataKey.width = width; + dataKey.height = height; + dataKey.xHot = xHot; + dataKey.yHot = yHot; + dataKey.fg = fg; + dataKey.bg = bg; + dataKey.display = Tk_Display(tkwin); + dataHashPtr = Tcl_CreateHashEntry(&dataTable, (char *) &dataKey, &new); + if (!new) { + cursorPtr = (TkCursor *) Tcl_GetHashValue(dataHashPtr); + cursorPtr->refCount++; + return cursorPtr->cursor; + } + + /* + * No suitable cursor exists yet. Make one using the data + * available and add it to the database. + */ + + if (XParseColor(dataKey.display, Tk_Colormap(tkwin), fg, &fgColor) == 0) { + Tcl_AppendResult(interp, "invalid color name \"", fg, "\"", + (char *) NULL); + goto error; + } + if (XParseColor(dataKey.display, Tk_Colormap(tkwin), bg, &bgColor) == 0) { + Tcl_AppendResult(interp, "invalid color name \"", bg, "\"", + (char *) NULL); + goto error; + } + + cursorPtr = TkCreateCursorFromData(tkwin, source, mask, width, height, + xHot, yHot, fgColor, bgColor); + + if (cursorPtr == NULL) { + goto error; + } + + cursorPtr->refCount = 1; + cursorPtr->otherTable = &dataTable; + cursorPtr->hashPtr = dataHashPtr; + idKey.display = dataKey.display; + idKey.cursor = cursorPtr->cursor; + idHashPtr = Tcl_CreateHashEntry(&idTable, (char *) &idKey, &new); + if (!new) { + panic("cursor already registered in Tk_GetCursorFromData"); + } + Tcl_SetHashValue(dataHashPtr, cursorPtr); + Tcl_SetHashValue(idHashPtr, cursorPtr); + return cursorPtr->cursor; + + error: + Tcl_DeleteHashEntry(dataHashPtr); + return None; +} + +/* + *-------------------------------------------------------------- + * + * Tk_NameOfCursor -- + * + * Given a cursor, return a textual string identifying it. + * + * Results: + * If cursor was created by Tk_GetCursor, then the return + * value is the "string" that was used to create it. + * Otherwise the return value is a string giving the X + * identifier for the cursor. The storage for the returned + * string is only guaranteed to persist up until the next + * call to this procedure. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +char * +Tk_NameOfCursor(display, cursor) + Display *display; /* Display for which cursor was allocated. */ + Tk_Cursor cursor; /* Identifier for cursor whose name is + * wanted. */ +{ + IdKey idKey; + Tcl_HashEntry *idHashPtr; + TkCursor *cursorPtr; + static char string[20]; + + if (!initialized) { + printid: + sprintf(string, "cursor id 0x%x", (unsigned int) cursor); + return string; + } + idKey.display = display; + idKey.cursor = cursor; + idHashPtr = Tcl_FindHashEntry(&idTable, (char *) &idKey); + if (idHashPtr == NULL) { + goto printid; + } + cursorPtr = (TkCursor *) Tcl_GetHashValue(idHashPtr); + if (cursorPtr->otherTable != &nameTable) { + goto printid; + } + return ((NameKey *) cursorPtr->hashPtr->key.words)->name; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_FreeCursor -- + * + * This procedure is called to release a cursor allocated by + * Tk_GetCursor or TkGetCursorFromData. + * + * Results: + * None. + * + * Side effects: + * The reference count associated with cursor is decremented, and + * it is officially deallocated if no-one is using it anymore. + * + *---------------------------------------------------------------------- + */ + +void +Tk_FreeCursor(display, cursor) + Display *display; /* Display for which cursor was allocated. */ + Tk_Cursor cursor; /* Identifier for cursor to be released. */ +{ + IdKey idKey; + Tcl_HashEntry *idHashPtr; + register TkCursor *cursorPtr; + + if (!initialized) { + panic("Tk_FreeCursor called before Tk_GetCursor"); + } + + idKey.display = display; + idKey.cursor = cursor; + idHashPtr = Tcl_FindHashEntry(&idTable, (char *) &idKey); + if (idHashPtr == NULL) { + panic("Tk_FreeCursor received unknown cursor argument"); + } + cursorPtr = (TkCursor *) Tcl_GetHashValue(idHashPtr); + cursorPtr->refCount--; + if (cursorPtr->refCount == 0) { + Tcl_DeleteHashEntry(cursorPtr->hashPtr); + Tcl_DeleteHashEntry(idHashPtr); + TkFreeCursor(cursorPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * CursorInit -- + * + * Initialize the structures used for cursor management. + * + * Results: + * None. + * + * Side effects: + * Read the code. + * + *---------------------------------------------------------------------- + */ + +static void +CursorInit() +{ + initialized = 1; + Tcl_InitHashTable(&nameTable, sizeof(NameKey)/sizeof(int)); + Tcl_InitHashTable(&dataTable, sizeof(DataKey)/sizeof(int)); + + /* + * The call below is tricky: can't use sizeof(IdKey) because it + * gets padded with extra unpredictable bytes on some 64-bit + * machines. + */ + + Tcl_InitHashTable(&idTable, (sizeof(Display *) + sizeof(Tk_Cursor)) + /sizeof(int)); +} diff --git a/tk3.6/tkEntry.c b/tk4.2/generic/tkEntry.c similarity index 64% rename from tk3.6/tkEntry.c rename to tk4.2/generic/tkEntry.c index c76c3f9..b669196 100644 --- a/tk3.6/tkEntry.c +++ b/tk4.2/generic/tkEntry.c @@ -5,33 +5,17 @@ * toolkit. An entry displays a string and allows * the string to be edited. * - * Copyright (c) 1990-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tkEntry.c 1.102 96/08/06 17:27:33 */ -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkEntry.c,v 1.55 93/10/18 17:14:57 ouster Exp $ SPRITE (Berkeley)"; -#endif - #include "default.h" -#include "tkConfig.h" +#include "tkPort.h" #include "tkInt.h" /* @@ -48,6 +32,7 @@ typedef struct { * other things, so that resources can be * freed even after tkwin has gone away. */ Tcl_Interp *interp; /* Interpreter associated with entry. */ + Tcl_Command widgetCmd; /* Token for entry's widget command. */ int numChars; /* Number of non-NULL characters in * string (may be 0). */ char *string; /* Pointer to storage for string; @@ -82,18 +67,38 @@ typedef struct { * in "on" state for each blink. */ int insertOffTime; /* Number of milliseconds cursor should spend * in "off" state for each blink. */ - Tk_TimerToken insertBlinkHandler; + Tcl_TimerToken insertBlinkHandler; /* Timer handler used to blink cursor on and * off. */ + int highlightWidth; /* Width in pixels of highlight to draw + * around widget when it has the focus. + * <= 0 means don't draw a highlight. */ + XColor *highlightBgColorPtr; + /* Color for drawing traversal highlight + * area when highlight is off. */ + XColor *highlightColorPtr; /* Color for drawing traversal highlight. */ + GC highlightGC; /* For drawing traversal highlight. */ + Tk_Justify justify; /* Justification to use for text within + * window. */ int avgWidth; /* Width of average character. */ int prefWidth; /* Desired width of window, measured in * average characters. */ - int offset; /* XPAD if window is flat, or borderWidth+XPAD - * if raised or sunken. */ + int inset; /* Number of pixels on the left and right + * sides that are taken up by XPAD, borderWidth + * (if any), and highlightWidth (if any). */ int leftIndex; /* Index of left-most character visible in * window. */ + int leftX; /* X position at which leftIndex is drawn + * (varies depending on justify). */ + int tabOrigin; /* Origin for tabs (left edge of string[0]). */ int insertPos; /* Index of character before which next * typed character will be inserted. */ + char *showChar; /* Value of -show option. If non-NULL, first + * character is used for displaying all + * characters in entry. Malloc'ed. */ + char *displayString; /* If non-NULL, points to string with same + * length as string but whose characters + * are all equal to showChar. Malloc'ed. */ /* * Information about what's selected, if any. @@ -122,7 +127,10 @@ typedef struct { * Miscellaneous information: */ - Cursor cursor; /* Current cursor for window, or None. */ + Tk_Cursor cursor; /* Current cursor for window, or None. */ + char *takeFocus; /* Value of -takefocus option; not used in + * the C code, but used by keyboard traversal + * scripts. Malloc'ed, but may be NULL. */ char *scrollCmd; /* Command prefix for communicating with * scrollbar(s). Malloc'ed. NULL means * no command to issue. */ @@ -189,6 +197,14 @@ static Tk_ConfigSpec configSpecs[] = { DEF_ENTRY_FONT, Tk_Offset(Entry, fontPtr), 0}, {TK_CONFIG_COLOR, "-foreground", "foreground", "Foreground", DEF_ENTRY_FG, Tk_Offset(Entry, fgColorPtr), 0}, + {TK_CONFIG_COLOR, "-highlightbackground", "highlightBackground", + "HighlightBackground", DEF_ENTRY_HIGHLIGHT_BG, + Tk_Offset(Entry, highlightBgColorPtr), 0}, + {TK_CONFIG_COLOR, "-highlightcolor", "highlightColor", "HighlightColor", + DEF_ENTRY_HIGHLIGHT, Tk_Offset(Entry, highlightColorPtr), 0}, + {TK_CONFIG_PIXELS, "-highlightthickness", "highlightThickness", + "HighlightThickness", + DEF_ENTRY_HIGHLIGHT_WIDTH, Tk_Offset(Entry, highlightWidth), 0}, {TK_CONFIG_BORDER, "-insertbackground", "insertBackground", "Foreground", DEF_ENTRY_INSERT_BG, Tk_Offset(Entry, insertBorder), 0}, {TK_CONFIG_PIXELS, "-insertborderwidth", "insertBorderWidth", "BorderWidth", @@ -203,11 +219,10 @@ static Tk_ConfigSpec configSpecs[] = { DEF_ENTRY_INSERT_ON_TIME, Tk_Offset(Entry, insertOnTime), 0}, {TK_CONFIG_PIXELS, "-insertwidth", "insertWidth", "InsertWidth", DEF_ENTRY_INSERT_WIDTH, Tk_Offset(Entry, insertWidth), 0}, + {TK_CONFIG_JUSTIFY, "-justify", "justify", "Justify", + DEF_ENTRY_JUSTIFY, Tk_Offset(Entry, justify), 0}, {TK_CONFIG_RELIEF, "-relief", "relief", "Relief", DEF_ENTRY_RELIEF, Tk_Offset(Entry, relief), 0}, - {TK_CONFIG_STRING, "-scrollcommand", "scrollCommand", "ScrollCommand", - DEF_ENTRY_SCROLL_COMMAND, Tk_Offset(Entry, scrollCmd), - TK_CONFIG_NULL_OK}, {TK_CONFIG_BORDER, "-selectbackground", "selectBackground", "Foreground", DEF_ENTRY_SELECT_COLOR, Tk_Offset(Entry, selBorder), TK_CONFIG_COLOR_ONLY}, @@ -226,13 +241,20 @@ static Tk_ConfigSpec configSpecs[] = { {TK_CONFIG_COLOR, "-selectforeground", "selectForeground", "Background", DEF_ENTRY_SELECT_FG_MONO, Tk_Offset(Entry, selFgColorPtr), TK_CONFIG_MONO_ONLY}, + {TK_CONFIG_STRING, "-show", "show", "Show", + DEF_ENTRY_SHOW, Tk_Offset(Entry, showChar), TK_CONFIG_NULL_OK}, {TK_CONFIG_UID, "-state", "state", "State", DEF_ENTRY_STATE, Tk_Offset(Entry, state), 0}, + {TK_CONFIG_STRING, "-takefocus", "takeFocus", "TakeFocus", + DEF_ENTRY_TAKE_FOCUS, Tk_Offset(Entry, takeFocus), TK_CONFIG_NULL_OK}, {TK_CONFIG_STRING, "-textvariable", "textVariable", "Variable", DEF_ENTRY_TEXT_VARIABLE, Tk_Offset(Entry, textVarName), TK_CONFIG_NULL_OK}, {TK_CONFIG_INT, "-width", "width", "Width", DEF_ENTRY_WIDTH, Tk_Offset(Entry, prefWidth), 0}, + {TK_CONFIG_STRING, "-xscrollcommand", "xScrollCommand", "ScrollCommand", + DEF_ENTRY_SCROLL_COMMAND, Tk_Offset(Entry, scrollCmd), + TK_CONFIG_NULL_OK}, {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, (char *) NULL, 0, 0} }; @@ -253,13 +275,12 @@ static int ConfigureEntry _ANSI_ARGS_((Tcl_Interp *interp, int flags)); static void DeleteChars _ANSI_ARGS_((Entry *entryPtr, int index, int count)); -static void DestroyEntry _ANSI_ARGS_((ClientData clientData)); +static void DestroyEntry _ANSI_ARGS_((char *memPtr)); static void DisplayEntry _ANSI_ARGS_((ClientData clientData)); -static int GetEntryIndex _ANSI_ARGS_((Tcl_Interp *interp, - Entry *entryPtr, char *string, int *indexPtr)); -static void InsertChars _ANSI_ARGS_((Entry *entryPtr, int index, - char *string)); static void EntryBlinkProc _ANSI_ARGS_((ClientData clientData)); +static void EntryCmdDeletedProc _ANSI_ARGS_(( + ClientData clientData)); +static void EntryComputeGeometry _ANSI_ARGS_((Entry *entryPtr)); static void EntryEventProc _ANSI_ARGS_((ClientData clientData, XEvent *eventPtr)); static void EntryFocusProc _ANSI_ARGS_ ((Entry *entryPtr, @@ -278,8 +299,15 @@ static char * EntryTextVarProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, char *name1, char *name2, int flags)); static void EntryUpdateScrollbar _ANSI_ARGS_((Entry *entryPtr)); +static void EntryValueChanged _ANSI_ARGS_((Entry *entryPtr)); +static void EntryVisibleRange _ANSI_ARGS_((Entry *entryPtr, + double *firstPtr, double *lastPtr)); static int EntryWidgetCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); +static int GetEntryIndex _ANSI_ARGS_((Tcl_Interp *interp, + Entry *entryPtr, char *string, int *indexPtr)); +static void InsertChars _ANSI_ARGS_((Entry *entryPtr, int index, + char *string)); /* *-------------------------------------------------------------- @@ -312,7 +340,7 @@ Tk_EntryCmd(clientData, interp, argc, argv) Tk_Window new; if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " pathName ?options?\"", (char *) NULL); return TCL_ERROR; } @@ -332,6 +360,9 @@ Tk_EntryCmd(clientData, interp, argc, argv) entryPtr->tkwin = new; entryPtr->display = Tk_Display(new); entryPtr->interp = interp; + entryPtr->widgetCmd = Tcl_CreateCommand(interp, + Tk_PathName(entryPtr->tkwin), EntryWidgetCmd, + (ClientData) entryPtr, EntryCmdDeletedProc); entryPtr->numChars = 0; entryPtr->string = (char *) ckalloc(1); entryPtr->string[0] = '\0'; @@ -352,12 +383,20 @@ Tk_EntryCmd(clientData, interp, argc, argv) entryPtr->insertBorderWidth = 0; entryPtr->insertOnTime = 0; entryPtr->insertOffTime = 0; - entryPtr->insertBlinkHandler = (Tk_TimerToken) NULL; + entryPtr->insertBlinkHandler = (Tcl_TimerToken) NULL; + entryPtr->highlightWidth = 0; + entryPtr->highlightBgColorPtr = NULL; + entryPtr->highlightColorPtr = NULL; + entryPtr->justify = TK_JUSTIFY_LEFT; entryPtr->avgWidth = 1; entryPtr->prefWidth = 0; - entryPtr->offset = XPAD; + entryPtr->inset = XPAD; entryPtr->leftIndex = 0; + entryPtr->leftX = 0; + entryPtr->tabOrigin = 0; entryPtr->insertPos = 0; + entryPtr->showChar = NULL; + entryPtr->displayString = NULL; entryPtr->selectFirst = -1; entryPtr->selectLast = -1; entryPtr->selectAnchor = 0; @@ -365,6 +404,7 @@ Tk_EntryCmd(clientData, interp, argc, argv) entryPtr->scanMarkX = 0; entryPtr->scanMarkIndex = 0; entryPtr->cursor = None; + entryPtr->takeFocus = NULL; entryPtr->scrollCmd = NULL; entryPtr->flags = 0; @@ -372,10 +412,8 @@ Tk_EntryCmd(clientData, interp, argc, argv) Tk_CreateEventHandler(entryPtr->tkwin, ExposureMask|StructureNotifyMask|FocusChangeMask, EntryEventProc, (ClientData) entryPtr); - Tk_CreateSelHandler(entryPtr->tkwin, XA_STRING, EntryFetchSelection, - (ClientData) entryPtr, XA_STRING); - Tcl_CreateCommand(interp, Tk_PathName(entryPtr->tkwin), EntryWidgetCmd, - (ClientData) entryPtr, (void (*)()) NULL); + Tk_CreateSelHandler(entryPtr->tkwin, XA_PRIMARY, XA_STRING, + EntryFetchSelection, (ClientData) entryPtr, XA_STRING); if (ConfigureEntry(interp, entryPtr, argc-2, argv+2, 0) != TCL_OK) { goto error; } @@ -415,18 +453,61 @@ EntryWidgetCmd(clientData, interp, argc, argv) { register Entry *entryPtr = (Entry *) clientData; int result = TCL_OK; - int length; - char c; + size_t length; + int c, height; if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " option ?arg arg ...?\"", (char *) NULL); return TCL_ERROR; } - Tk_Preserve((ClientData) entryPtr); + Tcl_Preserve((ClientData) entryPtr); c = argv[1][0]; length = strlen(argv[1]); - if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0)) { + if ((c == 'b') && (strncmp(argv[1], "bbox", length) == 0)) { + int index, x1, x2; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " bbox index\"", + (char *) NULL); + goto error; + } + if (GetEntryIndex(interp, entryPtr, argv[2], &index) != TCL_OK) { + goto error; + } + if ((index == entryPtr->numChars) && (index > 0)) { + index--; + } + TkMeasureChars(entryPtr->fontPtr, + (entryPtr->displayString == NULL) ? entryPtr->string + : entryPtr->displayString, index, entryPtr->tabOrigin, + 1000000, entryPtr->tabOrigin, TK_NEWLINES_NOT_SPECIAL, + &x1); + if (index < entryPtr->numChars) { + TkMeasureChars(entryPtr->fontPtr, + (entryPtr->displayString == NULL) ? entryPtr->string + : entryPtr->displayString, index+1, entryPtr->tabOrigin, + 1000000, entryPtr->tabOrigin, TK_NEWLINES_NOT_SPECIAL, + &x2); + } else { + x2 = x1; + } + height = entryPtr->fontPtr->ascent + entryPtr->fontPtr->descent; + sprintf(interp->result, "%d %d %d %d", x1, + (Tk_Height(entryPtr->tkwin) - height)/2, x2-x1, height); + } else if ((c == 'c') && (strncmp(argv[1], "cget", length) == 0) + && (length >= 2)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " cget option\"", + (char *) NULL); + goto error; + } + result = Tk_ConfigureValue(interp, entryPtr->tkwin, configSpecs, + (char *) entryPtr, argv[2], 0); + } else if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0) + && (length >= 2)) { if (argc == 2) { result = Tk_ConfigureInfo(interp, entryPtr->tkwin, configSpecs, (char *) entryPtr, (char *) NULL, 0); @@ -450,14 +531,14 @@ EntryWidgetCmd(clientData, interp, argc, argv) goto error; } if (argc == 3) { - last = first; + last = first+1; } else { if (GetEntryIndex(interp, entryPtr, argv[3], &last) != TCL_OK) { goto error; } } if ((last >= first) && (entryPtr->state == tkNormalUid)) { - DeleteChars(entryPtr, first, last+1-first); + DeleteChars(entryPtr, first, last-first); } } else if ((c == 'g') && (strncmp(argv[1], "get", length) == 0)) { if (argc != 2) { @@ -480,7 +561,7 @@ EntryWidgetCmd(clientData, interp, argc, argv) } EventuallyRedraw(entryPtr); } else if ((c == 'i') && (strncmp(argv[1], "index", length) == 0) - && (length >= 2)) { + && (length >= 3)) { int index; if (argc != 3) { @@ -493,7 +574,7 @@ EntryWidgetCmd(clientData, interp, argc, argv) } sprintf(interp->result, "%d", index); } else if ((c == 'i') && (strncmp(argv[1], "insert", length) == 0) - && (length >= 2)) { + && (length >= 3)) { int index; if (argc != 4) { @@ -529,25 +610,24 @@ EntryWidgetCmd(clientData, interp, argc, argv) EntryScanTo(entryPtr, x); } else { Tcl_AppendResult(interp, "bad scan option \"", argv[2], - "\": must be mark or dragto", (char *) NULL); + "\": must be mark or dragto", (char *) NULL); goto error; } } else if ((c == 's') && (length >= 2) - && (strncmp(argv[1], "select", length) == 0)) { - int index; + && (strncmp(argv[1], "selection", length) == 0)) { + int index, index2; if (argc < 3) { - Tcl_AppendResult(interp, "too few args: should be \"", + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " select option ?index?\"", (char *) NULL); goto error; } length = strlen(argv[2]); c = argv[2][0]; - if ((c == 'c') && (argv[2] != NULL) - && (strncmp(argv[2], "clear", length) == 0)) { + if ((c == 'c') && (strncmp(argv[2], "clear", length) == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " select clear\"", (char *) NULL); + argv[0], " selection clear\"", (char *) NULL); goto error; } if (entryPtr->selectFirst != -1) { @@ -555,6 +635,18 @@ EntryWidgetCmd(clientData, interp, argc, argv) EventuallyRedraw(entryPtr); } goto done; + } else if ((c == 'p') && (strncmp(argv[2], "present", length) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " selection present\"", (char *) NULL); + goto error; + } + if (entryPtr->selectFirst == -1) { + interp->result = "0"; + } else { + interp->result = "1"; + } + goto done; } if (argc >= 4) { if (GetEntryIndex(interp, entryPtr, argv[3], &index) != TCL_OK) { @@ -564,68 +656,132 @@ EntryWidgetCmd(clientData, interp, argc, argv) if ((c == 'a') && (strncmp(argv[2], "adjust", length) == 0)) { if (argc != 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " select adjust index\"", + argv[0], " selection adjust index\"", (char *) NULL); goto error; } if (entryPtr->selectFirst >= 0) { - if (index < (entryPtr->selectFirst + entryPtr->selectLast)/2) { - entryPtr->selectAnchor = entryPtr->selectLast + 1; - } else { + int half1, half2; + + half1 = (entryPtr->selectFirst + entryPtr->selectLast)/2; + half2 = (entryPtr->selectFirst + entryPtr->selectLast + 1)/2; + if (index < half1) { + entryPtr->selectAnchor = entryPtr->selectLast; + } else if (index > half2) { entryPtr->selectAnchor = entryPtr->selectFirst; + } else { + /* + * We're at about the halfway point in the selection; + * just keep the existing anchor. + */ } } EntrySelectTo(entryPtr, index); } else if ((c == 'f') && (strncmp(argv[2], "from", length) == 0)) { if (argc != 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " select from index\"", + argv[0], " selection from index\"", (char *) NULL); goto error; } entryPtr->selectAnchor = index; + } else if ((c == 'r') && (strncmp(argv[2], "range", length) == 0)) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " selection range start end\"", + (char *) NULL); + goto error; + } + if (GetEntryIndex(interp, entryPtr, argv[4], &index2) != TCL_OK) { + goto error; + } + if (index >= index2) { + entryPtr->selectFirst = entryPtr->selectLast = -1; + } else { + if ((entryPtr->selectFirst == -1) + && (entryPtr->exportSelection)) { + Tk_OwnSelection(entryPtr->tkwin, XA_PRIMARY, + EntryLostSelection, (ClientData) entryPtr); + } + entryPtr->selectFirst = index; + entryPtr->selectLast = index2; + } + if ((entryPtr->selectFirst == -1) && (entryPtr->exportSelection)) { + Tk_OwnSelection(entryPtr->tkwin, XA_PRIMARY, + EntryLostSelection, (ClientData) entryPtr); + } + EventuallyRedraw(entryPtr); } else if ((c == 't') && (strncmp(argv[2], "to", length) == 0)) { if (argc != 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " select to index\"", + argv[0], " selection to index\"", (char *) NULL); goto error; } EntrySelectTo(entryPtr, index); } else { - Tcl_AppendResult(interp, "bad select option \"", argv[2], - "\": must be adjust, clear, from, or to", (char *) NULL); + Tcl_AppendResult(interp, "bad selection option \"", argv[2], + "\": must be adjust, clear, from, present, range, or to", + (char *) NULL); goto error; } - } else if ((c == 'v') && (strncmp(argv[1], "view", length) == 0)) { - int index; + } else if ((c == 'x') && (strncmp(argv[1], "xview", length) == 0)) { + int index, type, count, charsPerPage; + double fraction, first, last; - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " view index\"", (char *) NULL); - goto error; + if (argc == 2) { + EntryVisibleRange(entryPtr, &first, &last); + sprintf(interp->result, "%g %g", first, last); + goto done; + } else if (argc == 3) { + if (GetEntryIndex(interp, entryPtr, argv[2], &index) != TCL_OK) { + goto error; + } + } else { + type = Tk_GetScrollInfo(interp, argc, argv, &fraction, &count); + index = entryPtr->leftIndex; + switch (type) { + case TK_SCROLL_ERROR: + goto error; + case TK_SCROLL_MOVETO: + index = (fraction * entryPtr->numChars) + 0.5; + break; + case TK_SCROLL_PAGES: + charsPerPage = ((Tk_Width(entryPtr->tkwin) + - 2*entryPtr->inset) / entryPtr->avgWidth) - 2; + if (charsPerPage < 1) { + charsPerPage = 1; + } + index += charsPerPage*count; + break; + case TK_SCROLL_UNITS: + index += count; + break; + } } - if (GetEntryIndex(interp, entryPtr, argv[2], &index) != TCL_OK) { - goto error; + if (index >= entryPtr->numChars) { + index = entryPtr->numChars-1; } - if ((index > entryPtr->numChars) && (index > 0)) { - index = entryPtr->numChars; + if (index < 0) { + index = 0; } entryPtr->leftIndex = index; entryPtr->flags |= UPDATE_SCROLLBAR; + EntryComputeGeometry(entryPtr); EventuallyRedraw(entryPtr); } else { Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be configure, delete, get, icursor, index, ", - "insert, scan, select, or view", (char *) NULL); + "\": must be bbox, cget, configure, delete, get, ", + "icursor, index, insert, scan, selection, or xview", + (char *) NULL); goto error; } done: - Tk_Release((ClientData) entryPtr); + Tcl_Release((ClientData) entryPtr); return result; error: - Tk_Release((ClientData) entryPtr); + Tcl_Release((ClientData) entryPtr); return TCL_ERROR; } @@ -634,7 +790,7 @@ EntryWidgetCmd(clientData, interp, argc, argv) * * DestroyEntry -- * - * This procedure is invoked by Tk_EventuallyFree or Tk_Release + * This procedure is invoked by Tcl_EventuallyFree or Tcl_Release * to clean up the internal structure of an entry at a safe time * (when no-one is using it anymore). * @@ -648,10 +804,10 @@ EntryWidgetCmd(clientData, interp, argc, argv) */ static void -DestroyEntry(clientData) - ClientData clientData; /* Info about entry widget. */ +DestroyEntry(memPtr) + char *memPtr; /* Info about entry widget. */ { - register Entry *entryPtr = (Entry *) clientData; + register Entry *entryPtr = (Entry *) memPtr; /* * Free up all the stuff that requires special handling, then @@ -671,7 +827,10 @@ DestroyEntry(clientData) if (entryPtr->selTextGC != None) { Tk_FreeGC(entryPtr->display, entryPtr->selTextGC); } - Tk_DeleteTimerHandler(entryPtr->insertBlinkHandler); + Tcl_DeleteTimerHandler(entryPtr->insertBlinkHandler); + if (entryPtr->displayString != NULL) { + ckfree(entryPtr->displayString); + } Tk_FreeOptions(configSpecs, (char *) entryPtr, entryPtr->display, 0); ckfree((char *) entryPtr); } @@ -708,7 +867,7 @@ ConfigureEntry(interp, entryPtr, argc, argv, flags) { XGCValues gcValues; GC new; - int width, height, fontHeight, oldExport; + int oldExport; /* * Eliminate any existing trace on a variable monitored by the entry. @@ -737,8 +896,7 @@ ConfigureEntry(interp, entryPtr, argc, argv, flags) value = Tcl_GetVar(interp, entryPtr->textVarName, TCL_GLOBAL_ONLY); if (value == NULL) { - Tcl_SetVar(interp, entryPtr->textVarName, entryPtr->string, - TCL_GLOBAL_ONLY); + EntryValueChanged(entryPtr); } else { EntrySetValue(entryPtr, value); } @@ -755,7 +913,7 @@ ConfigureEntry(interp, entryPtr, argc, argv, flags) if ((entryPtr->state != tkNormalUid) && (entryPtr->state != tkDisabledUid)) { Tcl_AppendResult(interp, "bad state value \"", entryPtr->state, - "\": must be normal or disabled", (char *) NULL); + "\": must be normal or disabled", (char *) NULL); entryPtr->state = tkNormalUid; return TCL_ERROR; } @@ -780,11 +938,8 @@ ConfigureEntry(interp, entryPtr, argc, argv, flags) } entryPtr->selTextGC = new; - if (entryPtr->insertWidth > 2*entryPtr->fontPtr->min_bounds.width) { - entryPtr->insertWidth = 2*entryPtr->fontPtr->min_bounds.width; - if (entryPtr->insertWidth == 0) { - entryPtr->insertWidth = 2; - } + if (entryPtr->insertWidth <= 0) { + entryPtr->insertWidth = 2; } if (entryPtr->insertBorderWidth > entryPtr->insertWidth/2) { entryPtr->insertBorderWidth = entryPtr->insertWidth/2; @@ -805,27 +960,23 @@ ConfigureEntry(interp, entryPtr, argc, argv, flags) if (entryPtr->exportSelection && (!oldExport) && (entryPtr->selectFirst != -1)) { - Tk_OwnSelection(entryPtr->tkwin, EntryLostSelection, + Tk_OwnSelection(entryPtr->tkwin, XA_PRIMARY, EntryLostSelection, (ClientData) entryPtr); } /* - * Register the desired geometry for the window, and arrange for - * the window to be redisplayed. + * Recompute the window's geometry and arrange for it to be + * redisplayed. */ - fontHeight = entryPtr->fontPtr->ascent + entryPtr->fontPtr->descent; - entryPtr->avgWidth = XTextWidth(entryPtr->fontPtr, "0", 1); - width = entryPtr->prefWidth*entryPtr->avgWidth + 2*entryPtr->borderWidth - + 2*XPAD; - height = fontHeight + 2*entryPtr->borderWidth + 2*YPAD; - Tk_GeometryRequest(entryPtr->tkwin, width, height); - Tk_SetInternalBorder(entryPtr->tkwin, entryPtr->borderWidth); - if (entryPtr->relief != TK_RELIEF_FLAT) { - entryPtr->offset = entryPtr->borderWidth + XPAD; - } else { - entryPtr->offset = XPAD; + Tk_SetInternalBorder(entryPtr->tkwin, + entryPtr->borderWidth + entryPtr->highlightWidth); + if (entryPtr->highlightWidth <= 0) { + entryPtr->highlightWidth = 0; } + entryPtr->inset = entryPtr->highlightWidth + entryPtr->borderWidth + XPAD; + entryPtr->avgWidth = XTextWidth(entryPtr->fontPtr, "0", 1); + EntryComputeGeometry(entryPtr); entryPtr->flags |= UPDATE_SCROLLBAR; EventuallyRedraw(entryPtr); return TCL_OK; @@ -853,9 +1004,10 @@ DisplayEntry(clientData) { register Entry *entryPtr = (Entry *) clientData; register Tk_Window tkwin = entryPtr->tkwin; - int startX, baseY, selStartX, selEndX, index, cursorX; + int baseY, selStartX, selEndX, index, cursorX; int xBound, count; Pixmap pixmap; + char *displayString; entryPtr->flags &= ~REDRAW_PENDING; if ((entryPtr->tkwin == NULL) || !Tk_IsMapped(tkwin)) { @@ -867,6 +1019,7 @@ DisplayEntry(clientData) */ if (entryPtr->flags & UPDATE_SCROLLBAR) { + entryPtr->flags &= ~UPDATE_SCROLLBAR; EntryUpdateScrollbar(entryPtr); } @@ -877,17 +1030,15 @@ DisplayEntry(clientData) * no point in time where the on-screen image has been cleared. */ - pixmap = XCreatePixmap(entryPtr->display, Tk_WindowId(tkwin), + pixmap = Tk_GetPixmap(entryPtr->display, Tk_WindowId(tkwin), Tk_Width(tkwin), Tk_Height(tkwin), Tk_Depth(tkwin)); /* - * Compute x-coordinate of the "leftIndex" character, plus limit - * of visible x-coordinates (actually, pixel just after last visible - * one), plus vertical position of baseline of text. + * Compute x-coordinate of the pixel just after last visible + * one, plus vertical position of baseline of text. */ - startX = entryPtr->offset; - xBound = Tk_Width(tkwin) - entryPtr->offset; + xBound = Tk_Width(tkwin) - entryPtr->inset; baseY = (Tk_Height(tkwin) + entryPtr->fontPtr->ascent - entryPtr->fontPtr->descent)/2; @@ -897,26 +1048,31 @@ DisplayEntry(clientData) * insertion cursor background. */ - Tk_Fill3DRectangle(entryPtr->display, pixmap, entryPtr->normalBorder, + Tk_Fill3DRectangle(tkwin, pixmap, entryPtr->normalBorder, 0, 0, Tk_Width(tkwin), Tk_Height(tkwin), 0, TK_RELIEF_FLAT); - - if (entryPtr->selectLast >= entryPtr->leftIndex) { + if (entryPtr->displayString == NULL) { + displayString = entryPtr->string; + } else { + displayString = entryPtr->displayString; + } + if (entryPtr->selectLast > entryPtr->leftIndex) { if (entryPtr->selectFirst <= entryPtr->leftIndex) { - selStartX = startX; + selStartX = entryPtr->leftX; index = entryPtr->leftIndex; } else { (void) TkMeasureChars(entryPtr->fontPtr, - entryPtr->string+entryPtr->leftIndex, - entryPtr->selectFirst - entryPtr->leftIndex, startX, - xBound, TK_PARTIAL_OK|TK_NEWLINES_NOT_SPECIAL, &selStartX); + displayString + entryPtr->leftIndex, + entryPtr->selectFirst - entryPtr->leftIndex, + entryPtr->leftX, xBound, entryPtr->tabOrigin, + TK_PARTIAL_OK|TK_NEWLINES_NOT_SPECIAL, &selStartX); index = entryPtr->selectFirst; } if ((selStartX - entryPtr->selBorderWidth) < xBound) { (void) TkMeasureChars(entryPtr->fontPtr, - entryPtr->string + index, entryPtr->selectLast +1 - index, - selStartX, xBound, TK_PARTIAL_OK|TK_NEWLINES_NOT_SPECIAL, - &selEndX); - Tk_Fill3DRectangle(entryPtr->display, pixmap, entryPtr->selBorder, + displayString + index, entryPtr->selectLast - index, + selStartX, xBound, entryPtr->tabOrigin, + TK_PARTIAL_OK|TK_NEWLINES_NOT_SPECIAL, &selEndX); + Tk_Fill3DRectangle(tkwin, pixmap, entryPtr->selBorder, selStartX - entryPtr->selBorderWidth, baseY - entryPtr->fontPtr->ascent - entryPtr->selBorderWidth, @@ -932,32 +1088,31 @@ DisplayEntry(clientData) /* * Draw a special background for the insertion cursor, overriding * even the selection background. As a special hack to keep the - * cursor visible on mono displays, write background in the cursor - * area (instead of nothing) when the cursor isn't on. Otherwise - * the selection would hide the cursor. + * cursor visible when the insertion cursor color is the same as + * the color for selected text (e.g., on mono displays), write + * background in the cursor area (instead of nothing) when the + * cursor isn't on. Otherwise the selection would hide the cursor. */ if ((entryPtr->insertPos >= entryPtr->leftIndex) && (entryPtr->state == tkNormalUid) && (entryPtr->flags & GOT_FOCUS)) { (void) TkMeasureChars(entryPtr->fontPtr, - entryPtr->string + entryPtr->leftIndex, - entryPtr->insertPos - entryPtr->leftIndex, startX, - xBound + entryPtr->insertWidth, + displayString + entryPtr->leftIndex, + entryPtr->insertPos - entryPtr->leftIndex, entryPtr->leftX, + xBound + entryPtr->insertWidth, entryPtr->tabOrigin, TK_PARTIAL_OK|TK_NEWLINES_NOT_SPECIAL, &cursorX); cursorX -= (entryPtr->insertWidth)/2; if (cursorX < xBound) { if (entryPtr->flags & CURSOR_ON) { - Tk_Fill3DRectangle(entryPtr->display, pixmap, - entryPtr->insertBorder, cursorX, - baseY - entryPtr->fontPtr->ascent, + Tk_Fill3DRectangle(tkwin, pixmap, entryPtr->insertBorder, + cursorX, baseY - entryPtr->fontPtr->ascent, entryPtr->insertWidth, entryPtr->fontPtr->ascent + entryPtr->fontPtr->descent, entryPtr->insertBorderWidth, TK_RELIEF_RAISED); - } else if (Tk_GetColorModel(tkwin) != TK_COLOR) { - Tk_Fill3DRectangle(entryPtr->display, pixmap, - entryPtr->normalBorder, cursorX, - baseY - entryPtr->fontPtr->ascent, + } else if (entryPtr->insertBorder == entryPtr->selBorder) { + Tk_Fill3DRectangle(tkwin, pixmap, entryPtr->normalBorder, + cursorX, baseY - entryPtr->fontPtr->ascent, entryPtr->insertWidth, entryPtr->fontPtr->ascent + entryPtr->fontPtr->descent, 0, TK_RELIEF_FLAT); @@ -971,46 +1126,60 @@ DisplayEntry(clientData) * of the selection. */ - if (entryPtr->selectLast < entryPtr->leftIndex) { + if (entryPtr->selectLast <= entryPtr->leftIndex) { TkDisplayChars(entryPtr->display, pixmap, entryPtr->textGC, - entryPtr->fontPtr, entryPtr->string + entryPtr->leftIndex, - entryPtr->numChars - entryPtr->leftIndex, startX, baseY, - TK_NEWLINES_NOT_SPECIAL); + entryPtr->fontPtr, displayString + entryPtr->leftIndex, + entryPtr->numChars - entryPtr->leftIndex, entryPtr->leftX, + baseY, entryPtr->tabOrigin, TK_NEWLINES_NOT_SPECIAL); } else { count = entryPtr->selectFirst - entryPtr->leftIndex; if (count > 0) { TkDisplayChars(entryPtr->display, pixmap, entryPtr->textGC, - entryPtr->fontPtr, entryPtr->string + entryPtr->leftIndex, - count, startX, baseY, TK_NEWLINES_NOT_SPECIAL); + entryPtr->fontPtr, displayString + entryPtr->leftIndex, + count, entryPtr->leftX, baseY, entryPtr->tabOrigin, + TK_NEWLINES_NOT_SPECIAL); index = entryPtr->selectFirst; } else { index = entryPtr->leftIndex; } - count = entryPtr->selectLast + 1 - index; + count = entryPtr->selectLast - index; if ((selStartX < xBound) && (count > 0)) { TkDisplayChars(entryPtr->display, pixmap, entryPtr->selTextGC, - entryPtr->fontPtr, entryPtr->string + index, count, - selStartX, baseY, TK_NEWLINES_NOT_SPECIAL); + entryPtr->fontPtr, displayString + index, count, + selStartX, baseY, entryPtr->tabOrigin, + TK_NEWLINES_NOT_SPECIAL); } - count = entryPtr->numChars - entryPtr->selectLast - 1; + count = entryPtr->numChars - entryPtr->selectLast; if ((selEndX < xBound) && (count > 0)) { TkDisplayChars(entryPtr->display, pixmap, entryPtr->textGC, entryPtr->fontPtr, - entryPtr->string + entryPtr->selectLast + 1, - count, selEndX, baseY, TK_NEWLINES_NOT_SPECIAL); + displayString + entryPtr->selectLast, + count, selEndX, baseY, entryPtr->tabOrigin, + TK_NEWLINES_NOT_SPECIAL); } } /* - * Draw the border last, so it will overwrite any text that extends - * past the viewable part of the window. + * Draw the border and focus highlight last, so they will overwrite + * any text that extends past the viewable part of the window. */ if (entryPtr->relief != TK_RELIEF_FLAT) { - Tk_Draw3DRectangle(entryPtr->display, pixmap, - entryPtr->normalBorder, 0, 0, Tk_Width(tkwin), - Tk_Height(tkwin), entryPtr->borderWidth, - entryPtr->relief); + Tk_Draw3DRectangle(tkwin, pixmap, entryPtr->normalBorder, + entryPtr->highlightWidth, entryPtr->highlightWidth, + Tk_Width(tkwin) - 2*entryPtr->highlightWidth, + Tk_Height(tkwin) - 2*entryPtr->highlightWidth, + entryPtr->borderWidth, entryPtr->relief); + } + if (entryPtr->highlightWidth != 0) { + GC gc; + + if (entryPtr->flags & GOT_FOCUS) { + gc = Tk_GCForColor(entryPtr->highlightColorPtr, pixmap); + } else { + gc = Tk_GCForColor(entryPtr->highlightBgColorPtr, pixmap); + } + Tk_DrawFocusHighlight(tkwin, gc, entryPtr->highlightWidth, pixmap); } /* @@ -1019,11 +1188,121 @@ DisplayEntry(clientData) */ XCopyArea(entryPtr->display, pixmap, Tk_WindowId(tkwin), entryPtr->textGC, - 0, 0, Tk_Width(tkwin), Tk_Height(tkwin), 0, 0); - XFreePixmap(entryPtr->display, pixmap); + 0, 0, (unsigned) Tk_Width(tkwin), (unsigned) Tk_Height(tkwin), + 0, 0); + Tk_FreePixmap(entryPtr->display, pixmap); entryPtr->flags &= ~BORDER_NEEDED; } +/* + *---------------------------------------------------------------------- + * + * EntryComputeGeometry -- + * + * This procedure is invoked to recompute information about where + * in its window an entry's string will be displayed. It also + * computes the requested size for the window. + * + * Results: + * None. + * + * Side effects: + * The leftX and tabOrigin fields are recomputed for entryPtr, + * and leftIndex may be adjusted. Tk_GeometryRequest is called + * to register the desired dimensions for the window. + * + *---------------------------------------------------------------------- + */ + +static void +EntryComputeGeometry(entryPtr) + Entry *entryPtr; /* Widget record for entry. */ +{ + int totalLength, overflow, maxOffScreen, rightX; + int fontHeight, height, width, i; + char *p, *displayString; + + /* + * If we're displaying a special character instead of the value of + * the entry, recompute the displayString. + */ + + if (entryPtr->displayString != NULL) { + ckfree(entryPtr->displayString); + entryPtr->displayString = NULL; + } + if (entryPtr->showChar != NULL) { + entryPtr->displayString = (char *) ckalloc((unsigned) + (entryPtr->numChars + 1)); + for (p = entryPtr->displayString, i = entryPtr->numChars; i > 0; + i--, p++) { + *p = entryPtr->showChar[0]; + } + *p = 0; + displayString = entryPtr->displayString; + } else { + displayString = entryPtr->string; + } + + /* + * Recompute where the leftmost character on the display will + * be drawn (entryPtr->leftX) and adjust leftIndex if necessary + * so that we don't let characters hang off the edge of the + * window unless the entire window is full. + */ + + TkMeasureChars(entryPtr->fontPtr, displayString, entryPtr->numChars, + 0, INT_MAX, 0, TK_NEWLINES_NOT_SPECIAL, &totalLength); + overflow = totalLength - (Tk_Width(entryPtr->tkwin) - 2*entryPtr->inset); + if (overflow <= 0) { + entryPtr->leftIndex = 0; + if (entryPtr->justify == TK_JUSTIFY_LEFT) { + entryPtr->leftX = entryPtr->inset; + } else if (entryPtr->justify == TK_JUSTIFY_RIGHT) { + entryPtr->leftX = Tk_Width(entryPtr->tkwin) - entryPtr->inset + - totalLength; + } else { + entryPtr->leftX = (Tk_Width(entryPtr->tkwin) - totalLength)/2; + } + entryPtr->tabOrigin = entryPtr->leftX; + } else { + /* + * The whole string can't fit in the window. Compute the + * maximum number of characters that may be off-screen to + * the left without leaving empty space on the right of the + * window, then don't let leftIndex be any greater than that. + */ + + maxOffScreen = TkMeasureChars(entryPtr->fontPtr, displayString, + entryPtr->numChars, 0, overflow, 0, + TK_NEWLINES_NOT_SPECIAL|TK_PARTIAL_OK, &rightX); + if (rightX < overflow) { + maxOffScreen += 1; + } + if (entryPtr->leftIndex > maxOffScreen) { + entryPtr->leftIndex = maxOffScreen; + } + TkMeasureChars(entryPtr->fontPtr, displayString, + entryPtr->leftIndex, 0, INT_MAX, 0, + TK_NEWLINES_NOT_SPECIAL|TK_PARTIAL_OK, &rightX); + entryPtr->leftX = entryPtr->inset; + entryPtr->tabOrigin = entryPtr->leftX - rightX; + } + + fontHeight = entryPtr->fontPtr->ascent + entryPtr->fontPtr->descent; + height = fontHeight + 2*entryPtr->inset + 2*(YPAD-XPAD); + if (entryPtr->prefWidth > 0) { + width = entryPtr->prefWidth*entryPtr->avgWidth + 2*entryPtr->inset; + } else { + if (totalLength == 0) { + width = entryPtr->avgWidth + 2*entryPtr->inset; + } else { + width = totalLength + 2*entryPtr->inset; + } + } + Tk_GeometryRequest(entryPtr->tkwin, width, height); +} + /* *---------------------------------------------------------------------- * @@ -1058,7 +1337,7 @@ InsertChars(entryPtr, index, string) return; } new = (char *) ckalloc((unsigned) (entryPtr->numChars + length + 1)); - strncpy(new, entryPtr->string, index); + strncpy(new, entryPtr->string, (size_t) index); strcpy(new+index, string); strcpy(new+index+length, entryPtr->string+index); ckfree(entryPtr->string); @@ -1068,16 +1347,18 @@ InsertChars(entryPtr, index, string) /* * Inserting characters invalidates all indexes into the string. * Touch up the indexes so that they still refer to the same - * characters (at new positions). + * characters (at new positions). When updating the selection + * end-points, don't include the new text in the selection unless + * it was completely surrounded by the selection. */ if (entryPtr->selectFirst >= index) { entryPtr->selectFirst += length; } - if (entryPtr->selectLast >= index) { + if (entryPtr->selectLast > index) { entryPtr->selectLast += length; } - if (entryPtr->selectAnchor >= index) { + if ((entryPtr->selectAnchor > index) || (entryPtr->selectFirst >= index)) { entryPtr->selectAnchor += length; } if (entryPtr->leftIndex > index) { @@ -1086,13 +1367,7 @@ InsertChars(entryPtr, index, string) if (entryPtr->insertPos >= index) { entryPtr->insertPos += length; } - - if (entryPtr->textVarName != NULL) { - Tcl_SetVar(entryPtr->interp, entryPtr->textVarName, entryPtr->string, - TCL_GLOBAL_ONLY); - } - entryPtr->flags |= UPDATE_SCROLLBAR; - EventuallyRedraw(entryPtr); + EntryValueChanged(entryPtr); } /* @@ -1128,7 +1403,7 @@ DeleteChars(entryPtr, index, count) } new = (char *) ckalloc((unsigned) (entryPtr->numChars + 1 - count)); - strncpy(new, entryPtr->string, index); + strncpy(new, entryPtr->string, (size_t) index); strcpy(new+index, entryPtr->string+index+count); ckfree(entryPtr->string); entryPtr->string = new; @@ -1139,6 +1414,7 @@ DeleteChars(entryPtr, index, count) * renumbered. Update the various indexes into the string to reflect * this change. */ + if (entryPtr->selectFirst >= index) { if (entryPtr->selectFirst >= (index+count)) { entryPtr->selectFirst -= count; @@ -1150,10 +1426,10 @@ DeleteChars(entryPtr, index, count) if (entryPtr->selectLast >= (index+count)) { entryPtr->selectLast -= count; } else { - entryPtr->selectLast = index-1; + entryPtr->selectLast = index; } } - if (entryPtr->selectLast < entryPtr->selectFirst) { + if (entryPtr->selectLast <= entryPtr->selectFirst) { entryPtr->selectFirst = entryPtr->selectLast = -1; } if (entryPtr->selectAnchor >= index) { @@ -1177,13 +1453,60 @@ DeleteChars(entryPtr, index, count) entryPtr->insertPos = index; } } + EntryValueChanged(entryPtr); +} + +/* + *---------------------------------------------------------------------- + * + * EntryValueChanged -- + * + * This procedure is invoked when characters are inserted into + * an entry or deleted from it. It updates the entry's associated + * variable, if there is one, and does other bookkeeping such + * as arranging for redisplay. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - if (entryPtr->textVarName != NULL) { - Tcl_SetVar(entryPtr->interp, entryPtr->textVarName, entryPtr->string, - TCL_GLOBAL_ONLY); +static void +EntryValueChanged(entryPtr) + Entry *entryPtr; /* Entry whose value just changed. */ +{ + char *newValue; + + if (entryPtr->textVarName == NULL) { + newValue = NULL; + } else { + newValue = Tcl_SetVar(entryPtr->interp, entryPtr->textVarName, + entryPtr->string, TCL_GLOBAL_ONLY); + } + + if ((newValue != NULL) && (strcmp(newValue, entryPtr->string) != 0)) { + /* + * The value of the variable is different than what we asked for. + * This means that a trace on the variable modified it. In this + * case our trace procedure wasn't invoked since the modification + * came while a trace was already active on the variable. So, + * update our value to reflect the variable's latest value. + */ + + EntrySetValue(entryPtr, newValue); + } else { + /* + * Arrange for redisplay. + */ + + entryPtr->flags |= UPDATE_SCROLLBAR; + EntryComputeGeometry(entryPtr); + EventuallyRedraw(entryPtr); } - entryPtr->flags |= UPDATE_SCROLLBAR; - EventuallyRedraw(entryPtr); } /* @@ -1199,11 +1522,11 @@ DeleteChars(entryPtr, index, count) * None. * * Side effects: - * The string displayed in the entry will change. Any selection - * in the entry is lost and the insertion point gets set to the - * end of the entry. Note: this procedure does *not* update the - * entry's associated variable, since that could result in an - * infinite loop. + * The string displayed in the entry will change. The selection, + * insertion point, and view may have to be adjusted to keep them + * within the bounds of the new string. Note: this procedure does + * *not* update the entry's associated variable, since that could + * result in an infinite loop. * *---------------------------------------------------------------------- */ @@ -1218,11 +1541,22 @@ EntrySetValue(entryPtr, value) entryPtr->numChars = strlen(value); entryPtr->string = (char *) ckalloc((unsigned) (entryPtr->numChars + 1)); strcpy(entryPtr->string, value); - entryPtr->selectFirst = entryPtr->selectLast = -1; - entryPtr->leftIndex = 0; - entryPtr->insertPos = entryPtr->numChars; + if (entryPtr->selectFirst != -1) { + if (entryPtr->selectFirst >= entryPtr->numChars) { + entryPtr->selectFirst = entryPtr->selectLast = -1; + } else if (entryPtr->selectLast > entryPtr->numChars) { + entryPtr->selectLast = entryPtr->numChars; + } + } + if (entryPtr->leftIndex >= entryPtr->numChars) { + entryPtr->leftIndex = entryPtr->numChars-1; + } + if (entryPtr->insertPos > entryPtr->numChars) { + entryPtr->insertPos = entryPtr->numChars; + } entryPtr->flags |= UPDATE_SCROLLBAR; + EntryComputeGeometry(entryPtr); EventuallyRedraw(entryPtr); } @@ -1254,21 +1588,67 @@ EntryEventProc(clientData, eventPtr) EventuallyRedraw(entryPtr); entryPtr->flags |= BORDER_NEEDED; } else if (eventPtr->type == DestroyNotify) { - Tcl_DeleteCommand(entryPtr->interp, Tk_PathName(entryPtr->tkwin)); - entryPtr->tkwin = NULL; - if (entryPtr->flags & REDRAW_PENDING) { - Tk_CancelIdleCall(DisplayEntry, (ClientData) entryPtr); + if (entryPtr->tkwin != NULL) { + entryPtr->tkwin = NULL; + Tcl_DeleteCommand(entryPtr->interp, + Tcl_GetCommandName(entryPtr->interp, entryPtr->widgetCmd)); } - Tk_EventuallyFree((ClientData) entryPtr, DestroyEntry); + if (entryPtr->flags & REDRAW_PENDING) { + Tcl_CancelIdleCall(DisplayEntry, (ClientData) entryPtr); + } + Tcl_EventuallyFree((ClientData) entryPtr, DestroyEntry); } else if (eventPtr->type == ConfigureNotify) { - Tk_Preserve((ClientData) entryPtr); + Tcl_Preserve((ClientData) entryPtr); entryPtr->flags |= UPDATE_SCROLLBAR; + EntryComputeGeometry(entryPtr); EventuallyRedraw(entryPtr); - Tk_Release((ClientData) entryPtr); + Tcl_Release((ClientData) entryPtr); } else if (eventPtr->type == FocusIn) { - EntryFocusProc(entryPtr, 1); + if (eventPtr->xfocus.detail != NotifyInferior) { + EntryFocusProc(entryPtr, 1); + } } else if (eventPtr->type == FocusOut) { - EntryFocusProc(entryPtr, 0); + if (eventPtr->xfocus.detail != NotifyInferior) { + EntryFocusProc(entryPtr, 0); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * EntryCmdDeletedProc -- + * + * This procedure is invoked when a widget command is deleted. If + * the widget isn't already in the process of being destroyed, + * this command destroys it. + * + * Results: + * None. + * + * Side effects: + * The widget is destroyed. + * + *---------------------------------------------------------------------- + */ + +static void +EntryCmdDeletedProc(clientData) + ClientData clientData; /* Pointer to widget record for widget. */ +{ + Entry *entryPtr = (Entry *) clientData; + Tk_Window tkwin = entryPtr->tkwin; + + /* + * This procedure could be invoked either because the window was + * destroyed and the command was then deleted (in which case tkwin + * is NULL) or because the command was deleted, and then this procedure + * destroys the widget. + */ + + if (tkwin != NULL) { + entryPtr->tkwin = NULL; + Tk_DestroyWindow(tkwin); } } @@ -1301,13 +1681,13 @@ GetEntryIndex(interp, entryPtr, string, indexPtr) char *string; /* Specifies character in entryPtr. */ int *indexPtr; /* Where to store converted index. */ { - int length; + size_t length; length = strlen(string); - if (string[0] == 'e') { - if (strncmp(string, "end", length) == 0) { - *indexPtr = entryPtr->numChars; + if (string[0] == 'a') { + if (strncmp(string, "anchor", length) == 0) { + *indexPtr = entryPtr->selectAnchor; } else { badIndex: @@ -1321,6 +1701,12 @@ GetEntryIndex(interp, entryPtr, string, indexPtr) "\"", (char *) NULL); return TCL_ERROR; } + } else if (string[0] == 'e') { + if (strncmp(string, "end", length) == 0) { + *indexPtr = entryPtr->numChars; + } else { + goto badIndex; + } } else if (string[0] == 'i') { if (strncmp(string, "insert", length) == 0) { *indexPtr = entryPtr->insertPos; @@ -1343,19 +1729,38 @@ GetEntryIndex(interp, entryPtr, string, indexPtr) goto badIndex; } } else if (string[0] == '@') { - int x, dummy; + int x, dummy, roundUp; if (Tcl_GetInt(interp, string+1, &x) != TCL_OK) { goto badIndex; } + if (x < entryPtr->inset) { + x = entryPtr->inset; + } + roundUp = 0; + if (x >= (Tk_Width(entryPtr->tkwin) - entryPtr->inset)) { + x = Tk_Width(entryPtr->tkwin) - entryPtr->inset - 1; + roundUp = 1; + } if (entryPtr->numChars == 0) { *indexPtr = 0; } else { - *indexPtr = entryPtr->leftIndex + TkMeasureChars(entryPtr->fontPtr, - entryPtr->string + entryPtr->leftIndex, - entryPtr->numChars - entryPtr->leftIndex, - entryPtr->offset, x, TK_NEWLINES_NOT_SPECIAL, - &dummy); + *indexPtr = TkMeasureChars(entryPtr->fontPtr, + (entryPtr->displayString == NULL) ? entryPtr->string + : entryPtr->displayString, + entryPtr->numChars, entryPtr->tabOrigin, x, + entryPtr->tabOrigin, TK_NEWLINES_NOT_SPECIAL, &dummy); + } + + /* + * Special trick: if the x-position was off-screen to the right, + * round the index up to refer to the character just after the + * last visible one on the screen. This is needed to enable the + * last character to be selected, for example. + */ + + if (roundUp && (*indexPtr < entryPtr->numChars)) { + *indexPtr += 1; } } else { if (Tcl_GetInt(interp, string, indexPtr) != TCL_OK) { @@ -1419,6 +1824,7 @@ EntryScanTo(entryPtr, x) if (newLeftIndex != entryPtr->leftIndex) { entryPtr->leftIndex = newLeftIndex; entryPtr->flags |= UPDATE_SCROLLBAR; + EntryComputeGeometry(entryPtr); EventuallyRedraw(entryPtr); } } @@ -1454,48 +1860,33 @@ EntrySelectTo(entryPtr, index) */ if ((entryPtr->selectFirst == -1) && (entryPtr->exportSelection)) { - Tk_OwnSelection(entryPtr->tkwin, EntryLostSelection, + Tk_OwnSelection(entryPtr->tkwin, XA_PRIMARY, EntryLostSelection, (ClientData) entryPtr); } - if (((index < 0) && (entryPtr->selectAnchor <= 0 )) - || ((index >= entryPtr->numChars) - && (entryPtr->selectAnchor >= entryPtr->numChars))) { + /* + * Pick new starting and ending points for the selection. + */ - /* - * The selection is entirely out of the range of the entry's - * characters, so select nothing. - */ - - entryPtr->selectFirst = -1; - entryPtr->selectLast = -1; - } else { - if (index < 0) { - index = 0; - } - if (index >= entryPtr->numChars) { - index = entryPtr->numChars-1; - } - if (entryPtr->selectAnchor > entryPtr->numChars) { - entryPtr->selectAnchor = entryPtr->numChars; - } - if (entryPtr->selectAnchor <= index) { - newFirst = entryPtr->selectAnchor; - newLast = index; - } else { - newFirst = index; - newLast = entryPtr->selectAnchor - 1; - if (newLast < 0) { - newFirst = newLast = -1; - } - } - if ((entryPtr->selectFirst == newFirst) - && (entryPtr->selectLast == newLast)) { - return; - } - entryPtr->selectFirst = newFirst; - entryPtr->selectLast = newLast; + if (entryPtr->selectAnchor > entryPtr->numChars) { + entryPtr->selectAnchor = entryPtr->numChars; } + if (entryPtr->selectAnchor <= index) { + newFirst = entryPtr->selectAnchor; + newLast = index; + } else { + newFirst = index; + newLast = entryPtr->selectAnchor; + if (newLast < 0) { + newFirst = newLast = -1; + } + } + if ((entryPtr->selectFirst == newFirst) + && (entryPtr->selectLast == newLast)) { + return; + } + entryPtr->selectFirst = newFirst; + entryPtr->selectLast = newLast; EventuallyRedraw(entryPtr); } @@ -1533,18 +1924,25 @@ EntryFetchSelection(clientData, offset, buffer, maxBytes) { Entry *entryPtr = (Entry *) clientData; int count; + char *displayString; if ((entryPtr->selectFirst < 0) || !(entryPtr->exportSelection)) { return -1; } - count = entryPtr->selectLast + 1 - entryPtr->selectFirst - offset; + count = entryPtr->selectLast - entryPtr->selectFirst - offset; if (count > maxBytes) { count = maxBytes; } if (count <= 0) { return 0; } - strncpy(buffer, entryPtr->string + entryPtr->selectFirst + offset, count); + if (entryPtr->displayString == NULL) { + displayString = entryPtr->string; + } else { + displayString = entryPtr->displayString; + } + strncpy(buffer, displayString + entryPtr->selectFirst + offset, + (size_t) count); buffer[count] = '\0'; return count; } @@ -1615,7 +2013,57 @@ EventuallyRedraw(entryPtr) if (!(entryPtr->flags & REDRAW_PENDING)) { entryPtr->flags |= REDRAW_PENDING; - Tk_DoWhenIdle(DisplayEntry, (ClientData) entryPtr); + Tcl_DoWhenIdle(DisplayEntry, (ClientData) entryPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * EntryVisibleRange -- + * + * Return information about the range of the entry that is + * currently visible. + * + * Results: + * *firstPtr and *lastPtr are modified to hold fractions between + * 0 and 1 identifying the range of characters visible in the + * entry. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +EntryVisibleRange(entryPtr, firstPtr, lastPtr) + Entry *entryPtr; /* Information about widget. */ + double *firstPtr; /* Return position of first visible + * character in widget. */ + double *lastPtr; /* Return position of char just after + * last visible one. */ +{ + char *displayString; + int charsInWindow, endX; + + if (entryPtr->displayString == NULL) { + displayString = entryPtr->string; + } else { + displayString = entryPtr->displayString; + } + if (entryPtr->numChars == 0) { + *firstPtr = 0.0; + *lastPtr = 1.0; + } else { + charsInWindow = TkMeasureChars(entryPtr->fontPtr, + displayString + entryPtr->leftIndex, + entryPtr->numChars - entryPtr->leftIndex, entryPtr->inset, + Tk_Width(entryPtr->tkwin) - entryPtr->inset, entryPtr->inset, + TK_AT_LEAST_ONE|TK_NEWLINES_NOT_SPECIAL, &endX); + *firstPtr = ((double) entryPtr->leftIndex)/entryPtr->numChars; + *lastPtr = ((double) (entryPtr->leftIndex + charsInWindow)) + /entryPtr->numChars; } } @@ -1641,44 +2089,29 @@ EventuallyRedraw(entryPtr) static void EntryUpdateScrollbar(entryPtr) - register Entry *entryPtr; /* Information about widget. */ + Entry *entryPtr; /* Information about widget. */ { char args[100]; - int result, last, charsInWindow, endX; + int code; + double first, last; + Tcl_Interp *interp; if (entryPtr->scrollCmd == NULL) { return; } - /* - * The most painful part here is guessing how many characters - * actually fit in the window. This is only an estimate in the - * case where the window isn't completely filled with characters. - */ - - charsInWindow = TkMeasureChars(entryPtr->fontPtr, - entryPtr->string + entryPtr->leftIndex, - entryPtr->numChars - entryPtr->leftIndex, entryPtr->offset, - Tk_Width(entryPtr->tkwin), - TK_AT_LEAST_ONE|TK_NEWLINES_NOT_SPECIAL, &endX); - if (charsInWindow == 0) { - last = entryPtr->leftIndex; - } else { - last = entryPtr->leftIndex + charsInWindow - 1; - } - if (endX < Tk_Width(entryPtr->tkwin)) { - charsInWindow += (Tk_Width(entryPtr->tkwin) - endX)/entryPtr->avgWidth; - } - sprintf(args, " %d %d %d %d", entryPtr->numChars, charsInWindow, - entryPtr->leftIndex, last); - result = Tcl_VarEval(entryPtr->interp, entryPtr->scrollCmd, args, - (char *) NULL); - if (result != TCL_OK) { - Tcl_AddErrorInfo(entryPtr->interp, + interp = entryPtr->interp; + Tcl_Preserve((ClientData) interp); + EntryVisibleRange(entryPtr, &first, &last); + sprintf(args, " %g %g", first, last); + code = Tcl_VarEval(interp, entryPtr->scrollCmd, args, (char *) NULL); + if (code != TCL_OK) { + Tcl_AddErrorInfo(interp, "\n (horizontal scrolling command executed by entry)"); - Tk_BackgroundError(entryPtr->interp); + Tcl_BackgroundError(interp); } - Tcl_SetResult(entryPtr->interp, (char *) NULL, TCL_STATIC); + Tcl_SetResult(interp, (char *) NULL, TCL_STATIC); + Tcl_Release((ClientData) interp); } /* @@ -1710,11 +2143,11 @@ EntryBlinkProc(clientData) } if (entryPtr->flags & CURSOR_ON) { entryPtr->flags &= ~CURSOR_ON; - entryPtr->insertBlinkHandler = Tk_CreateTimerHandler( + entryPtr->insertBlinkHandler = Tcl_CreateTimerHandler( entryPtr->insertOffTime, EntryBlinkProc, (ClientData) entryPtr); } else { entryPtr->flags |= CURSOR_ON; - entryPtr->insertBlinkHandler = Tk_CreateTimerHandler( + entryPtr->insertBlinkHandler = Tcl_CreateTimerHandler( entryPtr->insertOnTime, EntryBlinkProc, (ClientData) entryPtr); } EventuallyRedraw(entryPtr); @@ -1744,17 +2177,17 @@ EntryFocusProc(entryPtr, gotFocus) int gotFocus; /* 1 means window is getting focus, 0 means * it's losing it. */ { - Tk_DeleteTimerHandler(entryPtr->insertBlinkHandler); + Tcl_DeleteTimerHandler(entryPtr->insertBlinkHandler); if (gotFocus) { entryPtr->flags |= GOT_FOCUS | CURSOR_ON; if (entryPtr->insertOffTime != 0) { - entryPtr->insertBlinkHandler = Tk_CreateTimerHandler( + entryPtr->insertBlinkHandler = Tcl_CreateTimerHandler( entryPtr->insertOnTime, EntryBlinkProc, (ClientData) entryPtr); } } else { entryPtr->flags &= ~(GOT_FOCUS | CURSOR_ON); - entryPtr->insertBlinkHandler = (Tk_TimerToken) NULL; + entryPtr->insertBlinkHandler = (Tcl_TimerToken) NULL; } EventuallyRedraw(entryPtr); } @@ -1782,8 +2215,8 @@ static char * EntryTextVarProc(clientData, interp, name1, name2, flags) ClientData clientData; /* Information about button. */ Tcl_Interp *interp; /* Interpreter containing variable. */ - char *name1; /* Name of variable. */ - char *name2; /* Second part of variable name. */ + char *name1; /* Not used. */ + char *name2; /* Not used. */ int flags; /* Information about what happened. */ { register Entry *entryPtr = (Entry *) clientData; @@ -1796,9 +2229,9 @@ EntryTextVarProc(clientData, interp, name1, name2, flags) if (flags & TCL_TRACE_UNSETS) { if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) { - Tcl_SetVar2(interp, name1, name2, entryPtr->string, - flags & TCL_GLOBAL_ONLY); - Tcl_TraceVar2(interp, name1, name2, + Tcl_SetVar(interp, entryPtr->textVarName, entryPtr->string, + TCL_GLOBAL_ONLY); + Tcl_TraceVar(interp, entryPtr->textVarName, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, EntryTextVarProc, clientData); } @@ -1812,7 +2245,7 @@ EntryTextVarProc(clientData, interp, name1, name2, flags) * the entry). */ - value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY); + value = Tcl_GetVar(interp, entryPtr->textVarName, TCL_GLOBAL_ONLY); if (value == NULL) { value = ""; } diff --git a/tk3.6/tkError.c b/tk4.2/generic/tkError.c similarity index 81% rename from tk3.6/tkError.c rename to tk4.2/generic/tkError.c index 9cb7102..ce9cc8c 100644 --- a/tk3.6/tkError.c +++ b/tk4.2/generic/tkError.c @@ -6,34 +6,27 @@ * to the X server. This is useful, for example, when * communicating with a window that may not exist. * - * Copyright (c) 1990-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tkError.c 1.20 96/02/15 18:53:17 */ -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkError.c,v 1.12 93/06/16 17:14:52 ouster Exp $ SPRITE (Berkeley)"; -#endif - -#include "tkConfig.h" +#include "tkPort.h" #include "tkInt.h" +/* + * The default X error handler gets saved here, so that it can + * be invoked if an error occurs that we can't handle. + */ + +static int (*defaultHandler) _ANSI_ARGS_((Display *display, + XErrorEvent *eventPtr)) = NULL; + + /* * Forward references to procedures declared later in this file: */ @@ -110,21 +103,17 @@ Tk_CreateErrorHandler(display, error, request, minorCode, errorProc, clientData) * it's an error: panic. */ - for (dispPtr = tkDisplayList; ; dispPtr = dispPtr->nextPtr) { - if (dispPtr->display == display) { - break; - } - if (dispPtr == NULL) { - panic("Unknown display passed to Tk_CreateErrorHandler"); - } + dispPtr = TkGetDisplay(display); + if (dispPtr == NULL) { + panic("Unknown display passed to Tk_CreateErrorHandler"); } /* * Make sure that X calls us whenever errors occur. */ - if (dispPtr->defaultHandler == NULL) { - dispPtr->defaultHandler = XSetErrorHandler(ErrorProc); + if (defaultHandler == NULL) { + defaultHandler = XSetErrorHandler(ErrorProc); } /* @@ -134,7 +123,7 @@ Tk_CreateErrorHandler(display, error, request, minorCode, errorProc, clientData) errorPtr = (TkErrorHandler *) ckalloc(sizeof(TkErrorHandler)); errorPtr->dispPtr = dispPtr; errorPtr->firstRequest = NextRequest(display); - errorPtr->lastRequest = -1; + errorPtr->lastRequest = (unsigned) -1; errorPtr->error = error; errorPtr->request = request; errorPtr->minorCode = minorCode; @@ -256,13 +245,9 @@ ErrorProc(display, errEventPtr) * invoke the default error handler. */ - for (dispPtr = tkDisplayList; ; dispPtr = dispPtr->nextPtr) { - if (dispPtr == NULL) { - goto couldntHandle; - } - if (dispPtr->display == display) { - break; - } + dispPtr = TkGetDisplay(display); + if (dispPtr == NULL) { + goto couldntHandle; } /* @@ -292,10 +277,24 @@ ErrorProc(display, errEventPtr) } } + /* + * See if the error is a BadWindow error. If so, and it refers + * to a window that still exists in our window table, then ignore + * the error. Errors like this can occur if a window owned by us + * is deleted by someone externally, like a window manager. We'll + * ignore the errors at least long enough to clean up internally and + * remove the entry from the window table. + */ + + if ((errEventPtr->error_code == BadWindow) && (Tk_IdToWindow(display, + (Window) errEventPtr->resourceid) != NULL)) { + return 0; + } + /* * We couldn't handle the error. Use the default handler. */ couldntHandle: - return (*dispPtr->defaultHandler)(display, errEventPtr); + return (*defaultHandler)(display, errEventPtr); } diff --git a/tk4.2/generic/tkEvent.c b/tk4.2/generic/tkEvent.c new file mode 100644 index 0000000..9f77ae4 --- /dev/null +++ b/tk4.2/generic/tkEvent.c @@ -0,0 +1,1057 @@ +/* + * tkEvent.c -- + * + * This file provides basic low-level facilities for managing + * X events in Tk. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkEvent.c 1.18 96/09/12 09:25:22 + */ + +#include "tkPort.h" +#include "tkInt.h" +#include + +/* + * There's a potential problem if a handler is deleted while it's + * current (i.e. its procedure is executing), since Tk_HandleEvent + * will need to read the handler's "nextPtr" field when the procedure + * returns. To handle this problem, structures of the type below + * indicate the next handler to be processed for any (recursively + * nested) dispatches in progress. The nextHandler fields get + * updated if the handlers pointed to are deleted. Tk_HandleEvent + * also needs to know if the entire window gets deleted; the winPtr + * field is set to zero if that particular window gets deleted. + */ + +typedef struct InProgress { + XEvent *eventPtr; /* Event currently being handled. */ + TkWindow *winPtr; /* Window for event. Gets set to None if + * window is deleted while event is being + * handled. */ + TkEventHandler *nextHandler; /* Next handler in search. */ + struct InProgress *nextPtr; /* Next higher nested search. */ +} InProgress; + +static InProgress *pendingPtr = NULL; + /* Topmost search in progress, or + * NULL if none. */ + +/* + * For each call to Tk_CreateGenericHandler, an instance of the following + * structure will be created. All of the active handlers are linked into a + * list. + */ + +typedef struct GenericHandler { + Tk_GenericProc *proc; /* Procedure to dispatch on all X events. */ + ClientData clientData; /* Client data to pass to procedure. */ + int deleteFlag; /* Flag to set when this handler is deleted. */ + struct GenericHandler *nextPtr; + /* Next handler in list of all generic + * handlers, or NULL for end of list. */ +} GenericHandler; + +static GenericHandler *genericList = NULL; + /* First handler in the list, or NULL. */ +static GenericHandler *lastGenericPtr = NULL; + /* Last handler in list. */ + +/* + * There's a potential problem if Tk_HandleEvent is entered recursively. + * A handler cannot be deleted physically until we have returned from + * calling it. Otherwise, we're looking at unallocated memory in advancing to + * its `next' entry. We deal with the problem by using the `delete flag' and + * deleting handlers only when it's known that there's no handler active. + * + * The following variable has a non-zero value when a handler is active. + */ + +static int genericHandlersActive = 0; + +/* + * The following structure is used for queueing X-style events on the + * Tcl event queue. + */ + +typedef struct TkWindowEvent { + Tcl_Event header; /* Standard information for all events. */ + XEvent event; /* The X event. */ +} TkWindowEvent; + +/* + * Array of event masks corresponding to each X event: + */ + +static unsigned long eventMasks[TK_LASTEVENT] = { + 0, + 0, + KeyPressMask, /* KeyPress */ + KeyReleaseMask, /* KeyRelease */ + ButtonPressMask, /* ButtonPress */ + ButtonReleaseMask, /* ButtonRelease */ + PointerMotionMask|PointerMotionHintMask|ButtonMotionMask + |Button1MotionMask|Button2MotionMask|Button3MotionMask + |Button4MotionMask|Button5MotionMask, + /* MotionNotify */ + EnterWindowMask, /* EnterNotify */ + LeaveWindowMask, /* LeaveNotify */ + FocusChangeMask, /* FocusIn */ + FocusChangeMask, /* FocusOut */ + KeymapStateMask, /* KeymapNotify */ + ExposureMask, /* Expose */ + ExposureMask, /* GraphicsExpose */ + ExposureMask, /* NoExpose */ + VisibilityChangeMask, /* VisibilityNotify */ + SubstructureNotifyMask, /* CreateNotify */ + StructureNotifyMask, /* DestroyNotify */ + StructureNotifyMask, /* UnmapNotify */ + StructureNotifyMask, /* MapNotify */ + SubstructureRedirectMask, /* MapRequest */ + StructureNotifyMask, /* ReparentNotify */ + StructureNotifyMask, /* ConfigureNotify */ + SubstructureRedirectMask, /* ConfigureRequest */ + StructureNotifyMask, /* GravityNotify */ + ResizeRedirectMask, /* ResizeRequest */ + StructureNotifyMask, /* CirculateNotify */ + SubstructureRedirectMask, /* CirculateRequest */ + PropertyChangeMask, /* PropertyNotify */ + 0, /* SelectionClear */ + 0, /* SelectionRequest */ + 0, /* SelectionNotify */ + ColormapChangeMask, /* ColormapNotify */ + 0, /* ClientMessage */ + 0, /* Mapping Notify */ + VirtualEventMask, /* VirtualEvents */ + ActivateMask, /* ActivateNotify */ + ActivateMask /* DeactivateNotify */ +}; + +/* + * If someone has called Tk_RestrictEvents, the information below + * keeps track of it. + */ + +static Tk_RestrictProc *restrictProc; + /* Procedure to call. NULL means no + * restrictProc is currently in effect. */ +static ClientData restrictArg; /* Argument to pass to restrictProc. */ + +/* + * Prototypes for procedures that are only referenced locally within + * this file. + */ + +static void DelayedMotionProc _ANSI_ARGS_((ClientData clientData)); +static int WindowEventProc _ANSI_ARGS_((Tcl_Event *evPtr, + int flags)); + +/* + *-------------------------------------------------------------- + * + * Tk_CreateEventHandler -- + * + * Arrange for a given procedure to be invoked whenever + * events from a given class occur in a given window. + * + * Results: + * None. + * + * Side effects: + * From now on, whenever an event of the type given by + * mask occurs for token and is processed by Tk_HandleEvent, + * proc will be called. See the manual entry for details + * of the calling sequence and return value for proc. + * + *-------------------------------------------------------------- + */ + +void +Tk_CreateEventHandler(token, mask, proc, clientData) + Tk_Window token; /* Token for window in which to + * create handler. */ + unsigned long mask; /* Events for which proc should + * be called. */ + Tk_EventProc *proc; /* Procedure to call for each + * selected event */ + ClientData clientData; /* Arbitrary data to pass to proc. */ +{ + register TkEventHandler *handlerPtr; + register TkWindow *winPtr = (TkWindow *) token; + int found; + + /* + * Skim through the list of existing handlers to (a) compute the + * overall event mask for the window (so we can pass this new + * value to the X system) and (b) see if there's already a handler + * declared with the same callback and clientData (if so, just + * change the mask). If no existing handler matches, then create + * a new handler. + */ + + found = 0; + if (winPtr->handlerList == NULL) { + handlerPtr = (TkEventHandler *) ckalloc( + (unsigned) sizeof(TkEventHandler)); + winPtr->handlerList = handlerPtr; + goto initHandler; + } else { + for (handlerPtr = winPtr->handlerList; ; + handlerPtr = handlerPtr->nextPtr) { + if ((handlerPtr->proc == proc) + && (handlerPtr->clientData == clientData)) { + handlerPtr->mask = mask; + found = 1; + } + if (handlerPtr->nextPtr == NULL) { + break; + } + } + } + + /* + * Create a new handler if no matching old handler was found. + */ + + if (!found) { + handlerPtr->nextPtr = (TkEventHandler *) + ckalloc(sizeof(TkEventHandler)); + handlerPtr = handlerPtr->nextPtr; + initHandler: + handlerPtr->mask = mask; + handlerPtr->proc = proc; + handlerPtr->clientData = clientData; + handlerPtr->nextPtr = NULL; + } + + /* + * No need to call XSelectInput: Tk always selects on all events + * for all windows (needed to support bindings on classes and "all"). + */ +} + +/* + *-------------------------------------------------------------- + * + * Tk_DeleteEventHandler -- + * + * Delete a previously-created handler. + * + * Results: + * None. + * + * Side effects: + * If there existed a handler as described by the + * parameters, the handler is deleted so that proc + * will not be invoked again. + * + *-------------------------------------------------------------- + */ + +void +Tk_DeleteEventHandler(token, mask, proc, clientData) + Tk_Window token; /* Same as corresponding arguments passed */ + unsigned long mask; /* previously to Tk_CreateEventHandler. */ + Tk_EventProc *proc; + ClientData clientData; +{ + register TkEventHandler *handlerPtr; + register InProgress *ipPtr; + TkEventHandler *prevPtr; + register TkWindow *winPtr = (TkWindow *) token; + + /* + * Find the event handler to be deleted, or return + * immediately if it doesn't exist. + */ + + for (handlerPtr = winPtr->handlerList, prevPtr = NULL; ; + prevPtr = handlerPtr, handlerPtr = handlerPtr->nextPtr) { + if (handlerPtr == NULL) { + return; + } + if ((handlerPtr->mask == mask) && (handlerPtr->proc == proc) + && (handlerPtr->clientData == clientData)) { + break; + } + } + + /* + * If Tk_HandleEvent is about to process this handler, tell it to + * process the next one instead. + */ + + for (ipPtr = pendingPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { + if (ipPtr->nextHandler == handlerPtr) { + ipPtr->nextHandler = handlerPtr->nextPtr; + } + } + + /* + * Free resources associated with the handler. + */ + + if (prevPtr == NULL) { + winPtr->handlerList = handlerPtr->nextPtr; + } else { + prevPtr->nextPtr = handlerPtr->nextPtr; + } + ckfree((char *) handlerPtr); + + + /* + * No need to call XSelectInput: Tk always selects on all events + * for all windows (needed to support bindings on classes and "all"). + */ +} + +/*-------------------------------------------------------------- + * + * Tk_CreateGenericHandler -- + * + * Register a procedure to be called on each X event, regardless + * of display or window. Generic handlers are useful for capturing + * events that aren't associated with windows, or events for windows + * not managed by Tk. + * + * Results: + * None. + * + * Side Effects: + * From now on, whenever an X event is given to Tk_HandleEvent, + * invoke proc, giving it clientData and the event as arguments. + * + *-------------------------------------------------------------- + */ + +void +Tk_CreateGenericHandler(proc, clientData) + Tk_GenericProc *proc; /* Procedure to call on every event. */ + ClientData clientData; /* One-word value to pass to proc. */ +{ + GenericHandler *handlerPtr; + + handlerPtr = (GenericHandler *) ckalloc (sizeof (GenericHandler)); + + handlerPtr->proc = proc; + handlerPtr->clientData = clientData; + handlerPtr->deleteFlag = 0; + handlerPtr->nextPtr = NULL; + if (genericList == NULL) { + genericList = handlerPtr; + } else { + lastGenericPtr->nextPtr = handlerPtr; + } + lastGenericPtr = handlerPtr; +} + +/* + *-------------------------------------------------------------- + * + * Tk_DeleteGenericHandler -- + * + * Delete a previously-created generic handler. + * + * Results: + * None. + * + * Side Effects: + * If there existed a handler as described by the parameters, + * that handler is logically deleted so that proc will not be + * invoked again. The physical deletion happens in the event + * loop in Tk_HandleEvent. + * + *-------------------------------------------------------------- + */ + +void +Tk_DeleteGenericHandler(proc, clientData) + Tk_GenericProc *proc; + ClientData clientData; +{ + GenericHandler * handler; + + for (handler = genericList; handler; handler = handler->nextPtr) { + if ((handler->proc == proc) && (handler->clientData == clientData)) { + handler->deleteFlag = 1; + } + } +} + +/* + *-------------------------------------------------------------- + * + * Tk_HandleEvent -- + * + * Given an event, invoke all the handlers that have + * been registered for the event. + * + * Results: + * None. + * + * Side effects: + * Depends on the handlers. + * + *-------------------------------------------------------------- + */ + +void +Tk_HandleEvent(eventPtr) + XEvent *eventPtr; /* Event to dispatch. */ +{ + register TkEventHandler *handlerPtr; + register GenericHandler *genericPtr; + register GenericHandler *genPrevPtr; + TkWindow *winPtr; + unsigned long mask; + InProgress ip; + Window handlerWindow; + TkDisplay *dispPtr; + Tcl_Interp *interp = (Tcl_Interp *) NULL; + + /* + * Next, invoke all the generic event handlers (those that are + * invoked for all events). If a generic event handler reports that + * an event is fully processed, go no further. + */ + + for (genPrevPtr = NULL, genericPtr = genericList; genericPtr != NULL; ) { + if (genericPtr->deleteFlag) { + if (!genericHandlersActive) { + GenericHandler *tmpPtr; + + /* + * This handler needs to be deleted and there are no + * calls pending through the handler, so now is a safe + * time to delete it. + */ + + tmpPtr = genericPtr->nextPtr; + if (genPrevPtr == NULL) { + genericList = tmpPtr; + } else { + genPrevPtr->nextPtr = tmpPtr; + } + if (tmpPtr == NULL) { + lastGenericPtr = genPrevPtr; + } + (void) ckfree((char *) genericPtr); + genericPtr = tmpPtr; + continue; + } + } else { + int done; + + genericHandlersActive++; + done = (*genericPtr->proc)(genericPtr->clientData, eventPtr); + genericHandlersActive--; + if (done) { + return; + } + } + genPrevPtr = genericPtr; + genericPtr = genPrevPtr->nextPtr; + } + + /* + * If the event is a MappingNotify event, find its display and + * refresh the keyboard mapping information for the display. + * After that there's nothing else to do with the event, so just + * quit. + */ + + if (eventPtr->type == MappingNotify) { + dispPtr = TkGetDisplay(eventPtr->xmapping.display); + if (dispPtr != NULL) { + XRefreshKeyboardMapping(&eventPtr->xmapping); + dispPtr->bindInfoStale = 1; + } + return; + } + + /* + * Events selected by StructureNotify require special handling. + * They look the same as those selected by SubstructureNotify. + * The only difference is whether the "event" and "window" fields + * are the same. Compare the two fields and convert StructureNotify + * to SubstructureNotify if necessary. + */ + + handlerWindow = eventPtr->xany.window; + mask = eventMasks[eventPtr->xany.type]; + if (mask == StructureNotifyMask) { + if (eventPtr->xmap.event != eventPtr->xmap.window) { + mask = SubstructureNotifyMask; + handlerWindow = eventPtr->xmap.event; + } + } + winPtr = (TkWindow *) Tk_IdToWindow(eventPtr->xany.display, handlerWindow); + if (winPtr == NULL) { + + /* + * There isn't a TkWindow structure for this window. + * However, if the event is a PropertyNotify event then call + * the selection manager (it deals beneath-the-table with + * certain properties). + */ + + if (eventPtr->type == PropertyNotify) { + TkSelPropProc(eventPtr); + } + return; + } + + /* + * Once a window has started getting deleted, don't process any more + * events for it except for the DestroyNotify event. This check is + * needed because a DestroyNotify handler could re-invoke the event + * loop, causing other pending events to be handled for the window + * (the window doesn't get totally expunged from our tables until + * after the DestroyNotify event has been completely handled). + */ + + if ((winPtr->flags & TK_ALREADY_DEAD) + && (eventPtr->type != DestroyNotify)) { + return; + } + + if (winPtr->mainPtr != NULL) { + + /* + * Protect interpreter for this window from possible deletion + * while we are dealing with the event for this window. Thus, + * widget writers do not have to worry about protecting the + * interpreter in their own code. + */ + + interp = winPtr->mainPtr->interp; + Tcl_Preserve((ClientData) interp); + + /* + * Call focus-related code to look at FocusIn, FocusOut, Enter, + * and Leave events; depending on its return value, ignore the + * event. + */ + + if ((mask & (FocusChangeMask|EnterWindowMask|LeaveWindowMask)) + && !TkFocusFilterEvent(winPtr, eventPtr)) { + Tcl_Release((ClientData) interp); + return; + } + + /* + * Redirect KeyPress and KeyRelease events to the focus window, + * or ignore them entirely if there is no focus window. Map the + * x and y coordinates to make sense in the context of the focus + * window, if possible (make both -1 if the map-from and map-to + * windows don't share the same screen). + */ + + if (mask & (KeyPressMask|KeyReleaseMask)) { + TkWindow *focusPtr; + int winX, winY, focusX, focusY; + + winPtr->dispPtr->lastEventTime = eventPtr->xkey.time; + focusPtr = TkGetFocus(winPtr); + if (focusPtr == NULL) { + Tcl_Release((ClientData) interp); + return; + } + if ((focusPtr->display != winPtr->display) + || (focusPtr->screenNum != winPtr->screenNum)) { + eventPtr->xkey.x = -1; + eventPtr->xkey.y = -1; + } else { + Tk_GetRootCoords((Tk_Window) winPtr, &winX, &winY); + Tk_GetRootCoords((Tk_Window) focusPtr, &focusX, &focusY); + eventPtr->xkey.x -= focusX - winX; + eventPtr->xkey.y -= focusY - winY; + } + eventPtr->xkey.window = focusPtr->window; + winPtr = focusPtr; + } + + /* + * Call a grab-related procedure to do special processing on + * pointer events. + */ + + if (mask & (ButtonPressMask|ButtonReleaseMask|PointerMotionMask + |EnterWindowMask|LeaveWindowMask)) { + if (mask & (ButtonPressMask|ButtonReleaseMask)) { + winPtr->dispPtr->lastEventTime = eventPtr->xbutton.time; + } else if (mask & PointerMotionMask) { + winPtr->dispPtr->lastEventTime = eventPtr->xmotion.time; + } else { + winPtr->dispPtr->lastEventTime = eventPtr->xcrossing.time; + } + if (TkPointerEvent(eventPtr, winPtr) == 0) { + goto done; + } + } + } + +#ifdef TK_USE_INPUT_METHODS + /* + * Pass the event to the input method(s), if there are any, and + * discard the event if the input method(s) insist. Create the + * input context for the window if it hasn't already been done + * (XFilterEvent needs this context). + */ + + if (!(winPtr->flags & TK_CHECKED_IC)) { + if (winPtr->dispPtr->inputMethod != NULL) { + winPtr->inputContext = XCreateIC( + winPtr->dispPtr->inputMethod, XNInputStyle, + XIMPreeditNothing|XIMStatusNothing, + XNClientWindow, winPtr->window, + XNFocusWindow, winPtr->window, NULL); + } + winPtr->flags |= TK_CHECKED_IC; + } + if (XFilterEvent(eventPtr, None)) { + goto done; + } +#endif /* TK_USE_INPUT_METHODS */ + + /* + * For events where it hasn't already been done, update the current + * time in the display. + */ + + if (eventPtr->type == PropertyNotify) { + winPtr->dispPtr->lastEventTime = eventPtr->xproperty.time; + } + + /* + * There's a potential interaction here with Tk_DeleteEventHandler. + * Read the documentation for pendingPtr. + */ + + ip.eventPtr = eventPtr; + ip.winPtr = winPtr; + ip.nextHandler = NULL; + ip.nextPtr = pendingPtr; + pendingPtr = &ip; + if (mask == 0) { + if ((eventPtr->type == SelectionClear) + || (eventPtr->type == SelectionRequest) + || (eventPtr->type == SelectionNotify)) { + TkSelEventProc((Tk_Window) winPtr, eventPtr); + } else if ((eventPtr->type == ClientMessage) + && (eventPtr->xclient.message_type == + Tk_InternAtom((Tk_Window) winPtr, "WM_PROTOCOLS"))) { + TkWmProtocolEventProc(winPtr, eventPtr); + } + } else { + for (handlerPtr = winPtr->handlerList; handlerPtr != NULL; ) { + if ((handlerPtr->mask & mask) != 0) { + ip.nextHandler = handlerPtr->nextPtr; + (*(handlerPtr->proc))(handlerPtr->clientData, eventPtr); + handlerPtr = ip.nextHandler; + } else { + handlerPtr = handlerPtr->nextPtr; + } + } + + /* + * Pass the event to the "bind" command mechanism. But, don't + * do this for SubstructureNotify events. The "bind" command + * doesn't support them anyway, and it's easier to filter out + * these events here than in the lower-level procedures. + */ + + if ((ip.winPtr != None) && (mask != SubstructureNotifyMask)) { + TkBindEventProc(winPtr, eventPtr); + } + } + pendingPtr = ip.nextPtr; +done: + + /* + * Release the interpreter for this window so that it can be potentially + * deleted if requested. + */ + + if (interp != (Tcl_Interp *) NULL) { + Tcl_Release((ClientData) interp); + } +} + +/* + *-------------------------------------------------------------- + * + * TkEventDeadWindow -- + * + * This procedure is invoked when it is determined that + * a window is dead. It cleans up event-related information + * about the window. + * + * Results: + * None. + * + * Side effects: + * Various things get cleaned up and recycled. + * + *-------------------------------------------------------------- + */ + +void +TkEventDeadWindow(winPtr) + TkWindow *winPtr; /* Information about the window + * that is being deleted. */ +{ + register TkEventHandler *handlerPtr; + register InProgress *ipPtr; + + /* + * While deleting all the handlers, be careful to check for + * Tk_HandleEvent being about to process one of the deleted + * handlers. If it is, tell it to quit (all of the handlers + * are being deleted). + */ + + while (winPtr->handlerList != NULL) { + handlerPtr = winPtr->handlerList; + winPtr->handlerList = handlerPtr->nextPtr; + for (ipPtr = pendingPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { + if (ipPtr->nextHandler == handlerPtr) { + ipPtr->nextHandler = NULL; + } + if (ipPtr->winPtr == winPtr) { + ipPtr->winPtr = None; + } + } + ckfree((char *) handlerPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * TkCurrentTime -- + * + * Try to deduce the current time. "Current time" means the time + * of the event that led to the current code being executed, which + * means the time in the most recently-nested invocation of + * Tk_HandleEvent. + * + * Results: + * The return value is the time from the current event, or + * CurrentTime if there is no current event or if the current + * event contains no time. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Time +TkCurrentTime(dispPtr) + TkDisplay *dispPtr; /* Display for which the time is desired. */ +{ + register XEvent *eventPtr; + + if (pendingPtr == NULL) { + return dispPtr->lastEventTime; + } + eventPtr = pendingPtr->eventPtr; + switch (eventPtr->type) { + case ButtonPress: + case ButtonRelease: + return eventPtr->xbutton.time; + case KeyPress: + case KeyRelease: + return eventPtr->xkey.time; + case MotionNotify: + return eventPtr->xmotion.time; + case EnterNotify: + case LeaveNotify: + return eventPtr->xcrossing.time; + case PropertyNotify: + return eventPtr->xproperty.time; + } + return dispPtr->lastEventTime; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_RestrictEvents -- + * + * This procedure is used to globally restrict the set of events + * that will be dispatched. The restriction is done by filtering + * all incoming X events through a procedure that determines + * whether they are to be processed immediately, deferred, or + * discarded. + * + * Results: + * The return value is the previous restriction procedure in effect, + * if there was one, or NULL if there wasn't. + * + * Side effects: + * From now on, proc will be called to determine whether to process, + * defer or discard each incoming X event. + * + *---------------------------------------------------------------------- + */ + +Tk_RestrictProc * +Tk_RestrictEvents(proc, arg, prevArgPtr) + Tk_RestrictProc *proc; /* Procedure to call for each incoming + * event. */ + ClientData arg; /* Arbitrary argument to pass to proc. */ + ClientData *prevArgPtr; /* Place to store information about previous + * argument. */ +{ + Tk_RestrictProc *prev; + + prev = restrictProc; + *prevArgPtr = restrictArg; + restrictProc = proc; + restrictArg = arg; + return prev; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_QueueWindowEvent -- + * + * Given an X-style window event, this procedure adds it to the + * Tcl event queue at the given position. This procedure also + * performs mouse motion event collapsing if possible. + * + * Results: + * None. + * + * Side effects: + * Adds stuff to the event queue, which will eventually be + * processed. + * + *---------------------------------------------------------------------- + */ + +void +Tk_QueueWindowEvent(eventPtr, position) + XEvent *eventPtr; /* Event to add to queue. This + * procedures copies it before adding + * it to the queue. */ + Tcl_QueuePosition position; /* Where to put it on the queue: + * TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, + * or TCL_QUEUE_MARK. */ +{ + TkWindowEvent *wevPtr; + TkDisplay *dispPtr; + + /* + * Find our display structure for the event's display. + */ + + for (dispPtr = tkDisplayList; ; dispPtr = dispPtr->nextPtr) { + if (dispPtr == NULL) { + return; + } + if (dispPtr->display == eventPtr->xany.display) { + break; + } + } + + if ((dispPtr->delayedMotionPtr != NULL) && (position == TCL_QUEUE_TAIL)) { + if ((eventPtr->type == MotionNotify) && (eventPtr->xmotion.window + == dispPtr->delayedMotionPtr->event.xmotion.window)) { + /* + * The new event is a motion event in the same window as the + * saved motion event. Just replace the saved event with the + * new one. + */ + + dispPtr->delayedMotionPtr->event = *eventPtr; + return; + } else if ((eventPtr->type != GraphicsExpose) + && (eventPtr->type != NoExpose) + && (eventPtr->type != Expose)) { + /* + * The new event may conflict with the saved motion event. Queue + * the saved motion event now so that it will be processed before + * the new event. + */ + + Tcl_QueueEvent(&dispPtr->delayedMotionPtr->header, position); + dispPtr->delayedMotionPtr = NULL; + Tcl_CancelIdleCall(DelayedMotionProc, (ClientData) dispPtr); + } + } + + wevPtr = (TkWindowEvent *) ckalloc(sizeof(TkWindowEvent)); + wevPtr->header.proc = WindowEventProc; + wevPtr->event = *eventPtr; + if ((eventPtr->type == MotionNotify) && (position == TCL_QUEUE_TAIL)) { + /* + * The new event is a motion event so don't queue it immediately; + * save it around in case another motion event arrives that it can + * be collapsed with. + */ + + if (dispPtr->delayedMotionPtr != NULL) { + panic("Tk_QueueWindowEvent found unexpected delayed motion event"); + } + dispPtr->delayedMotionPtr = wevPtr; + Tcl_DoWhenIdle(DelayedMotionProc, (ClientData) dispPtr); + } else { + Tcl_QueueEvent(&wevPtr->header, position); + } +} + +/* + *--------------------------------------------------------------------------- + * + * TkQueueEventForAllChildren -- + * + * Given an XEvent, recursively queue the event for this window and + * all non-toplevel children of the given window. + * + * Results: + * None. + * + * Side effects: + * Events queued. + * + *--------------------------------------------------------------------------- + */ + +void +TkQueueEventForAllChildren(tkwin, eventPtr) + Tk_Window tkwin; /* Window to which event is sent. */ + XEvent *eventPtr; /* The event to be sent. */ +{ + TkWindow *winPtr, *childPtr; + + winPtr = (TkWindow *) tkwin; + eventPtr->xany.window = winPtr->window; + Tk_QueueWindowEvent(eventPtr, TCL_QUEUE_TAIL); + + childPtr = winPtr->childList; + while (childPtr != NULL) { + if (!Tk_IsTopLevel(childPtr)) { + TkQueueEventForAllChildren((Tk_Window) childPtr, eventPtr); + } + childPtr = childPtr->nextPtr; + } +} + +/* + *---------------------------------------------------------------------- + * + * WindowEventProc -- + * + * This procedure is called by Tcl_DoOneEvent when a window event + * reaches the front of the event queue. This procedure is responsible + * for actually handling the event. + * + * Results: + * Returns 1 if the event was handled, meaning it should be removed + * from the queue. Returns 0 if the event was not handled, meaning + * it should stay on the queue. The event isn't handled if the + * TCL_WINDOW_EVENTS bit isn't set in flags, if a restrict proc + * prevents the event from being handled. + * + * Side effects: + * Whatever the event handlers for the event do. + * + *---------------------------------------------------------------------- + */ + +static int +WindowEventProc(evPtr, flags) + Tcl_Event *evPtr; /* Event to service. */ + int flags; /* Flags that indicate what events to + * handle, such as TCL_WINDOW_EVENTS. */ +{ + TkWindowEvent *wevPtr = (TkWindowEvent *) evPtr; + Tk_RestrictAction result; + + if (!(flags & TCL_WINDOW_EVENTS)) { + return 0; + } + if (restrictProc != NULL) { + result = (*restrictProc)(restrictArg, &wevPtr->event); + if (result != TK_PROCESS_EVENT) { + if (result == TK_DEFER_EVENT) { + return 0; + } else { + /* + * TK_DELETE_EVENT: return and say we processed the event, + * even though we didn't do anything at all. + */ + return 1; + } + } + } + Tk_HandleEvent(&wevPtr->event); + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * DelayedMotionProc -- + * + * This procedure is invoked as an idle handler when a mouse motion + * event has been delayed. It queues the delayed event so that it + * will finally be serviced. + * + * Results: + * None. + * + * Side effects: + * The delayed mouse motion event gets added to the Tcl event + * queue for servicing. + * + *---------------------------------------------------------------------- + */ + +static void +DelayedMotionProc(clientData) + ClientData clientData; /* Pointer to display containing a delayed + * motion event to be serviced. */ +{ + TkDisplay *dispPtr = (TkDisplay *) clientData; + + if (dispPtr->delayedMotionPtr == NULL) { + panic("DelayedMotionProc found no delayed mouse motion event"); + } + Tcl_QueueEvent(&dispPtr->delayedMotionPtr->header, TCL_QUEUE_TAIL); + dispPtr->delayedMotionPtr = NULL; +} + +/* + *-------------------------------------------------------------- + * + * Tk_MainLoop -- + * + * Call Tcl_DoOneEvent over and over again in an infinite + * loop as long as there exist any main windows. + * + * Results: + * None. + * + * Side effects: + * Arbitrary; depends on handlers for events. + * + *-------------------------------------------------------------- + */ + +void +Tk_MainLoop() +{ + while (Tk_GetNumMainWindows() > 0) { + Tcl_DoOneEvent(0); + } +} diff --git a/tk4.2/generic/tkFileFilter.c b/tk4.2/generic/tkFileFilter.c new file mode 100644 index 0000000..80f74cc --- /dev/null +++ b/tk4.2/generic/tkFileFilter.c @@ -0,0 +1,486 @@ +/* + * tkFileFilter.c -- + * + * Process the -filetypes option for the file dialogs on Windows and the + * Mac. + * + * Copyright (c) 1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkFileFilter.c 1.4 96/08/28 22:15:14 + * + */ + +#include "tkInt.h" +#include "tkFileFilter.h" + +static int AddClause _ANSI_ARGS_(( + Tcl_Interp * interp, FileFilter * filterPtr, + char * patternsStr, char * ostypesStr, + int isWindows)); +static void FreeClauses _ANSI_ARGS_((FileFilter * filterPtr)); +static void FreeGlobPatterns _ANSI_ARGS_(( + FileFilterClause * clausePtr)); +static void FreeMacFileTypes _ANSI_ARGS_(( + FileFilterClause * clausePtr)); +static FileFilter * GetFilter _ANSI_ARGS_((FileFilterList * flistPtr, + char * name)); + +/* + *---------------------------------------------------------------------- + * + * TkInitFileFilters -- + * + * Initializes a FileFilterList data structure. A FileFilterList + * must be initialized EXACTLY ONCE before any calls to + * TkGetFileFilters() is made. The usual flow of control is: + * TkInitFileFilters(&flist); + * TkGetFileFilters(&flist, ...); + * TkGetFileFilters(&flist, ...); + * ... + * TkFreeFileFilters(&flist); + * + * Results: + * None. + * + * Side effects: + * The fields in flistPtr are initialized. + *---------------------------------------------------------------------- + */ + +void +TkInitFileFilters(flistPtr) + FileFilterList * flistPtr; /* The structure to be initialized. */ +{ + flistPtr->filters = NULL; + flistPtr->filtersTail = NULL; + flistPtr->numFilters = 0; +} + +/* + *---------------------------------------------------------------------- + * + * TkGetFileFilters -- + * + * This function is called by the Mac and Windows implementation + * of tk_getOpenFile and tk_getSaveFile to translate the string + * value of the -filetypes option of into an easy-to-parse C + * structure (flistPtr). The caller of this function will then use + * flistPtr to perform filetype matching in a platform specific way. + * + * flistPtr must be initialized (See comments in TkInitFileFilters). + * + * Results: + * A standard TCL return value. + * + * Side effects: + * The fields in flistPtr are changed according to string. + *---------------------------------------------------------------------- + */ +int +TkGetFileFilters(interp, flistPtr, string, isWindows) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + FileFilterList * flistPtr; /* Stores the list of file filters. */ + char * string; /* Value of the -filetypes option. */ + int isWindows; /* True if we are running on Windows. */ +{ + int listArgc; + char ** listArgv = NULL; + char ** typeInfo = NULL; + int code = TCL_OK; + int i; + + if (Tcl_SplitList(interp, string, &listArgc, &listArgv) != TCL_OK) { + return TCL_ERROR; + } + if (listArgc == 0) { + goto done; + } + + /* + * Free the filter information that have been allocated the previous + * time -- the -filefilters option may have been used more than once in + * the command line. + */ + TkFreeFileFilters(flistPtr); + + for (i = 0; ifilters; + while (filterPtr) { + toFree = filterPtr; + filterPtr=filterPtr->next; + FreeClauses(toFree); + ckfree((char*)toFree->name); + ckfree((char*)toFree); + } + flistPtr->filters = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * AddClause -- + * + * Add one FileFilterClause to filterPtr. + * + * Results: + * A standard TCL result. + * + * Side effects: + * The list of filter clauses are updated in filterPtr. + *---------------------------------------------------------------------- + */ + +static int AddClause(interp, filterPtr, patternsStr, ostypesStr, isWindows) + Tcl_Interp * interp; /* Interpreter to use for error reporting. */ + FileFilter * filterPtr; /* Stores the new filter clause */ + char * patternsStr; /* A TCL list of glob patterns. */ + char * ostypesStr; /* A TCL list of Mac OSType strings. */ + int isWindows; /* True if we are running on Windows; False + * if we are running on the Mac; Glob + * patterns need to be processed differently + * on these two platforms */ +{ + char ** globList = NULL; + int globCount; + char ** ostypeList = NULL; + int ostypeCount; + FileFilterClause * clausePtr; + int i; + int code = TCL_OK; + + if (Tcl_SplitList(interp, patternsStr, &globCount, &globList)!= TCL_OK) { + code = TCL_ERROR; + goto done; + } + if (ostypesStr != NULL) { + if (Tcl_SplitList(interp, ostypesStr, &ostypeCount, &ostypeList) + != TCL_OK) { + code = TCL_ERROR; + goto done; + } + for (i=0; ipatterns = NULL; + clausePtr->patternsTail = NULL; + clausePtr->macTypes = NULL; + clausePtr->macTypesTail = NULL; + + if (filterPtr->clauses == NULL) { + filterPtr->clauses = filterPtr->clausesTail = clausePtr; + } else { + filterPtr->clausesTail->next = clausePtr; + filterPtr->clausesTail = clausePtr; + } + clausePtr->next = NULL; + + if (globCount > 0 && globList != NULL) { + for (i=0; ipattern = (char*)ckalloc(len+1); + globPtr->pattern[0] = '*'; + strcpy(globPtr->pattern+1, globList[i]); + } + else if (isWindows) { + if (strcmp(globList[i], "*") == 0) { + globPtr->pattern = (char*)ckalloc(4*sizeof(char)); + strcpy(globPtr->pattern, "*.*"); + } + else if (strcmp(globList[i], "") == 0) { + /* + * An empty string means "match all files with no + * extensions" + * BUG: "*." actually matches with all files on Win95 + */ + globPtr->pattern = (char*)ckalloc(3*sizeof(char)); + strcpy(globPtr->pattern, "*."); + } + else { + globPtr->pattern = (char*)ckalloc(len); + strcpy(globPtr->pattern, globList[i]); + } + } else { + globPtr->pattern = (char*)ckalloc(len); + strcpy(globPtr->pattern, globList[i]); + } + + /* + * Add the glob pattern into the list of patterns. + */ + + if (clausePtr->patterns == NULL) { + clausePtr->patterns = clausePtr->patternsTail = globPtr; + } else { + clausePtr->patternsTail->next = globPtr; + clausePtr->patternsTail = globPtr; + } + globPtr->next = NULL; + } + } + if (ostypeCount > 0 && ostypeList != NULL) { + for (i=0; itype, ostypeList[i], sizeof(OSType)); + + /* + * Add the Mac type pattern into the list of Mac types + */ + if (clausePtr->macTypes == NULL) { + clausePtr->macTypes = clausePtr->macTypesTail = mfPtr; + } else { + clausePtr->macTypesTail->next = mfPtr; + clausePtr->macTypesTail = mfPtr; + } + mfPtr->next = NULL; + } + } + + done: + if (globList) { + ckfree((char*)globList); + } + if (ostypeList) { + ckfree((char*)ostypeList); + } + + return code; +} + +/* + *---------------------------------------------------------------------- + * + * GetFilter -- + * + * Add one FileFilter to flistPtr. + * + * Results: + * A standard TCL result. + * + * Side effects: + * The list of filters are updated in flistPtr. + *---------------------------------------------------------------------- + */ + +static FileFilter * GetFilter(flistPtr, name) + FileFilterList * flistPtr; /* The FileFilterList that contains the + * newly created filter */ + char * name; /* Name of the filter. It is usually displayed + * in the "File Types" listbox in the file + * dialogs. */ +{ + FileFilter * filterPtr; + + for (filterPtr=flistPtr->filters; filterPtr; filterPtr=filterPtr->next) { + if (strcmp(filterPtr->name, name)==0) { + return filterPtr; + } + } + + filterPtr = (FileFilter*)ckalloc(sizeof(FileFilter)); + filterPtr->clauses = NULL; + filterPtr->clausesTail = NULL; + filterPtr->name = (char*)ckalloc((strlen(name)+1) * sizeof(char)); + strcpy(filterPtr->name, name); + + if (flistPtr->filters == NULL) { + flistPtr->filters = flistPtr->filtersTail = filterPtr; + } else { + flistPtr->filtersTail->next = filterPtr; + flistPtr->filtersTail = filterPtr; + } + filterPtr->next = NULL; + + ++flistPtr->numFilters; + return filterPtr; +} + +/* + *---------------------------------------------------------------------- + * + * FreeClauses -- + * + * Frees the malloc'ed file type clause + * + * Results: + * None. + * + * Side effects: + * The list of clauses in filterPtr->clauses are freed. + *---------------------------------------------------------------------- + */ + +static void +FreeClauses(filterPtr) + FileFilter * filterPtr; /* FileFilter whose clauses are to be freed */ +{ + FileFilterClause * clausePtr, * toFree; + + clausePtr = filterPtr->clauses; + while (clausePtr) { + toFree = clausePtr; + clausePtr=clausePtr->next; + FreeGlobPatterns(toFree); + FreeMacFileTypes(toFree); + ckfree((char*)toFree); + } + filterPtr->clauses = NULL; + filterPtr->clausesTail = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * FreeGlobPatterns -- + * + * Frees the malloc'ed glob patterns in a clause + * + * Results: + * None. + * + * Side effects: + * The list of glob patterns in clausePtr->patterns are freed. + *---------------------------------------------------------------------- + */ + +static void +FreeGlobPatterns(clausePtr) + FileFilterClause * clausePtr;/* The clause whose patterns are to be freed*/ +{ + GlobPattern * globPtr, * toFree; + + globPtr = clausePtr->patterns; + while (globPtr) { + toFree = globPtr; + globPtr=globPtr->next; + + ckfree((char*)toFree->pattern); + ckfree((char*)toFree); + } + clausePtr->patterns = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * FreeMacFileTypes -- + * + * Frees the malloc'ed Mac file types in a clause + * + * Results: + * None. + * + * Side effects: + * The list of Mac file types in clausePtr->macTypes are freed. + *---------------------------------------------------------------------- + */ + +static void +FreeMacFileTypes(clausePtr) + FileFilterClause * clausePtr; /* The clause whose mac types are to be + * freed */ +{ + MacFileType * mfPtr, * toFree; + + mfPtr = clausePtr->macTypes; + while (mfPtr) { + toFree = mfPtr; + mfPtr=mfPtr->next; + ckfree((char*)toFree); + } + clausePtr->macTypes = NULL; +} diff --git a/tk4.2/generic/tkFileFilter.h b/tk4.2/generic/tkFileFilter.h new file mode 100644 index 0000000..2b113fc --- /dev/null +++ b/tk4.2/generic/tkFileFilter.h @@ -0,0 +1,83 @@ +/* + * tkFileFilter.h -- + * + * Declarations for the file filter processing routines needed by + * the file selection dialogs. + * + * Copyright (c) 1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkFileFilter.h 1.1 96/08/27 15:05:38 + * + */ + +#ifndef _TK_FILE_FILTER +#define _TK_FILE_FILTER + +#ifdef MAC_TCL +#include +#else +#define OSType long +#endif + +typedef struct GlobPattern { + struct GlobPattern * next; /* Chains to the next glob pattern + * in a glob pattern list */ + char * pattern; /* String value of the pattern, such + * as "*.txt" or "*.*" + */ +} GlobPattern; + +typedef struct MacFileType { + struct MacFileType * next; /* Chains to the next mac file type + * in a mac file type list */ + OSType type; /* Mac file type, such as 'TEXT' or + * 'GIFF' */ +} MacFileType; + +typedef struct FileFilterClause { + struct FileFilterClause * next; /* Chains to the next clause in + * a clause list */ + GlobPattern * patterns; /* Head of glob pattern type list */ + GlobPattern * patternsTail; /* Tail of glob pattern type list */ + MacFileType * macTypes; /* Head of mac file type list */ + MacFileType * macTypesTail; /* Tail of mac file type list */ +} FileFilterClause; + +typedef struct FileFilter { + struct FileFilter * next; /* Chains to the next filter + * in a filter list */ + char * name; /* Name of the file filter, + * such as "Text Documents" */ + FileFilterClause * clauses; /* Head of the clauses list */ + FileFilterClause * clausesTail; /* Tail of the clauses list */ +} FileFilter; + +/*---------------------------------------------------------------------- + * FileFilterList -- + * + * The routine TkGetFileFilters() translates the string value of the + * -filefilters option into a FileFilterList structure, which consists + * of a list of file filters. + * + * Each file filter consists of one or more clauses. Each clause has + * one or more glob patterns and/or one or more Mac file types + *---------------------------------------------------------------------- + */ + +typedef struct FileFilterList { + FileFilter * filters; /* Head of the filter list */ + FileFilter * filtersTail; /* Tail of the filter list */ + int numFilters; /* number of filters in the list */ +} FileFilterList; + +EXTERN void TkFreeFileFilters _ANSI_ARGS_(( + FileFilterList * flistPtr)); +EXTERN void TkInitFileFilters _ANSI_ARGS_(( + FileFilterList * flistPtr)); +EXTERN int TkGetFileFilters _ANSI_ARGS_ ((Tcl_Interp *interp, + FileFilterList * flistPtr, char * string, + int isWindows)); +#endif diff --git a/tk4.2/generic/tkFocus.c b/tk4.2/generic/tkFocus.c new file mode 100644 index 0000000..0336510 --- /dev/null +++ b/tk4.2/generic/tkFocus.c @@ -0,0 +1,802 @@ +/* + * tkFocus.c -- + * + * This file contains procedures that manage the input + * focus for Tk. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkFocus.c 1.27 96/02/15 18:53:29 + */ + +#include "tkInt.h" +#include "tkPort.h" + +/* + * For each top-level window that has ever received the focus, there + * is a record of the following type: + */ + +typedef struct TkFocusInfo { + TkWindow *topLevelPtr; /* Information about top-level window. */ + TkWindow *focusWinPtr; /* The next time the focus comes to this + * top-level, it will be given to this + * window. */ + struct TkFocusInfo *nextPtr;/* Next in list of all focus records for + * a given application. */ +} FocusInfo; + +static int focusDebug = 0; + +/* + * The following magic value is stored in the "send_event" field of + * FocusIn and FocusOut events that are generated in this file. This + * allows us to separate "real" events coming from the server from + * those that we generated. + */ + +#define GENERATED_EVENT_MAGIC ((Bool) 0x547321ac) + +/* + * Forward declarations for procedures defined in this file: + */ + + +static void ChangeXFocus _ANSI_ARGS_((TkWindow *topLevelPtr, + int focus)); +static void FocusMapProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +static void GenerateFocusEvents _ANSI_ARGS_((TkWindow *sourcePtr, + TkWindow *destPtr)); +static void SetFocus _ANSI_ARGS_((TkWindow *winPtr, int force)); + +/* + *-------------------------------------------------------------- + * + * Tk_FocusCmd -- + * + * This procedure is invoked to process the "focus" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +int +Tk_FocusCmd(clientData, interp, argc, argv) + ClientData clientData; /* Main window associated with + * interpreter. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tk_Window tkwin = (Tk_Window) clientData; + TkWindow *winPtr = (TkWindow *) clientData; + TkWindow *newPtr, *focusWinPtr, *topLevelPtr; + FocusInfo *focusPtr; + char c; + size_t length; + + /* + * If invoked with no arguments, just return the current focus window. + */ + + if (argc == 1) { + focusWinPtr = TkGetFocus(winPtr); + if (focusWinPtr != NULL) { + interp->result = focusWinPtr->pathName; + } + return TCL_OK; + } + + /* + * If invoked with a single argument beginning with "." then focus + * on that window. + */ + + if (argc == 2) { + if (argv[1][0] == 0) { + return TCL_OK; + } + if (argv[1][0] == '.') { + newPtr = (TkWindow *) Tk_NameToWindow(interp, argv[1], tkwin); + if (newPtr == NULL) { + return TCL_ERROR; + } + if (!(newPtr->flags & TK_ALREADY_DEAD)) { + SetFocus(newPtr, 0); + } + return TCL_OK; + } + } + + length = strlen(argv[1]); + c = argv[1][1]; + if ((c == 'd') && (strncmp(argv[1], "-displayof", length) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " -displayof window\"", (char *) NULL); + return TCL_ERROR; + } + newPtr = (TkWindow *) Tk_NameToWindow(interp, argv[2], tkwin); + if (newPtr == NULL) { + return TCL_ERROR; + } + newPtr = TkGetFocus(newPtr); + if (newPtr != NULL) { + interp->result = newPtr->pathName; + } + } else if ((c == 'f') && (strncmp(argv[1], "-force", length) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " -force window\"", (char *) NULL); + return TCL_ERROR; + } + if (argv[2][0] == 0) { + return TCL_OK; + } + newPtr = (TkWindow *) Tk_NameToWindow(interp, argv[2], tkwin); + if (newPtr == NULL) { + return TCL_ERROR; + } + SetFocus(newPtr, 1); + } else if ((c == 'l') && (strncmp(argv[1], "-lastfor", length) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " -lastfor window\"", (char *) NULL); + return TCL_ERROR; + } + newPtr = (TkWindow *) Tk_NameToWindow(interp, argv[2], tkwin); + if (newPtr == NULL) { + return TCL_ERROR; + } + for (topLevelPtr = newPtr; topLevelPtr != NULL; + topLevelPtr = topLevelPtr->parentPtr) { + if (topLevelPtr->flags & TK_TOP_LEVEL) { + for (focusPtr = newPtr->mainPtr->focusPtr; focusPtr != NULL; + focusPtr = focusPtr->nextPtr) { + if (focusPtr->topLevelPtr == topLevelPtr) { + interp->result = focusPtr->focusWinPtr->pathName; + return TCL_OK; + } + } + interp->result = topLevelPtr->pathName; + return TCL_OK; + } + } + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be -displayof, -force, or -lastfor", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * TkFocusFilterEvent -- + * + * This procedure is invoked by Tk_HandleEvent when it encounters + * a FocusIn, FocusOut, Enter, or Leave event. + * + * Results: + * A return value of 1 means that Tk_HandleEvent should process + * the event normally (i.e. event handlers should be invoked). + * A return value of 0 means that this event should be ignored. + * + * Side effects: + * Additional events may be generated, and the focus may switch. + * + *-------------------------------------------------------------- + */ + +int +TkFocusFilterEvent(winPtr, eventPtr) + TkWindow *winPtr; /* Window that focus event is directed to. */ + XEvent *eventPtr; /* FocusIn or FocusOut event. */ +{ + /* + * Design notes: the window manager and X server work together to + * transfer the focus among top-level windows. This procedure takes + * care of transferring the focus from a top-level window to the + * actual window within that top-level that has the focus. We + * do this by synthesizing X events to move the focus around. None + * of the FocusIn and FocusOut events generated by X are ever used + * outside of this procedure; only the synthesized events get through + * to the rest of the application. At one point (e.g. Tk4.0b1) Tk + * used to call X to move the focus from a top-level to one of its + * descendants, then just pass through the events generated by X. + * This approach didn't work very well, for a variety of reasons. + * For example, if X generates the events they go at the back of + * the event queue, which could cause problems if other things + * have already happened, such as moving the focus to yet another + * window. + */ + + FocusInfo *focusPtr; + TkDisplay *dispPtr = winPtr->dispPtr; + TkWindow *newFocusPtr; + int retValue, delta; + + /* + * If this was a generated event, just turn off the generated + * flag and pass the event through. + */ + + if (eventPtr->xfocus.send_event == GENERATED_EVENT_MAGIC) { + eventPtr->xfocus.send_event = 0; + return 1; + } + + /* + * This was not a generated event. We'll return 1 (so that the + * event will be processed) if it's an Enter or Leave event, and + * 0 (so that the event won't be processed) if it's a FocusIn or + * FocusOut event. Also, skip NotifyPointer, NotifyPointerRoot, + * and NotifyInferior focus events immediately; they're not + * useful and tend to cause confusion. + */ + + if ((eventPtr->type == FocusIn) || (eventPtr->type == FocusOut)) { + retValue = 0; + if ((eventPtr->xfocus.detail == NotifyPointer) + || (eventPtr->xfocus.detail == NotifyPointerRoot) + || (eventPtr->xfocus.detail == NotifyInferior)) { + return retValue; + } + } else { + retValue = 1; + if (eventPtr->xcrossing.detail == NotifyInferior) { + return retValue; + } + } + + /* + * If winPtr isn't a top-level window than just ignore the event. + */ + + if (!(winPtr->flags & TK_TOP_LEVEL)) { + return retValue; + } + + /* + * If there is a grab in effect and this window is outside the + * grabbed tree, then ignore the event. + */ + + if (TkGrabState(winPtr) == TK_GRAB_EXCLUDED) { + return retValue; + } + + /* + * Find the FocusInfo structure for the window, and make a new one + * if there isn't one already. + */ + + for (focusPtr = winPtr->mainPtr->focusPtr; focusPtr != NULL; + focusPtr = focusPtr->nextPtr) { + if (focusPtr->topLevelPtr == winPtr) { + break; + } + } + if (focusPtr == NULL) { + focusPtr = (FocusInfo *) ckalloc(sizeof(FocusInfo)); + focusPtr->topLevelPtr = focusPtr->focusWinPtr = winPtr; + focusPtr->nextPtr = winPtr->mainPtr->focusPtr; + winPtr->mainPtr->focusPtr = focusPtr; + } + + /* + * It is possible that there were outstanding FocusIn and FocusOut + * events on their way to us at the time the focus was changed + * internally with the "focus" command. If so, these events could + * potentially cause us to lose the focus (switch it to the window + * of the last FocusIn event) even though the focus change occurred + * after those events. The following code detects this and puts + * the focus back to the place where it was rightfully set. + */ + + newFocusPtr = focusPtr->focusWinPtr; + delta = eventPtr->xfocus.serial - winPtr->mainPtr->focusSerial; + if (focusDebug) { + printf("check event serial %d, delta %d\n", + (int) eventPtr->xfocus.serial, delta); + } + if ((delta < 0) && (winPtr->mainPtr->lastFocusPtr != NULL)) { + newFocusPtr = winPtr->mainPtr->lastFocusPtr; + if (focusDebug) { + printf("reverting to %s instead of %s\n", newFocusPtr->pathName, + focusPtr->focusWinPtr->pathName); + } + } + + if (eventPtr->type == FocusIn) { + GenerateFocusEvents(dispPtr->focusWinPtr, newFocusPtr); + dispPtr->focusWinPtr = newFocusPtr; + dispPtr->implicitWinPtr = NULL; + if (focusDebug) { + printf("Focussed on %s\n", newFocusPtr->pathName); + } + } else if (eventPtr->type == FocusOut) { + GenerateFocusEvents(dispPtr->focusWinPtr, (TkWindow *) NULL); + dispPtr->focusWinPtr = NULL; + dispPtr->implicitWinPtr = NULL; + if (focusDebug) { + printf("Unfocussed from %s, detail %d\n", winPtr->pathName, + eventPtr->xfocus.detail); + } + } else if (eventPtr->type == EnterNotify) { + /* + * If there is no window manager, or if the window manager isn't + * moving the focus around (e.g. the disgusting "NoTitleFocus" + * option has been selected in twm), then we won't get FocusIn + * or FocusOut events. Instead, the "focus" field will be set + * in an Enter event to indicate that we've already got the focus + * when then mouse enters the window (even though we didn't get + * a FocusIn event). Watch for this and grab the focus when it + * happens. + */ + + if (eventPtr->xcrossing.focus && (dispPtr->focusWinPtr == NULL)) { + GenerateFocusEvents(dispPtr->focusWinPtr, newFocusPtr); + dispPtr->focusWinPtr = newFocusPtr; + dispPtr->implicitWinPtr = winPtr; + if (focusDebug) { + printf("Focussed implicitly on %s\n", + newFocusPtr->pathName); + } + } + } else if (eventPtr->type == LeaveNotify) { + /* + * If the pointer just left a window for which we automatically + * claimed the focus on enter, generate FocusOut events. Note: + * dispPtr->implicitWinPtr may not be the same as + * dispPtr->focusWinPtr (e.g. because the "focus" command was + * used to redirect the focus after it arrived at + * dispPtr->implicitWinPtr)!! + */ + + if (dispPtr->implicitWinPtr == winPtr) { + GenerateFocusEvents(dispPtr->focusWinPtr, (TkWindow *) NULL); + dispPtr->focusWinPtr = NULL; + dispPtr->implicitWinPtr = NULL; + if (focusDebug) { + printf("Defocussed implicitly\n"); + } + } + } + return retValue; +} + +/* + *---------------------------------------------------------------------- + * + * SetFocus -- + * + * This procedure is invoked to change the focus window for a + * given display in a given application. + * + * Results: + * None. + * + * Side effects: + * Event handlers may be invoked to process the change of + * focus. + * + *---------------------------------------------------------------------- + */ + +static void +SetFocus(winPtr, force) + TkWindow *winPtr; /* Window that is to be the new focus for + * its display and application. */ + int force; /* If non-zero, set the X focus to this + * window even if the application doesn't + * currently have the X focus. */ +{ + TkDisplay *dispPtr = winPtr->dispPtr; + FocusInfo *focusPtr; + TkWindow *topLevelPtr, *topLevelPtr2; + + if (winPtr == dispPtr->focusWinPtr) { + return; + } + + /* + * Find the top-level window for winPtr, then find (or create) + * a record for the top-level. + */ + + for (topLevelPtr = winPtr; ; topLevelPtr = topLevelPtr->parentPtr) { + if (topLevelPtr == NULL) { + /* + * The window is being deleted. No point in worrying about + * giving it the focus. + */ + + return; + } + if (topLevelPtr->flags & TK_TOP_LEVEL) { + break; + } + } + for (focusPtr = winPtr->mainPtr->focusPtr; focusPtr != NULL; + focusPtr = focusPtr->nextPtr) { + if (focusPtr->topLevelPtr == topLevelPtr) { + break; + } + } + if (focusPtr == NULL) { + focusPtr = (FocusInfo *) ckalloc(sizeof(FocusInfo)); + focusPtr->topLevelPtr = topLevelPtr; + focusPtr->nextPtr = winPtr->mainPtr->focusPtr; + winPtr->mainPtr->focusPtr = focusPtr; + } + + /* + * Reset the focus, but only if the application already has the + * input focus or "force" has been specified. + */ + + focusPtr->focusWinPtr = winPtr; + Tk_MakeWindowExist((Tk_Window) winPtr); + if (force || ((dispPtr->focusWinPtr != NULL) + && (dispPtr->focusWinPtr->mainPtr == winPtr->mainPtr))) { + /* + * Reset the focus in X if it has changed top-levels and if the + * new top-level isn't override-redirect (the only reason to + * change the X focus is so that the window manager can redecorate + * the focus window, but if it's override-redirect then it won't + * be decorated anyway; also, changing the focus to menus causes + * all sorts of problems with olvwm: the focus gets lost if + * keyboard traversal is used to move among menus. + */ + + if (dispPtr->focusWinPtr != NULL) { + for (topLevelPtr2 = dispPtr->focusWinPtr; + (topLevelPtr2 != NULL) + && !(topLevelPtr2->flags & TK_TOP_LEVEL); + topLevelPtr2 = topLevelPtr2->parentPtr) { + /* Empty loop body. */ + } + } else { + topLevelPtr2 = NULL; + } + if ((topLevelPtr2 != topLevelPtr) + && !(topLevelPtr->atts.override_redirect)) { + if (dispPtr->focusOnMapPtr != NULL) { + Tk_DeleteEventHandler((Tk_Window) dispPtr->focusOnMapPtr, + StructureNotifyMask, FocusMapProc, + (ClientData) dispPtr->focusOnMapPtr); + dispPtr->focusOnMapPtr = NULL; + } + if (topLevelPtr->flags & TK_MAPPED) { + ChangeXFocus(topLevelPtr, force); + } else { + /* + * The window isn't mapped, so we can't give it the focus + * right now. Create an event handler that will give it + * the focus as soon as it is mapped. + */ + + Tk_CreateEventHandler((Tk_Window) topLevelPtr, + StructureNotifyMask, FocusMapProc, + (ClientData) topLevelPtr); + dispPtr->focusOnMapPtr = topLevelPtr; + dispPtr->forceFocus = force; + } + } + GenerateFocusEvents(dispPtr->focusWinPtr, winPtr); + dispPtr->focusWinPtr = winPtr; + } + + /* + * Remember the current serial number for the X server and issue + * a dummy server request. This marks the position at which we + * changed the focus, so we can distinguish FocusIn and FocusOut + * events on either side of the mark. + */ + + winPtr->mainPtr->lastFocusPtr = winPtr; + winPtr->mainPtr->focusSerial = NextRequest(winPtr->display); + XNoOp(winPtr->display); + if (focusDebug) { + printf("focus marking for %s at %d\n", winPtr->pathName, + (int) winPtr->mainPtr->focusSerial); + } +} + +/* + *---------------------------------------------------------------------- + * + * TkGetFocus -- + * + * Given a window, this procedure returns the current focus + * window for its application and display. + * + * Results: + * The return value is a pointer to the window that currently + * has the input focus for the specified application and + * display, or NULL if none. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +TkWindow * +TkGetFocus(winPtr) + TkWindow *winPtr; /* Window that selects an application + * and a display. */ +{ + TkWindow *focusWinPtr; + + focusWinPtr = winPtr->dispPtr->focusWinPtr; + if ((focusWinPtr != NULL) && (focusWinPtr->mainPtr == winPtr->mainPtr)) { + return focusWinPtr; + } + return (TkWindow *) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TkFocusDeadWindow -- + * + * This procedure is invoked when it is determined that + * a window is dead. It cleans up focus-related information + * about the window. + * + * Results: + * None. + * + * Side effects: + * Various things get cleaned up and recycled. + * + *---------------------------------------------------------------------- + */ + +void +TkFocusDeadWindow(winPtr) + register TkWindow *winPtr; /* Information about the window + * that is being deleted. */ +{ + FocusInfo *focusPtr, *prevPtr; + TkDisplay *dispPtr = winPtr->dispPtr; + + /* + * Search for focus records that refer to this window either as + * the top-level window or the current focus window. + */ + + for (prevPtr = NULL, focusPtr = winPtr->mainPtr->focusPtr; + focusPtr != NULL; + prevPtr = focusPtr, focusPtr = focusPtr->nextPtr) { + if (winPtr == focusPtr->topLevelPtr) { + /* + * The top-level window is the one being deleted: free + * the focus record and release the focus back to PointerRoot + * if we acquired it implicitly. + */ + + if (dispPtr->implicitWinPtr == winPtr) { + if (focusDebug) { + printf("releasing focus to root after %s died\n", + focusPtr->topLevelPtr->pathName); + } + dispPtr->implicitWinPtr = NULL; + dispPtr->focusWinPtr = NULL; + } + if (dispPtr->focusWinPtr == focusPtr->focusWinPtr) { + dispPtr->focusWinPtr = NULL; + } + if (dispPtr->focusOnMapPtr == focusPtr->topLevelPtr) { + dispPtr->focusOnMapPtr = NULL; + } + if (prevPtr == NULL) { + winPtr->mainPtr->focusPtr = focusPtr->nextPtr; + } else { + prevPtr->nextPtr = focusPtr->nextPtr; + } + ckfree((char *) focusPtr); + break; + } else if (winPtr == focusPtr->focusWinPtr) { + /* + * The deleted window had the focus for its top-level: + * move the focus to the top-level itself. + */ + + focusPtr->focusWinPtr = focusPtr->topLevelPtr; + if ((dispPtr->focusWinPtr == winPtr) + && !(focusPtr->topLevelPtr->flags & TK_ALREADY_DEAD)) { + if (focusDebug) { + printf("forwarding focus to %s after %s died\n", + focusPtr->topLevelPtr->pathName, winPtr->pathName); + } + GenerateFocusEvents(dispPtr->focusWinPtr, + focusPtr->topLevelPtr); + dispPtr->focusWinPtr = focusPtr->topLevelPtr; + } + break; + } + } + + if (winPtr->mainPtr->lastFocusPtr == winPtr) { + winPtr->mainPtr->lastFocusPtr = NULL; + } +} + +/* + *---------------------------------------------------------------------- + * + * GenerateFocusEvents -- + * + * This procedure is called to create FocusIn and FocusOut events to + * move the input focus from one window to another. + * + * Results: + * None. + * + * Side effects: + * FocusIn and FocusOut events are generated. + * + *---------------------------------------------------------------------- + */ + +static void +GenerateFocusEvents(sourcePtr, destPtr) + TkWindow *sourcePtr; /* Window that used to have the focus (may + * be NULL). */ + TkWindow *destPtr; /* New window to have the focus (may be + * NULL). */ + +{ + XEvent event; + TkWindow *winPtr; + + winPtr = sourcePtr; + if (winPtr == NULL) { + winPtr = destPtr; + if (winPtr == NULL) { + return; + } + } + + event.xfocus.serial = LastKnownRequestProcessed(winPtr->display); + event.xfocus.send_event = GENERATED_EVENT_MAGIC; + event.xfocus.display = winPtr->display; + event.xfocus.mode = NotifyNormal; + TkInOutEvents(&event, sourcePtr, destPtr, FocusOut, FocusIn, + TCL_QUEUE_MARK); +} + +/* + *---------------------------------------------------------------------- + * + * ChangeXFocus -- + * + * This procedure is invoked to move the official X focus from + * one top-level to another. We do this when the application + * changes the focus window from one top-level to another, in + * order to notify the window manager so that it can highlight + * the new focus top-level. + * + * Results: + * None. + * + * Side effects: + * The official X focus window changes; the application's focus + * window isn't changed by this procedure. + * + *---------------------------------------------------------------------- + */ + +static void +ChangeXFocus(topLevelPtr, force) + TkWindow *topLevelPtr; /* Top-level window that is to receive + * the X focus. */ + int force; /* Non-zero means claim the focus even + * if it didn't originally belong to + * topLevelPtr's application. */ +{ + TkDisplay *dispPtr = topLevelPtr->dispPtr; + TkWindow *winPtr; + Window focusWindow; + int dummy; + Tk_ErrorHandler errHandler; + + /* + * If the focus was received implicitly, then there's no advantage + * in setting an explicit focus; just return. + */ + + if (dispPtr->implicitWinPtr != NULL) { + return; + } + + /* + * Check to make sure that the focus is still in one of the + * windows of this application. Furthermore, grab the server + * to make sure that the focus doesn't change in the middle + * of this operation. + */ + + if (!focusDebug) { + XGrabServer(dispPtr->display); + } + if (!force) { + XGetInputFocus(dispPtr->display, &focusWindow, &dummy); + winPtr = (TkWindow *) Tk_IdToWindow(dispPtr->display, focusWindow); + if ((winPtr == NULL) || (winPtr->mainPtr != topLevelPtr->mainPtr)) { + goto done; + } + } + + /* + * Tell X to change the focus. Ignore errors that occur when changing + * the focus: it is still possible that the window we're focussing + * to could have gotten unmapped, which will generate an error. + */ + + errHandler = Tk_CreateErrorHandler(dispPtr->display, -1, -1, -1, + (Tk_ErrorProc *) NULL, (ClientData) NULL); + XSetInputFocus(dispPtr->display, topLevelPtr->window, RevertToParent, + CurrentTime); + Tk_DeleteErrorHandler(errHandler); + if (focusDebug) { + printf("Set X focus to %s\n", topLevelPtr->pathName); + } + + done: + if (!focusDebug) { + XUngrabServer(dispPtr->display); + } +} + +/* + *---------------------------------------------------------------------- + * + * FocusMapProc -- + * + * This procedure is called as an event handler for StructureNotify + * events, if a window receives the focus at a time when its + * toplevel isn't mapped. The procedure is needed because X + * won't allow the focus to be set to an unmapped window; we + * detect when the toplevel is mapped and set the focus to it then. + * + * Results: + * None. + * + * Side effects: + * If this is a map event, the focus gets set to the toplevel + * given by clientData. + * + *---------------------------------------------------------------------- + */ + +static void +FocusMapProc(clientData, eventPtr) + ClientData clientData; /* Toplevel window. */ + XEvent *eventPtr; /* Information about event. */ +{ + TkWindow *winPtr = (TkWindow *) clientData; + TkDisplay *dispPtr = winPtr->dispPtr; + + if (eventPtr->type == MapNotify) { + ChangeXFocus(winPtr, dispPtr->forceFocus); + Tk_DeleteEventHandler((Tk_Window) winPtr, StructureNotifyMask, + FocusMapProc, clientData); + dispPtr->focusOnMapPtr = NULL; + } +} diff --git a/tk3.6/tkFont.c b/tk4.2/generic/tkFont.c similarity index 69% rename from tk3.6/tkFont.c rename to tk4.2/generic/tkFont.c index 1df99b7..622ce18 100644 --- a/tk3.6/tkFont.c +++ b/tk4.2/generic/tkFont.c @@ -3,34 +3,19 @@ * * This file maintains a database of looked-up fonts for the Tk * toolkit, in order to avoid round-trips to the server to map - * font names to XFontStructs. + * font names to XFontStructs. It also provides several utility + * procedures for measuring and displaying text. * - * Copyright (c) 1990-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tkFont.c 1.38 96/02/15 18:53:31 */ -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkFont.c,v 1.24 93/08/18 16:25:30 ouster Exp $ SPRITE (Berkeley)"; -#endif - -#include "tkConfig.h" +#include "tkPort.h" #include "tkInt.h" /* @@ -46,8 +31,10 @@ static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkFont.c,v 1.24 93/08/18 * on this line (character has infinite width). * REPLACE: This character doesn't print: instead of * displaying character, display a replacement - * sequence of the form "\xdd" where dd is the - * hex equivalent of the character. + * sequence like "\n" (for those characters where + * ANSI C defines such a sequence) or a sequence + * of the form "\xdd" where dd is the hex equivalent + * of the character. * SKIP: Don't display anything for this character. This * is only used where the font doesn't contain * all the characters needed to generate @@ -112,11 +99,23 @@ static TkFont *lastFontPtr = NULL; static XFontStruct *lastFontStructPtr = NULL; /* - * Characters used when displaying control sequences as their - * hex equivalents. + * Characters used when displaying control sequences. */ -static char hexChars[] = "0123456789abcdefx\\"; +static char hexChars[] = "0123456789abcdefxtnvr\\"; + +/* + * The following table maps some control characters to sequences + * like '\n' rather than '\x10'. A zero entry in the table means + * no such mapping exists, and the table only maps characters + * less than 0x10. + */ + +static char mapChars[] = { + 0, 0, 0, 0, 0, 0, 0, + 'a', 'b', 't', 'n', 'v', 'f', 'r', + 0 +}; /* * Forward declarations for procedures defined in this file: @@ -239,7 +238,7 @@ Tk_NameOfFontStruct(fontStructPtr) if (!initialized) { printid: - sprintf(string, "font id 0x%x", fontStructPtr->fid); + sprintf(string, "font id 0x%x", (unsigned int) fontStructPtr->fid); return string; } fontHashPtr = Tcl_FindHashEntry(&fontTable, (char *) fontStructPtr); @@ -287,6 +286,17 @@ Tk_FreeFontStruct(fontStructPtr) fontPtr = (TkFont *) Tcl_GetHashValue(fontHashPtr); fontPtr->refCount--; if (fontPtr->refCount == 0) { + /* + * We really should call Tk_FreeXId below to release the font's + * resource identifier, but this seems to cause problems on + * many X servers (as of 5/1/94) where the font resource isn't + * really released, which can cause the wrong font to be used + * later on. So, don't release the resource id after all, even + * though this results in an id leak. + * + * Tk_FreeXId(fontPtr->display, (XID) fontPtr->fontStructPtr->fid); + */ + XFreeFont(fontPtr->display, fontPtr->fontStructPtr); Tcl_DeleteHashEntry(fontPtr->nameHashPtr); Tcl_DeleteHashEntry(fontHashPtr); @@ -347,7 +357,7 @@ SetFontMetrics(fontPtr) register TkFont *fontPtr; /* Font structure in which to * set metrics. */ { - int i, replaceOK, baseWidth; + int i, replaceOK; register XFontStruct *fontStructPtr = fontPtr->fontStructPtr; char *p; @@ -367,7 +377,7 @@ SetFontMetrics(fontPtr) * information. */ - for (i = ' '; i < 256; i++) { + for (i = 0; i < 256; i++) { if ((i == 0177) || (i < fontStructPtr->min_char_or_byte2) || (i > fontStructPtr->max_char_or_byte2)) { continue; @@ -383,13 +393,12 @@ SetFontMetrics(fontPtr) /* * Pass 3: fill in information for characters that have to - * be replaced with "\xhh" strings. If the font doesn't + * be replaced with "\xhh" or "\n" strings. If the font doesn't * have the characters needed for this, then just use the * font's default character. */ replaceOK = 1; - baseWidth = fontPtr->widths['\\'] + fontPtr->widths['x']; for (p = hexChars; *p != 0; p++) { if (fontPtr->types[*p] != NORMAL) { replaceOK = 0; @@ -401,9 +410,15 @@ SetFontMetrics(fontPtr) continue; } if (replaceOK) { - fontPtr->widths[i] = baseWidth - + fontPtr->widths[hexChars[i & 0xf]] - + fontPtr->widths[hexChars[(i>>4) & 0xf]]; + if ((i < sizeof(mapChars)) && (mapChars[i] != 0)) { + fontPtr->widths[i] = fontPtr->widths['\\'] + + fontPtr->widths[mapChars[i]]; + } else { + fontPtr->widths[i] = fontPtr->widths['\\'] + + fontPtr->widths['x'] + + fontPtr->widths[hexChars[i & 0xf]] + + fontPtr->widths[hexChars[(i>>4) & 0xf]]; + } } else { fontPtr->types[i] = SKIP; fontPtr->widths[i] = 0; @@ -415,7 +430,6 @@ SetFontMetrics(fontPtr) */ fontPtr->types['\n'] = NEWLINE; - fontPtr->widths['\n'] = 0; fontPtr->types['\t'] = TAB; fontPtr->widths['\t'] = 0; if (fontPtr->types['0'] == NORMAL) { @@ -458,7 +472,8 @@ SetFontMetrics(fontPtr) */ int -TkMeasureChars(fontStructPtr, source, maxChars, startX, maxX, flags, nextXPtr) +TkMeasureChars(fontStructPtr, source, maxChars, startX, maxX, + tabOrigin, flags, nextXPtr) XFontStruct *fontStructPtr; /* Font in which to draw characters. */ char *source; /* Characters to be displayed. Need not * be NULL-terminated. */ @@ -468,6 +483,8 @@ TkMeasureChars(fontStructPtr, source, maxChars, startX, maxX, flags, nextXPtr) * be drawn. */ int maxX; /* Don't consider any character that would * cross this x-position. */ + int tabOrigin; /* X-location that serves as "origin" for + * tab stops. */ int flags; /* Various flag bits OR-ed together. * TK_WHOLE_WORDS means stop on a word boundary * (just before a space character) if @@ -478,7 +495,9 @@ TkMeasureChars(fontStructPtr, source, maxChars, startX, maxX, flags, nextXPtr) * a part of the last character in the line. * TK_NEWLINES_NOT_SPECIAL means that newlines * are treated just like other control chars: - * they don't terminate the line,*/ + * they don't terminate the line. + * TK_IGNORE_TABS means give all tabs zero + * width. */ int *nextXPtr; /* Return x-position of terminating * character here. */ { @@ -491,6 +510,7 @@ TkMeasureChars(fontStructPtr, source, maxChars, startX, maxX, flags, nextXPtr) int curX; /* X-position corresponding to p. */ int newX; /* X-position corresponding to p+1. */ int type; + int rem; /* * Find the TkFont structure for this font, and make sure its @@ -529,28 +549,39 @@ TkMeasureChars(fontStructPtr, source, maxChars, startX, maxX, flags, nextXPtr) term = source; for (p = source, c = *p & 0xff; maxChars > 0; p++, maxChars--) { type = fontPtr->types[c]; - if (type == NORMAL) { + if ((type == NORMAL) || (type == REPLACE)) { newX += fontPtr->widths[c]; } else if (type == TAB) { - newX += fontPtr->tabWidth; - newX -= newX % fontPtr->tabWidth; - } else if (type == REPLACE) { - replaceType: - newX += fontPtr->widths['\\'] + fontPtr->widths['x'] - + fontPtr->widths[hexChars[(c >> 4) & 0xf]] - + fontPtr->widths[hexChars[c & 0xf]]; + if (!(flags & TK_IGNORE_TABS)) { + newX += fontPtr->tabWidth; + rem = (newX - tabOrigin) % fontPtr->tabWidth; + if (rem < 0) { + rem += fontPtr->tabWidth; + } + newX -= rem; + } } else if (type == NEWLINE) { if (flags & TK_NEWLINES_NOT_SPECIAL) { - goto replaceType; + newX += fontPtr->widths[c]; + } else { + break; } - break; } else if (type != SKIP) { panic("Unknown type %d in TkMeasureChars", type); } if (newX > maxX) { break; } - c = p[1] & 0xff; + if (maxChars > 1) { + c = p[1] & 0xff; + } else { + /* + * Can't look at next character: it could be in uninitialized + * memory. + */ + + c = 0; + } if (isspace(UCHAR(c)) || (c == 0)) { term = p+1; termX = newX; @@ -604,7 +635,7 @@ TkMeasureChars(fontStructPtr, source, maxChars, startX, maxX, flags, nextXPtr) void TkDisplayChars(display, drawable, gc, fontStructPtr, string, numChars, - x, y, flags) + x, y, tabOrigin, flags) Display *display; /* Display on which to draw. */ Drawable drawable; /* Window or pixmap in which to draw. */ GC gc; /* Graphics context for actually drawing @@ -616,10 +647,12 @@ TkDisplayChars(display, drawable, gc, fontStructPtr, string, numChars, int numChars; /* Number of characters to display from * string. */ int x, y; /* Coordinates at which to draw string. */ + int tabOrigin; /* X-location that serves as "origin" for + * tab stops. */ int flags; /* Flags to control display. Only - * TK_NEWLINES_NOT_SPECIAL is supported right - * now. See TkMeasureChars for information - * about it. */ + * TK_NEWLINES_NOT_SPECIAL and TK_IGNORE_TABS + * are supported right now. See + * TkMeasureChars for information about it. */ { register TkFont *fontPtr; register char *p; /* Current character being scanned. */ @@ -629,6 +662,7 @@ TkDisplayChars(display, drawable, gc, fontStructPtr, string, numChars, int startX; /* X-coordinate corresponding to start. */ int curX; /* X-coordinate corresponding to p. */ char replace[10]; + int rem; /* * Find the TkFont structure for this font, and make sure its @@ -677,24 +711,35 @@ TkDisplayChars(display, drawable, gc, fontStructPtr, string, numChars, startX = curX; } if (type == TAB) { - curX += fontPtr->tabWidth; - curX -= curX % fontPtr->tabWidth; - } else if (type == REPLACE) { - doReplace: - replace[0] = '\\'; - replace[1] = 'x'; - replace[2] = hexChars[(c >> 4) & 0xf]; - replace[3] = hexChars[c & 0xf]; - XDrawString(display, drawable, gc, startX, y, replace, 4); - curX += fontPtr->widths[replace[0]] - + fontPtr->widths[replace[1]] - + fontPtr->widths[replace[2]] - + fontPtr->widths[replace[3]]; - } else if (type == NEWLINE) { - if (flags & TK_NEWLINES_NOT_SPECIAL) { - goto doReplace; + if (!(flags & TK_IGNORE_TABS)) { + curX += fontPtr->tabWidth; + rem = (curX - tabOrigin) % fontPtr->tabWidth; + if (rem < 0) { + rem += fontPtr->tabWidth; + } + curX -= rem; } - y += fontStructPtr->ascent + fontStructPtr->descent; + } else if (type == REPLACE || + (type == NEWLINE && flags & TK_NEWLINES_NOT_SPECIAL)) { + if ((c < sizeof(mapChars)) && (mapChars[c] != 0)) { + replace[0] = '\\'; + replace[1] = mapChars[c]; + XDrawString(display, drawable, gc, startX, y, replace, 2); + curX += fontPtr->widths[replace[0]] + + fontPtr->widths[replace[1]]; + } else { + replace[0] = '\\'; + replace[1] = 'x'; + replace[2] = hexChars[(c >> 4) & 0xf]; + replace[3] = hexChars[c & 0xf]; + XDrawString(display, drawable, gc, startX, y, replace, 4); + curX += fontPtr->widths[replace[0]] + + fontPtr->widths[replace[1]] + + fontPtr->widths[replace[2]] + + fontPtr->widths[replace[3]]; + } + } else if (type == NEWLINE) { + y += fontStructPtr->ascent + fontStructPtr->descent; curX = x; } else if (type != SKIP) { panic("Unknown type %d in TkDisplayChars", type); @@ -734,7 +779,7 @@ TkDisplayChars(display, drawable, gc, fontStructPtr, string, numChars, void TkUnderlineChars(display, drawable, gc, fontStructPtr, string, x, y, - flags, firstChar, lastChar) + tabOrigin, flags, firstChar, lastChar) Display *display; /* Display on which to draw. */ Drawable drawable; /* Window or pixmap in which to draw. */ GC gc; /* Graphics context for actually drawing @@ -746,6 +791,8 @@ TkUnderlineChars(display, drawable, gc, fontStructPtr, string, x, y, * underlined. */ int x, y; /* Coordinates at which first character of * string is drawn. */ + int tabOrigin; /* X-location that serves as "origin" for + * tab stops. */ int flags; /* Flags that were passed to TkDisplayChars. */ int firstChar; /* Index of first character to underline. */ int lastChar; /* Index of last character to underline. */ @@ -773,12 +820,158 @@ TkUnderlineChars(display, drawable, gc, fontStructPtr, string, x, y, * Now compute the horizontal span of the underline. */ - TkMeasureChars(fontStructPtr, string, firstChar, x, (int) 1000000, flags, - &xUnder); + TkMeasureChars(fontStructPtr, string, firstChar, x, (int) 1000000, + tabOrigin, flags, &xUnder); TkMeasureChars(fontStructPtr, string+firstChar, lastChar+1-firstChar, - xUnder, (int) 1000000, flags, &width); + xUnder, (int) 1000000, tabOrigin, flags, &width); width -= xUnder; XFillRectangle(display, drawable, gc, xUnder, yUnder, (unsigned int) width, (unsigned int) height); } + +/* + *---------------------------------------------------------------------- + * + * TkComputeTextGeometry -- + * + * This procedure computes the amount of screen space needed to + * display a multi-line string of text. + * + * Results: + * There is no return value. The dimensions of the screen area + * needed to display the text are returned in *widthPtr, and *heightPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TkComputeTextGeometry(fontStructPtr, string, numChars, wrapLength, + widthPtr, heightPtr) + XFontStruct *fontStructPtr; /* Font that will be used to display text. */ + char *string; /* String whose dimensions are to be + * computed. */ + int numChars; /* Number of characters to consider from + * string. */ + int wrapLength; /* Longest permissible line length, in + * pixels. <= 0 means no automatic wrapping: + * just let lines get as long as needed. */ + int *widthPtr; /* Store width of string here. */ + int *heightPtr; /* Store height of string here. */ +{ + int thisWidth, maxWidth, numLines; + char *p; + + if (wrapLength <= 0) { + wrapLength = INT_MAX; + } + maxWidth = 0; + for (numLines = 1, p = string; (p - string) < numChars; numLines++) { + p += TkMeasureChars(fontStructPtr, p, numChars - (p - string), 0, + wrapLength, 0, TK_WHOLE_WORDS|TK_AT_LEAST_ONE, &thisWidth); + if (thisWidth > maxWidth) { + maxWidth = thisWidth; + } + if (*p == 0) { + break; + } + + /* + * If the character that didn't fit in this line was a white + * space character then skip it. + */ + + if (isspace(UCHAR(*p))) { + p++; + } + } + *widthPtr = maxWidth; + *heightPtr = numLines * (fontStructPtr->ascent + fontStructPtr->descent); +} + +/* + *---------------------------------------------------------------------- + * + * TkDisplayText -- + * + * Display a text string on one or more lines. + * + * Results: + * None. + * + * Side effects: + * The text given by "string" gets displayed at the given location + * in the given drawable with the given font etc. + * + *---------------------------------------------------------------------- + */ + +void +TkDisplayText(display, drawable, fontStructPtr, string, numChars, x, y, + length, justify, underline, gc) + Display *display; /* X display to use for drawing text. */ + Drawable drawable; /* Window or pixmap in which to draw the + * text. */ + XFontStruct *fontStructPtr; /* Font that determines geometry of text + * (should be same as font in gc). */ + char *string; /* String to display; may contain embedded + * newlines. */ + int numChars; /* Number of characters to use from string. */ + int x, y; /* Pixel coordinates within drawable of + * upper left corner of display area. */ + int length; /* Line length in pixels; used to compute + * word wrap points and also for + * justification. Must be > 0. */ + Tk_Justify justify; /* How to justify lines. */ + int underline; /* Index of character to underline, or < 0 + * for no underlining. */ + GC gc; /* Graphics context to use for drawing text. */ +{ + char *p; + int charsThisLine, lengthThisLine, xThisLine; + + /* + * Work through the string one line at a time. Display each line + * in four steps: + * 1. Compute the line's length. + * 2. Figure out where to display the line for justification. + * 3. Display the line. + * 4. Underline one character if needed. + */ + + y += fontStructPtr->ascent; + for (p = string; numChars > 0; ) { + charsThisLine = TkMeasureChars(fontStructPtr, p, numChars, 0, length, + 0, TK_WHOLE_WORDS|TK_AT_LEAST_ONE, &lengthThisLine); + if (justify == TK_JUSTIFY_LEFT) { + xThisLine = x; + } else if (justify == TK_JUSTIFY_CENTER) { + xThisLine = x + (length - lengthThisLine)/2; + } else { + xThisLine = x + (length - lengthThisLine); + } + TkDisplayChars(display, drawable, gc, fontStructPtr, p, charsThisLine, + xThisLine, y, xThisLine, 0); + if ((underline >= 0) && (underline < charsThisLine)) { + TkUnderlineChars(display, drawable, gc, fontStructPtr, p, + xThisLine, y, xThisLine, 0, underline, underline); + } + p += charsThisLine; + numChars -= charsThisLine; + underline -= charsThisLine; + y += fontStructPtr->ascent + fontStructPtr->descent; + + /* + * If the character that didn't fit was a space character, skip it. + */ + + if (isspace(UCHAR(*p))) { + p++; + numChars--; + underline--; + } + } +} diff --git a/tk4.2/generic/tkFrame.c b/tk4.2/generic/tkFrame.c new file mode 100644 index 0000000..95b1bfa --- /dev/null +++ b/tk4.2/generic/tkFrame.c @@ -0,0 +1,785 @@ +/* + * tkFrame.c -- + * + * This module implements "frame" and "toplevel" widgets for + * the Tk toolkit. Frames are windows with a background color + * and possibly a 3-D effect, but not much else in the way of + * attributes. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkFrame.c 1.68 96/02/15 18:53:30 + */ + +#include "default.h" +#include "tkPort.h" +#include "tkInt.h" + +/* + * A data structure of the following type is kept for each + * frame that currently exists for this process: + */ + +typedef struct { + Tk_Window tkwin; /* Window that embodies the frame. NULL + * means that the window has been destroyed + * but the data structures haven't yet been + * cleaned up. */ + Display *display; /* Display containing widget. Used, among + * other things, so that resources can be + * freed even after tkwin has gone away. */ + Tcl_Interp *interp; /* Interpreter associated with widget. Used + * to delete widget command. */ + Tcl_Command widgetCmd; /* Token for frame's widget command. */ + char *className; /* Class name for widget (from configuration + * option). Malloc-ed. */ + int mask; /* Either FRAME or TOPLEVEL; used to select + * which configuration options are valid for + * widget. */ + char *screenName; /* Screen on which widget is created. Non-null + * only for top-levels. Malloc-ed, may be + * NULL. */ + char *visualName; /* Textual description of visual for window, + * from -visual option. Malloc-ed, may be + * NULL. */ + char *colormapName; /* Textual description of colormap for window, + * from -colormap option. Malloc-ed, may be + * NULL. */ + Colormap colormap; /* If not None, identifies a colormap + * allocated for this window, which must be + * freed when the window is deleted. */ + Tk_3DBorder border; /* Structure used to draw 3-D border and + * background. NULL means no background + * or border. */ + int borderWidth; /* Width of 3-D border (if any). */ + int relief; /* 3-d effect: TK_RELIEF_RAISED etc. */ + int highlightWidth; /* Width in pixels of highlight to draw + * around widget when it has the focus. + * 0 means don't draw a highlight. */ + XColor *highlightBgColorPtr; + /* Color for drawing traversal highlight + * area when highlight is off. */ + XColor *highlightColorPtr; /* Color for drawing traversal highlight. */ + int width; /* Width to request for window. <= 0 means + * don't request any size. */ + int height; /* Height to request for window. <= 0 means + * don't request any size. */ + Tk_Cursor cursor; /* Current cursor for window, or None. */ + char *takeFocus; /* Value of -takefocus option; not used in + * the C code, but used by keyboard traversal + * scripts. Malloc'ed, but may be NULL. */ + int flags; /* Various flags; see below for + * definitions. */ +} Frame; + +/* + * Flag bits for frames: + * + * REDRAW_PENDING: Non-zero means a DoWhenIdle handler + * has already been queued to redraw + * this window. + * GOT_FOCUS: Non-zero means this widget currently + * has the input focus. + */ + +#define REDRAW_PENDING 1 +#define GOT_FOCUS 4 + +/* + * The following flag bits are used so that there can be separate + * defaults for some configuration options for frames and toplevels. + */ + +#define FRAME TK_CONFIG_USER_BIT +#define TOPLEVEL (TK_CONFIG_USER_BIT << 1) +#define BOTH (FRAME | TOPLEVEL) + +static Tk_ConfigSpec configSpecs[] = { + {TK_CONFIG_BORDER, "-background", "background", "Background", + DEF_FRAME_BG_COLOR, Tk_Offset(Frame, border), + BOTH|TK_CONFIG_COLOR_ONLY|TK_CONFIG_NULL_OK}, + {TK_CONFIG_BORDER, "-background", "background", "Background", + DEF_FRAME_BG_MONO, Tk_Offset(Frame, border), + BOTH|TK_CONFIG_MONO_ONLY|TK_CONFIG_NULL_OK}, + {TK_CONFIG_SYNONYM, "-bd", "borderWidth", (char *) NULL, + (char *) NULL, 0, BOTH}, + {TK_CONFIG_SYNONYM, "-bg", "background", (char *) NULL, + (char *) NULL, 0, BOTH}, + {TK_CONFIG_PIXELS, "-borderwidth", "borderWidth", "BorderWidth", + DEF_FRAME_BORDER_WIDTH, Tk_Offset(Frame, borderWidth), BOTH}, + {TK_CONFIG_STRING, "-class", "class", "Class", + DEF_FRAME_CLASS, Tk_Offset(Frame, className), FRAME}, + {TK_CONFIG_STRING, "-class", "class", "Class", + DEF_TOPLEVEL_CLASS, Tk_Offset(Frame, className), TOPLEVEL}, + {TK_CONFIG_STRING, "-colormap", "colormap", "Colormap", + DEF_FRAME_COLORMAP, Tk_Offset(Frame, colormapName), + BOTH|TK_CONFIG_NULL_OK}, + {TK_CONFIG_ACTIVE_CURSOR, "-cursor", "cursor", "Cursor", + DEF_FRAME_CURSOR, Tk_Offset(Frame, cursor), BOTH|TK_CONFIG_NULL_OK}, + {TK_CONFIG_PIXELS, "-height", "height", "Height", + DEF_FRAME_HEIGHT, Tk_Offset(Frame, height), BOTH}, + {TK_CONFIG_COLOR, "-highlightbackground", "highlightBackground", + "HighlightBackground", DEF_FRAME_HIGHLIGHT_BG, + Tk_Offset(Frame, highlightBgColorPtr), BOTH}, + {TK_CONFIG_COLOR, "-highlightcolor", "highlightColor", "HighlightColor", + DEF_FRAME_HIGHLIGHT, Tk_Offset(Frame, highlightColorPtr), BOTH}, + {TK_CONFIG_PIXELS, "-highlightthickness", "highlightThickness", + "HighlightThickness", + DEF_FRAME_HIGHLIGHT_WIDTH, Tk_Offset(Frame, highlightWidth), BOTH}, + {TK_CONFIG_RELIEF, "-relief", "relief", "Relief", + DEF_FRAME_RELIEF, Tk_Offset(Frame, relief), BOTH}, + {TK_CONFIG_STRING, "-screen", "screen", "Screen", + DEF_TOPLEVEL_SCREEN, Tk_Offset(Frame, screenName), + TOPLEVEL|TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-takefocus", "takeFocus", "TakeFocus", + DEF_FRAME_TAKE_FOCUS, Tk_Offset(Frame, takeFocus), + BOTH|TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-visual", "visual", "Visual", + DEF_FRAME_VISUAL, Tk_Offset(Frame, visualName), + BOTH|TK_CONFIG_NULL_OK}, + {TK_CONFIG_PIXELS, "-width", "width", "Width", + DEF_FRAME_WIDTH, Tk_Offset(Frame, width), BOTH}, + {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, 0} +}; + +/* + * Forward declarations for procedures defined later in this file: + */ + +static int ConfigureFrame _ANSI_ARGS_((Tcl_Interp *interp, + Frame *framePtr, int argc, char **argv, + int flags)); +static void DestroyFrame _ANSI_ARGS_((char *memPtr)); +static void DisplayFrame _ANSI_ARGS_((ClientData clientData)); +static void FrameCmdDeletedProc _ANSI_ARGS_(( + ClientData clientData)); +static void FrameEventProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +static int FrameWidgetCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static void MapFrame _ANSI_ARGS_((ClientData clientData)); + +/* + *-------------------------------------------------------------- + * + * Tk_FrameCmd, Tk_ToplevelCmd -- + * + * These procedures are invoked to process the "frame" and + * "toplevel" Tcl commands. See the user documentation for + * details on what they do. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. These procedures are just wrappers; + * they call ButtonCreate to do all of the real work. + * + *-------------------------------------------------------------- + */ + +int +Tk_FrameCmd(clientData, interp, argc, argv) + ClientData clientData; /* Main window associated with + * interpreter. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + return TkCreateFrame(clientData, interp, argc, argv, 0, (char *) NULL); +} + +int +Tk_ToplevelCmd(clientData, interp, argc, argv) + ClientData clientData; /* Main window associated with + * interpreter. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + return TkCreateFrame(clientData, interp, argc, argv, 1, (char *) NULL); +} + +/* + *-------------------------------------------------------------- + * + * TkFrameCreate -- + * + * This procedure is invoked to process the "frame" and "toplevel" + * Tcl commands; it is also invoked directly by Tk_Init to create + * a new main window. See the user documentation for the "frame" + * and "toplevel" commands for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +int +TkCreateFrame(clientData, interp, argc, argv, toplevel, appName) + ClientData clientData; /* Main window associated with interpreter. + * If we're called by Tk_Init to create a + * new application, then this is NULL. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ + int toplevel; /* Non-zero means create a toplevel window, + * zero means create a frame. */ + char *appName; /* Should only be non-NULL if clientData is + * NULL: gives the base name to use for the + * new application. */ +{ + Tk_Window tkwin = (Tk_Window) clientData; + Frame *framePtr; + Tk_Window new = NULL; + char *className, *screenName, *visualName, *colormapName, *arg; + int i, c, length, depth; + Colormap colormap; + Visual *visual; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " pathName ?options?\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * Pre-process the argument list. Scan through it to find any + * "-class", "-screen", "-visual", and "-colormap" options. These + * arguments need to be processed specially, before the window + * is configured using the usual Tk mechanisms. + */ + + className = colormapName = screenName = visualName = NULL; + colormap = None; + for (i = 2; i < argc; i += 2) { + arg = argv[i]; + length = strlen(arg); + if (length < 2) { + continue; + } + c = arg[1]; + if ((c == 'c') && (strncmp(arg, "-class", strlen(arg)) == 0) + && (length >= 3)) { + className = argv[i+1]; + } else if ((c == 'c') + && (strncmp(arg, "-colormap", strlen(arg)) == 0)) { + colormapName = argv[i+1]; + } else if ((c == 's') && toplevel + && (strncmp(arg, "-screen", strlen(arg)) == 0)) { + screenName = argv[i+1]; + } else if ((c == 'v') + && (strncmp(arg, "-visual", strlen(arg)) == 0)) { + visualName = argv[i+1]; + } + } + + /* + * Create the window, and deal with the special options -classname, + * -colormap, -screenname, and -visual. The order here is tricky, + * because we want to allow values for these options to come from + * the database, yet we can't do that until the window is created. + */ + + if (screenName == NULL) { + screenName = (toplevel) ? "" : NULL; + } + if (tkwin != NULL) { + new = Tk_CreateWindowFromPath(interp, tkwin, argv[1], screenName); + } else { + /* + * We were called from Tk_Init; create a new application. + */ + + if (appName == NULL) { + panic("TkCreateFrame didn't get application name"); + } + new = TkCreateMainWindow(interp, screenName, appName); + } + if (new == NULL) { + goto error; + } + if (className == NULL) { + className = Tk_GetOption(new, "class", "Class"); + if (className == NULL) { + className = (toplevel) ? "Toplevel" : "Frame"; + } + } + Tk_SetClass(new, className); + if (visualName == NULL) { + visualName = Tk_GetOption(new, "visual", "Visual"); + } + if (colormapName == NULL) { + colormapName = Tk_GetOption(new, "colormap", "Colormap"); + } + if (visualName != NULL) { + visual = Tk_GetVisual(interp, new, visualName, &depth, + (colormapName == NULL) ? &colormap : (Colormap *) NULL); + if (visual == NULL) { + goto error; + } + Tk_SetWindowVisual(new, visual, depth, colormap); + } + if (colormapName != NULL) { + colormap = Tk_GetColormap(interp, new, colormapName); + if (colormap == None) { + goto error; + } + Tk_SetWindowColormap(new, colormap); + } + + /* + * For top-level windows, provide an initial geometry request of + * 200x200, just so the window looks nicer on the screen if it + * doesn't request a size for itself. + */ + + if (toplevel) { + Tk_GeometryRequest(new, 200, 200); + } + + /* + * Create the widget record, process configuration options, and + * create event handlers. Then fill in a few additional fields + * in the widget record from the special options. + */ + + framePtr = (Frame *) ckalloc(sizeof(Frame)); + framePtr->tkwin = new; + framePtr->display = Tk_Display(new); + framePtr->interp = interp; + framePtr->widgetCmd = Tcl_CreateCommand(interp, + Tk_PathName(new), FrameWidgetCmd, + (ClientData) framePtr, FrameCmdDeletedProc); + framePtr->className = NULL; + framePtr->mask = (toplevel) ? TOPLEVEL : FRAME; + framePtr->screenName = NULL; + framePtr->visualName = NULL; + framePtr->colormapName = NULL; + framePtr->colormap = colormap; + framePtr->border = NULL; + framePtr->borderWidth = 0; + framePtr->relief = TK_RELIEF_FLAT; + framePtr->highlightWidth = 0; + framePtr->highlightBgColorPtr = NULL; + framePtr->highlightColorPtr = NULL; + framePtr->width = 0; + framePtr->height = 0; + framePtr->cursor = None; + framePtr->takeFocus = NULL; + framePtr->flags = 0; + Tk_CreateEventHandler(new, ExposureMask|StructureNotifyMask|FocusChangeMask, + FrameEventProc, (ClientData) framePtr); + if (ConfigureFrame(interp, framePtr, argc-2, argv+2, 0) != TCL_OK) { + goto error; + } + if (toplevel) { + Tcl_DoWhenIdle(MapFrame, (ClientData) framePtr); + } + interp->result = Tk_PathName(new); + return TCL_OK; + + error: + if (new != NULL) { + Tk_DestroyWindow(new); + } + return TCL_ERROR; +} + +/* + *-------------------------------------------------------------- + * + * FrameWidgetCmd -- + * + * This procedure is invoked to process the Tcl command + * that corresponds to a frame widget. See the user + * documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +static int +FrameWidgetCmd(clientData, interp, argc, argv) + ClientData clientData; /* Information about frame widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register Frame *framePtr = (Frame *) clientData; + int result = TCL_OK; + size_t length; + int c, i; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_Preserve((ClientData) framePtr); + c = argv[1][0]; + length = strlen(argv[1]); + if ((c == 'c') && (strncmp(argv[1], "cget", length) == 0) + && (length >= 2)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " cget option\"", + (char *) NULL); + result = TCL_ERROR; + goto done; + } + result = Tk_ConfigureValue(interp, framePtr->tkwin, configSpecs, + (char *) framePtr, argv[2], framePtr->mask); + } else if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0) + && (length >= 2)) { + if (argc == 2) { + result = Tk_ConfigureInfo(interp, framePtr->tkwin, configSpecs, + (char *) framePtr, (char *) NULL, framePtr->mask); + } else if (argc == 3) { + result = Tk_ConfigureInfo(interp, framePtr->tkwin, configSpecs, + (char *) framePtr, argv[2], framePtr->mask); + } else { + /* + * Don't allow the options -class, -newcmap, -screen, + * or -visual to be changed. + */ + + for (i = 2; i < argc; i++) { + length = strlen(argv[i]); + if (length < 2) { + continue; + } + c = argv[i][1]; + if (((c == 'c') && (strncmp(argv[i], "-class", length) == 0) + && (length >= 2)) + || ((c == 'c') && (framePtr->mask == TOPLEVEL) + && (strncmp(argv[i], "-colormap", length) == 0)) + || ((c == 's') && (framePtr->mask == TOPLEVEL) + && (strncmp(argv[i], "-screen", length) == 0)) + || ((c == 'v') && (framePtr->mask == TOPLEVEL) + && (strncmp(argv[i], "-visual", length) == 0))) { + Tcl_AppendResult(interp, "can't modify ", argv[i], + " option after widget is created", (char *) NULL); + result = TCL_ERROR; + goto done; + } + } + result = ConfigureFrame(interp, framePtr, argc-2, argv+2, + TK_CONFIG_ARGV_ONLY); + } + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be cget or configure", (char *) NULL); + result = TCL_ERROR; + } + + done: + Tcl_Release((ClientData) framePtr); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * DestroyFrame -- + * + * This procedure is invoked by Tcl_EventuallyFree or Tcl_Release + * to clean up the internal structure of a frame at a safe time + * (when no-one is using it anymore). + * + * Results: + * None. + * + * Side effects: + * Everything associated with the frame is freed up. + * + *---------------------------------------------------------------------- + */ + +static void +DestroyFrame(memPtr) + char *memPtr; /* Info about frame widget. */ +{ + register Frame *framePtr = (Frame *) memPtr; + + Tk_FreeOptions(configSpecs, (char *) framePtr, framePtr->display, + framePtr->mask); + if (framePtr->colormap != None) { + Tk_FreeColormap(framePtr->display, framePtr->colormap); + } + ckfree((char *) framePtr); +} + +/* + *---------------------------------------------------------------------- + * + * ConfigureFrame -- + * + * This procedure is called to process an argv/argc list, plus + * the Tk option database, in order to configure (or + * reconfigure) a frame widget. + * + * Results: + * The return value is a standard Tcl result. If TCL_ERROR is + * returned, then interp->result contains an error message. + * + * Side effects: + * Configuration information, such as text string, colors, font, + * etc. get set for framePtr; old resources get freed, if there + * were any. + * + *---------------------------------------------------------------------- + */ + +static int +ConfigureFrame(interp, framePtr, argc, argv, flags) + Tcl_Interp *interp; /* Used for error reporting. */ + register Frame *framePtr; /* Information about widget; may or may + * not already have values for some fields. */ + int argc; /* Number of valid entries in argv. */ + char **argv; /* Arguments. */ + int flags; /* Flags to pass to Tk_ConfigureWidget. */ +{ + if (Tk_ConfigureWidget(interp, framePtr->tkwin, configSpecs, + argc, argv, (char *) framePtr, flags | framePtr->mask) != TCL_OK) { + return TCL_ERROR; + } + + if (framePtr->border != NULL) { + Tk_SetBackgroundFromBorder(framePtr->tkwin, framePtr->border); + } + if (framePtr->highlightWidth < 0) { + framePtr->highlightWidth = 0; + } + Tk_SetInternalBorder(framePtr->tkwin, + framePtr->borderWidth + framePtr->highlightWidth); + if ((framePtr->width > 0) || (framePtr->height > 0)) { + Tk_GeometryRequest(framePtr->tkwin, framePtr->width, + framePtr->height); + } + + if (Tk_IsMapped(framePtr->tkwin)) { + if (!(framePtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(DisplayFrame, (ClientData) framePtr); + } + framePtr->flags |= REDRAW_PENDING; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * DisplayFrame -- + * + * This procedure is invoked to display a frame widget. + * + * Results: + * None. + * + * Side effects: + * Commands are output to X to display the frame in its + * current mode. + * + *---------------------------------------------------------------------- + */ + +static void +DisplayFrame(clientData) + ClientData clientData; /* Information about widget. */ +{ + register Frame *framePtr = (Frame *) clientData; + register Tk_Window tkwin = framePtr->tkwin; + GC gc; + + framePtr->flags &= ~REDRAW_PENDING; + if ((framePtr->tkwin == NULL) || !Tk_IsMapped(tkwin)) { + return; + } + + if (framePtr->border != NULL) { + Tk_Fill3DRectangle(tkwin, Tk_WindowId(tkwin), + framePtr->border, framePtr->highlightWidth, + framePtr->highlightWidth, + Tk_Width(tkwin) - 2*framePtr->highlightWidth, + Tk_Height(tkwin) - 2*framePtr->highlightWidth, + framePtr->borderWidth, framePtr->relief); + } + if (framePtr->highlightWidth != 0) { + if (framePtr->flags & GOT_FOCUS) { + gc = Tk_GCForColor(framePtr->highlightColorPtr, + Tk_WindowId(tkwin)); + } else { + gc = Tk_GCForColor(framePtr->highlightBgColorPtr, + Tk_WindowId(tkwin)); + } + Tk_DrawFocusHighlight(tkwin, gc, framePtr->highlightWidth, + Tk_WindowId(tkwin)); + } +} + +/* + *-------------------------------------------------------------- + * + * FrameEventProc -- + * + * This procedure is invoked by the Tk dispatcher on + * structure changes to a frame. For frames with 3D + * borders, this procedure is also invoked for exposures. + * + * Results: + * None. + * + * Side effects: + * When the window gets deleted, internal structures get + * cleaned up. When it gets exposed, it is redisplayed. + * + *-------------------------------------------------------------- + */ + +static void +FrameEventProc(clientData, eventPtr) + ClientData clientData; /* Information about window. */ + register XEvent *eventPtr; /* Information about event. */ +{ + register Frame *framePtr = (Frame *) clientData; + + if (((eventPtr->type == Expose) && (eventPtr->xexpose.count == 0)) + || (eventPtr->type == ConfigureNotify)) { + goto redraw; + } else if (eventPtr->type == DestroyNotify) { + if (framePtr->tkwin != NULL) { + framePtr->tkwin = NULL; + Tcl_DeleteCommand(framePtr->interp, + Tcl_GetCommandName(framePtr->interp, framePtr->widgetCmd)); + } + if (framePtr->flags & REDRAW_PENDING) { + Tcl_CancelIdleCall(DisplayFrame, (ClientData) framePtr); + } + Tcl_CancelIdleCall(MapFrame, (ClientData) framePtr); + Tcl_EventuallyFree((ClientData) framePtr, DestroyFrame); + } else if (eventPtr->type == FocusIn) { + if (eventPtr->xfocus.detail != NotifyInferior) { + framePtr->flags |= GOT_FOCUS; + if (framePtr->highlightWidth > 0) { + goto redraw; + } + } + } else if (eventPtr->type == FocusOut) { + if (eventPtr->xfocus.detail != NotifyInferior) { + framePtr->flags &= ~GOT_FOCUS; + if (framePtr->highlightWidth > 0) { + goto redraw; + } + } + } + return; + + redraw: + if ((framePtr->tkwin != NULL) && !(framePtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(DisplayFrame, (ClientData) framePtr); + framePtr->flags |= REDRAW_PENDING; + } +} + +/* + *---------------------------------------------------------------------- + * + * FrameCmdDeletedProc -- + * + * This procedure is invoked when a widget command is deleted. If + * the widget isn't already in the process of being destroyed, + * this command destroys it. + * + * Results: + * None. + * + * Side effects: + * The widget is destroyed. + * + *---------------------------------------------------------------------- + */ + +static void +FrameCmdDeletedProc(clientData) + ClientData clientData; /* Pointer to widget record for widget. */ +{ + Frame *framePtr = (Frame *) clientData; + Tk_Window tkwin = framePtr->tkwin; + + /* + * This procedure could be invoked either because the window was + * destroyed and the command was then deleted (in which case tkwin + * is NULL) or because the command was deleted, and then this procedure + * destroys the widget. + */ + + if (tkwin != NULL) { + framePtr->tkwin = NULL; + Tk_DestroyWindow(tkwin); + } +} + +/* + *---------------------------------------------------------------------- + * + * MapFrame -- + * + * This procedure is invoked as a when-idle handler to map a + * newly-created top-level frame. + * + * Results: + * None. + * + * Side effects: + * The frame given by the clientData argument is mapped. + * + *---------------------------------------------------------------------- + */ + +static void +MapFrame(clientData) + ClientData clientData; /* Pointer to frame structure. */ +{ + Frame *framePtr = (Frame *) clientData; + + /* + * Wait for all other background events to be processed before + * mapping window. This ensures that the window's correct geometry + * will have been determined before it is first mapped, so that the + * window manager doesn't get a false idea of its desired geometry. + */ + + Tcl_Preserve((ClientData) framePtr); + while (1) { + if (Tcl_DoOneEvent(TCL_IDLE_EVENTS) == 0) { + break; + } + + /* + * After each event, make sure that the window still exists + * and quit if the window has been destroyed. + */ + + if (framePtr->tkwin == NULL) { + Tcl_Release((ClientData) framePtr); + return; + } + } + Tk_MapWindow(framePtr->tkwin); + Tcl_Release((ClientData) framePtr); +} diff --git a/tk3.6/tkGC.c b/tk4.2/generic/tkGC.c similarity index 86% rename from tk3.6/tkGC.c rename to tk4.2/generic/tkGC.c index f3c9341..f68db12 100644 --- a/tk3.6/tkGC.c +++ b/tk4.2/generic/tkGC.c @@ -4,38 +4,23 @@ * This file maintains a database of read-only graphics contexts * for the Tk toolkit, in order to allow GC's to be shared. * - * Copyright (c) 1990-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tkGC.c 1.18 96/02/15 18:53:32 */ -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkGC.c,v 1.12 93/06/16 17:16:16 ouster Exp $ SPRITE (Berkeley)"; -#endif /* not lint */ - -#include "tkConfig.h" +#include "tkPort.h" #include "tk.h" /* * One of the following data structures exists for each GC that is * currently active. The structure is indexed with two hash tables, - * one based on font name and one based on XFontStruct address. + * one based on the values in the graphics context and the other + * based on the display and GC identifier. */ typedef struct { @@ -143,7 +128,7 @@ Tk_GetGC(tkwin, valueMask, valuePtr) if (valueMask & GCPlaneMask) { valueKey.values.plane_mask = valuePtr->plane_mask; } else { - valueKey.values.plane_mask = ~0; + valueKey.values.plane_mask = (unsigned) ~0; } if (valueMask & GCForeground) { valueKey.values.foreground = valuePtr->foreground; @@ -280,7 +265,7 @@ Tk_GetGC(tkwin, valueMask, valuePtr) DefaultDepth(valueKey.display, valueKey.screenNum)) { d = RootWindow(valueKey.display, valueKey.screenNum); } else { - d = XCreatePixmap(valueKey.display, + d = Tk_GetPixmap(valueKey.display, RootWindow(valueKey.display, valueKey.screenNum), 1, 1, valueKey.depth); freeDrawable = d; @@ -299,7 +284,7 @@ Tk_GetGC(tkwin, valueMask, valuePtr) Tcl_SetHashValue(valueHashPtr, gcPtr); Tcl_SetHashValue(idHashPtr, gcPtr); if (freeDrawable != None) { - XFreePixmap(valueKey.display, freeDrawable); + Tk_FreePixmap(valueKey.display, freeDrawable); } return gcPtr->gc; @@ -310,7 +295,7 @@ Tk_GetGC(tkwin, valueMask, valuePtr) * * Tk_FreeGC -- * - * This procedure is called to release a font allocated by + * This procedure is called to release a graphics context allocated by * Tk_GetGC. * * Results: @@ -345,6 +330,7 @@ Tk_FreeGC(display, gc) gcPtr = (TkGC *) Tcl_GetHashValue(idHashPtr); gcPtr->refCount--; if (gcPtr->refCount == 0) { + Tk_FreeXId(gcPtr->display, (XID) XGContextFromGC(gcPtr->gc)); XFreeGC(gcPtr->display, gcPtr->gc); Tcl_DeleteHashEntry(gcPtr->valueHashPtr); Tcl_DeleteHashEntry(idHashPtr); diff --git a/tk4.2/generic/tkGeometry.c b/tk4.2/generic/tkGeometry.c new file mode 100644 index 0000000..ec2c959 --- /dev/null +++ b/tk4.2/generic/tkGeometry.c @@ -0,0 +1,582 @@ +/* + * tkGeometry.c -- + * + * This file contains generic Tk code for geometry management + * (stuff that's used by all geometry managers). + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkGeometry.c 1.31 96/02/15 18:53:32 + */ + +#include "tkPort.h" +#include "tkInt.h" + +/* + * Data structures of the following type are used by Tk_MaintainGeometry. + * For each slave managed by Tk_MaintainGeometry, there is one of these + * structures associated with its master. + */ + +typedef struct MaintainSlave { + Tk_Window slave; /* The slave window being positioned. */ + Tk_Window master; /* The master that determines slave's + * position; it must be a descendant of + * slave's parent. */ + int x, y; /* Desired position of slave relative to + * master. */ + int width, height; /* Desired dimensions of slave. */ + struct MaintainSlave *nextPtr; + /* Next in list of Maintains associated + * with master. */ +} MaintainSlave; + +/* + * For each window that has been specified as a master to + * Tk_MaintainGeometry, there is a structure of the following type: + */ + +typedef struct MaintainMaster { + Tk_Window ancestor; /* The lowest ancestor of this window + * for which we have *not* created a + * StructureNotify handler. May be the + * same as the window itself. */ + int checkScheduled; /* Non-zero means that there is already a + * call to MaintainCheckProc scheduled as + * an idle handler. */ + MaintainSlave *slavePtr; /* First in list of all slaves associated + * with this master. */ +} MaintainMaster; + +/* + * Hash table that maps from a master's Tk_Window token to a list of + * Maintains for that master: + */ + +static Tcl_HashTable maintainHashTable; + +/* + * Has maintainHashTable been initialized yet? + */ + +static int initialized = 0; + +/* + * Prototypes for static procedures in this file: + */ + +static void MaintainCheckProc _ANSI_ARGS_((ClientData clientData)); +static void MaintainMasterProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +static void MaintainSlaveProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); + +/* + *-------------------------------------------------------------- + * + * Tk_ManageGeometry -- + * + * Arrange for a particular procedure to manage the geometry + * of a given slave window. + * + * Results: + * None. + * + * Side effects: + * Proc becomes the new geometry manager for tkwin, replacing + * any previous geometry manager. The geometry manager will + * be notified (by calling procedures in *mgrPtr) when interesting + * things happen in the future. If there was an existing geometry + * manager for tkwin different from the new one, it is notified + * by calling its lostSlaveProc. + * + *-------------------------------------------------------------- + */ + +void +Tk_ManageGeometry(tkwin, mgrPtr, clientData) + Tk_Window tkwin; /* Window whose geometry is to + * be managed by proc. */ + Tk_GeomMgr *mgrPtr; /* Static structure describing the + * geometry manager. This structure + * must never go away. */ + ClientData clientData; /* Arbitrary one-word argument to + * pass to geometry manager procedures. */ +{ + register TkWindow *winPtr = (TkWindow *) tkwin; + + if ((winPtr->geomMgrPtr != NULL) && (mgrPtr != NULL) + && ((winPtr->geomMgrPtr != mgrPtr) + || (winPtr->geomData != clientData)) + && (winPtr->geomMgrPtr->lostSlaveProc != NULL)) { + (*winPtr->geomMgrPtr->lostSlaveProc)(winPtr->geomData, tkwin); + } + + winPtr->geomMgrPtr = mgrPtr; + winPtr->geomData = clientData; +} + +/* + *-------------------------------------------------------------- + * + * Tk_GeometryRequest -- + * + * This procedure is invoked by widget code to indicate + * its preferences about the size of a window it manages. + * In general, widget code should call this procedure + * rather than Tk_ResizeWindow. + * + * Results: + * None. + * + * Side effects: + * The geometry manager for tkwin (if any) is invoked to + * handle the request. If possible, it will reconfigure + * tkwin and/or other windows to satisfy the request. The + * caller gets no indication of success or failure, but it + * will get X events if the window size was actually + * changed. + * + *-------------------------------------------------------------- + */ + +void +Tk_GeometryRequest(tkwin, reqWidth, reqHeight) + Tk_Window tkwin; /* Window that geometry information + * pertains to. */ + int reqWidth, reqHeight; /* Minimum desired dimensions for + * window, in pixels. */ +{ + register TkWindow *winPtr = (TkWindow *) tkwin; + + /* + * X gets very upset if a window requests a width or height of + * zero, so rounds requested sizes up to at least 1. + */ + + if (reqWidth <= 0) { + reqWidth = 1; + } + if (reqHeight <= 0) { + reqHeight = 1; + } + if ((reqWidth == winPtr->reqWidth) && (reqHeight == winPtr->reqHeight)) { + return; + } + winPtr->reqWidth = reqWidth; + winPtr->reqHeight = reqHeight; + if ((winPtr->geomMgrPtr != NULL) + && (winPtr->geomMgrPtr->requestProc != NULL)) { + (*winPtr->geomMgrPtr->requestProc)(winPtr->geomData, tkwin); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tk_SetInternalBorder -- + * + * Notify relevant geometry managers that a window has an internal + * border of a given width and that child windows should not be + * placed on that border. + * + * Results: + * None. + * + * Side effects: + * The border width is recorded for the window, and all geometry + * managers of all children are notified so that can re-layout, if + * necessary. + * + *---------------------------------------------------------------------- + */ + +void +Tk_SetInternalBorder(tkwin, width) + Tk_Window tkwin; /* Window that will have internal border. */ + int width; /* Width of internal border, in pixels. */ +{ + register TkWindow *winPtr = (TkWindow *) tkwin; + + if (width == winPtr->internalBorderWidth) { + return; + } + if (width < 0) { + width = 0; + } + winPtr->internalBorderWidth = width; + + /* + * All the slaves for which this is the master window must now be + * repositioned to take account of the new internal border width. + * To signal all the geometry managers to do this, just resize the + * window to its current size. The ConfigureNotify event will + * cause geometry managers to recompute everything. + */ + + Tk_ResizeWindow(tkwin, Tk_Width(tkwin), Tk_Height(tkwin)); +} + +/* + *---------------------------------------------------------------------- + * + * Tk_MaintainGeometry -- + * + * This procedure is invoked by geometry managers to handle slaves + * whose master's are not their parents. It translates the desired + * geometry for the slave into the coordinate system of the parent + * and respositions the slave if it isn't already at the right place. + * Furthermore, it sets up event handlers so that if the master (or + * any of its ancestors up to the slave's parent) is mapped, unmapped, + * or moved, then the slave will be adjusted to match. + * + * Results: + * None. + * + * Side effects: + * Event handlers are created and state is allocated to keep track + * of slave. Note: if slave was already managed for master by + * Tk_MaintainGeometry, then the previous information is replaced + * with the new information. The caller must eventually call + * Tk_UnmaintainGeometry to eliminate the correspondence (or, the + * state is automatically freed when either window is destroyed). + * + *---------------------------------------------------------------------- + */ + +void +Tk_MaintainGeometry(slave, master, x, y, width, height) + Tk_Window slave; /* Slave for geometry management. */ + Tk_Window master; /* Master for slave; must be a descendant + * of slave's parent. */ + int x, y; /* Desired position of slave within master. */ + int width, height; /* Desired dimensions for slave. */ +{ + Tcl_HashEntry *hPtr; + MaintainMaster *masterPtr; + register MaintainSlave *slavePtr; + int new, map; + Tk_Window ancestor, parent; + + if (!initialized) { + initialized = 1; + Tcl_InitHashTable(&maintainHashTable, TCL_ONE_WORD_KEYS); + } + + /* + * See if there is already a MaintainMaster structure for the master; + * if not, then create one. + */ + + parent = Tk_Parent(slave); + hPtr = Tcl_CreateHashEntry(&maintainHashTable, (char *) master, &new); + if (!new) { + masterPtr = (MaintainMaster *) Tcl_GetHashValue(hPtr); + } else { + masterPtr = (MaintainMaster *) ckalloc(sizeof(MaintainMaster)); + masterPtr->ancestor = master; + masterPtr->checkScheduled = 0; + masterPtr->slavePtr = NULL; + Tcl_SetHashValue(hPtr, masterPtr); + } + + /* + * Create a MaintainSlave structure for the slave if there isn't + * already one. + */ + + for (slavePtr = masterPtr->slavePtr; slavePtr != NULL; + slavePtr = slavePtr->nextPtr) { + if (slavePtr->slave == slave) { + goto gotSlave; + } + } + slavePtr = (MaintainSlave *) ckalloc(sizeof(MaintainSlave)); + slavePtr->slave = slave; + slavePtr->master = master; + slavePtr->nextPtr = masterPtr->slavePtr; + masterPtr->slavePtr = slavePtr; + Tk_CreateEventHandler(slave, StructureNotifyMask, MaintainSlaveProc, + (ClientData) slavePtr); + + /* + * Make sure that there are event handlers registered for all + * the windows between master and slave's parent (including master + * but not slave's parent). There may already be handlers for master + * and some of its ancestors (masterPtr->ancestor tells how many). + */ + + for (ancestor = master; ancestor != parent; + ancestor = Tk_Parent(ancestor)) { + if (ancestor == masterPtr->ancestor) { + Tk_CreateEventHandler(ancestor, StructureNotifyMask, + MaintainMasterProc, (ClientData) masterPtr); + masterPtr->ancestor = Tk_Parent(ancestor); + } + } + + /* + * Fill in up-to-date information in the structure, then update the + * window if it's not currently in the right place or state. + */ + + gotSlave: + slavePtr->x = x; + slavePtr->y = y; + slavePtr->width = width; + slavePtr->height = height; + map = 1; + for (ancestor = slavePtr->master; ; ancestor = Tk_Parent(ancestor)) { + if (!Tk_IsMapped(ancestor) && (ancestor != parent)) { + map = 0; + } + if (ancestor == parent) { + if ((x != Tk_X(slavePtr->slave)) + || (y != Tk_Y(slavePtr->slave)) + || (width != Tk_Width(slavePtr->slave)) + || (height != Tk_Height(slavePtr->slave))) { + Tk_MoveResizeWindow(slavePtr->slave, x, y, width, height); + } + if (map) { + Tk_MapWindow(slavePtr->slave); + } else { + Tk_UnmapWindow(slavePtr->slave); + } + break; + } + x += Tk_X(ancestor) + Tk_Changes(ancestor)->border_width; + y += Tk_Y(ancestor) + Tk_Changes(ancestor)->border_width; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tk_UnmaintainGeometry -- + * + * This procedure cancels a previous Tk_MaintainGeometry call, + * so that the relationship between slave and master is no longer + * maintained. + * + * Results: + * None. + * + * Side effects: + * The slave is unmapped and state is released, so that slave won't + * track master any more. If we weren't previously managing slave + * relative to master, then this procedure has no effect. + * + *---------------------------------------------------------------------- + */ + +void +Tk_UnmaintainGeometry(slave, master) + Tk_Window slave; /* Slave for geometry management. */ + Tk_Window master; /* Master for slave; must be a descendant + * of slave's parent. */ +{ + Tcl_HashEntry *hPtr; + MaintainMaster *masterPtr; + register MaintainSlave *slavePtr, *prevPtr; + Tk_Window ancestor; + + if (!initialized) { + initialized = 1; + Tcl_InitHashTable(&maintainHashTable, TCL_ONE_WORD_KEYS); + } + + if (!(((TkWindow *) slave)->flags & TK_ALREADY_DEAD)) { + Tk_UnmapWindow(slave); + } + hPtr = Tcl_FindHashEntry(&maintainHashTable, (char *) master); + if (hPtr == NULL) { + return; + } + masterPtr = (MaintainMaster *) Tcl_GetHashValue(hPtr); + slavePtr = masterPtr->slavePtr; + if (slavePtr->slave == slave) { + masterPtr->slavePtr = slavePtr->nextPtr; + } else { + for (prevPtr = slavePtr, slavePtr = slavePtr->nextPtr; ; + prevPtr = slavePtr, slavePtr = slavePtr->nextPtr) { + if (slavePtr == NULL) { + return; + } + if (slavePtr->slave == slave) { + prevPtr->nextPtr = slavePtr->nextPtr; + break; + } + } + } + Tk_DeleteEventHandler(slavePtr->slave, StructureNotifyMask, + MaintainSlaveProc, (ClientData) slavePtr); + ckfree((char *) slavePtr); + if (masterPtr->slavePtr == NULL) { + if (masterPtr->ancestor != NULL) { + for (ancestor = master; ; ancestor = Tk_Parent(ancestor)) { + Tk_DeleteEventHandler(ancestor, StructureNotifyMask, + MaintainMasterProc, (ClientData) masterPtr); + if (ancestor == masterPtr->ancestor) { + break; + } + } + } + if (masterPtr->checkScheduled) { + Tcl_CancelIdleCall(MaintainCheckProc, (ClientData) masterPtr); + } + Tcl_DeleteHashEntry(hPtr); + ckfree((char *) masterPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * MaintainMasterProc -- + * + * This procedure is invoked by the Tk event dispatcher in + * response to StructureNotify events on the master or one + * of its ancestors, on behalf of Tk_MaintainGeometry. + * + * Results: + * None. + * + * Side effects: + * It schedules a call to MaintainCheckProc, which will eventually + * caused the postions and mapped states to be recalculated for all + * the maintained slaves of the master. Or, if the master window is + * being deleted then state is cleaned up. + * + *---------------------------------------------------------------------- + */ + +static void +MaintainMasterProc(clientData, eventPtr) + ClientData clientData; /* Pointer to MaintainMaster structure + * for the master window. */ + XEvent *eventPtr; /* Describes what just happened. */ +{ + MaintainMaster *masterPtr = (MaintainMaster *) clientData; + MaintainSlave *slavePtr; + int done; + + if ((eventPtr->type == ConfigureNotify) + || (eventPtr->type == MapNotify) + || (eventPtr->type == UnmapNotify)) { + if (!masterPtr->checkScheduled) { + masterPtr->checkScheduled = 1; + Tcl_DoWhenIdle(MaintainCheckProc, (ClientData) masterPtr); + } + } else if (eventPtr->type == DestroyNotify) { + /* + * Delete all of the state associated with this master, but + * be careful not to use masterPtr after the last slave is + * deleted, since its memory will have been freed. + */ + + done = 0; + do { + slavePtr = masterPtr->slavePtr; + if (slavePtr->nextPtr == NULL) { + done = 1; + } + Tk_UnmaintainGeometry(slavePtr->slave, slavePtr->master); + } while (!done); + } +} + +/* + *---------------------------------------------------------------------- + * + * MaintainSlaveProc -- + * + * This procedure is invoked by the Tk event dispatcher in + * response to StructureNotify events on a slave being managed + * by Tk_MaintainGeometry. + * + * Results: + * None. + * + * Side effects: + * If the event is a DestroyNotify event then the Maintain state + * and event handlers for this slave are deleted. + * + *---------------------------------------------------------------------- + */ + +static void +MaintainSlaveProc(clientData, eventPtr) + ClientData clientData; /* Pointer to MaintainSlave structure + * for master-slave pair. */ + XEvent *eventPtr; /* Describes what just happened. */ +{ + MaintainSlave *slavePtr = (MaintainSlave *) clientData; + + if (eventPtr->type == DestroyNotify) { + Tk_UnmaintainGeometry(slavePtr->slave, slavePtr->master); + } +} + +/* + *---------------------------------------------------------------------- + * + * MaintainCheckProc -- + * + * This procedure is invoked by the Tk event dispatcher as an + * idle handler, when a master or one of its ancestors has been + * reconfigured, mapped, or unmapped. Its job is to scan all of + * the slaves for the master and reposition them, map them, or + * unmap them as needed to maintain their geometry relative to + * the master. + * + * Results: + * None. + * + * Side effects: + * Slaves can get repositioned, mapped, or unmapped. + * + *---------------------------------------------------------------------- + */ + +static void +MaintainCheckProc(clientData) + ClientData clientData; /* Pointer to MaintainMaster structure + * for the master window. */ +{ + MaintainMaster *masterPtr = (MaintainMaster *) clientData; + MaintainSlave *slavePtr; + Tk_Window ancestor, parent; + int x, y, map; + + masterPtr->checkScheduled = 0; + for (slavePtr = masterPtr->slavePtr; slavePtr != NULL; + slavePtr = slavePtr->nextPtr) { + parent = Tk_Parent(slavePtr->slave); + x = slavePtr->x; + y = slavePtr->y; + map = 1; + for (ancestor = slavePtr->master; ; ancestor = Tk_Parent(ancestor)) { + if (!Tk_IsMapped(ancestor) && (ancestor != parent)) { + map = 0; + } + if (ancestor == parent) { + if ((x != Tk_X(slavePtr->slave)) + || (y != Tk_Y(slavePtr->slave))) { + Tk_MoveWindow(slavePtr->slave, x, y); + } + if (map) { + Tk_MapWindow(slavePtr->slave); + } else { + Tk_UnmapWindow(slavePtr->slave); + } + break; + } + x += Tk_X(ancestor) + Tk_Changes(ancestor)->border_width; + y += Tk_Y(ancestor) + Tk_Changes(ancestor)->border_width; + } + } +} diff --git a/tk3.6/tkGet.c b/tk4.2/generic/tkGet.c similarity index 89% rename from tk3.6/tkGet.c rename to tk4.2/generic/tkGet.c index 077566c..9cd8257 100644 --- a/tk3.6/tkGet.c +++ b/tk4.2/generic/tkGet.c @@ -7,33 +7,17 @@ * The more complex procedures like Tk_GetColor are in separate * files. * - * Copyright (c) 1991-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tkGet.c 1.12 96/02/15 18:53:33 */ -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkGet.c,v 1.7 93/08/18 16:25:25 ouster Exp $ SPRITE (Berkeley)"; -#endif /* not lint */ - #include "tkInt.h" -#include "tkConfig.h" +#include "tkPort.h" /* * The hash table below is used to keep track of all the Tk_Uids created @@ -186,7 +170,8 @@ Tk_GetJoinStyle(interp, string, joinPtr) int *joinPtr; /* Where to store join style corresponding * to string. */ { - int c, length; + int c; + size_t length; c = string[0]; length = strlen(string); @@ -267,7 +252,8 @@ Tk_GetCapStyle(interp, string, capPtr) int *capPtr; /* Where to store cap style corresponding * to string. */ { - int c, length; + int c; + size_t length; c = string[0]; length = strlen(string); @@ -348,7 +334,8 @@ Tk_GetJustify(interp, string, justifyPtr) Tk_Justify *justifyPtr; /* Where to store Tk_Justify corresponding * to string. */ { - int c, length; + int c; + size_t length; c = string[0]; length = strlen(string); @@ -365,13 +352,9 @@ Tk_GetJustify(interp, string, justifyPtr) *justifyPtr = TK_JUSTIFY_CENTER; return TCL_OK; } - if ((c == 'f') && (strncmp(string, "fill", length) == 0)) { - *justifyPtr = TK_JUSTIFY_FILL; - return TCL_OK; - } Tcl_AppendResult(interp, "bad justification \"", string, - "\": must be left, right, center, or fill", + "\": must be left, right, or center", (char *) NULL); return TCL_ERROR; } @@ -402,7 +385,6 @@ Tk_NameOfJustify(justify) case TK_JUSTIFY_LEFT: return "left"; case TK_JUSTIFY_RIGHT: return "right"; case TK_JUSTIFY_CENTER: return "center"; - case TK_JUSTIFY_FILL: return "fill"; } return "unknown justification style"; } diff --git a/tk3.6/tkGrab.c b/tk4.2/generic/tkGrab.c similarity index 70% rename from tk3.6/tkGrab.c rename to tk4.2/generic/tkGrab.c index 9369737..aa68508 100644 --- a/tk3.6/tkGrab.c +++ b/tk4.2/generic/tkGrab.c @@ -3,62 +3,94 @@ * * This file provides procedures that implement grabs for Tk. * - * Copyright (c) 1992-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1992-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tkGrab.c 1.51 96/09/05 12:29:43 */ -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkGrab.c,v 1.34 93/10/23 16:21:43 ouster Exp $ SPRITE (Berkeley)"; -#endif - -#include "tkConfig.h" +#include "tkPort.h" #include "tkInt.h" /* - * This module is ridiculously complicated... sorry about that. The - * problem is that the grabs provided by the X server aren't very - * useful, so this module tries to create a more useful form of grab - * using the X server's rudimentary facilities. This requires us to - * suppress some of the events coming from the X server and generate - * many additional events. Managing the events is hard because of the - * asynchronous way that the event queue is processed. The current - * solution uses an extra "grab event queue" for each display, where - * we put the event that we synthesize here. Events in this queue - * are processed before any events in the normal X queue. The grab - * event queue is needed (rather than just pushing events back on the - * X queue) so that we can keep a clear boundary between the events - * we've synthesized and those coming from the server, so that we can - * add new events after all the other synthesized events but before - * those from the server. + * The grab state machine has four states: ungrabbed, button pressed, + * grabbed, and button pressed while grabbed. In addition, there are + * three pieces of grab state information: the current grab window, + * the current restrict window, and whether the mouse is captured. + * + * The current grab window specifies the point in the Tk window + * heirarchy above which pointer events will not be reported. Any + * window within the subtree below the grab window will continue to + * receive events as normal. Events outside of the grab tree will be + * reported to the grab window. + * + * If the current restrict window is set, then all pointer events will + * be reported only to the restrict window. The restrict window is + * normally set during an automatic button grab. + * + * The mouse capture state specifies whether the window system will + * report mouse events outside of any Tk toplevels. This is set + * during a global grab or an automatic button grab. + * + * The transitions between different states is given in the following + * table: + * + * Event\State U B G GB + * ----------- -- -- -- -- + * FirstPress B B GB GB + * Press B B G GB + * Release U B G GB + * LastRelease U U G G + * Grab G G G G + * Ungrab U B U U + * + * Note: U=Ungrabbed, B=Button, G=Grabbed, GB=Grab and Button + * + * In addition, the following conditions are always true: + * + * State\Variable Grab Restrict Capture + * -------------- ---- -------- ------- + * Ungrabbed 0 0 0 + * Button 0 1 1 + * Grabbed 1 0 b/g + * Grab and Button 1 1 1 + * + * Note: 0 means variable is set to NULL, 1 means variable is set to + * some window, b/g means the variable is set to a window if a button + * is currently down or a global grab is in effect. + * + * The final complication to all of this is enter and leave events. + * In order to correctly handle all of the various cases, Tk cannot + * rely on X enter/leave events in all situations. The following + * describes the correct sequence of enter and leave events that + * should be observed by Tk scripts: + * + * Event(state) Enter/Leave From -> To + * ------------ ---------------------- + * LastRelease(B | GB): restrict window -> anc(grab window, event window) + * Grab(U | B): event window -> anc(grab window, event window) + * Grab(G): anc(old grab window, event window) -> + * anc(new grab window, event window) + * Grab(GB): restrict window -> anc(new grab window, event window) + * Ungrab(G): anc(grab window, event window) -> event window + * Ungrab(GB): restrict window -> event window + * + * Note: anc(x,y) returns the least ancestor of y that is in the tree + * of x, terminating at toplevels. */ /* - * One of the following structures is kept for each event in the - * grab queue maintained by this module. + * The following structure is used to pass information to + * GrabRestrictProc from EatGrabEvents. */ -struct TkGrabEvent { - XEvent event; /* Event to process. */ - struct TkGrabEvent *nextPtr; /* Next event in list, or NULL for - * end of list. */ -}; +typedef struct { + Display *display; /* Display from which to discard events. */ + unsigned int serial; /* Serial number with which to compare. */ +} GrabInfo; /* * Bit definitions for grabFlags field of TkDisplay structures: @@ -67,11 +99,6 @@ struct TkGrabEvent { * the server so all applications are locked out). * 0 means this is a local grab that affects * only this application. - * GRAB_TRIGGER_QUEUED 1 means that there are events in the grab - * queue for this display and a fake event has - * been pushed to cause the events on the grab - * queue to be processed before any events on - * the regular X event queue. * GRAB_TEMP_GLOBAL 1 means we've temporarily grabbed via the * server because a button is down and we want * to make sure that we get the button-up @@ -80,9 +107,25 @@ struct TkGrabEvent { */ #define GRAB_GLOBAL 1 -#define GRAB_TRIGGER_QUEUED 2 #define GRAB_TEMP_GLOBAL 4 +/* + * The following structure is a Tcl_Event that triggers a change in + * the grabWinPtr field of a display. This event guarantees that + * the change occurs in the proper order relative to enter and leave + * events. + */ + +typedef struct NewGrabWinEvent { + Tcl_Event header; /* Standard information for all Tcl events. */ + TkDisplay *dispPtr; /* Display whose grab window is to change. */ + Window grabWindow; /* New grab window for display. This is + * recorded instead of a (TkWindow *) because + * it will allow us to detect cases where + * the window is destroyed before this event + * is processed. */ +} NewGrabWinEvent; + /* * The following magic value is stored in the "send_event" field of * EnterNotify and LeaveNotify events that are generated in this @@ -92,16 +135,6 @@ struct TkGrabEvent { #define GENERATED_EVENT_MAGIC ((Bool) 0x147321ac) -/* - * The following magic value stored in the "send_event" field of - * an event identifies it as a special dummy event to trigger a - * change in the grabWinPtr field of a display. The "window" - * field of the event actually contains a (TkWindow *) value to - * put in grabWinPtr. - */ - -#define GRAB_WINDOW_EVENT_MAGIC ((Bool) 0x347321ab) - /* * Mask that selects any of the state bits corresponding to buttons, * plus masks that select individual buttons' bits: @@ -117,20 +150,18 @@ static unsigned int buttonStates[] = { * Forward declarations for procedures declared later in this file: */ -static void ChangeEventWindow _ANSI_ARGS_((XEvent *eventPtr, - TkWindow *winPtr)); static void EatGrabEvents _ANSI_ARGS_((TkDisplay *dispPtr, unsigned int serial)); static TkWindow * FindCommonAncestor _ANSI_ARGS_((TkWindow *winPtr1, TkWindow *winPtr2, int *countPtr1, int *countPtr2)); -static void MovePointer _ANSI_ARGS_((XEvent *eventPtr, - TkWindow *sourcePtr, TkWindow *destPtr, - int leaveEvents, int EnterEvents)); +static Tk_RestrictAction GrabRestrictProc _ANSI_ARGS_((ClientData arg, + XEvent *eventPtr)); +static int GrabWinEventProc _ANSI_ARGS_((Tcl_Event *evPtr, + int flags)); static void MovePointer2 _ANSI_ARGS_((TkWindow *sourcePtr, TkWindow *destPtr, int mode, int leaveEvents, int EnterEvents)); -static void PushTriggerEvent _ANSI_ARGS_((TkDisplay *dispPtr)); static void QueueGrabWindowChange _ANSI_ARGS_((TkDisplay *dispPtr, TkWindow *grabWinPtr)); static void ReleaseButtonGrab _ANSI_ARGS_((TkDisplay *dispPtr)); @@ -161,11 +192,10 @@ Tk_GrabCmd(clientData, interp, argc, argv) int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { - int globalGrab; + int globalGrab, c; Tk_Window tkwin; TkDisplay *dispPtr; - int length; - char c; + size_t length; if (argc < 2) { badArgs: @@ -234,7 +264,7 @@ Tk_GrabCmd(clientData, interp, argc, argv) } } else if ((c == 's') && (strncmp(argv[1], "set", length) == 0) && (length >= 2)) { - if (argc > 4) { + if ((argc != 3) && (argc != 4)) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " set ?-global? window\"", (char *) NULL); return TCL_ERROR; @@ -322,7 +352,7 @@ Tk_Grab(interp, tkwin, grabGlobal) * Zero means the grab only applies * within this application. */ { - int grabResult; + int grabResult, numTries; TkWindow *winPtr = (TkWindow *) tkwin; TkDisplay *dispPtr = winPtr->dispPtr; TkWindow *winPtr2; @@ -339,7 +369,7 @@ Tk_Grab(interp, tkwin, grabGlobal) interp->result = "grab failed: another application has grab"; return TCL_ERROR; } - Tk_Ungrab(tkwin); + Tk_Ungrab((Tk_Window) dispPtr->eventualGrabWinPtr); } Tk_MakeWindowExist(tkwin); @@ -368,7 +398,7 @@ Tk_Grab(interp, tkwin, grabGlobal) setGlobalGrab: /* - * Tricky point: must ungrab before grabbing. This is needed + * Tricky point: must ungrab before grabbing. This is needed * in case there is a button auto-grab already in effect. If * there is, and the mouse has moved to a different window, X * won't generate enter and leave events to move the mouse if @@ -377,9 +407,28 @@ Tk_Grab(interp, tkwin, grabGlobal) XUngrabPointer(dispPtr->display, CurrentTime); serial = NextRequest(dispPtr->display); - grabResult = XGrabPointer(dispPtr->display, winPtr->window, - True, ButtonPressMask|ButtonReleaseMask|ButtonMotionMask, - GrabModeAsync, GrabModeAsync, None, None, CurrentTime); + + /* + * Another tricky point: there are races with some window + * managers that can cause grabs to fail because the window + * manager hasn't released its grab quickly enough. To work + * around this problem, retry a few times after AlreadyGrabbed + * errors to give the grab release enough time to register with + * the server. + */ + + grabResult = 0; /* Needed only to prevent gcc + * compiler warnings. */ + for (numTries = 0; numTries < 10; numTries++) { + grabResult = XGrabPointer(dispPtr->display, winPtr->window, + True, ButtonPressMask|ButtonReleaseMask|ButtonMotionMask + |PointerMotionMask, GrabModeAsync, GrabModeAsync, None, + None, CurrentTime); + if (grabResult != AlreadyGrabbed) { + break; + } + Tcl_Sleep(100); + } if (grabResult != 0) { grabError: if (grabResult == GrabNotViewable) { @@ -467,10 +516,10 @@ Tk_Grab(interp, tkwin, grabGlobal) void Tk_Ungrab(tkwin) - Tk_Window tkwin; /* Window that identifies display - * for grab to be released. */ + Tk_Window tkwin; /* Window whose grab should be + * released. */ { - TkDisplay *dispPtr = ((TkWindow *) tkwin)->dispPtr; + TkDisplay *dispPtr; TkWindow *grabWinPtr, *winPtr; unsigned int serial; @@ -601,33 +650,22 @@ TkPointerEvent(eventPtr, winPtr) * affected by the grab. */ /* - * If a grab is in effect, see if the event is being reported to - * a window in the grab tree or to an ancestor of the grab window - * within its same top-level window. Also see if the event is - * being reported to an application that is affected by the grab. + * Collect information about the grab (if any). */ - if (dispPtr->grabWinPtr != NULL) { - if ((winPtr->mainPtr == dispPtr->grabWinPtr->mainPtr) - || (dispPtr->grabFlags & GRAB_GLOBAL)) { + switch (TkGrabState(winPtr)) { + case TK_GRAB_IN_TREE: appGrabbed = 1; - } - for (winPtr2 = winPtr; winPtr2 != dispPtr->grabWinPtr; - winPtr2 = winPtr2->parentPtr) { - if (winPtr2 == NULL) { - outsideGrabTree = 1; - for (winPtr2 = dispPtr->grabWinPtr; ; - winPtr2 = winPtr2->parentPtr) { - if (winPtr2 == winPtr) { - ancestorOfGrab = 1; - } - if (winPtr2->flags & TK_TOP_LEVEL) { - break; - } - } - break; - } - } + break; + case TK_GRAB_ANCESTOR: + appGrabbed = 1; + outsideGrabTree = 1; + ancestorOfGrab = 1; + break; + case TK_GRAB_EXCLUDED: + appGrabbed = 1; + outsideGrabTree = 1; + break; } if ((eventPtr->type == EnterNotify) || (eventPtr->type == LeaveNotify)) { @@ -688,6 +726,7 @@ TkPointerEvent(eventPtr, winPtr) } return 1; } + if (!appGrabbed) { return 1; } @@ -710,11 +749,8 @@ TkPointerEvent(eventPtr, winPtr) winPtr2 = dispPtr->grabWinPtr; } if (winPtr2 != winPtr) { - XEvent newEvent; - - newEvent = *eventPtr; - ChangeEventWindow(&newEvent, winPtr2); - XPutBackEvent(winPtr2->display, &newEvent); + TkChangeEventWindow(eventPtr, winPtr2); + Tk_QueueWindowEvent(eventPtr, TCL_QUEUE_HEAD); return 0; } return 1; @@ -762,11 +798,8 @@ TkPointerEvent(eventPtr, winPtr) if (eventPtr->type == ButtonPress) { if ((eventPtr->xbutton.state & ALL_BUTTONS) == 0) { if (outsideGrabTree) { - XEvent newEvent; - - newEvent = *eventPtr; - ChangeEventWindow(&newEvent, dispPtr->grabWinPtr); - XPutBackEvent(dispPtr->display, &newEvent); + TkChangeEventWindow(eventPtr, dispPtr->grabWinPtr); + Tk_QueueWindowEvent(eventPtr, TCL_QUEUE_HEAD); return 0; /* Note 2. */ } if (!(dispPtr->grabFlags & GRAB_GLOBAL)) { /* Note 6. */ @@ -796,11 +829,8 @@ TkPointerEvent(eventPtr, winPtr) } } if (winPtr2 != winPtr) { - XEvent newEvent; - - newEvent = *eventPtr; - ChangeEventWindow(&newEvent, winPtr2); - XPutBackEvent(dispPtr->display, &newEvent); + TkChangeEventWindow(eventPtr, winPtr2); + Tk_QueueWindowEvent(eventPtr, TCL_QUEUE_HEAD); return 0; /* Note 3. */ } } @@ -811,7 +841,7 @@ TkPointerEvent(eventPtr, winPtr) /* *---------------------------------------------------------------------- * - * ChangeEventWindow -- + * TkChangeEventWindow -- * * Given an event and a new window to which the event should be * retargeted, modify fields of the event so that the event is @@ -827,8 +857,8 @@ TkPointerEvent(eventPtr, winPtr) *---------------------------------------------------------------------- */ -static void -ChangeEventWindow(eventPtr, winPtr) +void +TkChangeEventWindow(eventPtr, winPtr) register XEvent *eventPtr; /* Event to retarget. Must have * type ButtonPress, ButtonRelease, KeyPress, * KeyRelease, MotionNotify, EnterNotify, @@ -855,7 +885,7 @@ ChangeEventWindow(eventPtr, winPtr) bd = childPtr->changes.border_width; if ((x >= -bd) && (y >= -bd) && (x < (childPtr->changes.width + bd)) - && (y < (childPtr->changes.width + bd))) { + && (y < (childPtr->changes.height + bd))) { eventPtr->xmotion.subwindow = childPtr->window; } } @@ -876,10 +906,12 @@ ChangeEventWindow(eventPtr, winPtr) /* *---------------------------------------------------------------------- * - * MovePointer -- + * TkInOutEvents -- * * This procedure synthesizes EnterNotify and LeaveNotify events * to correctly transfer the pointer from one window to another. + * It can also be used to generate FocusIn and FocusOut events + * to move the input focus. * * Results: * None. @@ -891,29 +923,32 @@ ChangeEventWindow(eventPtr, winPtr) *---------------------------------------------------------------------- */ -static void -MovePointer(eventPtr, sourcePtr, destPtr, leaveEvents, enterEvents) +void +TkInOutEvents(eventPtr, sourcePtr, destPtr, leaveType, enterType, position) XEvent *eventPtr; /* A template X event. Must have all fields - * properly set for EnterNotify and LeaveNotify - * events except window, subwindow, x, y, - * detail, and same_screen. (x_root and y_root - * must be valid, even though x and y needn't - * be valid). */ - TkWindow *sourcePtr; /* Window currently containing pointer (NULL - * means it's not one managed by this - * process). */ - TkWindow *destPtr; /* Window that is to end up containing the - * pointer (NULL means it's not one managed + * properly set except for type, window, + * subwindow, x, y, detail, and same_screen + * (Not all of these fields are valid for + * FocusIn/FocusOut events; x_root and y_root + * must be valid for Enter/Leave events, even + * though x and y needn't be valid). */ + TkWindow *sourcePtr; /* Window that used to have the pointer or + * focus (NULL means it was not in a window + * managed by this process). */ + TkWindow *destPtr; /* Window that is to end up with the pointer + * or focus (NULL means it's not one managed * by this process). */ - int leaveEvents; /* Non-zero means generate leave events for the - * windows being left. Zero means don't - * generate leave events. */ - int enterEvents; /* Non-zero means generate enter events for the - * windows being entered. Zero means don't - * generate enter events. */ + int leaveType; /* Type of events to generate for windows + * being left (LeaveNotify or FocusOut). 0 + * means don't generate leave events. */ + int enterType; /* Type of events to generate for windows + * being entered (EnterNotify or FocusIn). 0 + * means don't generate enter events. */ + Tcl_QueuePosition position; /* Position at which events are added to + * the system event queue. */ { register TkWindow *winPtr; - int upLevels, downLevels, i, j; + int upLevels, downLevels, i, j, focus; /* * There are four possible cases to deal with: @@ -937,6 +972,11 @@ MovePointer(eventPtr, sourcePtr, destPtr, leaveEvents, enterEvents) if (sourcePtr == destPtr) { return; } + if ((leaveType == FocusOut) || (enterType == FocusIn)) { + focus = 1; + } else { + focus = 0; + } FindCommonAncestor(sourcePtr, destPtr, &upLevels, &downLevels); /* @@ -947,9 +987,14 @@ MovePointer(eventPtr, sourcePtr, destPtr, leaveEvents, enterEvents) #define QUEUE(w, t, d) \ if (w->window != None) { \ eventPtr->type = t; \ - eventPtr->xcrossing.detail = d; \ - ChangeEventWindow(eventPtr, w); \ - TkQueueEvent(w->dispPtr, eventPtr); \ + if (focus) { \ + eventPtr->xfocus.window = w->window; \ + eventPtr->xfocus.detail = d; \ + } else { \ + eventPtr->xcrossing.detail = d; \ + TkChangeEventWindow(eventPtr, w); \ + } \ + Tk_QueueWindowEvent(eventPtr, position); \ } if (downLevels == 0) { @@ -958,15 +1003,15 @@ MovePointer(eventPtr, sourcePtr, destPtr, leaveEvents, enterEvents) * SourcePtr is an inferior of destPtr. */ - if (leaveEvents) { - QUEUE(sourcePtr, LeaveNotify, NotifyAncestor); + if (leaveType != 0) { + QUEUE(sourcePtr, leaveType, NotifyAncestor); for (winPtr = sourcePtr->parentPtr, i = upLevels-1; i > 0; winPtr = winPtr->parentPtr, i--) { - QUEUE(winPtr, LeaveNotify, NotifyVirtual); + QUEUE(winPtr, leaveType, NotifyVirtual); } } - if ((enterEvents) && (destPtr != NULL)) { - QUEUE(destPtr, EnterNotify, NotifyInferior); + if ((enterType != 0) && (destPtr != NULL)) { + QUEUE(destPtr, enterType, NotifyInferior); } } else if (upLevels == 0) { @@ -974,18 +1019,18 @@ MovePointer(eventPtr, sourcePtr, destPtr, leaveEvents, enterEvents) * DestPtr is an inferior of sourcePtr. */ - if ((leaveEvents) && (sourcePtr != NULL)) { - QUEUE(sourcePtr, LeaveNotify, NotifyInferior); + if ((leaveType != 0) && (sourcePtr != NULL)) { + QUEUE(sourcePtr, leaveType, NotifyInferior); } - if (enterEvents) { + if (enterType != 0) { for (i = downLevels-1; i > 0; i--) { for (winPtr = destPtr->parentPtr, j = 1; j < i; winPtr = winPtr->parentPtr, j++) { } - QUEUE(winPtr, EnterNotify, NotifyVirtual); + QUEUE(winPtr, enterType, NotifyVirtual); } if (destPtr != NULL) { - QUEUE(destPtr, EnterNotify, NotifyAncestor); + QUEUE(destPtr, enterType, NotifyAncestor); } } } else { @@ -994,167 +1039,27 @@ MovePointer(eventPtr, sourcePtr, destPtr, leaveEvents, enterEvents) * Non-linear: neither window is an inferior of the other. */ - if (leaveEvents) { - QUEUE(sourcePtr, LeaveNotify, NotifyNonlinear); + if (leaveType != 0) { + QUEUE(sourcePtr, leaveType, NotifyNonlinear); for (winPtr = sourcePtr->parentPtr, i = upLevels-1; i > 0; winPtr = winPtr->parentPtr, i--) { - QUEUE(winPtr, LeaveNotify, NotifyNonlinearVirtual); + QUEUE(winPtr, leaveType, NotifyNonlinearVirtual); } } - if (enterEvents) { + if (enterType != 0) { for (i = downLevels-1; i > 0; i--) { for (winPtr = destPtr->parentPtr, j = 1; j < i; winPtr = winPtr->parentPtr, j++) { } - QUEUE(winPtr, EnterNotify, NotifyNonlinearVirtual); + QUEUE(winPtr, enterType, NotifyNonlinearVirtual); } if (destPtr != NULL) { - QUEUE(destPtr, EnterNotify, NotifyNonlinear); + QUEUE(destPtr, enterType, NotifyNonlinear); } } } } -/* - *---------------------------------------------------------------------- - * - * TkQueueEvent -- - * - * This procedure adds an enter or leave event to the end of the - * grab queue for dispPtr. - * - * Results: - * None. - * - * Side effects: - * A copy of *eventPtr is added to the grab queue for dispPtr. - * It will be processed after all other events on the grab queue - * but before any "real" X events (those not coming from the grab - * queue). - * - *---------------------------------------------------------------------- - */ - -void -TkQueueEvent(dispPtr, eventPtr) - TkDisplay *dispPtr; /* Display for which the event is to be - * queued. */ - XEvent *eventPtr; /* Event to queue. */ -{ - TkGrabEvent *grabEventPtr; - - grabEventPtr = (TkGrabEvent *) ckalloc(sizeof(TkGrabEvent)); - grabEventPtr->event = *eventPtr; - grabEventPtr->nextPtr = NULL; - if (dispPtr->firstGrabEventPtr == NULL) { - dispPtr->firstGrabEventPtr = grabEventPtr; - } else { - dispPtr->lastGrabEventPtr->nextPtr = grabEventPtr; - } - dispPtr->lastGrabEventPtr = grabEventPtr; - if (!(dispPtr->grabFlags & GRAB_TRIGGER_QUEUED)) { - PushTriggerEvent(dispPtr); - } -} - -/* - *---------------------------------------------------------------------- - * - * PushTriggerEvent -- - * - * This procedure creates a special "trigger" event and pushes it - * onto the front of the event queue for winPtr's display. - * When Tk_HandleEvent sees this event it will call back to this - * module so that we can feed events from the grab queue onto the - * front of the event queue. - * - * Results: - * None. - * - * Side effects: - * Causes TkGrabTriggerProc to be called later on when the event - * is actually handled. - * - *---------------------------------------------------------------------- - */ - -static void -PushTriggerEvent(dispPtr) - TkDisplay *dispPtr; /* Display on whose display a trigger - * event is to be pushed back. */ -{ - XEvent event; - - event.xany.type = -1; - event.xany.serial = 0; - event.xany.send_event = True; - event.xany.display = (Display *) dispPtr; - event.xany.window = None; - XPutBackEvent(dispPtr->display, &event); - dispPtr->grabFlags |= GRAB_TRIGGER_QUEUED; -} - -/* - *---------------------------------------------------------------------- - * - * TkGrabTriggerProc -- - * - * This procedure is invoked when a trigger event is encountered - * by Tk_HandleEvent. - * - * Results: - * None. - * - * Side effects: - * See code below. - * - *---------------------------------------------------------------------- - */ - -void -TkGrabTriggerProc(eventPtr) - XEvent *eventPtr; /* Pointer to the trigger event. */ -{ - TkDisplay *dispPtr = (TkDisplay *) eventPtr->xany.display; - TkGrabEvent *grabEventPtr; - - /* - * Remove the first event from the grab queue, if there is one. - * If there are additional events left on the queue, then push - * back a new trigger event so that this procedure will get called - * again to process them. - */ - - dispPtr->grabFlags &= ~GRAB_TRIGGER_QUEUED; - grabEventPtr = dispPtr->firstGrabEventPtr; - if (grabEventPtr == NULL) { - return; - } - dispPtr->firstGrabEventPtr = grabEventPtr->nextPtr; - if (dispPtr->firstGrabEventPtr == NULL) { - dispPtr->lastGrabEventPtr = NULL; - } else { - PushTriggerEvent(dispPtr); - } - - /* - * If this is a special event to change grabWinPtr, do that; otherwise - * call Tk_HandleEvent recursively to process the grab event. In either - * case, free up the event when done. - */ - - if (grabEventPtr->event.xany.send_event == GRAB_WINDOW_EVENT_MAGIC) { - if (XFindContext(grabEventPtr->event.xany.display, - grabEventPtr->event.xany.window, - tkWindowContext, (caddr_t *) &dispPtr->grabWinPtr) != 0) { - dispPtr->grabWinPtr = NULL; - } - } else { - Tk_HandleEvent(&grabEventPtr->event); - } - ckfree((char *) grabEventPtr); -} - /* *---------------------------------------------------------------------- * @@ -1162,9 +1067,9 @@ TkGrabTriggerProc(eventPtr) * * This procedure synthesizes EnterNotify and LeaveNotify events * to correctly transfer the pointer from one window to another. - * It is different from MovePointer in that no template X event + * It is different from TkInOutEvents in that no template X event * needs to be supplied; this procedure generates the template - * event and calls MovePointer. + * event and calls TkInOutEvents. * * Results: * None. @@ -1205,17 +1110,20 @@ MovePointer2(sourcePtr, destPtr, mode, leaveEvents, enterEvents) } } - event.xcrossing.serial = LastKnownRequestProcessed(winPtr->display); + event.xcrossing.serial = LastKnownRequestProcessed( + winPtr->display); event.xcrossing.send_event = GENERATED_EVENT_MAGIC; event.xcrossing.display = winPtr->display; - event.xcrossing.root = RootWindow(winPtr->display, winPtr->screenNum); + event.xcrossing.root = RootWindow(winPtr->display, + winPtr->screenNum); event.xcrossing.time = TkCurrentTime(winPtr->dispPtr); XQueryPointer(winPtr->display, winPtr->window, &dummy1, &dummy2, &event.xcrossing.x_root, &event.xcrossing.y_root, &dummy3, &dummy4, &event.xcrossing.state); event.xcrossing.mode = mode; event.xcrossing.focus = False; - MovePointer(&event, sourcePtr, destPtr, leaveEvents, enterEvents); + TkInOutEvents(&event, sourcePtr, destPtr, (leaveEvents) ? LeaveNotify : 0, + (enterEvents) ? EnterNotify : 0, TCL_QUEUE_MARK); } /* @@ -1254,7 +1162,7 @@ TkGrabDeadWindow(winPtr) ReleaseButtonGrab(dispPtr); } if (dispPtr->serverWinPtr == winPtr) { - if (winPtr->flags && TK_TOP_LEVEL) { + if (winPtr->flags & TK_TOP_LEVEL) { dispPtr->serverWinPtr = NULL; } else { dispPtr->serverWinPtr = winPtr->parentPtr; @@ -1273,16 +1181,15 @@ TkGrabDeadWindow(winPtr) * This procedure is called to eliminate any Enter, Leave, * FocusIn, or FocusOut events in the event queue for a * display that have mode NotifyGrab or NotifyUngrab and - * have a serial number no less than a given value. + * have a serial number no less than a given value and are not + * generated by the grab module. * * Results: * None. * * Side effects: * DispPtr's display gets sync-ed, and some of the events get - * removed from its queue. Unaffected events are initially - * removed from the queue but they are eventually put back again - * in the right order. + * removed from the Tk event queue. * *---------------------------------------------------------------------- */ @@ -1293,40 +1200,68 @@ EatGrabEvents(dispPtr, serial) unsigned int serial; /* Only discard events that have a serial * number at least this great. */ { - int numEvents, i, diff, mode; - XEvent *events, *eventPtr; + Tk_RestrictProc *oldProc; + GrabInfo info; + ClientData oldArg, dummy; + info.display = dispPtr->display; + info.serial = serial; XSync(dispPtr->display, False); - numEvents = QLength(dispPtr->display); - if (numEvents == 0) { - return; + oldProc = Tk_RestrictEvents(GrabRestrictProc, (ClientData)&info, &oldArg); + while (Tcl_DoOneEvent(TCL_DONT_WAIT|TCL_WINDOW_EVENTS)) { } - events = (XEvent *) ckalloc((unsigned) (numEvents * sizeof(XEvent))); - for (i = 0; i < numEvents; i++) { - XNextEvent(dispPtr->display, &events[i]); - } - for (i = numEvents-1, eventPtr = &events[i]; i >= 0; i--, eventPtr--) { - /* - * The diff caculation is trickier than it may seem. Don't forget - * that serial numbers can wrap around, so can't compare the two - * serial numbers directly. - */ + Tk_RestrictEvents(oldProc, oldArg, &dummy); +} + +/* + *---------------------------------------------------------------------- + * + * GrabRestrictProc -- + * + * A Tk_RestrictProc used by EatGrabEvents to eliminate any + * Enter, Leave, FocusIn, or FocusOut events in the event queue + * for a display that has mode NotifyGrab or NotifyUngrab and + * have a serial number no less than a given value. + * + * Results: + * Returns either TK_DISCARD_EVENT or TK_DEFER_EVENT. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - diff = eventPtr->xany.serial - serial; - if ((eventPtr->type == EnterNotify) - || (eventPtr->type == LeaveNotify)) { - mode = eventPtr->xcrossing.mode; - } else if ((eventPtr->type == FocusIn) - || (eventPtr->type == FocusOut)) { - mode = eventPtr->xfocus.mode; - } else { - mode = NotifyNormal; - } - if ((mode == NotifyNormal) || (diff < 0)) { - XPutBackEvent(dispPtr->display, eventPtr); - } +static Tk_RestrictAction +GrabRestrictProc(arg, eventPtr) + ClientData arg; + XEvent *eventPtr; +{ + GrabInfo *info = (GrabInfo *) arg; + int mode, diff; + + /* + * The diff caculation is trickier than it may seem. Don't forget + * that serial numbers can wrap around, so can't compare the two + * serial numbers directly. + */ + + diff = eventPtr->xany.serial - info->serial; + if ((eventPtr->type == EnterNotify) + || (eventPtr->type == LeaveNotify)) { + mode = eventPtr->xcrossing.mode; + } else if ((eventPtr->type == FocusIn) + || (eventPtr->type == FocusOut)) { + mode = eventPtr->xfocus.mode; + } else { + mode = NotifyNormal; + } + if ((info->display != eventPtr->xany.display) || (mode == NotifyNormal) + || (diff < 0)) { + return TK_DEFER_EVENT; + } else { + return TK_DISCARD_EVENT; } - ckfree((char *) events); } /* @@ -1334,19 +1269,19 @@ EatGrabEvents(dispPtr, serial) * * QueueGrabWindowChange -- * - * This procedure queues a special event in the grab event queue - * for dispPtr, which will cause the "grabWinPtr" field for the - * display to get modified when the event is processed. This - * procedure is needed to make sure that the grab window changes - * at the proper time relative to grab-related enter and leave - * events that are also in the queue. In particular, this approach - * works even when multiple grabs and ungrabs happen back-to-back. + * This procedure queues a special event in the Tcl event queue, + * which will cause the "grabWinPtr" field for the display to get + * modified when the event is processed. This is needed to make + * sure that the grab window changes at the proper time relative + * to grab-related enter and leave events that are also in the + * queue. In particular, this approach works even when multiple + * grabs and ungrabs happen back-to-back. * * Results: * None. * * Side effects: - * DispPtr->grabWinPtr will be modified later (by TkGrabTriggerProc) + * DispPtr->grabWinPtr will be modified later (by GrabWinEventProc) * when the event is removed from the grab event queue. * *---------------------------------------------------------------------- @@ -1359,15 +1294,54 @@ QueueGrabWindowChange(dispPtr, grabWinPtr) TkWindow *grabWinPtr; /* Window that is to become the new grab * window (may be NULL). */ { - XEvent event; + NewGrabWinEvent *grabEvPtr; - event.xany.display = dispPtr->display; - event.xany.send_event = GRAB_WINDOW_EVENT_MAGIC; - event.xany.window = (grabWinPtr == NULL) ? None : grabWinPtr->window; - TkQueueEvent(dispPtr, &event); + grabEvPtr = (NewGrabWinEvent *) ckalloc(sizeof(NewGrabWinEvent)); + grabEvPtr->header.proc = GrabWinEventProc; + grabEvPtr->dispPtr = dispPtr; + if (grabWinPtr == NULL) { + grabEvPtr->grabWindow = None; + } else { + grabEvPtr->grabWindow = grabWinPtr->window; + } + Tcl_QueueEvent(&grabEvPtr->header, TCL_QUEUE_MARK); dispPtr->eventualGrabWinPtr = grabWinPtr; } +/* + *---------------------------------------------------------------------- + * + * GrabWinEventProc -- + * + * This procedure is invoked as a handler for Tcl_Events of type + * NewGrabWinEvent. It updates the current grab window field in + * a display. + * + * Results: + * Returns 1 if the event was processed, 0 if it should be deferred + * for processing later. + * + * Side effects: + * The grabWinPtr field is modified in the display associated with + * the event. + * + *---------------------------------------------------------------------- + */ + +static int +GrabWinEventProc(evPtr, flags) + Tcl_Event *evPtr; /* Event of type NewGrabWinEvent. */ + int flags; /* Flags argument to Tk_DoOneEvent: indicates + * what kinds of events are being processed + * right now. */ +{ + NewGrabWinEvent *grabEvPtr = (NewGrabWinEvent *) evPtr; + + grabEvPtr->dispPtr->grabWinPtr = (TkWindow *) Tk_IdToWindow( + grabEvPtr->dispPtr->display, grabEvPtr->grabWindow); + return 1; +} + /* *---------------------------------------------------------------------- * @@ -1411,7 +1385,7 @@ FindCommonAncestor(winPtr1, winPtr2, countPtr1, countPtr2) */ if (winPtr1 != NULL) { - for (winPtr = winPtr1; ; winPtr = winPtr->parentPtr) { + for (winPtr = winPtr1; winPtr != NULL; winPtr = winPtr->parentPtr) { winPtr->flags |= TK_GRAB_FLAG; if (winPtr->flags & TK_TOP_LEVEL) { break; @@ -1428,7 +1402,7 @@ FindCommonAncestor(winPtr1, winPtr2, countPtr1, countPtr2) count2 = 0; ancestorPtr = NULL; if (winPtr2 != NULL) { - for (; ; count2++, winPtr = winPtr->parentPtr) { + for (; winPtr != NULL; count2++, winPtr = winPtr->parentPtr) { if (winPtr->flags & TK_GRAB_FLAG) { ancestorPtr = winPtr; break; @@ -1449,7 +1423,8 @@ FindCommonAncestor(winPtr1, winPtr2, countPtr1, countPtr2) count1 = 0; } else { count1 = -1; - for (i = 0, winPtr = winPtr1; ; i++, winPtr = winPtr->parentPtr) { + for (i = 0, winPtr = winPtr1; winPtr != NULL; + i++, winPtr = winPtr->parentPtr) { winPtr->flags &= ~TK_GRAB_FLAG; if (winPtr == ancestorPtr) { count1 = i; @@ -1467,3 +1442,94 @@ FindCommonAncestor(winPtr1, winPtr2, countPtr1, countPtr2) *countPtr2 = count2; return ancestorPtr; } + +/* + *---------------------------------------------------------------------- + * + * TkPositionInTree -- + * + * Compute where the given window is relative to a particular + * subtree of the window hierarchy. + * + * Results: + * + * Returns TK_GRAB_IN_TREE if the window is contained in the + * subtree. Returns TK_GRAB_ANCESTOR if the window is an + * ancestor of the subtree, in the same toplevel. Otherwise + * it returns TK_GRAB_EXCLUDED. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TkPositionInTree(winPtr, treePtr) + TkWindow *winPtr; /* Window to be checked. */ + TkWindow *treePtr; /* Root of tree to compare against. */ +{ + TkWindow *winPtr2; + + for (winPtr2 = winPtr; winPtr2 != treePtr; + winPtr2 = winPtr2->parentPtr) { + if (winPtr2 == NULL) { + for (winPtr2 = treePtr; winPtr2 != NULL; + winPtr2 = winPtr2->parentPtr) { + if (winPtr2 == winPtr) { + return TK_GRAB_ANCESTOR; + } + if (winPtr2->flags & TK_TOP_LEVEL) { + break; + } + } + return TK_GRAB_EXCLUDED; + } + } + return TK_GRAB_IN_TREE; +} + +/* + *---------------------------------------------------------------------- + * + * TkGrabState -- + * + * Given a window, this procedure returns a value that indicates + * the grab state of the application relative to the window. + * + * Results: + * The return value is one of three things: + * TK_GRAB_NONE - no grab is in effect. + * TK_GRAB_IN_TREE - there is a grab in effect, and winPtr + * is in the grabbed subtree. + * TK_GRAB_ANCESTOR - there is a grab in effect; winPtr is + * an ancestor of the grabbed window, in + * the same toplevel. + * TK_GRAB_EXCLUDED - there is a grab in effect; winPtr is + * outside the tree of the grab and is not + * an ancestor of the grabbed window in the + * same toplevel. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TkGrabState(winPtr) + TkWindow *winPtr; /* Window for which grab information is + * needed. */ +{ + TkWindow *grabWinPtr = winPtr->dispPtr->grabWinPtr; + + if (grabWinPtr == NULL) { + return TK_GRAB_NONE; + } + if ((winPtr->mainPtr != grabWinPtr->mainPtr) + && !(winPtr->dispPtr->grabFlags & GRAB_GLOBAL)) { + return TK_GRAB_NONE; + } + + return TkPositionInTree(winPtr, grabWinPtr); +} diff --git a/tk4.2/generic/tkGrid.c b/tk4.2/generic/tkGrid.c new file mode 100644 index 0000000..95c0a93 --- /dev/null +++ b/tk4.2/generic/tkGrid.c @@ -0,0 +1,2578 @@ +/* + * tkGrid.c -- + * + * Grid based geometry manager. + * + * Copyright (c) 1996 by Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkGrid.c 1.29 96/10/07 11:45:54 + */ + +#include "tkInt.h" + +/* + * Convenience Macros + */ + +#ifdef MAX +# undef MAX +#endif +#define MAX(x,y) ((x) > (y) ? (x) : (y)) +#ifdef MIN +# undef MIN +#endif +#define MIN(x,y) ((x) > (y) ? (y) : (x)) + +#define COLUMN (1) /* working on column offsets */ +#define ROW (2) /* working on row offsets */ + +#define CHECK_ONLY (1) /* check max slot constraint */ +#define CHECK_SPACE (2) /* alloc more space, don't change max */ + +/* + * Pre-allocate enough row and column slots for "typical" sized tables + * this value should be chosen so by the time the extra malloc's are + * required, the layout calculations overwehlm them. [A "slot" contains + * information for either a row or column, depending upon the context.] + */ + +#define TYPICAL_SIZE 25 /* (arbitrary guess) */ +#define PREALLOC 10 /* extra slots to allocate */ + +/* + * Data structures are allocated dynamically to support arbitrary sized tables. + * However, the space is proportional to the highest numbered slot with + * some non-default property. This limit is used to head off mistakes and + * denial of service attacks by limiting the amount of storage required. + */ + +#define MAX_ELEMENT 10000 + +/* + * Special characters to support relative layouts. + */ + +#define REL_SKIP 'x' /* Skip this column. */ +#define REL_HORIZ '-' /* Extend previous widget horizontally. */ +#define REL_VERT '^' /* Extend widget from row above. */ + +/* + * Structure to hold information for grid masters. A slot is either + * a row or column. + */ + +typedef struct SlotInfo { + int minSize; /* The minimum size of this slot (in pixels). + * It is set via the rowconfigure or + * columnconfigure commands. */ + int weight; /* The resize weight of this slot. (0) means + * this slot doesn't resize. Extra space in + * the layout is given distributed among slots + * inproportion to their weights. */ + int pad; /* Extra padding, in pixels, required for + * this slot. This amount is "added" to the + * largest slave in the slot. */ + int offset; /* This is a cached value used for + * introspection. It is the pixel + * offset of the right or bottom edge + * of this slot from the beginning of the + * layout. */ + int temp; /* This is a temporary value used for + * calculating adjusted weights when + * shrinking the layout below its + * nominal size. */ +} SlotInfo; + +/* + * Structure to hold information during layout calculations. There + * is one of these for each slot, an array for each of the rows or columns. + */ + +typedef struct GridLayout { + struct Gridder *binNextPtr; /* The next slave window in this bin. + * Each bin contains a list of all + * slaves whose spans are >1 and whose + * right edges fall in this slot. */ + int minSize; /* Minimum size needed for this slot, + * in pixels. This is the space required + * to hold any slaves contained entirely + * in this slot, adjusted for any slot + * constrants, such as size or padding. */ + int pad; /* Padding needed for this slot */ + int weight; /* Slot weight, controls resizing. */ + int minOffset; /* The minimum offset, in pixels, from + * the beginning of the layout to the + * right/bottom edge of the slot calculated + * from top/left to bottom/right. */ + int maxOffset; /* The maximum offset, in pixels, from + * the beginning of the layout to the + * right-or-bottom edge of the slot calculated + * from bottom-or-right to top-or-left. */ +} GridLayout; + +/* + * Keep one of these for each geometry master. + */ + +typedef struct { + SlotInfo *columnPtr; /* Pointer to array of column constraints. */ + SlotInfo *rowPtr; /* Pointer to array of row constraints. */ + int columnEnd; /* The last column occupied by any slave. */ + int columnMax; /* The number of columns with constraints. */ + int columnSpace; /* The number of slots currently allocated for + * column constraints. */ + int rowEnd; /* The last row occupied by any slave. */ + int rowMax; /* The number of rows with constraints. */ + int rowSpace; /* The number of slots currently allocated + * for row constraints. */ + int startX; /* Pixel offset of this layout within its + * parent. */ + int startY; /* Pixel offset of this layout within its + * parent. */ +} GridMaster; + +/* + * For each window that the grid cares about (either because + * the window is managed by the grid or because the window + * has slaves that are managed by the grid), there is a + * structure of the following type: + */ + +typedef struct Gridder { + Tk_Window tkwin; /* Tk token for window. NULL means that + * the window has been deleted, but the + * gridder hasn't had a chance to clean up + * yet because the structure is still in + * use. */ + struct Gridder *masterPtr; /* Master window within which this window + * is managed (NULL means this window + * isn't managed by the gridder). */ + struct Gridder *nextPtr; /* Next window managed within same + * parent. List order doesn't matter. */ + struct Gridder *slavePtr; /* First in list of slaves managed + * inside this window (NULL means + * no grid slaves). */ + GridMaster *masterDataPtr; /* Additional data for geometry master. */ + int column, row; /* Location in the grid (starting + * from zero). */ + int numCols, numRows; /* Number of columns or rows this slave spans. + * Should be at least 1. */ + int padX, padY; /* Total additional pixels to leave around the + * window (half of this space is left on each + * side). This is space *outside* the window: + * we'll allocate extra space in frame but + * won't enlarge window). */ + int iPadX, iPadY; /* Total extra pixels to allocate inside the + * window (half this amount will appear on + * each side). */ + int sticky; /* which sides of its cavity this window + * sticks to. See below for definitions */ + int doubleBw; /* Twice the window's last known border + * width. If this changes, the window + * must be re-arranged within its parent. */ + int *abortPtr; /* If non-NULL, it means that there is a nested + * call to ArrangeGrid already working on + * this window. *abortPtr may be set to 1 to + * abort that nested call. This happens, for + * example, if tkwin or any of its slaves + * is deleted. */ + int flags; /* Miscellaneous flags; see below + * for definitions. */ + + /* + * These fields are used temporarily for layout calculations only. + */ + + struct Gridder *binNextPtr; /* Link to next span>1 slave in this bin. */ + int size; /* Nominal size (width or height) in pixels + * of the slave. This includes the padding. */ +} Gridder; + +/* Flag values for "sticky"ness The 16 combinations subsume the packer's + * notion of anchor and fill. + * + * STICK_NORTH This window sticks to the top of its cavity. + * STICK_EAST This window sticks to the right edge of its cavity. + * STICK_SOUTH This window sticks to the bottom of its cavity. + * STICK_WEST This window sticks to the left edge of its cavity. + */ + +#define STICK_NORTH 1 +#define STICK_EAST 2 +#define STICK_SOUTH 4 +#define STICK_WEST 8 + +/* + * Flag values for Grid structures: + * + * REQUESTED_RELAYOUT: 1 means a Tcl_DoWhenIdle request + * has already been made to re-arrange + * all the slaves of this window. + * + * DONT_PROPAGATE: 1 means don't set this window's requested + * size. 0 means if this window is a master + * then Tk will set its requested size to fit + * the needs of its slaves. + */ + +#define REQUESTED_RELAYOUT 1 +#define DONT_PROPAGATE 2 + +/* + * Hash table used to map from Tk_Window tokens to corresponding + * Grid structures: + */ + +static Tcl_HashTable gridHashTable; +static initialized = 0; + +/* + * Prototypes for procedures used only in this file: + */ + +static int AdjustOffsets _ANSI_ARGS_((int width, + int elements, SlotInfo *slotPtr)); +static void ArrangeGrid _ANSI_ARGS_((ClientData clientData)); +static int CheckSlotData _ANSI_ARGS_((Gridder *masterPtr, int slot, + int slotType, int checkOnly)); +static int ConfigureSlaves _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, int argc, char *argv[])); +static void DestroyGrid _ANSI_ARGS_((char *memPtr)); +static Gridder *GetGrid _ANSI_ARGS_((Tk_Window tkwin)); +static void GridStructureProc _ANSI_ARGS_(( + ClientData clientData, XEvent *eventPtr)); +static void GridLostSlaveProc _ANSI_ARGS_((ClientData clientData, + Tk_Window tkwin)); +static void GridReqProc _ANSI_ARGS_((ClientData clientData, + Tk_Window tkwin)); +static void InitMasterData _ANSI_ARGS_((Gridder *masterPtr)); +static int ResolveConstraints _ANSI_ARGS_((Gridder *gridPtr, + int rowOrColumn, int maxOffset)); +static void SetGridSize _ANSI_ARGS_((Gridder *gridPtr)); +static void StickyToString _ANSI_ARGS_((int flags, char *result)); +static int StringToSticky _ANSI_ARGS_((char *string)); +static void Unlink _ANSI_ARGS_((Gridder *gridPtr)); + +static Tk_GeomMgr gridMgrType = { + "grid", /* name */ + GridReqProc, /* requestProc */ + GridLostSlaveProc, /* lostSlaveProc */ +}; + +/* + *-------------------------------------------------------------- + * + * Tk_GridCmd -- + * + * This procedure is invoked to process the "grid" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +int +Tk_GridCmd(clientData, interp, argc, argv) + ClientData clientData; /* Main window associated with + * interpreter. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tk_Window tkwin = (Tk_Window) clientData; + Gridder *masterPtr; /* master grid record */ + GridMaster *gridPtr; /* pointer to grid data */ + size_t length; /* streing length of argument */ + char c; /* 1st character of argument */ + + if ((argc >= 2) && ((argv[1][0] == '.') || (argv[1][0] == REL_SKIP) || + (argv[1][0] == REL_VERT))) { + return ConfigureSlaves(interp, tkwin, argc-1, argv+1); + } + if (argc < 3) { + 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 == 'b') && (strncmp(argv[1], "bbox", length) == 0)) { + Tk_Window master; + int row, column; /* origin for bounding box */ + int row2, column2; /* end of bounding box */ + int endX, endY; /* last column/row in the layout */ + int x=0, y=0; /* starting pixels for this bounding box */ + int width, height; /* size of the bounding box */ + + if (argc!=3 && argc != 5 && argc != 7) { + Tcl_AppendResult(interp, "wrong number of arguments: ", + "must be \"",argv[0], + " bbox master ?column row ?column row??\"", + (char *) NULL); + return TCL_ERROR; + } + + master = Tk_NameToWindow(interp, argv[2], tkwin); + if (master == NULL) { + return TCL_ERROR; + } + masterPtr = GetGrid(master); + + if (argc >= 5) { + if (Tcl_GetInt(interp, argv[3], &column) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[4], &row) != TCL_OK) { + return TCL_ERROR; + } + column2 = column; + row2 = row; + } + + if (argc == 7) { + if (Tcl_GetInt(interp, argv[5], &column2) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[6], &row2) != TCL_OK) { + return TCL_ERROR; + } + } + + gridPtr = masterPtr->masterDataPtr; + if (gridPtr == NULL) { + sprintf(interp->result, "%d %d %d %d",0,0,0,0); + return(TCL_OK); + } + + SetGridSize(masterPtr); + endX = MAX(gridPtr->columnEnd, gridPtr->columnMax); + endY = MAX(gridPtr->rowEnd, gridPtr->rowMax); + + if (endX == 0 || endY == 0) { + sprintf(interp->result, "%d %d %d %d",0,0,0,0); + return(TCL_OK); + } + if (argc == 3) { + row = column = 0; + row2 = endY; + column2 = endX; + } + + if (column > column2) { + int temp = column; + column = column2, column2 = temp; + } + if (row > row2) { + int temp = row; + row = row2, row2 = temp; + } + + if (column > 0 && column < endX) { + x = gridPtr->columnPtr[column-1].offset; + } else if (column > 0) { + x = gridPtr->columnPtr[endX-1].offset; + } + + if (row > 0 && row < endY) { + y = gridPtr->rowPtr[row-1].offset; + } else if (row > 0) { + y = gridPtr->rowPtr[endY-1].offset; + } + + if (column2 < 0) { + width = 0; + } else if (column2 >= endX) { + width = gridPtr->columnPtr[endX-1].offset - x; + } else { + width = gridPtr->columnPtr[column2].offset - x; + } + + if (row2 < 0) { + height = 0; + } else if (row2 >= endY) { + height = gridPtr->rowPtr[endY-1].offset - y; + } else { + height = gridPtr->rowPtr[row2].offset - y; + } + + sprintf(interp->result, "%d %d %d %d", + x + gridPtr->startX, y + gridPtr->startY, width, height); + } else if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0)) { + if (argv[2][0] != '.') { + Tcl_AppendResult(interp, "bad argument \"", argv[2], + "\": must be name of window", (char *) NULL); + return TCL_ERROR; + } + return ConfigureSlaves(interp, tkwin, argc-2, argv+2); + } else if (((c == 'f') && (strncmp(argv[1], "forget", length) == 0)) || + ((c == 'r') && (strncmp(argv[1], "remove", length) == 0))) { + Tk_Window slave; + Gridder *slavePtr; + int i; + + for (i = 2; i < argc; i++) { + slave = Tk_NameToWindow(interp, argv[i], tkwin); + if (slave == NULL) { + return TCL_ERROR; + } + slavePtr = GetGrid(slave); + if (slavePtr->masterPtr != NULL) { + + /* + * For "forget", reset all the settings to their defaults + */ + + if (c == 'f') { + slavePtr->column = slavePtr->row = -1; + slavePtr->numCols = 1; + slavePtr->numRows = 1; + slavePtr->padX = slavePtr->padY = 0; + slavePtr->iPadX = slavePtr->iPadY = 0; + slavePtr->doubleBw = 2*Tk_Changes(tkwin)->border_width; + slavePtr->flags = 0; + slavePtr->sticky = 0; + } + Tk_ManageGeometry(slave, (Tk_GeomMgr *) NULL, + (ClientData) NULL); + Unlink(slavePtr); + Tk_UnmapWindow(slavePtr->tkwin); + } + } + } else if ((c == 'i') && (strncmp(argv[1], "info", length) == 0)) { + register Gridder *slavePtr; + Tk_Window slave; + char buffer[70]; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " info window\"", (char *) NULL); + return TCL_ERROR; + } + slave = Tk_NameToWindow(interp, argv[2], tkwin); + if (slave == NULL) { + return TCL_ERROR; + } + slavePtr = GetGrid(slave); + if (slavePtr->masterPtr == NULL) { + interp->result[0] = '\0'; + return TCL_OK; + } + + Tcl_AppendElement(interp, "-in"); + Tcl_AppendElement(interp, Tk_PathName(slavePtr->masterPtr->tkwin)); + sprintf(buffer, " -column %d -row %d -columnspan %d -rowspan %d", + slavePtr->column, slavePtr->row, + slavePtr->numCols, slavePtr->numRows); + Tcl_AppendResult(interp, buffer, (char *) NULL); + sprintf(buffer, " -ipadx %d -ipady %d -padx %d -pady %d", + slavePtr->iPadX/2, slavePtr->iPadY/2, slavePtr->padX/2, + slavePtr->padY/2); + Tcl_AppendResult(interp, buffer, (char *) NULL); + StickyToString(slavePtr->sticky,buffer); + Tcl_AppendResult(interp, " -sticky ", buffer, (char *) NULL); + } else if((c == 'l') && (strncmp(argv[1], "location", length) == 0)) { + Tk_Window master; + register SlotInfo *slotPtr; + int x, y; /* Offset in pixels, from edge of parent. */ + int i, j; /* Corresponding column and row indeces. */ + int endX, endY; /* end of grid */ + + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " location master x y\"", (char *)NULL); + return TCL_ERROR; + } + + master = Tk_NameToWindow(interp, argv[2], tkwin); + if (master == NULL) { + return TCL_ERROR; + } + + if (Tk_GetPixels(interp, master, argv[3], &x) != TCL_OK) { + return TCL_ERROR; + } + if (Tk_GetPixels(interp, master, argv[4], &y) != TCL_OK) { + return TCL_ERROR; + } + + masterPtr = GetGrid(master); + if (masterPtr->masterDataPtr == NULL) { + sprintf(interp->result, "%d %d", -1, -1); + return TCL_OK; + } + gridPtr = masterPtr->masterDataPtr; + + /* + * Update any pending requests. This is not always the + * steady state value, as more configure events could be in + * the pipeline, but its as close as its easy to get. + */ + + while (masterPtr->flags & REQUESTED_RELAYOUT) { + Tk_CancelIdleCall(ArrangeGrid, (ClientData) masterPtr); + ArrangeGrid ((ClientData) masterPtr); + } + SetGridSize(masterPtr); + endX = MAX(gridPtr->columnEnd, gridPtr->columnMax); + endY = MAX(gridPtr->rowEnd, gridPtr->rowMax); + + slotPtr = masterPtr->masterDataPtr->columnPtr; + if (x < masterPtr->masterDataPtr->startX) { + i = -1; + } else { + x -= masterPtr->masterDataPtr->startX; + for (i=0;slotPtr[i].offset < x && i < endX; i++) { + /* null body */ + } + } + + slotPtr = masterPtr->masterDataPtr->rowPtr; + if (y < masterPtr->masterDataPtr->startY) { + j = -1; + } else { + y -= masterPtr->masterDataPtr->startY; + for (j=0;slotPtr[j].offset < y && j < endY; j++) { + /* null body */ + } + } + + sprintf(interp->result, "%d %d", i, j); + } else if ((c == 'p') && (strncmp(argv[1], "propagate", length) == 0)) { + Tk_Window master; + int propagate; + + if (argc > 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " propagate window ?boolean?\"", + (char *) NULL); + return TCL_ERROR; + } + master = Tk_NameToWindow(interp, argv[2], tkwin); + if (master == NULL) { + return TCL_ERROR; + } + masterPtr = GetGrid(master); + if (argc == 3) { + interp->result = (masterPtr->flags & DONT_PROPAGATE) ? "0" : "1"; + return TCL_OK; + } + if (Tcl_GetBoolean(interp, argv[3], &propagate) != TCL_OK) { + return TCL_ERROR; + } + if ((!propagate) ^ (masterPtr->flags&DONT_PROPAGATE)) { + masterPtr->flags ^= DONT_PROPAGATE; + + /* + * Re-arrange the master to allow new geometry information to + * propagate upwards to the master's master. + */ + + if (masterPtr->abortPtr != NULL) { + *masterPtr->abortPtr = 1; + } + if (!(masterPtr->flags & REQUESTED_RELAYOUT)) { + masterPtr->flags |= REQUESTED_RELAYOUT; + Tcl_DoWhenIdle(ArrangeGrid, (ClientData) masterPtr); + } + } + } else if ((c == 's') && (strncmp(argv[1], "size", length) == 0) + && (length > 1)) { + Tk_Window master; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " size window\"", (char *) NULL); + return TCL_ERROR; + } + master = Tk_NameToWindow(interp, argv[2], tkwin); + if (master == NULL) { + return TCL_ERROR; + } + masterPtr = GetGrid(master); + + if (masterPtr->masterDataPtr != NULL) { + SetGridSize(masterPtr); + gridPtr = masterPtr->masterDataPtr; + sprintf(interp->result, "%d %d", + MAX(gridPtr->columnEnd, gridPtr->columnMax), + MAX(gridPtr->rowEnd, gridPtr->rowMax)); + } else { + sprintf(interp->result, "%d %d",0, 0); + } + } else if ((c == 's') && (strncmp(argv[1], "slaves", length) == 0) + && (length > 1)) { + Tk_Window master; + Gridder *slavePtr; + int i, value; + int row = -1, column = -1; + + if ((argc < 3) || ((argc%2) == 0)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " slaves window ?-option value...?\"", + (char *) NULL); + return TCL_ERROR; + } + + for (i=3; islavePtr; slavePtr != NULL; + slavePtr = slavePtr->nextPtr) { + if (column>=0 && (slavePtr->column > column + || slavePtr->column+slavePtr->numCols-1 < column)) { + continue; + } + if (row>=0 && (slavePtr->row > row || + slavePtr->row+slavePtr->numRows-1 < row)) { + continue; + } + Tcl_AppendElement(interp, Tk_PathName(slavePtr->tkwin)); + } + + /* + * Sample argument combinations: + * grid columnconfigure -option + * grid columnconfigure -option value -option value + * grid rowconfigure + * grid rowconfigure -option + * grid rowconfigure -option value -option value. + */ + + } else if(((c=='c') && (strncmp(argv[1], "columnconfigure", length) == 0) + && (length > 3)) || + ((c=='r') && (strncmp(argv[1], "rowconfigure", length) == 0))) { + Tk_Window master; + SlotInfo *slotPtr = NULL; + int slot; /* the column or row number */ + size_t length; /* the # of chars in the "-option" string */ + int slotType; /* COLUMN or ROW */ + int size; /* the configuration value */ + int checkOnly; /* check the size only */ + int ok; /* temporary TCL result code */ + int i; + + if (((argc%2 != 0) && (argc>6)) || (argc < 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ", argv[1], " master index ?-option value...?\"", + (char *)NULL); + return TCL_ERROR; + } + + master = Tk_NameToWindow(interp, argv[2], tkwin); + if (master == NULL) { + return TCL_ERROR; + } + + if (Tcl_GetInt(interp, argv[3], &slot) != TCL_OK) { + return TCL_ERROR; + } + + slotType = (c == 'c') ? COLUMN : ROW; + masterPtr = GetGrid(master); + checkOnly = ((argc==4) || (argc==5)); + + ok = CheckSlotData(masterPtr, slot, slotType, checkOnly); + if ((ok!=TCL_OK) && (argc!=4)) { + Tcl_AppendResult(interp, argv[0], + " ", argv[1], ": \"", argv[3],"\" is out of range", + (char *) NULL); + return TCL_ERROR; + } else if (ok == TCL_OK) { + slotPtr = (slotType == COLUMN) ? + masterPtr->masterDataPtr->columnPtr : + masterPtr->masterDataPtr->rowPtr; + } + + /* + * Return all of the options for this row or column. If the + * request is out of range, return all 0's. + */ + + if ((argc==4) && (ok == TCL_OK)) { + sprintf(interp->result,"-minsize %d -pad %d -weight %d", + slotPtr[slot].minSize,slotPtr[slot].pad, + slotPtr[slot].weight); + return (TCL_OK); + } else if (argc == 4) { + sprintf(interp->result,"-minsize %d -pad %d -weight %d", 0,0,0); + return (TCL_OK); + } + + /* + * Loop through each option value pair, setting the values as required. + * If only one option is given, with no value, the current value is + * returned. + */ + + for (i=4; iresult,"%d",slotPtr[slot].minSize); + } else if (Tk_GetPixels(interp, master, argv[i+1], &size) + != TCL_OK) { + return TCL_ERROR; + } else { + slotPtr[slot].minSize = size; + } + } + else if (strncmp(argv[i], "-weight", length) == 0) { + int wt; + if (argc == 5) { + sprintf(interp->result,"%d",slotPtr[slot].weight); + } else if (Tcl_GetInt(interp, argv[i+1], &wt) != TCL_OK) { + return TCL_ERROR; + } else if (wt < 0) { + Tcl_AppendResult(interp, "invalid arg \"", argv[i], + "\": should be non-negative", (char *) NULL); + return TCL_ERROR; + } else { + slotPtr[slot].weight = wt; + } + } + else if (strncmp(argv[i], "-pad", length) == 0) { + if (argc == 5) { + sprintf(interp->result,"%d",slotPtr[slot].pad); + } else if (Tk_GetPixels(interp, master, argv[i+1], &size) + != TCL_OK) { + return TCL_ERROR; + } else if (size < 0) { + Tcl_AppendResult(interp, "invalid arg \"", argv[i], + "\": should be non-negative", (char *) NULL); + return TCL_ERROR; + } else { + slotPtr[slot].pad = size; + } + } else { + Tcl_AppendResult(interp, "invalid arg \"", + argv[i], "\": expecting -minsize, -pad, or -weight.", + (char *) NULL); + return TCL_ERROR; + } + } + + /* + * If we changed a property, re-arrange the table, + * and check for constraint shrinkage. + */ + + if (argc != 5) { + if (slotType==ROW) { + int last = masterPtr->masterDataPtr->rowMax - 1; + while (last>=0 && slotPtr[last].weight==0 && + slotPtr[last].pad==0 && slotPtr[last].minSize==0) { + last--; + } + masterPtr->masterDataPtr->rowMax = last+1; + } else { + int last = masterPtr->masterDataPtr->columnMax - 1; + while (last>=0 && slotPtr[last].weight==0 && + slotPtr[last].pad==0 && slotPtr[last].minSize==0) { + last--; + } + masterPtr->masterDataPtr->columnMax = last + 1; + } + + if (masterPtr->abortPtr != NULL) { + *masterPtr->abortPtr = 1; + } + if (!(masterPtr->flags & REQUESTED_RELAYOUT)) { + masterPtr->flags |= REQUESTED_RELAYOUT; + Tcl_DoWhenIdle(ArrangeGrid, (ClientData) masterPtr); + } + } + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be bbox, columnconfigure, configure, forget, info, ", + "location, propagate, remove, rowconfigure, size, or slaves.", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * GridReqProc -- + * + * This procedure is invoked by Tk_GeometryRequest for + * windows managed by the grid. + * + * Results: + * None. + * + * Side effects: + * Arranges for tkwin, and all its managed siblings, to + * be re-arranged at the next idle point. + * + *-------------------------------------------------------------- + */ + +static void +GridReqProc(clientData, tkwin) + ClientData clientData; /* Grid's information about + * window that got new preferred + * geometry. */ + Tk_Window tkwin; /* Other Tk-related information + * about the window. */ +{ + register Gridder *gridPtr = (Gridder *) clientData; + + gridPtr = gridPtr->masterPtr; + if (!(gridPtr->flags & REQUESTED_RELAYOUT)) { + gridPtr->flags |= REQUESTED_RELAYOUT; + Tcl_DoWhenIdle(ArrangeGrid, (ClientData) gridPtr); + } +} + +/* + *-------------------------------------------------------------- + * + * GridLostSlaveProc -- + * + * This procedure is invoked by Tk whenever some other geometry + * claims control over a slave that used to be managed by us. + * + * Results: + * None. + * + * Side effects: + * Forgets all grid-related information about the slave. + * + *-------------------------------------------------------------- + */ + +static void +GridLostSlaveProc(clientData, tkwin) + ClientData clientData; /* Grid structure for slave window that + * was stolen away. */ + Tk_Window tkwin; /* Tk's handle for the slave window. */ +{ + register Gridder *slavePtr = (Gridder *) clientData; + + if (slavePtr->masterPtr->tkwin != Tk_Parent(slavePtr->tkwin)) { + Tk_UnmaintainGeometry(slavePtr->tkwin, slavePtr->masterPtr->tkwin); + } + Unlink(slavePtr); + Tk_UnmapWindow(slavePtr->tkwin); +} + +/* + *-------------------------------------------------------------- + * + * AdjustOffsets -- + * + * This procedure adjusts the size of the layout to fit in the + * space provided. If it needs more space, the extra is added + * according to the weights. If it needs less, the space is removed + * according to the weights, but at no time does the size drop below + * the minsize specified for that slot. + * + * Results: + * The initial offset of the layout, + * if all the weights are zero, else 0. + * + * Side effects: + * The slot offsets are modified to shrink the layout. + * + *-------------------------------------------------------------- + */ + +static int +AdjustOffsets(size, slots, slotPtr) + int size; /* The total layout size (in pixels). */ + int slots; /* Number of slots. */ + register SlotInfo *slotPtr; /* Pointer to slot array. */ +{ + register int slot; /* Current slot. */ + int diff = 0; /* Extra pixels needed to add to the layout. */ + int totalWeight = 0; /* Sum of the weights for all the slots. */ + int weight = 0; /* Sum of the weights so far. */ + int minSize = 0; /* Minimum possible layout size. */ + int newDiff = 0; /* The most pixels that can be added on + * the current pass. */ + + diff = size - slotPtr[slots-1].offset; + + /* + * The layout is already the correct size; all done. + */ + + if (diff == 0) { + return(0); + } + + /* + * If all the weights are zero, center the layout in its parent if + * there is extra space, else clip on the bottom/right. + */ + + for (slot=0; slot < slots; slot++) { + totalWeight += slotPtr[slot].weight; + } + + if (totalWeight == 0 ) { + return(diff > 0 ? diff/2 : 0); + } + + /* + * Add extra space according to the slot weights. This is done + * cumulatively to prevent round-off error accumulation. + */ + + if (diff > 0) { + for (weight=slot=0; slot < slots; slot++) { + weight += slotPtr[slot].weight; + slotPtr[slot].offset += diff * weight / totalWeight; + } + return(0); + } + + /* + * The layout must shrink below its requested size. Compute the + * minimum possible size by looking at the slot minSizes. + */ + + for (slot=0; slot < slots; slot++) { + if (slotPtr[slot].weight > 0) { + minSize += slotPtr[slot].minSize; + } else if (slot > 0) { + minSize += slotPtr[slot].offset - slotPtr[slot-1].offset; + } else { + minSize += slotPtr[slot].offset; + } + } + + /* + * If the requested size is less than the minimum required size, + * set the slot sizes to their minimum values, then clip on the + * bottom/right. + */ + + if (size <= minSize) { + int offset = 0; + for (slot=0; slot < slots; slot++) { + if (slotPtr[slot].weight > 0) { + offset += slotPtr[slot].minSize; + } else if (slot > 0) { + offset += slotPtr[slot].offset - slotPtr[slot-1].offset; + } else { + offset += slotPtr[slot].offset; + } + slotPtr[slot].offset = offset; + } + return(0); + } + + /* + * Remove space from slots according to their weights. The weights + * get renormalized anytime a slot shrinks to its minimum size. + */ + + while (diff < 0) { + + /* + * Find the total weight for the shrinkable slots. + */ + + for (totalWeight=slot=0; slot < slots; slot++) { + int current = (slot==0) ? slotPtr[slot].offset : + slotPtr[slot].offset - slotPtr[slot-1].offset; + if (current > slotPtr[slot].minSize) { + totalWeight += slotPtr[slot].weight; + slotPtr[slot].temp = slotPtr[slot].weight; + } else { + slotPtr[slot].temp = 0; + } + } + if (totalWeight == 0) { + break; + } + + /* + * Find the maximum amount of space we can distribute this pass. + */ + + newDiff = diff; + for (weight=slot=0; slot < slots; slot++) { + int current; /* current size of this slot */ + int maxDiff; /* max diff that would cause + * this slot to equal its minsize */ + if (slotPtr[slot].temp == 0) { + continue; + } + weight += slotPtr[slot].temp; + current = (slot==0) ? slotPtr[slot].offset : + slotPtr[slot].offset - slotPtr[slot-1].offset; + maxDiff = totalWeight * (slotPtr[slot].minSize - current) + / slotPtr[slot].temp; + if (maxDiff > newDiff) { + newDiff = maxDiff; + } + } + + /* + * Now distribute the space. + */ + + for (weight=slot=0; slot < slots; slot++) { + weight += slotPtr[slot].temp; + slotPtr[slot].offset += newDiff * weight / totalWeight; + } + diff -= newDiff; + } + return(0); +} + +/* + *-------------------------------------------------------------- + * + * AdjustForSticky -- + * + * This procedure adjusts the size of a slave in its cavity based + * on its "sticky" flags. + * + * Results: + * The input x, y, width, and height are changed to represent the + * desired coordinates of the slave. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static void +AdjustForSticky(slavePtr, xPtr, yPtr, widthPtr, heightPtr) + Gridder *slavePtr; /* Slave window to arrange in its cavity. */ + int *xPtr; /* Pixel location of the left edge of the cavity. */ + int *yPtr; /* Pixel location of the top edge of the cavity. */ + int *widthPtr; /* Width of the cavity (in pixels). */ + int *heightPtr; /* Height of the cavity (in pixels). */ +{ + int diffx=0; /* Cavity width - slave width. */ + int diffy=0; /* Cavity hight - slave height. */ + int sticky = slavePtr->sticky; + + *xPtr += slavePtr->padX/2; + *widthPtr -= slavePtr->padX; + *yPtr += slavePtr->padY/2; + *heightPtr -= slavePtr->padY; + + if (*widthPtr > (Tk_ReqWidth(slavePtr->tkwin) + slavePtr->iPadX)) { + diffx = *widthPtr - Tk_ReqWidth(slavePtr->tkwin) + slavePtr->iPadX; + *widthPtr = Tk_ReqWidth(slavePtr->tkwin) + slavePtr->iPadX; + } + + if (*heightPtr > (Tk_ReqHeight(slavePtr->tkwin) + slavePtr->iPadY)) { + diffy = *heightPtr - Tk_ReqHeight(slavePtr->tkwin) + slavePtr->iPadY; + *heightPtr = Tk_ReqHeight(slavePtr->tkwin) + slavePtr->iPadY; + } + + if (sticky&STICK_EAST && sticky&STICK_WEST) { + *widthPtr += diffx; + } + if (sticky&STICK_NORTH && sticky&STICK_SOUTH) { + *heightPtr += diffy; + } + if (!(sticky&STICK_WEST)) { + *xPtr += (sticky&STICK_EAST) ? diffx : diffx/2; + } + if (!(sticky&STICK_NORTH)) { + *yPtr += (sticky&STICK_SOUTH) ? diffy : diffy/2; + } +} + +/* + *-------------------------------------------------------------- + * + * ArrangeGrid -- + * + * This procedure is invoked (using the Tcl_DoWhenIdle + * mechanism) to re-layout a set of windows managed by + * the grid. It is invoked at idle time so that a + * series of grid requests can be merged into a single + * layout operation. + * + * Results: + * None. + * + * Side effects: + * The slaves of masterPtr may get resized or moved. + * + *-------------------------------------------------------------- + */ + +static void +ArrangeGrid(clientData) + ClientData clientData; /* Structure describing parent whose slaves + * are to be re-layed out. */ +{ + register Gridder *masterPtr = (Gridder *) clientData; + register Gridder *slavePtr; + GridMaster *slotPtr = masterPtr->masterDataPtr; + int abort; + int width, height; /* requested size of layout, in pixels */ + int realWidth, realHeight; /* actual size layout should take-up */ + + masterPtr->flags &= ~REQUESTED_RELAYOUT; + + /* + * If the parent has no slaves anymore, then don't do anything + * at all: just leave the parent's size as-is. Otherwise there is + * no way to "relinquish" control over the parent so another geometry + * manager can take over. + */ + + if (masterPtr->slavePtr == NULL) { + return; + } + + if (masterPtr->masterDataPtr == NULL) { + return; + } + + /* + * Abort any nested call to ArrangeGrid for this window, since + * we'll do everything necessary here, and set up so this call + * can be aborted if necessary. + */ + + if (masterPtr->abortPtr != NULL) { + *masterPtr->abortPtr = 1; + } + masterPtr->abortPtr = &abort; + abort = 0; + Tcl_Preserve((ClientData) masterPtr); + + /* + * Call the constraint engine to fill in the row and column offsets. + */ + + SetGridSize(masterPtr); + width = ResolveConstraints(masterPtr, COLUMN, 0); + height = ResolveConstraints(masterPtr, ROW, 0); + width += 2*Tk_InternalBorderWidth(masterPtr->tkwin); + height += 2*Tk_InternalBorderWidth(masterPtr->tkwin); + + if (((width != Tk_ReqWidth(masterPtr->tkwin)) + || (height != Tk_ReqHeight(masterPtr->tkwin))) + && !(masterPtr->flags & DONT_PROPAGATE)) { + Tk_GeometryRequest(masterPtr->tkwin, width, height); + if (width>1 && height>1) { + masterPtr->flags |= REQUESTED_RELAYOUT; + Tcl_DoWhenIdle(ArrangeGrid, (ClientData) masterPtr); + } + masterPtr->abortPtr = NULL; + Tcl_Release((ClientData) masterPtr); + return; + } + + /* + * If the currently requested layout size doesn't match the parent's + * window size, then adjust the slot offsets according to the + * weights. If all of the weights are zero, center the layout in + * its parent. I haven't decided what to do if the parent is smaller + * than the requested size. + */ + + realWidth = Tk_Width(masterPtr->tkwin) - + 2*Tk_InternalBorderWidth(masterPtr->tkwin); + realHeight = Tk_Height(masterPtr->tkwin) - + 2*Tk_InternalBorderWidth(masterPtr->tkwin); + slotPtr->startX = AdjustOffsets(realWidth, + MAX(slotPtr->columnEnd,slotPtr->columnMax), slotPtr->columnPtr); + slotPtr->startY = AdjustOffsets(realHeight, + MAX(slotPtr->rowEnd,slotPtr->rowMax), slotPtr->rowPtr); + slotPtr->startX += Tk_InternalBorderWidth(masterPtr->tkwin); + slotPtr->startY += Tk_InternalBorderWidth(masterPtr->tkwin); + + /* + * Now adjust the actual size of the slave to its cavity by + * computing the cavity size, and adjusting the widget according + * to its stickyness. + */ + + for (slavePtr = masterPtr->slavePtr; slavePtr != NULL && !abort; + slavePtr = slavePtr->nextPtr) { + int x, y; /* top left coordinate */ + int width, height; /* slot or slave size */ + int col = slavePtr->column; + int row = slavePtr->row; + + x = (col>0) ? slotPtr->columnPtr[col-1].offset : 0; + y = (row>0) ? slotPtr->rowPtr[row-1].offset : 0; + + width = slotPtr->columnPtr[slavePtr->numCols+col-1].offset - x; + height = slotPtr->rowPtr[slavePtr->numRows+row-1].offset - y; + + x += slotPtr->startX; + y += slotPtr->startY; + + AdjustForSticky(slavePtr, &x, &y, &width, &height); + + /* + * Now put the window in the proper spot. (This was taken directly + * from tkPack.c.) If the slave is a child of the master, then + * do this here. Otherwise let Tk_MaintainGeometry do the work. + */ + + if (masterPtr->tkwin == Tk_Parent(slavePtr->tkwin)) { + if ((width <= 0) || (height <= 0)) { + Tk_UnmapWindow(slavePtr->tkwin); + } else { + if ((x != Tk_X(slavePtr->tkwin)) + || (y != Tk_Y(slavePtr->tkwin)) + || (width != Tk_Width(slavePtr->tkwin)) + || (height != Tk_Height(slavePtr->tkwin))) { + Tk_MoveResizeWindow(slavePtr->tkwin, x, y, width, height); + } + if (abort) { + break; + } + + /* + * Don't map the slave if the master isn't mapped: wait + * until the master gets mapped later. + */ + + if (Tk_IsMapped(masterPtr->tkwin)) { + Tk_MapWindow(slavePtr->tkwin); + } + } + } else { + if ((width <= 0) || (height <= 0)) { + Tk_UnmaintainGeometry(slavePtr->tkwin, masterPtr->tkwin); + Tk_UnmapWindow(slavePtr->tkwin); + } else { + Tk_MaintainGeometry(slavePtr->tkwin, masterPtr->tkwin, + x, y, width, height); + } + } + } + + masterPtr->abortPtr = NULL; + Tcl_Release((ClientData) masterPtr); +} + +/* + *-------------------------------------------------------------- + * + * ResolveConstraints -- + * + * Resolve all of the column and row boundaries. Most of + * the calculations are identical for rows and columns, so this procedure + * is called twice, once for rows, and again for columns. + * + * Results: + * The offset (in pixels) from the left/top edge of this layout is + * returned. + * + * Side effects: + * The slot offsets are copied into the SlotInfo structure for the + * geometry master. + * + *-------------------------------------------------------------- + */ + +static int +ResolveConstraints(masterPtr, slotType, maxOffset) + Gridder *masterPtr; /* The geometry master for this grid. */ + int slotType; /* Either ROW or COLUMN. */ + int maxOffset; /* The actual maximum size of this layout + * in pixels, or 0 (not currently used). */ +{ + register SlotInfo *slotPtr; /* Pointer to row/col constraints. */ + register Gridder *slavePtr; /* List of slave windows in this grid. */ + int constraintCount; /* Count of rows or columns that have + * constraints. */ + int slotCount; /* Last occupied row or column. */ + int gridCount; /* The larger of slotCount and constraintCount. + */ + GridLayout *layoutPtr; /* Temporary layout structure. */ + int requiredSize; /* The natural size of the grid (pixels). + * This is the minimum size needed to + * accomodate all of the slaves at their + * requested sizes. */ + int offset; /* The pixel offset of the right edge of the + * current slot from the beginning of the + * layout. */ + int slot; /* The current slot. */ + int start; /* The first slot of a contiguous set whose + * constraints are not yet fully resolved. */ + int end; /* The Last slot of a contiguous set whose + * constraints are not yet fully resolved. */ + + /* + * For typical sized tables, we'll use stack space for the layout data + * to avoid the overhead of a malloc and free for every layout. + */ + + GridLayout layoutData[TYPICAL_SIZE + 1]; + + if (slotType == COLUMN) { + constraintCount = masterPtr->masterDataPtr->columnMax; + slotCount = masterPtr->masterDataPtr->columnEnd; + slotPtr = masterPtr->masterDataPtr->columnPtr; + } else { + constraintCount = masterPtr->masterDataPtr->rowMax; + slotCount = masterPtr->masterDataPtr->rowEnd; + slotPtr = masterPtr->masterDataPtr->rowPtr; + } + + /* + * Make sure there is enough memory for the layout. + */ + + gridCount = MAX(constraintCount,slotCount); + if (gridCount >= TYPICAL_SIZE) { + layoutPtr = (GridLayout *) ckalloc(sizeof(GridLayout) * (1+gridCount)); + } else { + layoutPtr = layoutData; + } + + /* + * Allocate an extra layout slot to represent the left/top edge of + * the 0th slot to make it easier to calculate slot widths from + * offsets without special case code. + * Initialize the "dummy" slot to the left/top of the table. + * This slot avoids special casing the first slot. + */ + + layoutPtr->minOffset = 0; + layoutPtr->maxOffset = 0; + layoutPtr++; + + /* + * Step 1. + * Copy the slot constraints into the layout structure, + * and initialize the rest of the fields. + */ + + for (slot=0; slot < constraintCount; slot++) { + layoutPtr[slot].minSize = slotPtr[slot].minSize; + layoutPtr[slot].weight = slotPtr[slot].weight; + layoutPtr[slot].pad = slotPtr[slot].pad; + layoutPtr[slot].binNextPtr = NULL; + } + for(;slot 1 by their right edges. This + * allows the computation on minimum and maximum possible layout + * sizes at each slot boundary, without the need to re-sort the slaves. + */ + + switch (slotType) { + case COLUMN: + for (slavePtr = masterPtr->slavePtr; slavePtr != NULL; + slavePtr = slavePtr->nextPtr) { + int rightEdge = slavePtr->column + slavePtr->numCols - 1; + slavePtr->size = Tk_ReqWidth(slavePtr->tkwin) + + slavePtr->padX + slavePtr->iPadX + slavePtr->doubleBw; + if (slavePtr->numCols > 1) { + slavePtr->binNextPtr = layoutPtr[rightEdge].binNextPtr; + layoutPtr[rightEdge].binNextPtr = slavePtr; + } else { + int size = slavePtr->size + layoutPtr[rightEdge].pad; + if (size > layoutPtr[rightEdge].minSize) { + layoutPtr[rightEdge].minSize = size; + } + } + } + break; + case ROW: + for (slavePtr = masterPtr->slavePtr; slavePtr != NULL; + slavePtr = slavePtr->nextPtr) { + int rightEdge = slavePtr->row + slavePtr->numRows - 1; + slavePtr->size = Tk_ReqHeight(slavePtr->tkwin) + + slavePtr->padY + slavePtr->iPadY + slavePtr->doubleBw; + if (slavePtr->numRows > 1) { + slavePtr->binNextPtr = layoutPtr[rightEdge].binNextPtr; + layoutPtr[rightEdge].binNextPtr = slavePtr; + } else { + int size = slavePtr->size + layoutPtr[rightEdge].pad; + if (size > layoutPtr[rightEdge].minSize) { + layoutPtr[rightEdge].minSize = size; + } + } + } + break; + } + + /* + * Step 3. + * Determine the minimum slot offsets going from left to right + * that would fit all of the slaves. This determines the minimum + */ + + for (offset=slot=0; slot < gridCount; slot++) { + layoutPtr[slot].minOffset = layoutPtr[slot].minSize + offset; + for (slavePtr = layoutPtr[slot].binNextPtr; slavePtr != NULL; + slavePtr = slavePtr->binNextPtr) { + int span = (slotType == COLUMN) ? slavePtr->numCols : slavePtr->numRows; + int required = slavePtr->size + layoutPtr[slot - span].minOffset; + if (required > layoutPtr[slot].minOffset) { + layoutPtr[slot].minOffset = required; + } + } + offset = layoutPtr[slot].minOffset; + } + + /* + * At this point, we know the minimum required size of the entire layout. + * It might be prudent to stop here if our "master" will resize itself + * to this size. + */ + + requiredSize = offset; + if (maxOffset > offset) { + offset=maxOffset; + } + + /* + * Step 4. + * Determine the minimum slot offsets going from right to left, + * bounding the pixel range of each slot boundary. + * Pre-fill all of the right offsets with the actual size of the table; + * they will be reduced as required. + */ + + for (slot=0; slot < gridCount; slot++) { + layoutPtr[slot].maxOffset = offset; + } + for (slot=gridCount-1; slot > 0;) { + for (slavePtr = layoutPtr[slot].binNextPtr; slavePtr != NULL; + slavePtr = slavePtr->binNextPtr) { + int span = (slotType == COLUMN) ? slavePtr->numCols : slavePtr->numRows; + int require = offset - slavePtr->size; + int startSlot = slot - span; + if (startSlot >=0 && require < layoutPtr[startSlot].maxOffset) { + layoutPtr[startSlot].maxOffset = require; + } + } + offset -= layoutPtr[slot].minSize; + slot--; + if (layoutPtr[slot].maxOffset < offset) { + offset = layoutPtr[slot].maxOffset; + } else { + layoutPtr[slot].maxOffset = offset; + } + } + + /* + * Step 5. + * At this point, each slot boundary has a range of values that + * will satisfy the overall layout size. + * Make repeated passes over the layout structure looking for + * spans of slot boundaries where the minOffsets are less than + * the maxOffsets, and adjust the offsets according to the slot + * weights. At each pass, at least one slot boundary will have + * its range of possible values fixed at a single value. + */ + + for (start=0; start < gridCount;) { + int totalWeight = 0; /* Sum of the weights for all of the + * slots in this span. */ + int need = 0; /* The minimum space needed to layout + * this span. */ + int have = 0; /* The actual amount of space that will + * be taken up by this span. */ + int weight = 0; /* Cumulative weights of the columns in + * this span. */ + int noWeights = 0; /* True if the span has no weights. */ + + /* + * Find a span by identifying ranges of slots whose edges are + * already constrained at fixed offsets, but whose internal + * slot boundaries have a range of possible positions. + */ + + if (layoutPtr[start].minOffset == layoutPtr[start].maxOffset) { + start++; + continue; + } + + for (end=start+1; end0) && + (diff*totalWeight/weight) < (have-need)) { + have = diff * totalWeight / weight + need; + } + } + + /* + * Now distribute the extra space among the slots by + * adjusting the minSizes and minOffsets. + */ + + for (weight=0,slot=start; slot start; slot--) { + layoutPtr[slot-1].maxOffset = + layoutPtr[slot].maxOffset-layoutPtr[slot].minSize; + } + } + + + /* + * Step 6. + * All of the space has been apportioned; copy the + * layout information back into the master. + */ + + for (slot=0; slot < gridCount; slot++) { + slotPtr[slot].offset = layoutPtr[slot].minOffset; + } + + --layoutPtr; + if (layoutPtr != layoutData) { + ckfree((char *)layoutPtr); + } + return requiredSize; +} + +/* + *-------------------------------------------------------------- + * + * GetGrid -- + * + * This internal procedure is used to locate a Grid + * structure for a given window, creating one if one + * doesn't exist already. + * + * Results: + * The return value is a pointer to the Grid structure + * corresponding to tkwin. + * + * Side effects: + * A new grid structure may be created. If so, then + * a callback is set up to clean things up when the + * window is deleted. + * + *-------------------------------------------------------------- + */ + +static Gridder * +GetGrid(tkwin) + Tk_Window tkwin; /* Token for window for which + * grid structure is desired. */ +{ + register Gridder *gridPtr; + Tcl_HashEntry *hPtr; + int new; + + if (!initialized) { + initialized = 1; + Tcl_InitHashTable(&gridHashTable, TCL_ONE_WORD_KEYS); + } + + /* + * See if there's already grid for this window. If not, + * then create a new one. + */ + + hPtr = Tcl_CreateHashEntry(&gridHashTable, (char *) tkwin, &new); + if (!new) { + return (Gridder *) Tcl_GetHashValue(hPtr); + } + gridPtr = (Gridder *) ckalloc(sizeof(Gridder)); + gridPtr->tkwin = tkwin; + gridPtr->masterPtr = NULL; + gridPtr->masterDataPtr = NULL; + gridPtr->nextPtr = NULL; + gridPtr->slavePtr = NULL; + gridPtr->binNextPtr = NULL; + + gridPtr->column = gridPtr->row = -1; + gridPtr->numCols = 1; + gridPtr->numRows = 1; + + gridPtr->padX = gridPtr->padY = 0; + gridPtr->iPadX = gridPtr->iPadY = 0; + gridPtr->doubleBw = 2*Tk_Changes(tkwin)->border_width; + gridPtr->abortPtr = NULL; + gridPtr->flags = 0; + gridPtr->sticky = 0; + gridPtr->size = 0; + gridPtr->masterDataPtr = NULL; + Tcl_SetHashValue(hPtr, gridPtr); + Tk_CreateEventHandler(tkwin, StructureNotifyMask, + GridStructureProc, (ClientData) gridPtr); + return gridPtr; +} + +/* + *-------------------------------------------------------------- + * + * SetGridSize -- + * + * This internal procedure sets the size of the grid occupied + * by slaves. + * + * Results: + * none + * + * Side effects: + * The width and height arguments are filled in the master data structure. + * Additional space is allocated for the constraints to accomodate + * the offsets. + * + *-------------------------------------------------------------- + */ + +static void +SetGridSize(masterPtr) + Gridder *masterPtr; /* The geometry master for this grid. */ +{ + register Gridder *slavePtr; /* Current slave window. */ + int maxX = 0, maxY = 0; + + for (slavePtr = masterPtr->slavePtr; slavePtr != NULL; + slavePtr = slavePtr->nextPtr) { + maxX = MAX(maxX,slavePtr->numCols + slavePtr->column); + maxY = MAX(maxY,slavePtr->numRows + slavePtr->row); + } + masterPtr->masterDataPtr->columnEnd = maxX; + masterPtr->masterDataPtr->rowEnd = maxY; + CheckSlotData(masterPtr, maxX, COLUMN, CHECK_SPACE); + CheckSlotData(masterPtr, maxY, ROW, CHECK_SPACE); +} + +/* + *-------------------------------------------------------------- + * + * CheckSlotData -- + * + * This internal procedure is used to manage the storage for + * row and column (slot) constraints. + * + * Results: + * TRUE if the index is OK, False otherwise. + * + * Side effects: + * A new master grid structure may be created. If so, then + * it is initialized. In addition, additional storage for + * a row or column constraints may be allocated, and the constraint + * maximums are (sometimes incorrectly) adjusted. + * + *-------------------------------------------------------------- + */ + +static int +CheckSlotData(masterPtr, slot, slotType, checkOnly) + Gridder *masterPtr; /* the geometry master for this grid */ + int slot; /* which slot to look at */ + int slotType; /* ROW or COLUMN */ + int checkOnly; /* don't allocate new space if true */ +{ + int last; /* last available slot memory is alloced for */ + int end; /* last used constraint */ + + /* + * If slot is out of bounds, return immediately. + */ + + if (slot < 0 || slot >= MAX_ELEMENT) { + return TCL_ERROR; + } + + if (checkOnly==CHECK_ONLY && (masterPtr->masterDataPtr == NULL)) { + return TCL_ERROR; + } + + /* + * If we need to allocate more space, allocate a little extra to avoid + * repeated re-alloc's for large tables. We need enough space to + * hold all of the offsets as well. + */ + + InitMasterData(masterPtr); + end = (slotType==ROW) ? masterPtr->masterDataPtr->rowMax : + masterPtr->masterDataPtr->columnMax; + if (checkOnly==CHECK_ONLY) { + return (end < slot) ? TCL_ERROR : TCL_OK; + } else { + last = (slotType==ROW) ? masterPtr->masterDataPtr->rowSpace : + masterPtr->masterDataPtr->columnSpace; + if (last < slot) { + size_t size = sizeof(SlotInfo) * (slot + PREALLOC); + SlotInfo *new = (SlotInfo *) ckalloc(size); + SlotInfo *old = (slotType == ROW) ? + masterPtr->masterDataPtr->rowPtr : + masterPtr->masterDataPtr->columnPtr; + memcpy((VOID *) new, (VOID *) old, last * sizeof(SlotInfo)); + memset((VOID *) (new+last), 0, + (sizeof(SlotInfo) * (PREALLOC+slot-last))); + ckfree((char *) old); + if (slotType == ROW) { + masterPtr->masterDataPtr->rowPtr = new; + masterPtr->masterDataPtr->rowSpace = slot+PREALLOC; + } else { + masterPtr->masterDataPtr->columnPtr = new; + masterPtr->masterDataPtr->columnSpace = slot+PREALLOC; + } + } + if (slot >= end && checkOnly != CHECK_SPACE) { + if (slotType==ROW) { + masterPtr->masterDataPtr->rowMax = slot+1; + } else { + masterPtr->masterDataPtr->columnMax = slot+1; + } + } + return TCL_OK; + } +} + +/* + *-------------------------------------------------------------- + * + * InitMasterData -- + * + * This internal procedure is used to allocate and initialize + * the data for a geometry master, if the data + * doesn't exist already. + * + * Results: + * none + * + * Side effects: + * A new master grid structure may be created. If so, then + * it is initialized. + * + *-------------------------------------------------------------- + */ + +static void +InitMasterData(masterPtr) + Gridder *masterPtr; +{ + size_t size; + if (masterPtr->masterDataPtr == NULL) { + GridMaster *gridPtr = masterPtr->masterDataPtr = + (GridMaster *) ckalloc(sizeof(GridMaster)); + size = sizeof(SlotInfo) * TYPICAL_SIZE; + + gridPtr->columnEnd = 0; + gridPtr->columnMax = 0; + gridPtr->columnPtr = (SlotInfo *) ckalloc(size); + gridPtr->columnSpace = 0; + gridPtr->columnSpace = TYPICAL_SIZE; + gridPtr->rowEnd = 0; + gridPtr->rowMax = 0; + gridPtr->rowPtr = (SlotInfo *) ckalloc(size); + gridPtr->rowSpace = 0; + gridPtr->rowSpace = TYPICAL_SIZE; + + memset((VOID *) gridPtr->columnPtr, 0, size); + memset((VOID *) gridPtr->rowPtr, 0, size); + } +} + +/* + *---------------------------------------------------------------------- + * + * Unlink -- + * + * Remove a grid from its parent's list of slaves. + * + * Results: + * None. + * + * Side effects: + * The parent will be scheduled for re-arranging, and the size of the + * grid will be adjusted accordingly + * + *---------------------------------------------------------------------- + */ + +static void +Unlink(slavePtr) + register Gridder *slavePtr; /* Window to unlink. */ +{ + register Gridder *masterPtr, *slavePtr2; + GridMaster *gridPtr; /* pointer to grid data */ + + masterPtr = slavePtr->masterPtr; + if (masterPtr == NULL) { + return; + } + + gridPtr = masterPtr->masterDataPtr; + if (masterPtr->slavePtr == slavePtr) { + masterPtr->slavePtr = slavePtr->nextPtr; + } + else { + for (slavePtr2 = masterPtr->slavePtr; ; slavePtr2 = slavePtr2->nextPtr) { + if (slavePtr2 == NULL) { + panic("Unlink couldn't find previous window"); + } + if (slavePtr2->nextPtr == slavePtr) { + slavePtr2->nextPtr = slavePtr->nextPtr; + break; + } + } + } + if (!(masterPtr->flags & REQUESTED_RELAYOUT)) { + masterPtr->flags |= REQUESTED_RELAYOUT; + Tcl_DoWhenIdle(ArrangeGrid, (ClientData) masterPtr); + } + if (masterPtr->abortPtr != NULL) { + *masterPtr->abortPtr = 1; + } + + if (slavePtr->numCols+slavePtr->column == gridPtr->columnMax || + slavePtr->numRows+slavePtr->row == gridPtr->rowMax) { + } + slavePtr->masterPtr = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * DestroyGrid -- + * + * This procedure is invoked by Tk_EventuallyFree or Tcl_Release + * to clean up the internal structure of a grid at a safe time + * (when no-one is using it anymore). Cleaning up the grid involves + * freeing the main structure for all windows. and the master structure + * for geometry managers. + * + * Results: + * None. + * + * Side effects: + * Everything associated with the grid is freed up. + * + *---------------------------------------------------------------------- + */ + +static void +DestroyGrid(memPtr) + char *memPtr; /* Info about window that is now dead. */ +{ + register Gridder *gridPtr = (Gridder *) memPtr; + + if (gridPtr->masterDataPtr != NULL) { + if (gridPtr->masterDataPtr->rowPtr != NULL) { + ckfree((char *) gridPtr->masterDataPtr -> rowPtr); + } + if (gridPtr->masterDataPtr->columnPtr != NULL) { + ckfree((char *) gridPtr->masterDataPtr -> columnPtr); + } + ckfree((char *) gridPtr->masterDataPtr); + } + ckfree((char *) gridPtr); +} + +/* + *---------------------------------------------------------------------- + * + * GridStructureProc -- + * + * This procedure is invoked by the Tk event dispatcher in response + * to StructureNotify events. + * + * Results: + * None. + * + * Side effects: + * If a window was just deleted, clean up all its grid-related + * information. If it was just resized, re-configure its slaves, if + * any. + * + *---------------------------------------------------------------------- + */ + +static void +GridStructureProc(clientData, eventPtr) + ClientData clientData; /* Our information about window + * referred to by eventPtr. */ + XEvent *eventPtr; /* Describes what just happened. */ +{ + register Gridder *gridPtr = (Gridder *) clientData; + + if (eventPtr->type == ConfigureNotify) { + if (!(gridPtr->flags & REQUESTED_RELAYOUT)) { + gridPtr->flags |= REQUESTED_RELAYOUT; + Tcl_DoWhenIdle(ArrangeGrid, (ClientData) gridPtr); + } + if (gridPtr->doubleBw != 2*Tk_Changes(gridPtr->tkwin)->border_width) { + if ((gridPtr->masterPtr != NULL) && + !(gridPtr->masterPtr->flags & REQUESTED_RELAYOUT)) { + gridPtr->doubleBw = 2*Tk_Changes(gridPtr->tkwin)->border_width; + gridPtr->masterPtr->flags |= REQUESTED_RELAYOUT; + Tcl_DoWhenIdle(ArrangeGrid, (ClientData) gridPtr->masterPtr); + } + } + } else if (eventPtr->type == DestroyNotify) { + register Gridder *gridPtr2, *nextPtr; + + if (gridPtr->masterPtr != NULL) { + Unlink(gridPtr); + } + for (gridPtr2 = gridPtr->slavePtr; gridPtr2 != NULL; + gridPtr2 = nextPtr) { + Tk_UnmapWindow(gridPtr2->tkwin); + gridPtr2->masterPtr = NULL; + nextPtr = gridPtr2->nextPtr; + gridPtr2->nextPtr = NULL; + } + Tcl_DeleteHashEntry(Tcl_FindHashEntry(&gridHashTable, + (char *) gridPtr->tkwin)); + if (gridPtr->flags & REQUESTED_RELAYOUT) { + Tk_CancelIdleCall(ArrangeGrid, (ClientData) gridPtr); + } + gridPtr->tkwin = NULL; + Tk_EventuallyFree((ClientData) gridPtr, DestroyGrid); + } else if (eventPtr->type == MapNotify) { + if (!(gridPtr->flags & REQUESTED_RELAYOUT)) { + gridPtr->flags |= REQUESTED_RELAYOUT; + Tcl_DoWhenIdle(ArrangeGrid, (ClientData) gridPtr); + } + } else if (eventPtr->type == UnmapNotify) { + register Gridder *gridPtr2; + + for (gridPtr2 = gridPtr->slavePtr; gridPtr2 != NULL; + gridPtr2 = gridPtr2->nextPtr) { + Tk_UnmapWindow(gridPtr2->tkwin); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * ConfigureSlaves -- + * + * This implements the guts of the "grid configure" command. Given + * a list of slaves and configuration options, it arranges for the + * grid to manage the slaves and sets the specified options. + * arguments consist of windows or window shortcuts followed by + * "-option value" pairs. + * + * Results: + * TCL_OK is returned if all went well. Otherwise, TCL_ERROR is + * returned and interp->result is set to contain an error message. + * + * Side effects: + * Slave windows get taken over by the grid. + * + *---------------------------------------------------------------------- + */ + +static int +ConfigureSlaves(interp, tkwin, argc, argv) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + Tk_Window tkwin; /* Any window in application containing + * slaves. Used to look up slave names. */ + int argc; /* Number of elements in argv. */ + char *argv[]; /* Argument strings: contains one or more + * window names followed by any number + * of "option value" pairs. Caller must + * make sure that there is at least one + * window name. */ +{ + Gridder *masterPtr = (Gridder *)NULL; + Gridder *slavePtr; + Tk_Window other, slave, parent, ancestor; + int i, j, c, length, tmp; + int numWindows = 0; + int width; + int defaultColumn = 0; /* default column number */ + int defaultColumnSpan = 1; /* default number of columns */ + char *lastWindow = NULL; /* use this window to base current + * Row/col on */ + + /* + * Count the number of windows, or window short-cuts. + */ + + for(numWindows=i=0;i 1 && firstChar == '-') { + break; + } + if (length > 1) { + Tcl_AppendResult(interp, "unexpected parameter, \"", + argv[i], "\", in configure list. ", + "Should be window name or option", (char *) NULL); + return TCL_ERROR; + } + + if (firstChar==REL_HORIZ && (numWindows==0 || + *argv[i-1]==REL_SKIP || *argv[i-1]==REL_VERT)) { + Tcl_AppendResult(interp, + "Must specify window before shortcut '-'.", + (char *) NULL); + return TCL_ERROR; + } + + if (firstChar==REL_VERT || firstChar==REL_SKIP || + firstChar==REL_HORIZ) { + continue; + } + + Tcl_AppendResult(interp, "invalid window shortcut, \"", + argv[i], "\" should be '-', 'x', or '^'", (char *) NULL); + return TCL_ERROR; + } + numWindows = i; + + if ((argc-numWindows)&1) { + Tcl_AppendResult(interp, "extra option or", + " option with no value", (char *) NULL); + return TCL_ERROR; + } + + /* + * Iterate over all of the slave windows and short-cuts, parsing + * options for each slave. It's a bit wasteful to re-parse the + * options for each slave, but things get too messy if we try to + * parse the arguments just once at the beginning. For example, + * if a slave already is managed we want to just change a few + * existing values without resetting everything. If there are + * multiple windows, the -in option only gets processed for the + * first window. + */ + + masterPtr = NULL; + for (j = 0; j < numWindows; j++) { + char firstChar = *argv[j]; + + /* + * '^' and 'x' cause us to skip a column. '-' is processed + * as part of its preceeding slave. + */ + + if (firstChar==REL_VERT || firstChar==REL_SKIP) { + defaultColumn++; + continue; + } + if (firstChar==REL_HORIZ) { + continue; + } + + for (defaultColumnSpan=1; + j+defaultColumnSpan < numWindows && + *argv[j+defaultColumnSpan] == REL_HORIZ; + defaultColumnSpan++) { + /* null body */ + } + + slave = Tk_NameToWindow(interp, argv[j], tkwin); + if (slave == NULL) { + return TCL_ERROR; + } + if (Tk_IsTopLevel(slave)) { + Tcl_AppendResult(interp, "can't manage \"", argv[j], + "\": it's a top-level window", (char *) NULL); + return TCL_ERROR; + } + slavePtr = GetGrid(slave); + + /* + * The following statement is taken from tkPack.c: + * + * "If the slave isn't currently managed, reset all of its + * configuration information to default values (there could + * be old values left from a previous packer)." + * + * I [D.S.] disagree with this statement. If a slave is disabled (using + * "forget") and then re-enabled, I submit that 90% of the time the + * programmer will want it to retain its old configuration information. + * If the programmer doesn't want this behavior, then the + * defaults can be reestablished by hand, without having to worry + * about keeping track of the old state. + */ + + for (i = numWindows; i < argc; i+=2) { + length = strlen(argv[i]); + c = argv[i][1]; + + if (length < 2) { + Tcl_AppendResult(interp, "unknown or ambiguous option \"", + argv[i], "\": must be ", + "-column, -columnspan, -in, -ipadx, -ipady, ", + "-padx, -pady, -row, -rowspan, or -sticky", + (char *) NULL); + return TCL_ERROR; + } + if ((c == 'c') && (strcmp(argv[i], "-column") == 0)) { + if (Tcl_GetInt(interp, argv[i+1], &tmp) != TCL_OK || tmp<0) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad column value \"", argv[i+1], + "\": must be a non-negative integer", (char *)NULL); + return TCL_ERROR; + } + slavePtr->column = tmp; + } else if ((c == 'c') && (strcmp(argv[i], "-columnspan") == 0)) { + if (Tcl_GetInt(interp, argv[i+1], &tmp) != TCL_OK || tmp <= 0) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad columnspan value \"", argv[i+1], + "\": must be a positive integer", (char *)NULL); + return TCL_ERROR; + } + slavePtr->numCols = tmp; + } else if ((c == 'i') && (strcmp(argv[i], "-in") == 0)) { + other = Tk_NameToWindow(interp, argv[i+1], tkwin); + if (other == NULL) { + return TCL_ERROR; + } + if (other == slave) { + sprintf(interp->result,"Window can't be managed in itself"); + return TCL_ERROR; + } + masterPtr = GetGrid(other); + InitMasterData(masterPtr); + } else if ((c == 'i') && (strcmp(argv[i], "-ipadx") == 0)) { + if ((Tk_GetPixels(interp, slave, argv[i+1], &tmp) != TCL_OK) + || (tmp < 0)) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad ipadx value \"", argv[i+1], + "\": must be positive screen distance", + (char *) NULL); + return TCL_ERROR; + } + slavePtr->iPadX = tmp*2; + } else if ((c == 'i') && (strcmp(argv[i], "-ipady") == 0)) { + if ((Tk_GetPixels(interp, slave, argv[i+1], &tmp) != TCL_OK) + || (tmp< 0)) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad ipady value \"", argv[i+1], + "\": must be positive screen distance", + (char *) NULL); + return TCL_ERROR; + } + slavePtr->iPadY = tmp*2; + } else if ((c == 'p') && (strcmp(argv[i], "-padx") == 0)) { + if ((Tk_GetPixels(interp, slave, argv[i+1], &tmp) != TCL_OK) + || (tmp< 0)) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad padx value \"", argv[i+1], + "\": must be positive screen distance", + (char *) NULL); + return TCL_ERROR; + } + slavePtr->padX = tmp*2; + } else if ((c == 'p') && (strcmp(argv[i], "-pady") == 0)) { + if ((Tk_GetPixels(interp, slave, argv[i+1], &tmp) != TCL_OK) + || (tmp< 0)) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad pady value \"", argv[i+1], + "\": must be positive screen distance", + (char *) NULL); + return TCL_ERROR; + } + slavePtr->padY = tmp*2; + } else if ((c == 'r') && (strcmp(argv[i], "-row") == 0)) { + if (Tcl_GetInt(interp, argv[i+1], &tmp) != TCL_OK || tmp<0) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad grid value \"", argv[i+1], + "\": must be a non-negative integer", (char *)NULL); + return TCL_ERROR; + } + slavePtr->row = tmp; + } else if ((c == 'r') && (strcmp(argv[i], "-rowspan") == 0)) { + if ((Tcl_GetInt(interp, argv[i+1], &tmp) != TCL_OK) || tmp<=0) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad rowspan value \"", argv[i+1], + "\": must be a positive integer", (char *)NULL); + return TCL_ERROR; + } + slavePtr->numRows = tmp; + } else if ((c == 's') && strcmp(argv[i], "-sticky") == 0) { + int sticky = StringToSticky(argv[i+1]); + if (sticky == -1) { + Tcl_AppendResult(interp, "bad stickyness value \"", argv[i+1], + "\": must be a string containing n, e, s, and/or w", + (char *)NULL); + return TCL_ERROR; + } + slavePtr->sticky = sticky; + } else { + Tcl_AppendResult(interp, "unknown or ambiguous option \"", + argv[i], "\": must be ", + "-column, -columnspan, -in, -ipadx, -ipady, ", + "-padx, -pady, -row, -rowspan, or -sticky", + (char *) NULL); + return TCL_ERROR; + } + } + + /* + * Make sure we have a geometry master. We look at: + * 1) the -in flag + * 2) the geometry master of the first slave (if specified) + * 3) the parent of the first slave. + */ + + if (masterPtr == NULL) { + masterPtr = slavePtr->masterPtr; + } + parent = Tk_Parent(slave); + if (masterPtr == NULL) { + masterPtr = GetGrid(parent); + InitMasterData(masterPtr); + } + + /* + * Only one geometry master is allowed per grid call, + * otherwise the '-' 'x' and '^' get too confusing. + */ + + if (slavePtr->masterPtr == NULL) { + Gridder *tempPtr = masterPtr->slavePtr; + slavePtr->masterPtr = masterPtr; + masterPtr->slavePtr = slavePtr; + slavePtr->nextPtr = tempPtr; + } + + if (slavePtr->masterPtr != masterPtr) { + Tcl_AppendResult(interp, argv[i], " is already managed by ", + Tk_PathName(slavePtr->masterPtr->tkwin), + ", only one master allowed", + (char *) NULL); + Unlink(slavePtr); + return TCL_ERROR; + } + + /* + * Make sure that the slave's parent is either the master or + * an ancestor of the master, and that the master and slave + * aren't the same. + */ + + for (ancestor = masterPtr->tkwin; ; ancestor = Tk_Parent(ancestor)) { + if (ancestor == parent) { + break; + } + if (Tk_IsTopLevel(ancestor)) { + Tcl_AppendResult(interp, "can't put ", argv[j], + " inside ", Tk_PathName(masterPtr->tkwin), + (char *) NULL); + Unlink(slavePtr); + return TCL_ERROR; + } + } + + /* + * Try to make sure our master isn't managed by us. + */ + + if (masterPtr->masterPtr == slavePtr) { + Tcl_AppendResult(interp, "can't put ", argv[j], + " inside ", Tk_PathName(masterPtr->tkwin), + ", would cause management loop.", + (char *) NULL); + Unlink(slavePtr); + return TCL_ERROR; + } + + Tk_ManageGeometry(slave, &gridMgrType, (ClientData) slavePtr); + + /* + * Assign default position information. + */ + + if (slavePtr->column == -1) { + slavePtr->column = defaultColumn; + } + slavePtr->numCols += defaultColumnSpan - 1; + if (slavePtr->row == -1) { + if (masterPtr->masterDataPtr == NULL) { + slavePtr->row = 0; + } else { + slavePtr->row = masterPtr->masterDataPtr->rowEnd; + } + } + defaultColumn += slavePtr->numCols; + defaultColumnSpan = 1; + + /* + * Arrange for the parent to be re-arranged at the first + * idle moment. + */ + + if (masterPtr->abortPtr != NULL) { + *masterPtr->abortPtr = 1; + } + if (!(masterPtr->flags & REQUESTED_RELAYOUT)) { + masterPtr->flags |= REQUESTED_RELAYOUT; + Tcl_DoWhenIdle(ArrangeGrid, (ClientData) masterPtr); + } + } + + /* Now look for all the "^"'s. */ + + lastWindow = NULL; + for (j = 0; j < numWindows; j++) { + struct Gridder *otherPtr; + int match; /* found a match for the ^ */ + int lastRow, lastColumn; /* implied end of table */ + + if (*argv[j] == '.') { + lastWindow = argv[j]; + } + if (*argv[j] != REL_VERT) { + continue; + } + + if (masterPtr == NULL) { + Tcl_AppendResult(interp, "can't use '^', cant find master", + (char *) NULL); + return TCL_ERROR; + } + + for (width=1; width+j < numWindows && *argv[j+width] == REL_VERT; + width++) { + /* Null Body */ + } + + /* + * Find the implied grid location of the ^ + */ + + if (lastWindow == NULL) { + if (masterPtr->masterDataPtr != NULL) { + SetGridSize(masterPtr); + lastRow = masterPtr->masterDataPtr->rowEnd - 1; + } else { + lastRow = 0; + } + lastColumn = 0; + } else { + other = Tk_NameToWindow(interp, lastWindow, tkwin); + otherPtr = GetGrid(other); + lastRow = otherPtr->row; + lastColumn = otherPtr->column + otherPtr->numCols; + } + + for (match=0, slavePtr = masterPtr->slavePtr; slavePtr != NULL; + slavePtr = slavePtr->nextPtr) { + + if (slavePtr->numCols == width + && slavePtr->column == lastColumn + && slavePtr->row + slavePtr->numRows == lastRow) { + slavePtr->numRows++; + match++; + } + lastWindow = Tk_PathName(slavePtr->tkwin); + } + if (!match) { + Tcl_AppendResult(interp, "can't find slave to extend with \"^\".", + (char *) NULL); + return TCL_ERROR; + } + j += width - 1; + } + + if (masterPtr == NULL) { + Tcl_AppendResult(interp, "can't determine master window", + (char *) NULL); + return TCL_ERROR; + } + SetGridSize(masterPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * StickyToString + * + * Converts the internal boolean combination of "sticky" bits onto + * a TCL list element containing zero or mor of n, s, e, or w. + * + * Results: + * A string is placed into the "result" pointer. + * + * Side effects: + * none. + * + *---------------------------------------------------------------------- + */ + +static void +StickyToString(flags, result) + int flags; /* the sticky flags */ + char *result; /* where to put the result */ +{ + int count = 0; + if (flags&STICK_NORTH) { + result[count++] = 'n'; + } + if (flags&STICK_EAST) { + result[count++] = 'e'; + } + if (flags&STICK_SOUTH) { + result[count++] = 's'; + } + if (flags&STICK_WEST) { + result[count++] = 'w'; + } + if (count) { + result[count] = '\0'; + } else { + sprintf(result,"{}"); + } +} + +/* + *---------------------------------------------------------------------- + * + * StringToSticky -- + * + * Converts an ascii string representing a widgets stickyness + * into the boolean result. + * + * Results: + * The boolean combination of the "sticky" bits is retuned. If an + * error occurs, such as an invalid character, -1 is returned instead. + * + * Side effects: + * none + * + *---------------------------------------------------------------------- + */ + +static int +StringToSticky(string) + char *string; +{ + int sticky = 0; + char c; + + while ((c = *string++) != '\0') { + switch (c) { + case 'n': case 'N': sticky |= STICK_NORTH; break; + case 'e': case 'E': sticky |= STICK_EAST; break; + case 's': case 'S': sticky |= STICK_SOUTH; break; + case 'w': case 'W': sticky |= STICK_WEST; break; + case ' ': case ',': case '\t': case '\r': case '\n': break; + default: return -1; + } + } + return sticky; +} diff --git a/tk4.2/generic/tkImage.c b/tk4.2/generic/tkImage.c new file mode 100644 index 0000000..ff4a8de --- /dev/null +++ b/tk4.2/generic/tkImage.c @@ -0,0 +1,752 @@ +/* + * tkImage.c -- + * + * This module implements the image protocol, which allows lots + * of different kinds of images to be used in lots of different + * widgets. + * + * Copyright (c) 1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkImage.c 1.11 96/03/01 17:19:28 + */ + +#include "tkInt.h" +#include "tkPort.h" + +/* + * Each call to Tk_GetImage returns a pointer to one of the following + * structures, which is used as a token by clients (widgets) that + * display images. + */ + +typedef struct Image { + Tk_Window tkwin; /* Window passed to Tk_GetImage (needed to + * "re-get" the image later if the manager + * changes). */ + Display *display; /* Display for tkwin. Needed because when + * the image is eventually freed tkwin may + * not exist anymore. */ + struct ImageMaster *masterPtr; + /* Master for this image (identifiers image + * manager, for example). */ + ClientData instanceData; + /* One word argument to pass to image manager + * when dealing with this image instance. */ + Tk_ImageChangedProc *changeProc; + /* Code in widget to call when image changes + * in a way that affects redisplay. */ + ClientData widgetClientData; + /* Argument to pass to changeProc. */ + struct Image *nextPtr; /* Next in list of all image instances + * associated with the same name. */ + +} Image; + +/* + * For each image master there is one of the following structures, + * which represents a name in the image table and all of the images + * instantiated from it. Entries in mainPtr->imageTable point to + * these structures. + */ + +typedef struct ImageMaster { + Tk_ImageType *typePtr; /* Information about image type. NULL means + * that no image manager owns this image: the + * image was deleted. */ + ClientData masterData; /* One-word argument to pass to image mgr + * when dealing with the master, as opposed + * to instances. */ + int width, height; /* Last known dimensions for image. */ + Tcl_HashTable *tablePtr; /* Pointer to hash table containing image + * (the imageTable field in some TkMainInfo + * structure). */ + Tcl_HashEntry *hPtr; /* Hash entry in mainPtr->imageTable for + * this structure (used to delete the hash + * entry). */ + Image *instancePtr; /* Pointer to first in list of instances + * derived from this name. */ +} ImageMaster; + +/* + * The following variable points to the first in a list of all known + * image types. + */ + +static Tk_ImageType *imageTypeList = NULL; + +/* + * Prototypes for local procedures: + */ + +static void DeleteImage _ANSI_ARGS_((ImageMaster *masterPtr)); + +/* + *---------------------------------------------------------------------- + * + * Tk_CreateImageType -- + * + * This procedure is invoked by an image manager to tell Tk about + * a new kind of image and the procedures that manage the new type. + * The procedure is typically invoked during Tcl_AppInit. + * + * Results: + * None. + * + * Side effects: + * The new image type is entered into a table used in the "image + * create" command. + * + *---------------------------------------------------------------------- + */ + +void +Tk_CreateImageType(typePtr) + Tk_ImageType *typePtr; /* Structure describing the type. All of + * the fields except "nextPtr" must be filled + * in by caller. Must not have been passed + * to Tk_CreateImageType previously. */ +{ + Tk_ImageType *typePtr2; + + typePtr2 = (Tk_ImageType *) ckalloc(sizeof(Tk_ImageType)); + *typePtr2 = *typePtr; + typePtr2->name = (char *) ckalloc((unsigned) (strlen(typePtr->name) + 1)); + strcpy(typePtr2->name, typePtr->name); + typePtr2->nextPtr = imageTypeList; + imageTypeList = typePtr2; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_ImageCmd -- + * + * This procedure is invoked to process the "image" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tk_ImageCmd(clientData, interp, argc, argv) + ClientData clientData; /* Main window associated with interpreter. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + TkWindow *winPtr = (TkWindow *) clientData; + int c, i, new, firstOption; + size_t length; + Tk_ImageType *typePtr; + ImageMaster *masterPtr; + Image *imagePtr; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + char idString[30], *name; + static int id = 0; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option ?args?\"", (char *) NULL); + return TCL_ERROR; + } + c = argv[1][0]; + length = strlen(argv[1]); + if ((c == 'c') && (strncmp(argv[1], "create", length) == 0)) { + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " create type ?name? ?options?\"", (char *) NULL); + return TCL_ERROR; + } + c = argv[2][0]; + + /* + * Look up the image type. + */ + + for (typePtr = imageTypeList; typePtr != NULL; + typePtr = typePtr->nextPtr) { + if ((c == typePtr->name[0]) + && (strcmp(argv[2], typePtr->name) == 0)) { + break; + } + } + if (typePtr == NULL) { + Tcl_AppendResult(interp, "image type \"", argv[2], + "\" doesn't exist", (char *) NULL); + return TCL_ERROR; + } + + /* + * Figure out a name to use for the new image. + */ + + if ((argc == 3) || (argv[3][0] == '-')) { + id++; + sprintf(idString, "image%d", id); + name = idString; + firstOption = 3; + } else { + name = argv[3]; + firstOption = 4; + } + + /* + * Create the data structure for the new image. + */ + + hPtr = Tcl_CreateHashEntry(&winPtr->mainPtr->imageTable, name, &new); + if (new) { + masterPtr = (ImageMaster *) ckalloc(sizeof(ImageMaster)); + masterPtr->typePtr = NULL; + masterPtr->masterData = NULL; + masterPtr->width = masterPtr->height = 1; + masterPtr->tablePtr = &winPtr->mainPtr->imageTable; + masterPtr->hPtr = hPtr; + masterPtr->instancePtr = NULL; + Tcl_SetHashValue(hPtr, masterPtr); + } else { + /* + * An image already exists by this name. Disconnect the + * instances from the master. + */ + + masterPtr = (ImageMaster *) Tcl_GetHashValue(hPtr); + if (masterPtr->typePtr != NULL) { + for (imagePtr = masterPtr->instancePtr; imagePtr != NULL; + imagePtr = imagePtr->nextPtr) { + (*masterPtr->typePtr->freeProc)( + imagePtr->instanceData, imagePtr->display); + (*imagePtr->changeProc)(imagePtr->widgetClientData, 0, 0, + masterPtr->width, masterPtr->height, masterPtr->width, + masterPtr->height); + } + (*masterPtr->typePtr->deleteProc)(masterPtr->masterData); + masterPtr->typePtr = NULL; + } + } + + /* + * Call the image type manager so that it can perform its own + * initialization, then re-"get" for any existing instances of + * the image. + */ + + if ((*typePtr->createProc)(interp, name, argc-firstOption, + argv+firstOption, typePtr, (Tk_ImageMaster) masterPtr, + &masterPtr->masterData) != TCL_OK) { + DeleteImage(masterPtr); + return TCL_ERROR; + } + masterPtr->typePtr = typePtr; + for (imagePtr = masterPtr->instancePtr; imagePtr != NULL; + imagePtr = imagePtr->nextPtr) { + imagePtr->instanceData = (*typePtr->getProc)( + imagePtr->tkwin, masterPtr->masterData); + } + interp->result = Tcl_GetHashKey(&winPtr->mainPtr->imageTable, hPtr); + } else if ((c == 'd') && (strncmp(argv[1], "delete", length) == 0)) { + for (i = 2; i < argc; i++) { + hPtr = Tcl_FindHashEntry(&winPtr->mainPtr->imageTable, argv[i]); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "image \"", argv[i], + "\" doesn't exist", (char *) NULL); + return TCL_ERROR; + } + masterPtr = (ImageMaster *) Tcl_GetHashValue(hPtr); + DeleteImage(masterPtr); + } + } else if ((c == 'h') && (strncmp(argv[1], "height", length) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " height name\"", (char *) NULL); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&winPtr->mainPtr->imageTable, argv[2]); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "image \"", argv[2], + "\" doesn't exist", (char *) NULL); + return TCL_ERROR; + } + masterPtr = (ImageMaster *) Tcl_GetHashValue(hPtr); + sprintf(interp->result, "%d", masterPtr->height); + } else if ((c == 'n') && (strncmp(argv[1], "names", length) == 0)) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " names\"", (char *) NULL); + return TCL_ERROR; + } + for (hPtr = Tcl_FirstHashEntry(&winPtr->mainPtr->imageTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + Tcl_AppendElement(interp, Tcl_GetHashKey( + &winPtr->mainPtr->imageTable, hPtr)); + } + } else if ((c == 't') && (strcmp(argv[1], "type") == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " type name\"", (char *) NULL); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&winPtr->mainPtr->imageTable, argv[2]); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "image \"", argv[2], + "\" doesn't exist", (char *) NULL); + return TCL_ERROR; + } + masterPtr = (ImageMaster *) Tcl_GetHashValue(hPtr); + if (masterPtr->typePtr != NULL) { + interp->result = masterPtr->typePtr->name; + } + } else if ((c == 't') && (strcmp(argv[1], "types") == 0)) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " types\"", (char *) NULL); + return TCL_ERROR; + } + for (typePtr = imageTypeList; typePtr != NULL; + typePtr = typePtr->nextPtr) { + Tcl_AppendElement(interp, typePtr->name); + } + } else if ((c == 'w') && (strncmp(argv[1], "width", length) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " width name\"", (char *) NULL); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&winPtr->mainPtr->imageTable, argv[2]); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "image \"", argv[2], + "\" doesn't exist", (char *) NULL); + return TCL_ERROR; + } + masterPtr = (ImageMaster *) Tcl_GetHashValue(hPtr); + sprintf(interp->result, "%d", masterPtr->width); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be create, delete, height, names, type, types,", + " or width", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_ImageChanged -- + * + * This procedure is called by an image manager whenever something + * has happened that requires the image to be redrawn (some of its + * pixels have changed, or its size has changed). + * + * Results: + * None. + * + * Side effects: + * Any widgets that display the image are notified so that they + * can redisplay themselves as appropriate. + * + *---------------------------------------------------------------------- + */ + +void +Tk_ImageChanged(imageMaster, x, y, width, height, imageWidth, + imageHeight) + Tk_ImageMaster imageMaster; /* Image that needs redisplay. */ + int x, y; /* Coordinates of upper-left pixel of + * region of image that needs to be + * redrawn. */ + int width, height; /* Dimensions (in pixels) of region of + * image to redraw. If either dimension + * is zero then the image doesn't need to + * be redrawn (perhaps all that happened is + * that its size changed). */ + int imageWidth, imageHeight;/* New dimensions of image. */ +{ + ImageMaster *masterPtr = (ImageMaster *) imageMaster; + Image *imagePtr; + + masterPtr->width = imageWidth; + masterPtr->height = imageHeight; + for (imagePtr = masterPtr->instancePtr; imagePtr != NULL; + imagePtr = imagePtr->nextPtr) { + (*imagePtr->changeProc)(imagePtr->widgetClientData, x, y, + width, height, imageWidth, imageHeight); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tk_NameOfImage -- + * + * Given a token for an image master, this procedure returns + * the name of the image. + * + * Results: + * The return value is the string name for imageMaster. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tk_NameOfImage(imageMaster) + Tk_ImageMaster imageMaster; /* Token for image. */ +{ + ImageMaster *masterPtr = (ImageMaster *) imageMaster; + + return Tcl_GetHashKey(masterPtr->tablePtr, masterPtr->hPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tk_GetImage -- + * + * This procedure is invoked by a widget when it wants to use + * a particular image in a particular window. + * + * Results: + * The return value is a token for the image. If there is no image + * by the given name, then NULL is returned and an error message is + * left in interp->result. + * + * Side effects: + * Tk records the fact that the widget is using the image, and + * it will invoke changeProc later if the widget needs redisplay + * (i.e. its size changes or some of its pixels change). The + * caller must eventually invoke Tk_FreeImage when it no longer + * needs the image. + * + *---------------------------------------------------------------------- + */ + +Tk_Image +Tk_GetImage(interp, tkwin, name, changeProc, clientData) + Tcl_Interp *interp; /* Place to leave error message if image + * can't be found. */ + Tk_Window tkwin; /* Token for window in which image will + * be used. */ + char *name; /* Name of desired image. */ + Tk_ImageChangedProc *changeProc; + /* Procedure to invoke when redisplay is + * needed because image's pixels or size + * changed. */ + ClientData clientData; /* One-word argument to pass to damageProc. */ +{ + Tcl_HashEntry *hPtr; + ImageMaster *masterPtr; + Image *imagePtr; + + hPtr = Tcl_FindHashEntry(&((TkWindow *) tkwin)->mainPtr->imageTable, name); + if (hPtr == NULL) { + goto noSuchImage; + } + masterPtr = (ImageMaster *) Tcl_GetHashValue(hPtr); + if (masterPtr->typePtr == NULL) { + goto noSuchImage; + } + imagePtr = (Image *) ckalloc(sizeof(Image)); + imagePtr->tkwin = tkwin; + imagePtr->display = Tk_Display(tkwin); + imagePtr->masterPtr = masterPtr; + imagePtr->instanceData = + (*masterPtr->typePtr->getProc)(tkwin, masterPtr->masterData); + imagePtr->changeProc = changeProc; + imagePtr->widgetClientData = clientData; + imagePtr->nextPtr = masterPtr->instancePtr; + masterPtr->instancePtr = imagePtr; + return (Tk_Image) imagePtr; + + noSuchImage: + Tcl_AppendResult(interp, "image \"", name, "\" doesn't exist", + (char *) NULL); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_FreeImage -- + * + * This procedure is invoked by a widget when it no longer needs + * an image acquired by a previous call to Tk_GetImage. For each + * call to Tk_GetImage there must be exactly one call to Tk_FreeImage. + * + * Results: + * None. + * + * Side effects: + * The association between the image and the widget is removed. + * + *---------------------------------------------------------------------- + */ + +void +Tk_FreeImage(image) + Tk_Image image; /* Token for image that is no longer + * needed by a widget. */ +{ + Image *imagePtr = (Image *) image; + ImageMaster *masterPtr = imagePtr->masterPtr; + Image *prevPtr; + + /* + * Clean up the particular instance. + */ + + if (masterPtr->typePtr != NULL) { + (*masterPtr->typePtr->freeProc)(imagePtr->instanceData, + imagePtr->display); + } + prevPtr = masterPtr->instancePtr; + if (prevPtr == imagePtr) { + masterPtr->instancePtr = imagePtr->nextPtr; + } else { + while (prevPtr->nextPtr != imagePtr) { + prevPtr = prevPtr->nextPtr; + } + prevPtr->nextPtr = imagePtr->nextPtr; + } + ckfree((char *) imagePtr); + + /* + * If there are no more instances left for the master, and if the + * master image has been deleted, then delete the master too. + */ + + if ((masterPtr->typePtr == NULL) && (masterPtr->instancePtr == NULL)) { + Tcl_DeleteHashEntry(masterPtr->hPtr); + ckfree((char *) masterPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tk_RedrawImage -- + * + * This procedure is called by widgets that contain images in order + * to redisplay an image on the screen or an off-screen pixmap. + * + * Results: + * None. + * + * Side effects: + * The image's manager is notified, and it redraws the desired + * portion of the image before returning. + * + *---------------------------------------------------------------------- + */ + +void +Tk_RedrawImage(image, imageX, imageY, width, height, drawable, + drawableX, drawableY) + Tk_Image image; /* Token for image to redisplay. */ + int imageX, imageY; /* Upper-left pixel of region in image that + * needs to be redisplayed. */ + int width, height; /* Dimensions of region to redraw. */ + Drawable drawable; /* Drawable in which to display image + * (window or pixmap). If this is a pixmap, + * it must have the same depth as the window + * used in the Tk_GetImage call for the + * image. */ + int drawableX, drawableY; /* Coordinates in drawable that correspond + * to imageX and imageY. */ +{ + Image *imagePtr = (Image *) image; + + if (imagePtr->masterPtr->typePtr == NULL) { + /* + * No master for image, so nothing to display. + */ + + return; + } + + /* + * Clip the redraw area to the area of the image. + */ + + if (imageX < 0) { + width += imageX; + drawableX -= imageX; + imageX = 0; + } + if (imageY < 0) { + height += imageY; + drawableY -= imageY; + imageY = 0; + } + if ((imageX + width) > imagePtr->masterPtr->width) { + width = imagePtr->masterPtr->width - imageX; + } + if ((imageY + height) > imagePtr->masterPtr->height) { + height = imagePtr->masterPtr->height - imageY; + } + (*imagePtr->masterPtr->typePtr->displayProc)( + imagePtr->instanceData, imagePtr->display, drawable, + imageX, imageY, width, height, drawableX, drawableY); +} + +/* + *---------------------------------------------------------------------- + * + * Tk_SizeOfImage -- + * + * This procedure returns the current dimensions of an image. + * + * Results: + * The width and height of the image are returned in *widthPtr + * and *heightPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tk_SizeOfImage(image, widthPtr, heightPtr) + Tk_Image image; /* Token for image whose size is wanted. */ + int *widthPtr; /* Return width of image here. */ + int *heightPtr; /* Return height of image here. */ +{ + Image *imagePtr = (Image *) image; + + *widthPtr = imagePtr->masterPtr->width; + *heightPtr = imagePtr->masterPtr->height; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_DeleteImage -- + * + * Given the name of an image, this procedure destroys the + * image. + * + * Results: + * None. + * + * Side effects: + * The image is destroyed; existing instances will display as + * blank areas. If no such image exists then the procedure does + * nothing. + * + *---------------------------------------------------------------------- + */ + +void +Tk_DeleteImage(interp, name) + Tcl_Interp *interp; /* Interpreter in which the image was + * created. */ + char *name; /* Name of image. */ +{ + Tcl_HashEntry *hPtr; + Tcl_CmdInfo info; + TkWindow *winPtr; + + if (Tcl_GetCommandInfo(interp, "winfo", &info) == 0) { + return; + } + winPtr = (TkWindow *) info.clientData; + hPtr = Tcl_FindHashEntry(&winPtr->mainPtr->imageTable, name); + if (hPtr == NULL) { + return; + } + DeleteImage((ImageMaster *) Tcl_GetHashValue(hPtr)); +} + +/* + *---------------------------------------------------------------------- + * + * DeleteImage -- + * + * This procedure is responsible for deleting an image. + * + * Results: + * None. + * + * Side effects: + * The connection is dropped between instances of this image and + * an image master. Image instances will redisplay themselves + * as empty areas, but existing instances will not be deleted. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteImage(masterPtr) + ImageMaster *masterPtr; /* Pointer to main data structure for image. */ +{ + Image *imagePtr; + Tk_ImageType *typePtr; + + typePtr = masterPtr->typePtr; + masterPtr->typePtr = NULL; + if (typePtr != NULL) { + for (imagePtr = masterPtr->instancePtr; imagePtr != NULL; + imagePtr = imagePtr->nextPtr) { + (*typePtr->freeProc)(imagePtr->instanceData, + imagePtr->display); + (*imagePtr->changeProc)(imagePtr->widgetClientData, 0, 0, + masterPtr->width, masterPtr->height, masterPtr->width, + masterPtr->height); + } + (*typePtr->deleteProc)(masterPtr->masterData); + } + if (masterPtr->instancePtr == NULL) { + Tcl_DeleteHashEntry(masterPtr->hPtr); + ckfree((char *) masterPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * TkDeleteAllImages -- + * + * This procedure is called when an application is deleted. It + * calls back all of the managers for all images so that they + * can cleanup, then it deletes all of Tk's internal information + * about images. + * + * Results: + * None. + * + * Side effects: + * All information for all images gets deleted. + * + *---------------------------------------------------------------------- + */ + +void +TkDeleteAllImages(mainPtr) + TkMainInfo *mainPtr; /* Structure describing application that is + * going away. */ +{ + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + ImageMaster *masterPtr; + + for (hPtr = Tcl_FirstHashEntry(&mainPtr->imageTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + masterPtr = (ImageMaster *) Tcl_GetHashValue(hPtr); + DeleteImage(masterPtr); + } + Tcl_DeleteHashTable(&mainPtr->imageTable); +} diff --git a/tk4.2/generic/tkImgBmap.c b/tk4.2/generic/tkImgBmap.c new file mode 100644 index 0000000..365ce22 --- /dev/null +++ b/tk4.2/generic/tkImgBmap.c @@ -0,0 +1,1024 @@ +/* + * tkImgBmap.c -- + * + * This procedure implements images of type "bitmap" for Tk. + * + * Copyright (c) 1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkImgBmap.c 1.28 96/07/31 16:45:26 + */ + +#include "tkInt.h" +#include "tkPort.h" + +/* + * The following data structure represents the master for a bitmap + * image: + */ + +typedef struct BitmapMaster { + Tk_ImageMaster tkMaster; /* Tk's token for image master. NULL means + * the image is being deleted. */ + Tcl_Interp *interp; /* Interpreter for application that is + * using image. */ + Tcl_Command imageCmd; /* Token for image command (used to delete + * it when the image goes away). NULL means + * the image command has already been + * deleted. */ + int width, height; /* Dimensions of image. */ + char *data; /* Data comprising bitmap (suitable for + * input to XCreateBitmapFromData). May + * be NULL if no data. Malloc'ed. */ + char *maskData; /* Data for bitmap's mask (suitable for + * input to XCreateBitmapFromData). + * Malloc'ed. */ + Tk_Uid fgUid; /* Value of -foreground option (malloc'ed). */ + Tk_Uid bgUid; /* Value of -background option (malloc'ed). */ + char *fileString; /* Value of -file option (malloc'ed). */ + char *dataString; /* Value of -data option (malloc'ed). */ + char *maskFileString; /* Value of -maskfile option (malloc'ed). */ + char *maskDataString; /* Value of -maskdata option (malloc'ed). */ + struct BitmapInstance *instancePtr; + /* First in list of all instances associated + * with this master. */ +} BitmapMaster; + +/* + * The following data structure represents all of the instances of an + * image that lie within a particular window: + */ + +typedef struct BitmapInstance { + int refCount; /* Number of instances that share this + * data structure. */ + BitmapMaster *masterPtr; /* Pointer to master for image. */ + Tk_Window tkwin; /* Window in which the instances will be + * displayed. */ + XColor *fg; /* Foreground color for displaying image. */ + XColor *bg; /* Background color for displaying image. */ + Pixmap bitmap; /* The bitmap to display. */ + Pixmap mask; /* Mask: only display bitmap pixels where + * there are 1's here. */ + GC gc; /* Graphics context for displaying bitmap. + * None means there was an error while + * setting up the instance, so it cannot + * be displayed. */ + struct BitmapInstance *nextPtr; + /* Next in list of all instance structures + * associated with masterPtr (NULL means + * end of list). */ +} BitmapInstance; + +/* + * The type record for bitmap images: + */ + +static int ImgBmapCreate _ANSI_ARGS_((Tcl_Interp *interp, + char *name, int argc, char **argv, + Tk_ImageType *typePtr, Tk_ImageMaster master, + ClientData *clientDataPtr)); +static ClientData ImgBmapGet _ANSI_ARGS_((Tk_Window tkwin, + ClientData clientData)); +static void ImgBmapDisplay _ANSI_ARGS_((ClientData clientData, + Display *display, Drawable drawable, + int imageX, int imageY, int width, int height, + int drawableX, int drawableY)); +static void ImgBmapFree _ANSI_ARGS_((ClientData clientData, + Display *display)); +static void ImgBmapDelete _ANSI_ARGS_((ClientData clientData)); + +Tk_ImageType tkBitmapImageType = { + "bitmap", /* name */ + ImgBmapCreate, /* createProc */ + ImgBmapGet, /* getProc */ + ImgBmapDisplay, /* displayProc */ + ImgBmapFree, /* freeProc */ + ImgBmapDelete, /* deleteProc */ + (Tk_ImageType *) NULL /* nextPtr */ +}; + +/* + * Information used for parsing configuration specs: + */ + +static Tk_ConfigSpec configSpecs[] = { + {TK_CONFIG_UID, "-background", (char *) NULL, (char *) NULL, + "", Tk_Offset(BitmapMaster, bgUid), 0}, + {TK_CONFIG_STRING, "-data", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(BitmapMaster, dataString), TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-file", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(BitmapMaster, fileString), TK_CONFIG_NULL_OK}, + {TK_CONFIG_UID, "-foreground", (char *) NULL, (char *) NULL, + "#000000", Tk_Offset(BitmapMaster, fgUid), 0}, + {TK_CONFIG_STRING, "-maskdata", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(BitmapMaster, maskDataString), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-maskfile", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(BitmapMaster, maskFileString), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, 0} +}; + +/* + * The following data structure is used to describe the state of + * parsing a bitmap file or string. It is used for communication + * between TkGetBitmapData and NextBitmapWord. + */ + +#define MAX_WORD_LENGTH 100 +typedef struct ParseInfo { + char *string; /* Next character of string data for bitmap, + * or NULL if bitmap is being read from + * file. */ + FILE *f; /* File containing bitmap data, or NULL + * if no file. */ + char word[MAX_WORD_LENGTH+1]; + /* Current word of bitmap data, NULL + * terminated. */ + int wordLength; /* Number of non-NULL bytes in word. */ +} ParseInfo; + +/* + * Prototypes for procedures used only locally in this file: + */ + +static int ImgBmapCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static void ImgBmapCmdDeletedProc _ANSI_ARGS_(( + ClientData clientData)); +static void ImgBmapConfigureInstance _ANSI_ARGS_(( + BitmapInstance *instancePtr)); +static int ImgBmapConfigureMaster _ANSI_ARGS_(( + BitmapMaster *masterPtr, int argc, char **argv, + int flags)); +static int NextBitmapWord _ANSI_ARGS_((ParseInfo *parseInfoPtr)); + +/* + *---------------------------------------------------------------------- + * + * ImgBmapCreate -- + * + * This procedure is called by the Tk image code to create "test" + * images. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * The data structure for a new image is allocated. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +ImgBmapCreate(interp, name, argc, argv, typePtr, master, clientDataPtr) + Tcl_Interp *interp; /* Interpreter for application containing + * image. */ + char *name; /* Name to use for image. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings for options (doesn't + * include image name or type). */ + Tk_ImageType *typePtr; /* Pointer to our type record (not used). */ + Tk_ImageMaster master; /* Token for image, to be used by us in + * later callbacks. */ + ClientData *clientDataPtr; /* Store manager's token for image here; + * it will be returned in later callbacks. */ +{ + BitmapMaster *masterPtr; + + masterPtr = (BitmapMaster *) ckalloc(sizeof(BitmapMaster)); + masterPtr->tkMaster = master; + masterPtr->interp = interp; + masterPtr->imageCmd = Tcl_CreateCommand(interp, name, ImgBmapCmd, + (ClientData) masterPtr, ImgBmapCmdDeletedProc); + masterPtr->width = masterPtr->height = 0; + masterPtr->data = NULL; + masterPtr->maskData = NULL; + masterPtr->fgUid = NULL; + masterPtr->bgUid = NULL; + masterPtr->fileString = NULL; + masterPtr->dataString = NULL; + masterPtr->maskFileString = NULL; + masterPtr->maskDataString = NULL; + masterPtr->instancePtr = NULL; + if (ImgBmapConfigureMaster(masterPtr, argc, argv, 0) != TCL_OK) { + ImgBmapDelete((ClientData) masterPtr); + return TCL_ERROR; + } + *clientDataPtr = (ClientData) masterPtr; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ImgBmapConfigureMaster -- + * + * This procedure is called when a bitmap image is created or + * reconfigured. It process configuration options and resets + * any instances of the image. + * + * Results: + * A standard Tcl return value. If TCL_ERROR is returned then + * an error message is left in masterPtr->interp->result. + * + * Side effects: + * Existing instances of the image will be redisplayed to match + * the new configuration options. + * + *---------------------------------------------------------------------- + */ + +static int +ImgBmapConfigureMaster(masterPtr, argc, argv, flags) + BitmapMaster *masterPtr; /* Pointer to data structure describing + * overall bitmap image to (reconfigure). */ + int argc; /* Number of entries in argv. */ + char **argv; /* Pairs of configuration options for image. */ + int flags; /* Flags to pass to Tk_ConfigureWidget, + * such as TK_CONFIG_ARGV_ONLY. */ +{ + BitmapInstance *instancePtr; + int maskWidth, maskHeight, dummy1, dummy2; + + if (Tk_ConfigureWidget(masterPtr->interp, Tk_MainWindow(masterPtr->interp), + configSpecs, argc, argv, (char *) masterPtr, flags) + != TCL_OK) { + return TCL_ERROR; + } + + /* + * Parse the bitmap and/or mask to create binary data. Make sure that + * the bitmap and mask have the same dimensions. + */ + + if (masterPtr->data != NULL) { + ckfree(masterPtr->data); + masterPtr->data = NULL; + } + if ((masterPtr->fileString != NULL) || (masterPtr->dataString != NULL)) { + masterPtr->data = TkGetBitmapData(masterPtr->interp, + masterPtr->dataString, masterPtr->fileString, + &masterPtr->width, &masterPtr->height, &dummy1, &dummy2); + if (masterPtr->data == NULL) { + return TCL_ERROR; + } + } + if (masterPtr->maskData != NULL) { + ckfree(masterPtr->maskData); + masterPtr->maskData = NULL; + } + if ((masterPtr->maskFileString != NULL) + || (masterPtr->maskDataString != NULL)) { + if (masterPtr->data == NULL) { + masterPtr->interp->result = "can't have mask without bitmap"; + return TCL_ERROR; + } + masterPtr->maskData = TkGetBitmapData(masterPtr->interp, + masterPtr->maskDataString, masterPtr->maskFileString, + &maskWidth, &maskHeight, &dummy1, &dummy2); + if (masterPtr->maskData == NULL) { + return TCL_ERROR; + } + if ((maskWidth != masterPtr->width) + || (maskHeight != masterPtr->height)) { + ckfree(masterPtr->maskData); + masterPtr->maskData = NULL; + masterPtr->interp->result = "bitmap and mask have different sizes"; + return TCL_ERROR; + } + } + + /* + * Cycle through all of the instances of this image, regenerating + * the information for each instance. Then force the image to be + * redisplayed everywhere that it is used. + */ + + for (instancePtr = masterPtr->instancePtr; instancePtr != NULL; + instancePtr = instancePtr->nextPtr) { + ImgBmapConfigureInstance(instancePtr); + } + Tk_ImageChanged(masterPtr->tkMaster, 0, 0, masterPtr->width, + masterPtr->height, masterPtr->width, masterPtr->height); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ImgBmapConfigureInstance -- + * + * This procedure is called to create displaying information for + * a bitmap image instance based on the configuration information + * in the master. It is invoked both when new instances are + * created and when the master is reconfigured. + * + * Results: + * None. + * + * Side effects: + * Generates errors via Tcl_BackgroundError if there are problems + * in setting up the instance. + * + *---------------------------------------------------------------------- + */ + +static void +ImgBmapConfigureInstance(instancePtr) + BitmapInstance *instancePtr; /* Instance to reconfigure. */ +{ + BitmapMaster *masterPtr = instancePtr->masterPtr; + XColor *colorPtr; + XGCValues gcValues; + GC gc; + unsigned int mask; + + /* + * For each of the options in masterPtr, translate the string + * form into an internal form appropriate for instancePtr. + */ + + if (*masterPtr->bgUid != 0) { + colorPtr = Tk_GetColor(masterPtr->interp, instancePtr->tkwin, + masterPtr->bgUid); + if (colorPtr == NULL) { + goto error; + } + } else { + colorPtr = NULL; + } + if (instancePtr->bg != NULL) { + Tk_FreeColor(instancePtr->bg); + } + instancePtr->bg = colorPtr; + + colorPtr = Tk_GetColor(masterPtr->interp, instancePtr->tkwin, + masterPtr->fgUid); + if (colorPtr == NULL) { + goto error; + } + if (instancePtr->fg != NULL) { + Tk_FreeColor(instancePtr->fg); + } + instancePtr->fg = colorPtr; + + if (instancePtr->bitmap != None) { + Tk_FreePixmap(Tk_Display(instancePtr->tkwin), instancePtr->bitmap); + instancePtr->bitmap = None; + } + if (masterPtr->data != NULL) { + instancePtr->bitmap = XCreateBitmapFromData( + Tk_Display(instancePtr->tkwin), + RootWindowOfScreen(Tk_Screen(instancePtr->tkwin)), + masterPtr->data, (unsigned) masterPtr->width, + (unsigned) masterPtr->height); + } + + if (instancePtr->mask != None) { + Tk_FreePixmap(Tk_Display(instancePtr->tkwin), instancePtr->mask); + instancePtr->mask = None; + } + if (masterPtr->maskData != NULL) { + instancePtr->mask = XCreateBitmapFromData( + Tk_Display(instancePtr->tkwin), + RootWindowOfScreen(Tk_Screen(instancePtr->tkwin)), + masterPtr->maskData, (unsigned) masterPtr->width, + (unsigned) masterPtr->height); + } + + if (masterPtr->data != NULL) { + gcValues.foreground = instancePtr->fg->pixel; + gcValues.graphics_exposures = False; + mask = GCForeground|GCGraphicsExposures; + if (instancePtr->bg != NULL) { + gcValues.background = instancePtr->bg->pixel; + mask |= GCBackground; + if (instancePtr->mask != None) { + gcValues.clip_mask = instancePtr->mask; + mask |= GCClipMask; + } + } else { + gcValues.clip_mask = instancePtr->bitmap; + mask |= GCClipMask; + } + gc = Tk_GetGC(instancePtr->tkwin, mask, &gcValues); + } else { + gc = None; + } + if (instancePtr->gc != None) { + Tk_FreeGC(Tk_Display(instancePtr->tkwin), instancePtr->gc); + } + instancePtr->gc = gc; + return; + + error: + /* + * An error occurred: clear the graphics context in the instance to + * make it clear that this instance cannot be displayed. Then report + * the error. + */ + + if (instancePtr->gc != None) { + Tk_FreeGC(Tk_Display(instancePtr->tkwin), instancePtr->gc); + } + instancePtr->gc = None; + Tcl_AddErrorInfo(masterPtr->interp, "\n (while configuring image \""); + Tcl_AddErrorInfo(masterPtr->interp, Tk_NameOfImage(masterPtr->tkMaster)); + Tcl_AddErrorInfo(masterPtr->interp, "\")"); + Tcl_BackgroundError(masterPtr->interp); +} + +/* + *---------------------------------------------------------------------- + * + * TkGetBitmapData -- + * + * Given a file name or ASCII string, this procedure parses the + * file or string contents to produce binary data for a bitmap. + * + * Results: + * If the bitmap description was parsed successfully then the + * return value is a malloc-ed array containing the bitmap data. + * The dimensions of the data are stored in *widthPtr and + * *heightPtr. *hotXPtr and *hotYPtr are set to the bitmap + * hotspot if one is defined, otherwise they are set to -1, -1. + * If an error occurred, NULL is returned and an error message is + * left in interp->result. + * + * Side effects: + * A bitmap is created. + * + *---------------------------------------------------------------------- + */ + +char * +TkGetBitmapData(interp, string, fileName, widthPtr, heightPtr, + hotXPtr, hotYPtr) + Tcl_Interp *interp; /* For reporting errors. */ + char *string; /* String describing bitmap. May + * be NULL. */ + char *fileName; /* Name of file containing bitmap + * description. Used only if string + * is NULL. Must not be NULL if + * string is NULL. */ + int *widthPtr, *heightPtr; /* Dimensions of bitmap get returned + * here. */ + int *hotXPtr, *hotYPtr; /* Position of hot spot or -1,-1. */ +{ + int width, height, numBytes, hotX, hotY; + char *p, *end, *expandedFileName; + ParseInfo pi; + char *data = NULL; + Tcl_DString buffer; + + pi.string = string; + if (string == NULL) { + expandedFileName = Tcl_TranslateFileName(interp, fileName, &buffer); + if (expandedFileName == NULL) { + return NULL; + } + pi.f = fopen(expandedFileName, "r"); + Tcl_DStringFree(&buffer); + if (pi.f == NULL) { + Tcl_AppendResult(interp, "couldn't read bitmap file \"", + fileName, "\": ", Tcl_PosixError(interp), (char *) NULL); + return NULL; + } + } else { + pi.f = NULL; + } + + /* + * Parse the lines that define the dimensions of the bitmap, + * plus the first line that defines the bitmap data (it declares + * the name of a data variable but doesn't include any actual + * data). These lines look something like the following: + * + * #define foo_width 16 + * #define foo_height 16 + * #define foo_x_hot 3 + * #define foo_y_hot 3 + * static char foo_bits[] = { + * + * The x_hot and y_hot lines may or may not be present. It's + * important to check for "char" in the last line, in order to + * reject old X10-style bitmaps that used shorts. + */ + + width = 0; + height = 0; + hotX = -1; + hotY = -1; + while (1) { + if (NextBitmapWord(&pi) != TCL_OK) { + goto error; + } + if ((pi.wordLength >= 6) && (pi.word[pi.wordLength-6] == '_') + && (strcmp(pi.word+pi.wordLength-6, "_width") == 0)) { + if (NextBitmapWord(&pi) != TCL_OK) { + goto error; + } + width = strtol(pi.word, &end, 0); + if ((end == pi.word) || (*end != 0)) { + goto error; + } + } else if ((pi.wordLength >= 7) && (pi.word[pi.wordLength-7] == '_') + && (strcmp(pi.word+pi.wordLength-7, "_height") == 0)) { + if (NextBitmapWord(&pi) != TCL_OK) { + goto error; + } + height = strtol(pi.word, &end, 0); + if ((end == pi.word) || (*end != 0)) { + goto error; + } + } else if ((pi.wordLength >= 6) && (pi.word[pi.wordLength-6] == '_') + && (strcmp(pi.word+pi.wordLength-6, "_x_hot") == 0)) { + if (NextBitmapWord(&pi) != TCL_OK) { + goto error; + } + hotX = strtol(pi.word, &end, 0); + if ((end == pi.word) || (*end != 0)) { + goto error; + } + } else if ((pi.wordLength >= 6) && (pi.word[pi.wordLength-6] == '_') + && (strcmp(pi.word+pi.wordLength-6, "_y_hot") == 0)) { + if (NextBitmapWord(&pi) != TCL_OK) { + goto error; + } + hotY = strtol(pi.word, &end, 0); + if ((end == pi.word) || (*end != 0)) { + goto error; + } + } else if ((pi.word[0] == 'c') && (strcmp(pi.word, "char") == 0)) { + while (1) { + if (NextBitmapWord(&pi) != TCL_OK) { + goto error; + } + if ((pi.word[0] == '{') && (pi.word[1] == 0)) { + goto getData; + } + } + } else if ((pi.word[0] == '{') && (pi.word[1] == 0)) { + Tcl_AppendResult(interp, "format error in bitmap data; ", + "looks like it's an obsolete X10 bitmap file", + (char *) NULL); + goto errorCleanup; + } + } + + /* + * Now we've read everything but the data. Allocate an array + * and read in the data. + */ + + getData: + if ((width <= 0) || (height <= 0)) { + goto error; + } + numBytes = ((width+7)/8) * height; + data = (char *) ckalloc((unsigned) numBytes); + for (p = data; numBytes > 0; p++, numBytes--) { + if (NextBitmapWord(&pi) != TCL_OK) { + goto error; + } + *p = strtol(pi.word, &end, 0); + if (end == pi.word) { + goto error; + } + } + + /* + * All done. Clean up and return. + */ + + if (pi.f != NULL) { + fclose(pi.f); + } + *widthPtr = width; + *heightPtr = height; + *hotXPtr = hotX; + *hotYPtr = hotY; + return data; + + error: + interp->result = "format error in bitmap data"; + errorCleanup: + if (data != NULL) { + ckfree(data); + } + if (pi.f != NULL) { + fclose(pi.f); + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * NextBitmapWord -- + * + * This procedure retrieves the next word of information (stuff + * between commas or white space) from a bitmap description. + * + * Results: + * Returns TCL_OK if all went well. In this case the next word, + * and its length, will be availble in *parseInfoPtr. If the end + * of the bitmap description was reached then TCL_ERROR is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +NextBitmapWord(parseInfoPtr) + ParseInfo *parseInfoPtr; /* Describes what we're reading + * and where we are in it. */ +{ + char *src, *dst; + int c; + + parseInfoPtr->wordLength = 0; + dst = parseInfoPtr->word; + if (parseInfoPtr->string != NULL) { + for (src = parseInfoPtr->string; isspace(UCHAR(*src)) || (*src == ','); + src++) { + if (*src == 0) { + return TCL_ERROR; + } + } + for ( ; !isspace(UCHAR(*src)) && (*src != ',') && (*src != 0); src++) { + *dst = *src; + dst++; + parseInfoPtr->wordLength++; + if (parseInfoPtr->wordLength > MAX_WORD_LENGTH) { + return TCL_ERROR; + } + } + parseInfoPtr->string = src; + } else { + for (c = getc(parseInfoPtr->f); isspace(UCHAR(c)) || (c == ','); + c = getc(parseInfoPtr->f)) { + if (c == EOF) { + return TCL_ERROR; + } + } + for ( ; !isspace(UCHAR(c)) && (c != ',') && (c != EOF); + c = getc(parseInfoPtr->f)) { + *dst = c; + dst++; + parseInfoPtr->wordLength++; + if (parseInfoPtr->wordLength > MAX_WORD_LENGTH) { + return TCL_ERROR; + } + } + } + if (parseInfoPtr->wordLength == 0) { + return TCL_ERROR; + } + parseInfoPtr->word[parseInfoPtr->wordLength] = 0; + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * ImgBmapCmd -- + * + * This procedure is invoked to process the Tcl command + * that corresponds to an image managed by this module. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +static int +ImgBmapCmd(clientData, interp, argc, argv) + ClientData clientData; /* Information about the image master. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + BitmapMaster *masterPtr = (BitmapMaster *) clientData; + int c, code; + size_t length; + + if (argc < 2) { + sprintf(interp->result, + "wrong # args: should be \"%.50s option ?arg arg ...?\"", + argv[0]); + return TCL_ERROR; + } + c = argv[1][0]; + length = strlen(argv[1]); + if ((c == 'c') && (strncmp(argv[1], "cget", length) == 0) + && (length >= 2)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " cget option\"", + (char *) NULL); + return TCL_ERROR; + } + return Tk_ConfigureValue(interp, Tk_MainWindow(interp), configSpecs, + (char *) masterPtr, argv[2], 0); + } else if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0) + && (length >= 2)) { + if (argc == 2) { + code = Tk_ConfigureInfo(interp, Tk_MainWindow(interp), + configSpecs, (char *) masterPtr, (char *) NULL, 0); + } else if (argc == 3) { + code = Tk_ConfigureInfo(interp, Tk_MainWindow(interp), + configSpecs, (char *) masterPtr, argv[2], 0); + } else { + code = ImgBmapConfigureMaster(masterPtr, argc-2, argv+2, + TK_CONFIG_ARGV_ONLY); + } + return code; + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be cget or configure", (char *) NULL); + return TCL_ERROR; + } +} + +/* + *---------------------------------------------------------------------- + * + * ImgBmapGet -- + * + * This procedure is called for each use of a bitmap image in a + * widget. + * + * Results: + * The return value is a token for the instance, which is passed + * back to us in calls to ImgBmapDisplay and ImgBmapFree. + * + * Side effects: + * A data structure is set up for the instance (or, an existing + * instance is re-used for the new one). + * + *---------------------------------------------------------------------- + */ + +static ClientData +ImgBmapGet(tkwin, masterData) + Tk_Window tkwin; /* Window in which the instance will be + * used. */ + ClientData masterData; /* Pointer to our master structure for the + * image. */ +{ + BitmapMaster *masterPtr = (BitmapMaster *) masterData; + BitmapInstance *instancePtr; + + /* + * See if there is already an instance for this window. If so + * then just re-use it. + */ + + for (instancePtr = masterPtr->instancePtr; instancePtr != NULL; + instancePtr = instancePtr->nextPtr) { + if (instancePtr->tkwin == tkwin) { + instancePtr->refCount++; + return (ClientData) instancePtr; + } + } + + /* + * The image isn't already in use in this window. Make a new + * instance of the image. + */ + + instancePtr = (BitmapInstance *) ckalloc(sizeof(BitmapInstance)); + instancePtr->refCount = 1; + instancePtr->masterPtr = masterPtr; + instancePtr->tkwin = tkwin; + instancePtr->fg = NULL; + instancePtr->bg = NULL; + instancePtr->bitmap = None; + instancePtr->mask = None; + instancePtr->gc = None; + instancePtr->nextPtr = masterPtr->instancePtr; + masterPtr->instancePtr = instancePtr; + ImgBmapConfigureInstance(instancePtr); + + /* + * If this is the first instance, must set the size of the image. + */ + + if (instancePtr->nextPtr == NULL) { + Tk_ImageChanged(masterPtr->tkMaster, 0, 0, 0, 0, masterPtr->width, + masterPtr->height); + } + + return (ClientData) instancePtr; +} + +/* + *---------------------------------------------------------------------- + * + * ImgBmapDisplay -- + * + * This procedure is invoked to draw a bitmap image. + * + * Results: + * None. + * + * Side effects: + * A portion of the image gets rendered in a pixmap or window. + * + *---------------------------------------------------------------------- + */ + +static void +ImgBmapDisplay(clientData, display, drawable, imageX, imageY, width, + height, drawableX, drawableY) + ClientData clientData; /* Pointer to BitmapInstance structure for + * for instance to be displayed. */ + Display *display; /* Display on which to draw image. */ + Drawable drawable; /* Pixmap or window in which to draw image. */ + int imageX, imageY; /* Upper-left corner of region within image + * to draw. */ + int width, height; /* Dimensions of region within image to draw. */ + int drawableX, drawableY; /* Coordinates within drawable that + * correspond to imageX and imageY. */ +{ + BitmapInstance *instancePtr = (BitmapInstance *) clientData; + int masking; + + /* + * If there's no graphics context, it means that an error occurred + * while creating the image instance so it can't be displayed. + */ + + if (instancePtr->gc == None) { + return; + } + + /* + * If masking is in effect, must modify the mask origin within + * the graphics context to line up with the image's origin. + * Then draw the image and reset the clip origin, if there's + * a mask. + */ + + masking = (instancePtr->mask != None) || (instancePtr->bg == NULL); + if (masking) { + XSetClipOrigin(display, instancePtr->gc, drawableX - imageX, + drawableY - imageY); + } + XCopyPlane(display, instancePtr->bitmap, drawable, instancePtr->gc, + imageX, imageY, (unsigned) width, (unsigned) height, + drawableX, drawableY, 1); + if (masking) { + XSetClipOrigin(display, instancePtr->gc, 0, 0); + } +} + +/* + *---------------------------------------------------------------------- + * + * ImgBmapFree -- + * + * This procedure is called when a widget ceases to use a + * particular instance of an image. + * + * Results: + * None. + * + * Side effects: + * Internal data structures get cleaned up. + * + *---------------------------------------------------------------------- + */ + +static void +ImgBmapFree(clientData, display) + ClientData clientData; /* Pointer to BitmapInstance structure for + * for instance to be displayed. */ + Display *display; /* Display containing window that used image. */ +{ + BitmapInstance *instancePtr = (BitmapInstance *) clientData; + BitmapInstance *prevPtr; + + instancePtr->refCount--; + if (instancePtr->refCount > 0) { + return; + } + + /* + * There are no more uses of the image within this widget. Free + * the instance structure. + */ + + if (instancePtr->fg != NULL) { + Tk_FreeColor(instancePtr->fg); + } + if (instancePtr->bg != NULL) { + Tk_FreeColor(instancePtr->bg); + } + if (instancePtr->bitmap != None) { + Tk_FreePixmap(display, instancePtr->bitmap); + } + if (instancePtr->mask != None) { + Tk_FreePixmap(display, instancePtr->mask); + } + if (instancePtr->gc != None) { + Tk_FreeGC(display, instancePtr->gc); + } + if (instancePtr->masterPtr->instancePtr == instancePtr) { + instancePtr->masterPtr->instancePtr = instancePtr->nextPtr; + } else { + for (prevPtr = instancePtr->masterPtr->instancePtr; + prevPtr->nextPtr != instancePtr; prevPtr = prevPtr->nextPtr) { + /* Empty loop body */ + } + prevPtr->nextPtr = instancePtr->nextPtr; + } + ckfree((char *) instancePtr); +} + +/* + *---------------------------------------------------------------------- + * + * ImgBmapDelete -- + * + * This procedure is called by the image code to delete the + * master structure for an image. + * + * Results: + * None. + * + * Side effects: + * Resources associated with the image get freed. + * + *---------------------------------------------------------------------- + */ + +static void +ImgBmapDelete(masterData) + ClientData masterData; /* Pointer to BitmapMaster structure for + * image. Must not have any more instances. */ +{ + BitmapMaster *masterPtr = (BitmapMaster *) masterData; + + if (masterPtr->instancePtr != NULL) { + panic("tried to delete bitmap image when instances still exist"); + } + masterPtr->tkMaster = NULL; + if (masterPtr->imageCmd != NULL) { + Tcl_DeleteCommand(masterPtr->interp, + Tcl_GetCommandName(masterPtr->interp, masterPtr->imageCmd)); + } + if (masterPtr->data != NULL) { + ckfree(masterPtr->data); + } + if (masterPtr->maskData != NULL) { + ckfree(masterPtr->maskData); + } + Tk_FreeOptions(configSpecs, (char *) masterPtr, (Display *) NULL, 0); + ckfree((char *) masterPtr); +} + +/* + *---------------------------------------------------------------------- + * + * ImgBmapCmdDeletedProc -- + * + * This procedure is invoked when the image command for an image + * is deleted. It deletes the image. + * + * Results: + * None. + * + * Side effects: + * The image is deleted. + * + *---------------------------------------------------------------------- + */ + +static void +ImgBmapCmdDeletedProc(clientData) + ClientData clientData; /* Pointer to BitmapMaster structure for + * image. */ +{ + BitmapMaster *masterPtr = (BitmapMaster *) clientData; + + masterPtr->imageCmd = NULL; + if (masterPtr->tkMaster != NULL) { + Tk_DeleteImage(masterPtr->interp, Tk_NameOfImage(masterPtr->tkMaster)); + } +} diff --git a/tk4.2/generic/tkImgGIF.c b/tk4.2/generic/tkImgGIF.c new file mode 100644 index 0000000..08418cc --- /dev/null +++ b/tk4.2/generic/tkImgGIF.c @@ -0,0 +1,698 @@ +/* + * tkImgGIF.c -- + * + * A photo image file handler for GIF files. Reads 87a and 89a GIF files. + * At present there is no write function. + * + * Derived from the giftoppm code found in the pbmplus package + * and tkImgFmtPPM.c in the tk4.0b2 distribution by - + * + * Reed Wade (wade@cs.utk.edu), University of Tennessee + * + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * This file also contains code from the giftoppm program, which is + * copyrighted as follows: + * + * +-------------------------------------------------------------------+ + * | Copyright 1990, David Koblas. | + * | 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 and that both that copyright notice and this permission | + * | notice appear in supporting documentation. This software is | + * | provided "as is" without express or implied warranty. | + * +-------------------------------------------------------------------+ + * + * SCCS: @(#) tkImgGIF.c 1.9 96/07/19 09:57:18 + */ + +#include "tkInt.h" +#include "tkPort.h" + +/* + * The format record for the GIF file format: + */ + +static int FileMatchGIF _ANSI_ARGS_((FILE *f, char *fileName, + char *formatString, int *widthPtr, int *heightPtr)); +static int FileReadGIF _ANSI_ARGS_((Tcl_Interp *interp, + FILE *f, char *fileName, char *formatString, + Tk_PhotoHandle imageHandle, int destX, int destY, + int width, int height, int srcX, int srcY)); + +Tk_PhotoImageFormat tkImgFmtGIF = { + "GIF", /* name */ + FileMatchGIF, /* fileMatchProc */ + NULL, /* stringMatchProc */ + FileReadGIF, /* fileReadProc */ + NULL, /* stringReadProc */ + NULL, /* fileWriteProc */ + NULL, /* stringWriteProc */ +}; + +#define INTERLACE 0x40 +#define LOCALCOLORMAP 0x80 +#define BitSet(byte, bit) (((byte) & (bit)) == (bit)) +#define MAXCOLORMAPSIZE 256 +#define CM_RED 0 +#define CM_GREEN 1 +#define CM_BLUE 2 +#define MAX_LWZ_BITS 12 +#define LM_to_uint(a,b) (((b)<<8)|(a)) +#define ReadOK(file,buffer,len) (fread(buffer, len, 1, file) != 0) + +/* + * Prototypes for local procedures defined in this file: + */ + +static int DoExtension _ANSI_ARGS_((FILE *fd, int label, + int *transparent)); +static int GetCode _ANSI_ARGS_((FILE *fd, int code_size, + int flag)); +static int GetDataBlock _ANSI_ARGS_((FILE *fd, + unsigned char *buf)); +static int LWZReadByte _ANSI_ARGS_((FILE *fd, int flag, + int input_code_size)); +static int ReadColorMap _ANSI_ARGS_((FILE *fd, int number, + unsigned char buffer[3][MAXCOLORMAPSIZE])); +static int ReadGIFHeader _ANSI_ARGS_((FILE *f, int *widthPtr, + int *heightPtr)); +static int ReadImage _ANSI_ARGS_((Tcl_Interp *interp, + char *imagePtr, FILE *fd, int len, int height, + unsigned char cmap[3][MAXCOLORMAPSIZE], + int interlace, int transparent)); + +/* + *---------------------------------------------------------------------- + * + * FileMatchGIF -- + * + * This procedure is invoked by the photo image type to see if + * a file contains image data in GIF format. + * + * Results: + * The return value is 1 if the first characters in file f look + * like GIF data, and 0 otherwise. + * + * Side effects: + * The access position in f may change. + * + *---------------------------------------------------------------------- + */ + +static int +FileMatchGIF(f, fileName, formatString, widthPtr, heightPtr) + FILE *f; /* The image file, open for reading. */ + char *fileName; /* The name of the image file. */ + char *formatString; /* User-specified format string, or NULL. */ + int *widthPtr, *heightPtr; /* The dimensions of the image are + * returned here if the file is a valid + * raw GIF file. */ +{ + return ReadGIFHeader(f, widthPtr, heightPtr); +} + +/* + *---------------------------------------------------------------------- + * + * FileReadGIF -- + * + * This procedure is called by the photo image type to read + * GIF format data from a file and write it into a given + * photo image. + * + * Results: + * A standard TCL completion code. If TCL_ERROR is returned + * then an error message is left in interp->result. + * + * Side effects: + * The access position in file f is changed, and new data is + * added to the image given by imageHandle. + * + *---------------------------------------------------------------------- + */ + +static int +FileReadGIF(interp, f, fileName, formatString, imageHandle, destX, destY, + width, height, srcX, srcY) + Tcl_Interp *interp; /* Interpreter to use for reporting errors. */ + FILE *f; /* The image file, open for reading. */ + char *fileName; /* The name of the image file. */ + char *formatString; /* User-specified format string, or NULL. */ + Tk_PhotoHandle imageHandle; /* The photo image to write into. */ + int destX, destY; /* Coordinates of top-left pixel in + * photo image to be written to. */ + int width, height; /* Dimensions of block of photo image to + * be written to. */ + int srcX, srcY; /* Coordinates of top-left pixel to be used + * in image being read. */ +{ + int fileWidth, fileHeight; + int nBytes; + Tk_PhotoImageBlock block; + unsigned char buf[100]; + int bitPixel; + unsigned int colorResolution; + unsigned int background; + unsigned int aspectRatio; + unsigned char localColorMap[3][MAXCOLORMAPSIZE]; + unsigned char colorMap[3][MAXCOLORMAPSIZE]; + int useGlobalColormap; + int transparent = -1; + + if (!ReadGIFHeader(f, &fileWidth, &fileHeight)) { + Tcl_AppendResult(interp, "couldn't read GIF header from file \"", + fileName, "\"", NULL); + return TCL_ERROR; + } + if ((fileWidth <= 0) || (fileHeight <= 0)) { + Tcl_AppendResult(interp, "GIF image file \"", fileName, + "\" has dimension(s) <= 0", (char *) NULL); + return TCL_ERROR; + } + + if (fread(buf, 1, 3, f) != 3) { + return TCL_OK; + } + bitPixel = 2<<(buf[0]&0x07); + colorResolution = (((buf[0]&0x70)>>3)+1); + background = buf[1]; + aspectRatio = buf[2]; + + if (BitSet(buf[0], LOCALCOLORMAP)) { /* Global Colormap */ + if (!ReadColorMap(f, bitPixel, colorMap)) { + Tcl_AppendResult(interp, "error reading color map", + (char *) NULL); + return TCL_ERROR; + } + } + + if ((srcX + width) > fileWidth) { + width = fileWidth - srcX; + } + if ((srcY + height) > fileHeight) { + height = fileHeight - srcY; + } + if ((width <= 0) || (height <= 0) + || (srcX >= fileWidth) || (srcY >= fileHeight)) { + return TCL_OK; + } + + Tk_PhotoExpand(imageHandle, destX + width, destY + height); + + block.width = fileWidth; + block.height = fileHeight; + block.pixelSize = 3; + block.pitch = 3 * fileWidth; + block.offset[0] = 0; + block.offset[1] = 1; + block.offset[2] = 2; + nBytes = fileHeight * block.pitch; + block.pixelPtr = (unsigned char *) ckalloc((unsigned) nBytes); + + while (1) { + if (fread(buf, 1, 1, f) != 1) { + /* + * Premature end of image. We should really notify + * the user, but for now just show garbage. + */ + + break; + } + + if (buf[0] == ';') { + /* + * GIF terminator. + */ + + break; + } + + if (buf[0] == '!') { + /* + * This is a GIF extension. + */ + + if (fread(buf, 1, 1, f) != 1) { + interp->result = + "error reading extension function code in GIF image"; + goto error; + } + if (DoExtension(f, buf[0], &transparent) < 0) { + interp->result = "error reading extension in GIF image"; + goto error; + } + continue; + } + + if (buf[0] != ',') { + /* + * Not a valid start character; ignore it. + */ + continue; + } + + if (fread(buf, 1, 9, f) != 9) { + interp->result = "couldn't read left/top/width/height in GIF image"; + goto error; + } + + useGlobalColormap = ! BitSet(buf[8], LOCALCOLORMAP); + + bitPixel = 1<<((buf[8]&0x07)+1); + + if (!useGlobalColormap) { + if (!ReadColorMap(f, bitPixel, localColorMap)) { + Tcl_AppendResult(interp, "error reading color map", + (char *) NULL); + goto error; + } + if (ReadImage(interp, (char *) block.pixelPtr, f, fileWidth, + fileHeight, localColorMap, BitSet(buf[8], INTERLACE), + transparent) != TCL_OK) { + goto error; + } + } else { + if (ReadImage(interp, (char *) block.pixelPtr, f, fileWidth, + fileHeight, colorMap, BitSet(buf[8], INTERLACE), + transparent) != TCL_OK) { + goto error; + } + } + break; + } + + Tk_PhotoPutBlock(imageHandle, &block, destX, destY, fileWidth, fileHeight); + ckfree((char *) block.pixelPtr); + return TCL_OK; + + error: + ckfree((char *) block.pixelPtr); + return TCL_ERROR; + +} + +/* + *---------------------------------------------------------------------- + * + * ReadGIFHeader -- + * + * This procedure reads the GIF header from the beginning of a + * GIF file and returns the dimensions of the image. + * + * Results: + * The return value is 1 if file "f" appears to start with + * a valid GIF header, 0 otherwise. If the header is valid, + * then *widthPtr and *heightPtr are modified to hold the + * dimensions of the image. + * + * Side effects: + * The access position in f advances. + * + *---------------------------------------------------------------------- + */ + +static int +ReadGIFHeader(f, widthPtr, heightPtr) + FILE *f; /* Image file to read the header from */ + int *widthPtr, *heightPtr; /* The dimensions of the image are + * returned here. */ +{ + unsigned char buf[7]; + + if ((fread(buf, 1, 6, f) != 6) + || ((strncmp("GIF87a", (char *) buf, 6) != 0) + && (strncmp("GIF89a", (char *) buf, 6) != 0))) { + return 0; + } + + if (fread(buf, 1, 4, f) != 4) { + return 0; + } + + *widthPtr = LM_to_uint(buf[0],buf[1]); + *heightPtr = LM_to_uint(buf[2],buf[3]); + return 1; +} + +/* + *----------------------------------------------------------------- + * The code below is copied from the giftoppm program and modified + * just slightly. + *----------------------------------------------------------------- + */ + +static int +ReadColorMap(fd,number,buffer) +FILE *fd; +int number; +unsigned char buffer[3][MAXCOLORMAPSIZE]; +{ + int i; + unsigned char rgb[3]; + + for (i = 0; i < number; ++i) { + if (! ReadOK(fd, rgb, sizeof(rgb))) + return 0; + + buffer[CM_RED][i] = rgb[0] ; + buffer[CM_GREEN][i] = rgb[1] ; + buffer[CM_BLUE][i] = rgb[2] ; + } + return 1; +} + + + +static int +DoExtension(fd, label, transparent) +FILE *fd; +int label; +int *transparent; +{ + static unsigned char buf[256]; + int count = 0; + + switch (label) { + case 0x01: /* Plain Text Extension */ + break; + + case 0xff: /* Application Extension */ + break; + + case 0xfe: /* Comment Extension */ + do { + count = GetDataBlock(fd, (unsigned char*) buf); + } while (count > 0); + return count; + + case 0xf9: /* Graphic Control Extension */ + count = GetDataBlock(fd, (unsigned char*) buf); + if (count < 0) { + return 1; + } + if ((buf[0] & 0x1) != 0) { + *transparent = buf[3]; + } + + do { + count = GetDataBlock(fd, (unsigned char*) buf); + } while (count > 0); + return count; + } + + do { + count = GetDataBlock(fd, (unsigned char*) buf); + } while (count > 0); + return count; +} + +static int ZeroDataBlock = 0; + +static int +GetDataBlock(fd, buf) +FILE *fd; +unsigned char *buf; +{ + unsigned char count; + + if (! ReadOK(fd,&count,1)) { + return -1; + } + + ZeroDataBlock = count == 0; + + if ((count != 0) && (! ReadOK(fd, buf, count))) { + return -1; + } + + return count; +} + + +static int +ReadImage(interp, imagePtr, fd, len, height, cmap, interlace, transparent) +Tcl_Interp *interp; +char *imagePtr; +FILE *fd; +int len, height; +unsigned char cmap[3][MAXCOLORMAPSIZE]; +int interlace; +int transparent; +{ + unsigned char c; + int v; + int xpos = 0, ypos = 0, pass = 0; + char *colStr; + + + /* + * Initialize the Compression routines + */ + if (! ReadOK(fd,&c,1)) { + Tcl_AppendResult(interp, "error reading GIF image: ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + + if (LWZReadByte(fd, 1, c) < 0) { + interp->result = "format error in GIF image"; + return TCL_ERROR; + } + + if (transparent != -1) { + colStr = Tcl_GetVar(interp, "TRANSPARENT_GIF_COLOR", 0L); + if (colStr != NULL) { + XColor *colorPtr; + colorPtr = Tk_GetColor(interp, Tk_MainWindow(interp), + Tk_GetUid(colStr)); + if (colorPtr) { + cmap[CM_RED][transparent] = colorPtr->red >> 8; + cmap[CM_GREEN][transparent] = colorPtr->green >> 8; + cmap[CM_BLUE][transparent] = colorPtr->blue >> 8; + Tk_FreeColor(colorPtr); + } + } + } + + while ((v = LWZReadByte(fd,0,c)) >= 0 ) { + + imagePtr[ (xpos*3) + (ypos *len*3)] = cmap[CM_RED][v]; + imagePtr[ (xpos*3) + (ypos *len*3) +1] = cmap[CM_GREEN][v]; + imagePtr[ (xpos*3) + (ypos *len*3) +2] = cmap[CM_BLUE][v]; + + ++xpos; + if (xpos == len) { + xpos = 0; + if (interlace) { + switch (pass) { + case 0: + case 1: + ypos += 8; break; + case 2: + ypos += 4; break; + case 3: + ypos += 2; break; + } + + if (ypos >= height) { + ++pass; + switch (pass) { + case 1: + ypos = 4; break; + case 2: + ypos = 2; break; + case 3: + ypos = 1; break; + default: + return TCL_OK; + } + } + } else { + ++ypos; + } + } + if (ypos >= height) + break; + } + return TCL_OK; +} + +static int +LWZReadByte(fd, flag, input_code_size) +FILE *fd; +int flag; +int input_code_size; +{ + static int fresh = 0; + int code, incode; + static int code_size, set_code_size; + static int max_code, max_code_size; + static int firstcode, oldcode; + static int clear_code, end_code; + static int table[2][(1<< MAX_LWZ_BITS)]; + static int stack[(1<<(MAX_LWZ_BITS))*2], *sp; + register int i; + + + if (flag) { + + set_code_size = input_code_size; + code_size = set_code_size+1; + clear_code = 1 << set_code_size ; + end_code = clear_code + 1; + max_code_size = 2*clear_code; + max_code = clear_code+2; + + GetCode(fd, 0, 1); + + fresh = 1; + + for (i = 0; i < clear_code; ++i) { + table[0][i] = 0; + table[1][i] = i; + } + for (; i < (1< stack) + return *--sp; + + while ((code = GetCode(fd, code_size, 0)) >= 0) { + if (code == clear_code) { + for (i = 0; i < clear_code; ++i) { + table[0][i] = 0; + table[1][i] = i; + } + + for (; i < (1< 0) + ; + + if (count != 0) + return -2; + } + + incode = code; + + if (code >= max_code) { + *sp++ = firstcode; + code = oldcode; + } + + while (code >= clear_code) { + *sp++ = table[1][code]; + if (code == table[0][code]) { + return -2; + + /* + * Used to be this instead, Steve Ball suggested + * the change to just return. + + printf("circular table entry BIG ERROR\n"); + */ + } + code = table[0][code]; + } + + *sp++ = firstcode = table[1][code]; + + if ((code = max_code) <(1<=max_code_size) && (max_code_size < (1< stack) + return *--sp; + } + return code; +} + + +static int +GetCode(fd, code_size, flag) +FILE *fd; +int code_size; +int flag; +{ + static unsigned char buf[280]; + static int curbit, lastbit, done, last_byte; + int i, j, ret; + unsigned char count; + + if (flag) { + curbit = 0; + lastbit = 0; + done = 0; + return 0; + } + + + if ( (curbit+code_size) >= lastbit) { + if (done) { + /* ran off the end of my bits */ + return -1; + } + buf[0] = buf[last_byte-2]; + buf[1] = buf[last_byte-1]; + + if ((count = GetDataBlock(fd, &buf[2])) == 0) + done = 1; + + last_byte = 2 + count; + curbit = (curbit - lastbit) + 16; + lastbit = (2+count)*8 ; + } + + ret = 0; + for (i = curbit, j = 0; j < code_size; ++i, ++j) + ret |= ((buf[ i / 8 ] & (1 << (i % 8))) != 0) << j; + + + curbit += code_size; + + return ret; +} diff --git a/tk4.2/generic/tkImgPPM.c b/tk4.2/generic/tkImgPPM.c new file mode 100644 index 0000000..b87c02f --- /dev/null +++ b/tk4.2/generic/tkImgPPM.c @@ -0,0 +1,408 @@ +/* + * tkImgPPM.c -- + * + * A photo image file handler for PPM (Portable PixMap) files. + * + * Copyright (c) 1994 The Australian National University. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * Author: Paul Mackerras (paulus@cs.anu.edu.au), + * Department of Computer Science, + * Australian National University. + * + * SCCS: @(#) tkImgPPM.c 1.13 96/03/18 14:56:41 + */ + +#include "tkInt.h" +#include "tkPort.h" + +/* + * The maximum amount of memory to allocate for data read from the + * file. If we need more than this, we do it in pieces. + */ + +#define MAX_MEMORY 10000 /* don't allocate > 10KB */ + +/* + * Define PGM and PPM, i.e. gray images and color images. + */ + +#define PGM 1 +#define PPM 2 + +/* + * The format record for the PPM file format: + */ + +static int FileMatchPPM _ANSI_ARGS_((FILE *f, char *fileName, + char *formatString, int *widthPtr, + int *heightPtr)); +static int FileReadPPM _ANSI_ARGS_((Tcl_Interp *interp, + FILE *f, char *fileName, char *formatString, + Tk_PhotoHandle imageHandle, int destX, int destY, + int width, int height, int srcX, int srcY)); +static int FileWritePPM _ANSI_ARGS_((Tcl_Interp *interp, + char *fileName, char *formatString, + Tk_PhotoImageBlock *blockPtr)); + +Tk_PhotoImageFormat tkImgFmtPPM = { + "PPM", /* name */ + FileMatchPPM, /* fileMatchProc */ + NULL, /* stringMatchProc */ + FileReadPPM, /* fileReadProc */ + NULL, /* stringReadProc */ + FileWritePPM, /* fileWriteProc */ + NULL, /* stringWriteProc */ +}; + +/* + * Prototypes for local procedures defined in this file: + */ + +static int ReadPPMFileHeader _ANSI_ARGS_((FILE *f, int *widthPtr, + int *heightPtr, int *maxIntensityPtr)); + +/* + *---------------------------------------------------------------------- + * + * FileMatchPPM -- + * + * This procedure is invoked by the photo image type to see if + * a file contains image data in PPM format. + * + * Results: + * The return value is >0 if the first characters in file "f" look + * like PPM data, and 0 otherwise. + * + * Side effects: + * The access position in f may change. + * + *---------------------------------------------------------------------- + */ + +static int +FileMatchPPM(f, fileName, formatString, widthPtr, heightPtr) + FILE *f; /* The image file, open for reading. */ + char *fileName; /* The name of the image file. */ + char *formatString; /* User-specified format string, or NULL. */ + int *widthPtr, *heightPtr; /* The dimensions of the image are + * returned here if the file is a valid + * raw PPM file. */ +{ + int dummy; + + return ReadPPMFileHeader(f, widthPtr, heightPtr, &dummy); +} + +/* + *---------------------------------------------------------------------- + * + * FileReadPPM -- + * + * This procedure is called by the photo image type to read + * PPM format data from a file and write it into a given + * photo image. + * + * Results: + * A standard TCL completion code. If TCL_ERROR is returned + * then an error message is left in interp->result. + * + * Side effects: + * The access position in file f is changed, and new data is + * added to the image given by imageHandle. + * + *---------------------------------------------------------------------- + */ + +static int +FileReadPPM(interp, f, fileName, formatString, imageHandle, destX, destY, + width, height, srcX, srcY) + Tcl_Interp *interp; /* Interpreter to use for reporting errors. */ + FILE *f; /* The image file, open for reading. */ + char *fileName; /* The name of the image file. */ + char *formatString; /* User-specified format string, or NULL. */ + Tk_PhotoHandle imageHandle; /* The photo image to write into. */ + int destX, destY; /* Coordinates of top-left pixel in + * photo image to be written to. */ + int width, height; /* Dimensions of block of photo image to + * be written to. */ + int srcX, srcY; /* Coordinates of top-left pixel to be used + * in image being read. */ +{ + int fileWidth, fileHeight, maxIntensity; + int nLines, nBytes, h, type, count; + unsigned char *pixelPtr; + Tk_PhotoImageBlock block; + + type = ReadPPMFileHeader(f, &fileWidth, &fileHeight, &maxIntensity); + if (type == 0) { + Tcl_AppendResult(interp, "couldn't read raw PPM header from file \"", + fileName, "\"", NULL); + return TCL_ERROR; + } + if ((fileWidth <= 0) || (fileHeight <= 0)) { + Tcl_AppendResult(interp, "PPM image file \"", fileName, + "\" has dimension(s) <= 0", (char *) NULL); + return TCL_ERROR; + } + if ((maxIntensity <= 0) || (maxIntensity >= 256)) { + char buffer[30]; + + sprintf(buffer, "%d", maxIntensity); + Tcl_AppendResult(interp, "PPM image file \"", fileName, + "\" has bad maximum intensity value ", buffer, + (char *) NULL); + return TCL_ERROR; + } + + if ((srcX + width) > fileWidth) { + width = fileWidth - srcX; + } + if ((srcY + height) > fileHeight) { + height = fileHeight - srcY; + } + if ((width <= 0) || (height <= 0) + || (srcX >= fileWidth) || (srcY >= fileHeight)) { + return TCL_OK; + } + + if (type == PGM) { + block.pixelSize = 1; + block.offset[0] = 0; + block.offset[1] = 0; + block.offset[2] = 0; + } + else { + block.pixelSize = 3; + block.offset[0] = 0; + block.offset[1] = 1; + block.offset[2] = 2; + } + block.width = width; + block.pitch = block.pixelSize * fileWidth; + + Tk_PhotoExpand(imageHandle, destX + width, destY + height); + + if (srcY > 0) { + fseek(f, (long) (srcY * block.pitch), SEEK_CUR); + } + + nLines = (MAX_MEMORY + block.pitch - 1) / block.pitch; + if (nLines > height) { + nLines = height; + } + if (nLines <= 0) { + nLines = 1; + } + nBytes = nLines * block.pitch; + pixelPtr = (unsigned char *) ckalloc((unsigned) nBytes); + block.pixelPtr = pixelPtr + srcX * block.pixelSize; + + for (h = height; h > 0; h -= nLines) { + if (nLines > h) { + nLines = h; + nBytes = nLines * block.pitch; + } + count = fread(pixelPtr, 1, (unsigned) nBytes, f); + if (count != nBytes) { + Tcl_AppendResult(interp, "error reading PPM image file \"", + fileName, "\": ", + feof(f) ? "not enough data" : Tcl_PosixError(interp), + (char *) NULL); + ckfree((char *) pixelPtr); + return TCL_ERROR; + } + if (maxIntensity != 255) { + unsigned char *p; + + for (p = pixelPtr; count > 0; count--, p++) { + *p = (((int) *p) * 255)/maxIntensity; + } + } + block.height = nLines; + Tk_PhotoPutBlock(imageHandle, &block, destX, destY, width, nLines); + destY += nLines; + } + + ckfree((char *) pixelPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FileWritePPM -- + * + * This procedure is invoked to write image data to a file in PPM + * format. + * + * Results: + * A standard TCL completion code. If TCL_ERROR is returned + * then an error message is left in interp->result. + * + * Side effects: + * Data is written to the file given by "fileName". + * + *---------------------------------------------------------------------- + */ + +static int +FileWritePPM(interp, fileName, formatString, blockPtr) + Tcl_Interp *interp; + char *fileName; + char *formatString; + Tk_PhotoImageBlock *blockPtr; +{ + FILE *f; + int w, h; + int greenOffset, blueOffset, nBytes; + unsigned char *pixelPtr, *pixLinePtr; + + if ((f = fopen(fileName, "wb")) == NULL) { + Tcl_AppendResult(interp, fileName, ": ", Tcl_PosixError(interp), + (char *)NULL); + return TCL_ERROR; + } + + fprintf(f, "P6\n%d %d\n255\n", blockPtr->width, blockPtr->height); + + pixLinePtr = blockPtr->pixelPtr + blockPtr->offset[0]; + greenOffset = blockPtr->offset[1] - blockPtr->offset[0]; + blueOffset = blockPtr->offset[2] - blockPtr->offset[0]; + + if ((greenOffset == 1) && (blueOffset == 2) && (blockPtr->pixelSize == 3) + && (blockPtr->pitch == (blockPtr->width * 3))) { + nBytes = blockPtr->height * blockPtr->pitch; + if (fwrite(pixLinePtr, 1, (unsigned) nBytes, f) != nBytes) { + goto writeerror; + } + } else { + for (h = blockPtr->height; h > 0; h--) { + pixelPtr = pixLinePtr; + for (w = blockPtr->width; w > 0; w--) { + if ((putc(pixelPtr[0], f) == EOF) + || (putc(pixelPtr[greenOffset], f) == EOF) + || (putc(pixelPtr[blueOffset], f) == EOF)) { + goto writeerror; + } + pixelPtr += blockPtr->pixelSize; + } + pixLinePtr += blockPtr->pitch; + } + } + + if (fclose(f) == 0) { + return TCL_OK; + } + f = NULL; + + writeerror: + Tcl_AppendResult(interp, "error writing \"", fileName, "\": ", + Tcl_PosixError(interp), (char *) NULL); + if (f != NULL) { + fclose(f); + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * ReadPPMFileHeader -- + * + * This procedure reads the PPM header from the beginning of a + * PPM file and returns information from the header. + * + * Results: + * The return value is PGM if file "f" appears to start with + * a valid PGM header, PPM if "f" appears to start with a valid + * PPM header, and 0 otherwise. If the header is valid, + * then *widthPtr and *heightPtr are modified to hold the + * dimensions of the image and *maxIntensityPtr is modified to + * hold the value of a "fully on" intensity value. + * + * Side effects: + * The access position in f advances. + * + *---------------------------------------------------------------------- + */ + +static int +ReadPPMFileHeader(f, widthPtr, heightPtr, maxIntensityPtr) + FILE *f; /* Image file to read the header from */ + int *widthPtr, *heightPtr; /* The dimensions of the image are + * returned here. */ + int *maxIntensityPtr; /* The maximum intensity value for + * the image is stored here. */ +{ +#define BUFFER_SIZE 1000 + char buffer[BUFFER_SIZE]; + int i, numFields, firstInLine, c; + int type = 0; + + /* + * Read 4 space-separated fields from the file, ignoring + * comments (any line that starts with "#"). + */ + + c = getc(f); + firstInLine = 1; + i = 0; + for (numFields = 0; numFields < 4; numFields++) { + /* + * Skip comments and white space. + */ + + while (1) { + while (isspace(UCHAR(c))) { + firstInLine = (c == '\n'); + c = getc(f); + } + if (c != '#') { + break; + } + do { + c = getc(f); + } while ((c != EOF) && (c != '\n')); + firstInLine = 1; + } + + /* + * Read a field (everything up to the next white space). + */ + + while ((c != EOF) && !isspace(UCHAR(c))) { + if (i < (BUFFER_SIZE-2)) { + buffer[i] = c; + i++; + } + c = getc(f); + } + if (i < (BUFFER_SIZE-1)) { + buffer[i] = ' '; + i++; + } + firstInLine = 0; + } + buffer[i] = 0; + + /* + * Parse the fields, which are: id, width, height, maxIntensity. + */ + + if (strncmp(buffer, "P6 ", 3) == 0) { + type = PPM; + } else if (strncmp(buffer, "P5 ", 3) == 0) { + type = PGM; + } else { + return 0; + } + if (sscanf(buffer+3, "%d %d %d", widthPtr, heightPtr, maxIntensityPtr) + != 3) { + return 0; + } + return type; +} diff --git a/tk4.2/generic/tkImgPhoto.c b/tk4.2/generic/tkImgPhoto.c new file mode 100644 index 0000000..0e477d8 --- /dev/null +++ b/tk4.2/generic/tkImgPhoto.c @@ -0,0 +1,4123 @@ +/* + * tkImgPhoto.c -- + * + * Implements images of type "photo" for Tk. Photo images are + * stored in full color (24 bits per pixel) and displayed using + * dithering if necessary. + * + * Copyright (c) 1994 The Australian National University. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * Author: Paul Mackerras (paulus@cs.anu.edu.au), + * Department of Computer Science, + * Australian National University. + * + * SCCS: @(#) tkImgPhoto.c 1.45 96/10/04 13:04:29 + */ + +#include "tkInt.h" +#include "tkPort.h" +#include +#include + +/* + * Declaration for internal Xlib function used here: + */ + +extern _XInitImageFuncPtrs _ANSI_ARGS_((XImage *image)); + +/* + * A signed 8-bit integral type. If chars are unsigned and the compiler + * isn't an ANSI one, then we have to use short instead (which wastes + * space) to get signed behavior. + */ + +#if defined(__STDC__) || defined(_AIX) + typedef signed char schar; +#else +# ifndef __CHAR_UNSIGNED__ + typedef char schar; +# else + typedef short schar; +# endif +#endif + +/* + * An unsigned 32-bit integral type, used for pixel values. + * We use int rather than long here to accommodate those systems + * where longs are 64 bits. + */ + +typedef unsigned int pixel; + +/* + * The maximum number of pixels to transmit to the server in a + * single XPutImage call. + */ + +#define MAX_PIXELS 65536 + +/* + * The set of colors required to display a photo image in a window depends on: + * - the visual used by the window + * - the palette, which specifies how many levels of each primary + * color to use, and + * - the gamma value for the image. + * + * Pixel values allocated for specific colors are valid only for the + * colormap in which they were allocated. Sets of pixel values + * allocated for displaying photos are re-used in other windows if + * possible, that is, if the display, colormap, palette and gamma + * values match. A hash table is used to locate these sets of pixel + * values, using the following data structure as key: + */ + +typedef struct { + Display *display; /* Qualifies the colormap resource ID */ + Colormap colormap; /* Colormap that the windows are using. */ + double gamma; /* Gamma exponent value for images. */ + Tk_Uid palette; /* Specifies how many shades of each primary + * we want to allocate. */ +} ColorTableId; + +/* + * For a particular (display, colormap, palette, gamma) combination, + * a data structure of the following type is used to store the allocated + * pixel values and other information: + */ + +typedef struct ColorTable { + ColorTableId id; /* Information used in selecting this + * color table. */ + int flags; /* See below. */ + int refCount; /* Number of instances using this map. */ + int liveRefCount; /* Number of instances which are actually + * in use, using this map. */ + int numColors; /* Number of colors allocated for this map. */ + + XVisualInfo visualInfo; /* Information about the visual for windows + * using this color table. */ + + pixel redValues[256]; /* Maps 8-bit values of red intensity + * to a pixel value or index in pixelMap. */ + pixel greenValues[256]; /* Ditto for green intensity */ + pixel blueValues[256]; /* Ditto for blue intensity */ + unsigned long *pixelMap; /* Actual pixel values allocated. */ + + unsigned char colorQuant[3][256]; + /* Maps 8-bit intensities to quantized + * intensities. The first index is 0 for + * red, 1 for green, 2 for blue. */ +} ColorTable; + +/* + * Bit definitions for the flags field of a ColorTable. + * BLACK_AND_WHITE: 1 means only black and white colors are + * available. + * COLOR_WINDOW: 1 means a full 3-D color cube has been + * allocated. + * DISPOSE_PENDING: 1 means a call to DisposeColorTable has + * been scheduled as an idle handler, but it + * hasn't been invoked yet. + * MAP_COLORS: 1 means pixel values should be mapped + * through pixelMap. + */ + +#define BLACK_AND_WHITE 1 +#define COLOR_WINDOW 2 +#define DISPOSE_PENDING 4 +#define MAP_COLORS 8 + +/* + * Definition of the data associated with each photo image master. + */ + +typedef struct PhotoMaster { + Tk_ImageMaster tkMaster; /* Tk's token for image master. NULL means + * the image is being deleted. */ + Tcl_Interp *interp; /* Interpreter associated with the + * application using this image. */ + Tcl_Command imageCmd; /* Token for image command (used to delete + * it when the image goes away). NULL means + * the image command has already been + * deleted. */ + int flags; /* Sundry flags, defined below. */ + int width, height; /* Dimensions of image. */ + int userWidth, userHeight; /* User-declared image dimensions. */ + Tk_Uid palette; /* User-specified default palette for + * instances of this image. */ + double gamma; /* Display gamma value to correct for. */ + char *fileString; /* Name of file to read into image. */ + char *dataString; /* String value to use as contents of image. */ + char *format; /* User-specified format of data in image + * file or string value. */ + unsigned char *pix24; /* Local storage for 24-bit image. */ + int ditherX, ditherY; /* Location of first incorrectly + * dithered pixel in image. */ + TkRegion validRegion; /* Tk region indicating which parts of + * the image have valid image data. */ + struct PhotoInstance *instancePtr; + /* First in the list of instances + * associated with this master. */ +} PhotoMaster; + +/* + * Bit definitions for the flags field of a PhotoMaster. + * COLOR_IMAGE: 1 means that the image has different color + * components. + * IMAGE_CHANGED: 1 means that the instances of this image + * need to be redithered. + */ + +#define COLOR_IMAGE 1 +#define IMAGE_CHANGED 2 + +/* + * The following data structure represents all of the instances of + * a photo image in windows on a given screen that are using the + * same colormap. + */ + +typedef struct PhotoInstance { + PhotoMaster *masterPtr; /* Pointer to master for image. */ + Display *display; /* Display for windows using this instance. */ + Colormap colormap; /* The image may only be used in windows with + * this particular colormap. */ + struct PhotoInstance *nextPtr; + /* Pointer to the next instance in the list + * of instances associated with this master. */ + int refCount; /* Number of instances using this structure. */ + Tk_Uid palette; /* Palette for these particular instances. */ + double gamma; /* Gamma value for these instances. */ + Tk_Uid defaultPalette; /* Default palette to use if a palette + * is not specified for the master. */ + ColorTable *colorTablePtr; /* Pointer to information about colors + * allocated for image display in windows + * like this one. */ + Pixmap pixels; /* X pixmap containing dithered image. */ + int width, height; /* Dimensions of the pixmap. */ + schar *error; /* Error image, used in dithering. */ + XImage *imagePtr; /* Image structure for converted pixels. */ + XVisualInfo visualInfo; /* Information about the visual that these + * windows are using. */ + GC gc; /* Graphics context for writing images + * to the pixmap. */ +} PhotoInstance; + +/* + * The following data structure is used to return information + * from ParseSubcommandOptions: + */ + +struct SubcommandOptions { + int options; /* Individual bits indicate which + * options were specified - see below. */ + char *name; /* Name specified without an option. */ + int fromX, fromY; /* Values specified for -from option. */ + int fromX2, fromY2; /* Second coordinate pair for -from option. */ + int toX, toY; /* Values specified for -to option. */ + int toX2, toY2; /* Second coordinate pair for -to option. */ + int zoomX, zoomY; /* Values specified for -zoom option. */ + int subsampleX, subsampleY; /* Values specified for -subsample option. */ + char *format; /* Value specified for -format option. */ +}; + +/* + * Bit definitions for use with ParseSubcommandOptions: + * Each bit is set in the allowedOptions parameter on a call to + * ParseSubcommandOptions if that option is allowed for the current + * photo image subcommand. On return, the bit is set in the options + * field of the SubcommandOptions structure if that option was specified. + * + * OPT_FORMAT: Set if -format option allowed/specified. + * OPT_FROM: Set if -from option allowed/specified. + * OPT_SHRINK: Set if -shrink option allowed/specified. + * OPT_SUBSAMPLE: Set if -subsample option allowed/spec'd. + * OPT_TO: Set if -to option allowed/specified. + * OPT_ZOOM: Set if -zoom option allowed/specified. + */ + +#define OPT_FORMAT 1 +#define OPT_FROM 2 +#define OPT_SHRINK 4 +#define OPT_SUBSAMPLE 8 +#define OPT_TO 0x10 +#define OPT_ZOOM 0x20 + +/* + * List of option names. The order here must match the order of + * declarations of the OPT_* constants above. + */ + +static char *optionNames[] = { + "-format", + "-from", + "-shrink", + "-subsample", + "-to", + "-zoom", + (char *) NULL +}; + +/* + * The type record for photo images: + */ + +static int ImgPhotoCreate _ANSI_ARGS_((Tcl_Interp *interp, + char *name, int argc, char **argv, + Tk_ImageType *typePtr, Tk_ImageMaster master, + ClientData *clientDataPtr)); +static ClientData ImgPhotoGet _ANSI_ARGS_((Tk_Window tkwin, + ClientData clientData)); +static void ImgPhotoDisplay _ANSI_ARGS_((ClientData clientData, + Display *display, Drawable drawable, + int imageX, int imageY, int width, int height, + int drawableX, int drawableY)); +static void ImgPhotoFree _ANSI_ARGS_((ClientData clientData, + Display *display)); +static void ImgPhotoDelete _ANSI_ARGS_((ClientData clientData)); + +Tk_ImageType tkPhotoImageType = { + "photo", /* name */ + ImgPhotoCreate, /* createProc */ + ImgPhotoGet, /* getProc */ + ImgPhotoDisplay, /* displayProc */ + ImgPhotoFree, /* freeProc */ + ImgPhotoDelete, /* deleteProc */ + (Tk_ImageType *) NULL /* nextPtr */ +}; + +/* + * Default configuration + */ + +#define DEF_PHOTO_GAMMA "1" +#define DEF_PHOTO_HEIGHT "0" +#define DEF_PHOTO_PALETTE "" +#define DEF_PHOTO_WIDTH "0" + +/* + * Information used for parsing configuration specifications: + */ +static Tk_ConfigSpec configSpecs[] = { + {TK_CONFIG_STRING, "-data", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(PhotoMaster, dataString), TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-format", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(PhotoMaster, format), TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-file", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(PhotoMaster, fileString), TK_CONFIG_NULL_OK}, + {TK_CONFIG_DOUBLE, "-gamma", (char *) NULL, (char *) NULL, + DEF_PHOTO_GAMMA, Tk_Offset(PhotoMaster, gamma), 0}, + {TK_CONFIG_INT, "-height", (char *) NULL, (char *) NULL, + DEF_PHOTO_HEIGHT, Tk_Offset(PhotoMaster, userHeight), 0}, + {TK_CONFIG_UID, "-palette", (char *) NULL, (char *) NULL, + DEF_PHOTO_PALETTE, Tk_Offset(PhotoMaster, palette), 0}, + {TK_CONFIG_INT, "-width", (char *) NULL, (char *) NULL, + DEF_PHOTO_WIDTH, Tk_Offset(PhotoMaster, userWidth), 0}, + {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, 0} +}; + +/* + * Hash table used to provide access to photo images from C code. + */ + +static Tcl_HashTable imgPhotoHash; +static int imgPhotoHashInitialized; /* set when Tcl_InitHashTable done */ + +/* + * Hash table used to hash from (display, colormap, palette, gamma) + * to ColorTable address. + */ + +static Tcl_HashTable imgPhotoColorHash; +static int imgPhotoColorHashInitialized; +#define N_COLOR_HASH (sizeof(ColorTableId) / sizeof(int)) + +/* + * Pointer to the first in the list of known photo image formats. + */ + +static Tk_PhotoImageFormat *formatList = NULL; + +/* + * Forward declarations + */ + +static int ImgPhotoCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static int ParseSubcommandOptions _ANSI_ARGS_(( + struct SubcommandOptions *optPtr, + Tcl_Interp *interp, int allowedOptions, + int *indexPtr, int argc, char **argv)); +static void ImgPhotoCmdDeletedProc _ANSI_ARGS_(( + ClientData clientData)); +static int ImgPhotoConfigureMaster _ANSI_ARGS_(( + Tcl_Interp *interp, PhotoMaster *masterPtr, + int argc, char **argv, int flags)); +static void ImgPhotoConfigureInstance _ANSI_ARGS_(( + PhotoInstance *instancePtr)); +static void ImgPhotoSetSize _ANSI_ARGS_((PhotoMaster *masterPtr, + int width, int height)); +static void ImgPhotoInstanceSetSize _ANSI_ARGS_(( + PhotoInstance *instancePtr)); +static int IsValidPalette _ANSI_ARGS_((PhotoInstance *instancePtr, + char *palette)); +static int CountBits _ANSI_ARGS_((pixel mask)); +static void GetColorTable _ANSI_ARGS_((PhotoInstance *instancePtr)); +static void FreeColorTable _ANSI_ARGS_((ColorTable *colorPtr)); +static void AllocateColors _ANSI_ARGS_((ColorTable *colorPtr)); +static void DisposeColorTable _ANSI_ARGS_((ClientData clientData)); +static void DisposeInstance _ANSI_ARGS_((ClientData clientData)); +static int ReclaimColors _ANSI_ARGS_((ColorTableId *id, + int numColors)); +static int MatchFileFormat _ANSI_ARGS_((Tcl_Interp *interp, + FILE *f, char *fileName, char *formatString, + Tk_PhotoImageFormat **imageFormatPtr, + int *widthPtr, int *heightPtr)); +static int MatchStringFormat _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char *formatString, + Tk_PhotoImageFormat **imageFormatPtr, + int *widthPtr, int *heightPtr)); +static void Dither _ANSI_ARGS_((PhotoMaster *masterPtr, + int x, int y, int width, int height)); +static void DitherInstance _ANSI_ARGS_((PhotoInstance *instancePtr, + int x, int y, int width, int height)); + +#undef MIN +#define MIN(a, b) ((a) < (b)? (a): (b)) +#undef MAX +#define MAX(a, b) ((a) > (b)? (a): (b)) + +/* + *---------------------------------------------------------------------- + * + * Tk_CreatePhotoImageFormat -- + * + * This procedure is invoked by an image file handler to register + * a new photo image format and the procedures that handle the + * new format. The procedure is typically invoked during + * Tcl_AppInit. + * + * Results: + * None. + * + * Side effects: + * The new image file format is entered into a table used in the + * photo image "read" and "write" subcommands. + * + *---------------------------------------------------------------------- + */ + +void +Tk_CreatePhotoImageFormat(formatPtr) + Tk_PhotoImageFormat *formatPtr; + /* Structure describing the format. All of + * the fields except "nextPtr" must be filled + * in by caller. Must not have been passed + * to Tk_CreatePhotoImageFormat previously. */ +{ + Tk_PhotoImageFormat *copyPtr; + + copyPtr = (Tk_PhotoImageFormat *) ckalloc(sizeof(Tk_PhotoImageFormat)); + *copyPtr = *formatPtr; + copyPtr->name = (char *) ckalloc((unsigned) (strlen(formatPtr->name) + 1)); + strcpy(copyPtr->name, formatPtr->name); + copyPtr->nextPtr = formatList; + formatList = copyPtr; +} + +/* + *---------------------------------------------------------------------- + * + * ImgPhotoCreate -- + * + * This procedure is called by the Tk image code to create + * a new photo image. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * The data structure for a new photo image is allocated and + * initialized. + * + *---------------------------------------------------------------------- + */ + +static int +ImgPhotoCreate(interp, name, argc, argv, typePtr, master, clientDataPtr) + Tcl_Interp *interp; /* Interpreter for application containing + * image. */ + char *name; /* Name to use for image. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings for options (doesn't + * include image name or type). */ + Tk_ImageType *typePtr; /* Pointer to our type record (not used). */ + Tk_ImageMaster master; /* Token for image, to be used by us in + * later callbacks. */ + ClientData *clientDataPtr; /* Store manager's token for image here; + * it will be returned in later callbacks. */ +{ + PhotoMaster *masterPtr; + Tcl_HashEntry *entry; + int isNew; + + /* + * Allocate and initialize the photo image master record. + */ + + masterPtr = (PhotoMaster *) ckalloc(sizeof(PhotoMaster)); + memset((void *) masterPtr, 0, sizeof(PhotoMaster)); + masterPtr->tkMaster = master; + masterPtr->interp = interp; + masterPtr->imageCmd = Tcl_CreateCommand(interp, name, ImgPhotoCmd, + (ClientData) masterPtr, ImgPhotoCmdDeletedProc); + masterPtr->palette = NULL; + masterPtr->pix24 = NULL; + masterPtr->instancePtr = NULL; + masterPtr->validRegion = TkCreateRegion(); + + /* + * Process configuration options given in the image create command. + */ + + if (ImgPhotoConfigureMaster(interp, masterPtr, argc, argv, 0) != TCL_OK) { + ImgPhotoDelete((ClientData) masterPtr); + return TCL_ERROR; + } + + /* + * Enter this photo image in the hash table. + */ + + if (!imgPhotoHashInitialized) { + Tcl_InitHashTable(&imgPhotoHash, TCL_STRING_KEYS); + imgPhotoHashInitialized = 1; + } + entry = Tcl_CreateHashEntry(&imgPhotoHash, name, &isNew); + Tcl_SetHashValue(entry, masterPtr); + + *clientDataPtr = (ClientData) masterPtr; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ImgPhotoCmd -- + * + * This procedure is invoked to process the Tcl command that + * corresponds to a photo image. See the user documentation + * for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +ImgPhotoCmd(clientData, interp, argc, argv) + ClientData clientData; /* Information about photo master. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + PhotoMaster *masterPtr = (PhotoMaster *) clientData; + int c, result, index; + int x, y, width, height; + int dataWidth, dataHeight; + struct SubcommandOptions options; + int listArgc; + char **listArgv; + char **srcArgv; + unsigned char *pixelPtr; + Tk_PhotoImageBlock block; + Tk_Window tkwin; + char string[16]; + XColor color; + Tk_PhotoImageFormat *imageFormat; + int imageWidth, imageHeight; + int matched; + FILE *f; + Tk_PhotoHandle srcHandle; + size_t length; + Tcl_DString buffer; + char *realFileName; + + 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 == 'b') && (strncmp(argv[1], "blank", length) == 0)) { + /* + * photo blank command - just call Tk_PhotoBlank. + */ + + if (argc == 2) { + Tk_PhotoBlank(masterPtr); + } else { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " blank\"", (char *) NULL); + return TCL_ERROR; + } + } else if ((c == 'c') && (length >= 2) + && (strncmp(argv[1], "cget", length) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " cget option\"", + (char *) NULL); + return TCL_ERROR; + } + result = Tk_ConfigureValue(interp, Tk_MainWindow(interp), configSpecs, + (char *) masterPtr, argv[2], 0); + } else if ((c == 'c') && (length >= 3) + && (strncmp(argv[1], "configure", length) == 0)) { + /* + * photo configure command - handle this in the standard way. + */ + + if (argc == 2) { + return Tk_ConfigureInfo(interp, Tk_MainWindow(interp), + configSpecs, (char *) masterPtr, (char *) NULL, 0); + } + if (argc == 3) { + return Tk_ConfigureInfo(interp, Tk_MainWindow(interp), + configSpecs, (char *) masterPtr, argv[2], 0); + } + return ImgPhotoConfigureMaster(interp, masterPtr, argc-2, argv+2, + TK_CONFIG_ARGV_ONLY); + } else if ((c == 'c') && (length >= 3) + && (strncmp(argv[1], "copy", length) == 0)) { + /* + * photo copy command - first parse options. + */ + + index = 2; + memset((VOID *) &options, 0, sizeof(options)); + options.zoomX = options.zoomY = 1; + options.subsampleX = options.subsampleY = 1; + options.name = NULL; + if (ParseSubcommandOptions(&options, interp, + OPT_FROM | OPT_TO | OPT_ZOOM | OPT_SUBSAMPLE | OPT_SHRINK, + &index, argc, argv) != TCL_OK) { + return TCL_ERROR; + } + if (options.name == NULL || index < argc) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " copy source-image ?-from x1 y1 x2 y2?", + " ?-to x1 y1 x2 y2? ?-zoom x y? ?-subsample x y?", + "\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * Look for the source image and get a pointer to its image data. + * Check the values given for the -from option. + */ + + if ((srcHandle = Tk_FindPhoto(options.name)) == NULL) { + Tcl_AppendResult(interp, "image \"", argv[2], "\" doesn't", + " exist or is not a photo image", (char *) NULL); + return TCL_ERROR; + } + Tk_PhotoGetImage(srcHandle, &block); + if ((options.fromX2 > block.width) || (options.fromY2 > block.height) + || (options.fromX2 > block.width) + || (options.fromY2 > block.height)) { + Tcl_AppendResult(interp, "coordinates for -from option extend ", + "outside source image", (char *) NULL); + return TCL_ERROR; + } + + /* + * Fill in default values for unspecified parameters. + */ + + if (((options.options & OPT_FROM) == 0) || (options.fromX2 < 0)) { + options.fromX2 = block.width; + options.fromY2 = block.height; + } + if (((options.options & OPT_TO) == 0) || (options.toX2 < 0)) { + width = options.fromX2 - options.fromX; + if (options.subsampleX > 0) { + width = (width + options.subsampleX - 1) / options.subsampleX; + } else if (options.subsampleX == 0) { + width = 0; + } else { + width = (width - options.subsampleX - 1) / -options.subsampleX; + } + options.toX2 = options.toX + width * options.zoomX; + + height = options.fromY2 - options.fromY; + if (options.subsampleY > 0) { + height = (height + options.subsampleY - 1) + / options.subsampleY; + } else if (options.subsampleY == 0) { + height = 0; + } else { + height = (height - options.subsampleY - 1) + / -options.subsampleY; + } + options.toY2 = options.toY + height * options.zoomY; + } + + /* + * Set the destination image size if the -shrink option was specified. + */ + + if (options.options & OPT_SHRINK) { + ImgPhotoSetSize(masterPtr, options.toX2, options.toY2); + } + + /* + * Copy the image data over using Tk_PhotoPutZoomedBlock. + */ + + block.pixelPtr += options.fromX * block.pixelSize + + options.fromY * block.pitch; + block.width = options.fromX2 - options.fromX; + block.height = options.fromY2 - options.fromY; + Tk_PhotoPutZoomedBlock((Tk_PhotoHandle) masterPtr, &block, + options.toX, options.toY, options.toX2 - options.toX, + options.toY2 - options.toY, options.zoomX, options.zoomY, + options.subsampleX, options.subsampleY); + + } else if ((c == 'g') && (strncmp(argv[1], "get", length) == 0)) { + /* + * photo get command - first parse and check parameters. + */ + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " get x y\"", (char *) NULL); + return TCL_ERROR; + } + if ((Tcl_GetInt(interp, argv[2], &x) != TCL_OK) + || (Tcl_GetInt(interp, argv[3], &y) != TCL_OK)) { + return TCL_ERROR; + } + if ((x < 0) || (x >= masterPtr->width) + || (y < 0) || (y >= masterPtr->height)) { + Tcl_AppendResult(interp, argv[0], " get: ", + "coordinates out of range", (char *) NULL); + return TCL_ERROR; + } + + /* + * Extract the value of the desired pixel and format it as a string. + */ + + pixelPtr = masterPtr->pix24 + (y * masterPtr->width + x) * 3; + sprintf(string, "%d %d %d", pixelPtr[0], pixelPtr[1], + pixelPtr[2]); + Tcl_AppendResult(interp, string, (char *) NULL); + } else if ((c == 'p') && (strncmp(argv[1], "put", length) == 0)) { + /* + * photo put command - first parse the options and colors specified. + */ + + index = 2; + memset((VOID *) &options, 0, sizeof(options)); + options.name = NULL; + if (ParseSubcommandOptions(&options, interp, OPT_TO, + &index, argc, argv) != TCL_OK) { + return TCL_ERROR; + } + if ((options.name == NULL) || (index < argc)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " put {{colors...}...} ?-to x1 y1 x2 y2?\"", + (char *) NULL); + return TCL_ERROR; + } + if (Tcl_SplitList(interp, options.name, &dataHeight, &srcArgv) + != TCL_OK) { + return TCL_ERROR; + } + tkwin = Tk_MainWindow(interp); + block.pixelPtr = NULL; + dataWidth = 0; + pixelPtr = NULL; + for (y = 0; y < dataHeight; ++y) { + if (Tcl_SplitList(interp, srcArgv[y], &listArgc, &listArgv) + != TCL_OK) { + break; + } + if (y == 0) { + dataWidth = listArgc; + pixelPtr = (unsigned char *) ckalloc((unsigned) + dataWidth * dataHeight * 3); + block.pixelPtr = pixelPtr; + } else { + if (listArgc != dataWidth) { + Tcl_AppendResult(interp, "all elements of color list must", + " have the same number of elements", + (char *) NULL); + ckfree((char *) listArgv); + break; + } + } + for (x = 0; x < dataWidth; ++x) { + if (!XParseColor(Tk_Display(tkwin), Tk_Colormap(tkwin), + listArgv[x], &color)) { + Tcl_AppendResult(interp, "can't parse color \"", + listArgv[x], "\"", (char *) NULL); + break; + } + *pixelPtr++ = color.red >> 8; + *pixelPtr++ = color.green >> 8; + *pixelPtr++ = color.blue >> 8; + } + ckfree((char *) listArgv); + if (x < dataWidth) + break; + } + ckfree((char *) srcArgv); + if (y < dataHeight || dataHeight == 0 || dataWidth == 0) { + if (block.pixelPtr != NULL) { + ckfree((char *) block.pixelPtr); + } + if (y < dataHeight) { + return TCL_ERROR; + } + return TCL_OK; + } + + /* + * Fill in default values for the -to option, then + * copy the block in using Tk_PhotoPutBlock. + */ + + if (((options.options & OPT_TO) == 0) || (options.toX2 < 0)) { + options.toX2 = options.toX + dataWidth; + options.toY2 = options.toY + dataHeight; + } + block.width = dataWidth; + block.height = dataHeight; + block.pitch = dataWidth * 3; + block.pixelSize = 3; + block.offset[0] = 0; + block.offset[1] = 1; + block.offset[2] = 2; + Tk_PhotoPutBlock((ClientData)masterPtr, &block, + options.toX, options.toY, options.toX2 - options.toX, + options.toY2 - options.toY); + ckfree((char *) block.pixelPtr); + } else if ((c == 'r') && (length >= 3) + && (strncmp(argv[1], "read", length) == 0)) { + /* + * photo read command - first parse the options specified. + */ + + index = 2; + memset((VOID *) &options, 0, sizeof(options)); + options.name = NULL; + options.format = NULL; + if (ParseSubcommandOptions(&options, interp, + OPT_FORMAT | OPT_FROM | OPT_TO | OPT_SHRINK, + &index, argc, argv) != TCL_OK) { + return TCL_ERROR; + } + if ((options.name == NULL) || (index < argc)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " read fileName ?-format format-name?", + " ?-from x1 y1 x2 y2? ?-to x y? ?-shrink?\"", + (char *) NULL); + return TCL_ERROR; + } + + /* + * Open the image file and look for a handler for it. + */ + + realFileName = Tcl_TranslateFileName(interp, options.name, &buffer); + if (realFileName == NULL) { + return TCL_ERROR; + } + f = fopen(realFileName, "rb"); + Tcl_DStringFree(&buffer); + if (f == NULL) { + Tcl_AppendResult(interp, "couldn't read image file \"", + options.name, "\": ", Tcl_PosixError(interp), + (char *) NULL); + return TCL_ERROR; + } + if (MatchFileFormat(interp, f, options.name, options.format, + &imageFormat, &imageWidth, &imageHeight) != TCL_OK) { + fclose(f); + return TCL_ERROR; + } + + /* + * Check the values given for the -from option. + */ + + if ((options.fromX > imageWidth) || (options.fromY > imageHeight) + || (options.fromX2 > imageWidth) + || (options.fromY2 > imageHeight)) { + Tcl_AppendResult(interp, "coordinates for -from option extend ", + "outside source image", (char *) NULL); + fclose(f); + return TCL_ERROR; + } + if (((options.options & OPT_FROM) == 0) || (options.fromX2 < 0)) { + width = imageWidth - options.fromX; + height = imageHeight - options.fromY; + } else { + width = options.fromX2 - options.fromX; + height = options.fromY2 - options.fromY; + } + + /* + * If the -shrink option was specified, set the size of the image. + */ + + if (options.options & OPT_SHRINK) { + ImgPhotoSetSize(masterPtr, options.toX + width, + options.toY + height); + } + + /* + * Call the handler's file read procedure to read the data + * into the image. + */ + + result = (*imageFormat->fileReadProc)(interp, f, options.name, + options.format, (Tk_PhotoHandle) masterPtr, options.toX, + options.toY, width, height, options.fromX, options.fromY); + if (f != NULL) { + fclose(f); + } + return result; + } else if ((c == 'r') && (length >= 3) + && (strncmp(argv[1], "redither", length) == 0)) { + + if (argc == 2) { + /* + * Call Dither if any part of the image is not correctly + * dithered at present. + */ + + x = masterPtr->ditherX; + y = masterPtr->ditherY; + if (masterPtr->ditherX != 0) { + Dither(masterPtr, x, y, masterPtr->width - x, 1); + } + if (masterPtr->ditherY < masterPtr->height) { + x = 0; + Dither(masterPtr, 0, masterPtr->ditherY, masterPtr->width, + masterPtr->height - masterPtr->ditherY); + } + + if (y < masterPtr->height) { + /* + * Tell the core image code that part of the image has changed. + */ + + Tk_ImageChanged(masterPtr->tkMaster, x, y, + (masterPtr->width - x), (masterPtr->height - y), + masterPtr->width, masterPtr->height); + } + + } else { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " redither\"", (char *) NULL); + return TCL_ERROR; + } + } else if ((c == 'w') && (strncmp(argv[1], "write", length) == 0)) { + /* + * photo write command - first parse and check any options given. + */ + + index = 2; + memset((VOID *) &options, 0, sizeof(options)); + options.name = NULL; + options.format = NULL; + if (ParseSubcommandOptions(&options, interp, OPT_FORMAT | OPT_FROM, + &index, argc, argv) != TCL_OK) { + return TCL_ERROR; + } + if ((options.name == NULL) || (index < argc)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " write fileName ?-format format-name?", + "?-from x1 y1 x2 y2?\"", (char *) NULL); + return TCL_ERROR; + } + if ((options.fromX > masterPtr->width) + || (options.fromY > masterPtr->height) + || (options.fromX2 > masterPtr->width) + || (options.fromY2 > masterPtr->height)) { + Tcl_AppendResult(interp, "coordinates for -from option extend ", + "outside image", (char *) NULL); + return TCL_ERROR; + } + + /* + * Fill in default values for unspecified parameters. + */ + + if (((options.options & OPT_FROM) == 0) || (options.fromX2 < 0)) { + options.fromX2 = masterPtr->width; + options.fromY2 = masterPtr->height; + } + + /* + * Search for an appropriate image file format handler, + * and give an error if none is found. + */ + + matched = 0; + for (imageFormat = formatList; imageFormat != NULL; + imageFormat = imageFormat->nextPtr) { + if ((options.format == NULL) + || (strncasecmp(options.format, imageFormat->name, + strlen(imageFormat->name)) == 0)) { + matched = 1; + if (imageFormat->fileWriteProc != NULL) { + break; + } + } + } + if (imageFormat == NULL) { + if (options.format == NULL) { + Tcl_AppendResult(interp, "no available image file format ", + "has file writing capability", (char *) NULL); + } else if (!matched) { + Tcl_AppendResult(interp, "image file format \"", + options.format, "\" is unknown", (char *) NULL); + } else { + Tcl_AppendResult(interp, "image file format \"", + options.format, "\" has no file writing capability", + (char *) NULL); + } + return TCL_ERROR; + } + + /* + * Call the handler's file write procedure to write out + * the image. + */ + + Tk_PhotoGetImage((Tk_PhotoHandle) masterPtr, &block); + block.pixelPtr += options.fromY * block.pitch + options.fromX * 3; + block.width = options.fromX2 - options.fromX; + block.height = options.fromY2 - options.fromY; + return (*imageFormat->fileWriteProc)(interp, options.name, + options.format, &block); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be blank, cget, configure, copy, get, put,", + " read, redither, or write", (char *) NULL); + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ParseSubcommandOptions -- + * + * This procedure is invoked to process one of the options + * which may be specified for the photo image subcommands, + * namely, -from, -to, -zoom, -subsample, -format, and -shrink. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Fields in *optPtr get filled in. + * + *---------------------------------------------------------------------- + */ + +static int +ParseSubcommandOptions(optPtr, interp, allowedOptions, optIndexPtr, argc, argv) + struct SubcommandOptions *optPtr; + /* Information about the options specified + * and the values given is returned here. */ + Tcl_Interp *interp; /* Interpreter to use for reporting errors. */ + int allowedOptions; /* Indicates which options are valid for + * the current command. */ + int *optIndexPtr; /* Points to a variable containing the + * current index in argv; this variable is + * updated by this procedure. */ + int argc; /* Number of arguments in argv[]. */ + char **argv; /* Arguments to be parsed. */ +{ + int index, c, bit, currentBit; + size_t length; + char *option, **listPtr; + int values[4]; + int numValues, maxValues, argIndex; + + for (index = *optIndexPtr; index < argc; *optIndexPtr = ++index) { + /* + * We can have one value specified without an option; + * it goes into optPtr->name. + */ + + option = argv[index]; + if (option[0] != '-') { + if (optPtr->name == NULL) { + optPtr->name = option; + continue; + } + break; + } + + /* + * Work out which option this is. + */ + + length = strlen(option); + c = option[0]; + bit = 0; + currentBit = 1; + for (listPtr = optionNames; *listPtr != NULL; ++listPtr) { + if ((c == *listPtr[0]) + && (strncmp(option, *listPtr, length) == 0)) { + if (bit != 0) { + bit = 0; /* An ambiguous option. */ + break; + } + bit = currentBit; + } + currentBit <<= 1; + } + + /* + * If this option is not recognized and allowed, put + * an error message in the interpreter and return. + */ + + if ((allowedOptions & bit) == 0) { + Tcl_AppendResult(interp, "unrecognized option \"", argv[index], + "\": must be ", (char *)NULL); + bit = 1; + for (listPtr = optionNames; *listPtr != NULL; ++listPtr) { + if ((allowedOptions & bit) != 0) { + if ((allowedOptions & (bit - 1)) != 0) { + Tcl_AppendResult(interp, ", ", (char *) NULL); + if ((allowedOptions & ~((bit << 1) - 1)) == 0) { + Tcl_AppendResult(interp, "or ", (char *) NULL); + } + } + Tcl_AppendResult(interp, *listPtr, (char *) NULL); + } + bit <<= 1; + } + return TCL_ERROR; + } + + /* + * For the -from, -to, -zoom and -subsample options, + * parse the values given. Report an error if too few + * or too many values are given. + */ + + if ((bit != OPT_SHRINK) && (bit != OPT_FORMAT)) { + maxValues = ((bit == OPT_FROM) || (bit == OPT_TO))? 4: 2; + argIndex = index + 1; + for (numValues = 0; numValues < maxValues; ++numValues) { + if ((argIndex < argc) && (isdigit(UCHAR(argv[argIndex][0])) + || ((argv[argIndex][0] == '-') + && (isdigit(UCHAR(argv[argIndex][1])))))) { + if (Tcl_GetInt(interp, argv[argIndex], &values[numValues]) + != TCL_OK) { + return TCL_ERROR; + } + } else { + break; + } + ++argIndex; + } + + if (numValues == 0) { + Tcl_AppendResult(interp, "the \"", argv[index], "\" option ", + "requires one ", maxValues == 2? "or two": "to four", + " integer values", (char *) NULL); + return TCL_ERROR; + } + *optIndexPtr = (index += numValues); + + /* + * Y values default to the corresponding X value if not specified. + */ + + if (numValues == 1) { + values[1] = values[0]; + } + if (numValues == 3) { + values[3] = values[2]; + } + + /* + * Check the values given and put them in the appropriate + * field of the SubcommandOptions structure. + */ + + switch (bit) { + case OPT_FROM: + if ((values[0] < 0) || (values[1] < 0) || ((numValues > 2) + && ((values[2] < 0) || (values[3] < 0)))) { + Tcl_AppendResult(interp, "value(s) for the -from", + " option must be non-negative", (char *) NULL); + return TCL_ERROR; + } + if (numValues <= 2) { + optPtr->fromX = values[0]; + optPtr->fromY = values[1]; + optPtr->fromX2 = -1; + optPtr->fromY2 = -1; + } else { + optPtr->fromX = MIN(values[0], values[2]); + optPtr->fromY = MIN(values[1], values[3]); + optPtr->fromX2 = MAX(values[0], values[2]); + optPtr->fromY2 = MAX(values[1], values[3]); + } + break; + case OPT_SUBSAMPLE: + optPtr->subsampleX = values[0]; + optPtr->subsampleY = values[1]; + break; + case OPT_TO: + if ((values[0] < 0) || (values[1] < 0) || ((numValues > 2) + && ((values[2] < 0) || (values[3] < 0)))) { + Tcl_AppendResult(interp, "value(s) for the -to", + " option must be non-negative", (char *) NULL); + return TCL_ERROR; + } + if (numValues <= 2) { + optPtr->toX = values[0]; + optPtr->toY = values[1]; + optPtr->toX2 = -1; + optPtr->toY2 = -1; + } else { + optPtr->toX = MIN(values[0], values[2]); + optPtr->toY = MIN(values[1], values[3]); + optPtr->toX2 = MAX(values[0], values[2]); + optPtr->toY2 = MAX(values[1], values[3]); + } + break; + case OPT_ZOOM: + if ((values[0] <= 0) || (values[1] <= 0)) { + Tcl_AppendResult(interp, "value(s) for the -zoom", + " option must be positive", (char *) NULL); + return TCL_ERROR; + } + optPtr->zoomX = values[0]; + optPtr->zoomY = values[1]; + break; + } + } else if (bit == OPT_FORMAT) { + /* + * The -format option takes a single string value. + */ + + if (index + 1 < argc) { + *optIndexPtr = ++index; + optPtr->format = argv[index]; + } else { + Tcl_AppendResult(interp, "the \"-format\" option ", + "requires a value", (char *) NULL); + return TCL_ERROR; + } + } + + /* + * Remember that we saw this option. + */ + + optPtr->options |= bit; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ImgPhotoConfigureMaster -- + * + * This procedure is called when a photo image is created or + * reconfigured. It processes configuration options and resets + * any instances of the image. + * + * Results: + * A standard Tcl return value. If TCL_ERROR is returned then + * an error message is left in masterPtr->interp->result. + * + * Side effects: + * Existing instances of the image will be redisplayed to match + * the new configuration options. + * + *---------------------------------------------------------------------- + */ + +static int +ImgPhotoConfigureMaster(interp, masterPtr, argc, argv, flags) + Tcl_Interp *interp; /* Interpreter to use for reporting errors. */ + PhotoMaster *masterPtr; /* Pointer to data structure describing + * overall photo image to (re)configure. */ + int argc; /* Number of entries in argv. */ + char **argv; /* Pairs of configuration options for image. */ + int flags; /* Flags to pass to Tk_ConfigureWidget, + * such as TK_CONFIG_ARGV_ONLY. */ +{ + PhotoInstance *instancePtr; + char *oldFileString, *oldDataString, *realFileName, *oldPaletteString; + double oldGamma; + int result; + FILE *f; + Tk_PhotoImageFormat *imageFormat; + int imageWidth, imageHeight; + Tcl_DString buffer; + + /* + * Save the current values for fileString and dataString, so we + * can tell if the user specifies them anew. + */ + + oldFileString = masterPtr->fileString; + oldDataString = (oldFileString == NULL)? masterPtr->dataString: NULL; + oldPaletteString = masterPtr->palette; + oldGamma = masterPtr->gamma; + + /* + * Process the configuration options specified. + */ + + if (Tk_ConfigureWidget(interp, Tk_MainWindow(interp), configSpecs, + argc, argv, (char *) masterPtr, flags) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Regard the empty string for -file, -data or -format as the null + * value. + */ + + if ((masterPtr->fileString != NULL) && (masterPtr->fileString[0] == 0)) { + ckfree(masterPtr->fileString); + masterPtr->fileString = NULL; + } + if ((masterPtr->dataString != NULL) && (masterPtr->dataString[0] == 0)) { + ckfree(masterPtr->dataString); + masterPtr->dataString = NULL; + } + if ((masterPtr->format != NULL) && (masterPtr->format[0] == 0)) { + ckfree(masterPtr->format); + masterPtr->format = NULL; + } + + /* + * Set the image to the user-requested size, if any, + * and make sure storage is correctly allocated for this image. + */ + + ImgPhotoSetSize(masterPtr, masterPtr->width, masterPtr->height); + + /* + * Read in the image from the file or string if the user has + * specified the -file or -data option. + */ + + if ((masterPtr->fileString != NULL) + && (masterPtr->fileString != oldFileString)) { + + realFileName = Tcl_TranslateFileName(interp, masterPtr->fileString, + &buffer); + if (realFileName == NULL) { + return TCL_ERROR; + } + f = fopen(realFileName, "rb"); + Tcl_DStringFree(&buffer); + if (f == NULL) { + Tcl_AppendResult(interp, "couldn't read image file \"", + masterPtr->fileString, "\": ", Tcl_PosixError(interp), + (char *) NULL); + return TCL_ERROR; + } + if (MatchFileFormat(interp, f, masterPtr->fileString, + masterPtr->format, &imageFormat, &imageWidth, + &imageHeight) != TCL_OK) { + fclose(f); + return TCL_ERROR; + } + ImgPhotoSetSize(masterPtr, imageWidth, imageHeight); + result = (*imageFormat->fileReadProc)(interp, f, masterPtr->fileString, + masterPtr->format, (Tk_PhotoHandle) masterPtr, 0, 0, + imageWidth, imageHeight, 0, 0); + fclose(f); + if (result != TCL_OK) { + return TCL_ERROR; + } + + masterPtr->flags |= IMAGE_CHANGED; + } + + if ((masterPtr->fileString == NULL) && (masterPtr->dataString != NULL) + && (masterPtr->dataString != oldDataString)) { + + if (MatchStringFormat(interp, masterPtr->dataString, + masterPtr->format, &imageFormat, &imageWidth, + &imageHeight) != TCL_OK) { + return TCL_ERROR; + } + ImgPhotoSetSize(masterPtr, imageWidth, imageHeight); + if ((*imageFormat->stringReadProc)(interp, masterPtr->dataString, + masterPtr->format, (Tk_PhotoHandle) masterPtr, + 0, 0, imageWidth, imageHeight, 0, 0) != TCL_OK) { + return TCL_ERROR; + } + + masterPtr->flags |= IMAGE_CHANGED; + } + + /* + * Enforce a reasonable value for gamma. + */ + + if (masterPtr->gamma <= 0) { + masterPtr->gamma = 1.0; + } + + if ((masterPtr->gamma != oldGamma) + || (masterPtr->palette != oldPaletteString)) { + masterPtr->flags |= IMAGE_CHANGED; + } + + /* + * Cycle through all of the instances of this image, regenerating + * the information for each instance. Then force the image to be + * redisplayed everywhere that it is used. + */ + + for (instancePtr = masterPtr->instancePtr; instancePtr != NULL; + instancePtr = instancePtr->nextPtr) { + ImgPhotoConfigureInstance(instancePtr); + } + + /* + * Inform the generic image code that the image + * has (potentially) changed. + */ + + Tk_ImageChanged(masterPtr->tkMaster, 0, 0, masterPtr->width, + masterPtr->height, masterPtr->width, masterPtr->height); + masterPtr->flags &= ~IMAGE_CHANGED; + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ImgPhotoConfigureInstance -- + * + * This procedure is called to create displaying information for + * a photo image instance based on the configuration information + * in the master. It is invoked both when new instances are + * created and when the master is reconfigured. + * + * Results: + * None. + * + * Side effects: + * Generates errors via Tcl_BackgroundError if there are problems + * in setting up the instance. + * + *---------------------------------------------------------------------- + */ + +static void +ImgPhotoConfigureInstance(instancePtr) + PhotoInstance *instancePtr; /* Instance to reconfigure. */ +{ + PhotoMaster *masterPtr = instancePtr->masterPtr; + XImage *imagePtr; + int bitsPerPixel; + ColorTable *colorTablePtr; + XRectangle validBox; + + /* + * If the -palette configuration option has been set for the master, + * use the value specified for our palette, but only if it is + * a valid palette for our windows. Use the gamma value specified + * the master. + */ + + if ((masterPtr->palette && masterPtr->palette[0]) + && IsValidPalette(instancePtr, masterPtr->palette)) { + instancePtr->palette = masterPtr->palette; + } else { + instancePtr->palette = instancePtr->defaultPalette; + } + instancePtr->gamma = masterPtr->gamma; + + /* + * If we don't currently have a color table, or if the one we + * have no longer applies (e.g. because our palette or gamma + * has changed), get a new one. + */ + + colorTablePtr = instancePtr->colorTablePtr; + if ((colorTablePtr == NULL) + || (instancePtr->colormap != colorTablePtr->id.colormap) + || (instancePtr->palette != colorTablePtr->id.palette) + || (instancePtr->gamma != colorTablePtr->id.gamma)) { + /* + * Free up our old color table, and get a new one. + */ + + if (colorTablePtr != NULL) { + colorTablePtr->liveRefCount -= 1; + FreeColorTable(colorTablePtr); + } + GetColorTable(instancePtr); + + /* + * Create a new XImage structure for sending data to + * the X server, if necessary. + */ + + if (instancePtr->colorTablePtr->flags & BLACK_AND_WHITE) { + bitsPerPixel = 1; + } else { + bitsPerPixel = instancePtr->visualInfo.depth; + } + + if ((instancePtr->imagePtr == NULL) + || (instancePtr->imagePtr->bits_per_pixel != bitsPerPixel)) { + if (instancePtr->imagePtr != NULL) { + XFree((char *) instancePtr->imagePtr); + } + imagePtr = XCreateImage(instancePtr->display, + instancePtr->visualInfo.visual, (unsigned) bitsPerPixel, + (bitsPerPixel > 1? ZPixmap: XYBitmap), 0, (char *) NULL, + 1, 1, 32, 0); + instancePtr->imagePtr = imagePtr; + + /* + * Determine the endianness of this machine. + * We create images using the local host's endianness, rather + * than the endianness of the server; otherwise we would have + * to byte-swap any 16 or 32 bit values that we store in the + * image in those situations where the server's endianness + * is different from ours. + */ + + if (imagePtr != NULL) { + union { + int i; + char c[sizeof(int)]; + } kludge; + + imagePtr->bitmap_unit = sizeof(pixel) * NBBY; + kludge.i = 0; + kludge.c[0] = 1; + imagePtr->byte_order = (kludge.i == 1) ? LSBFirst : MSBFirst; + _XInitImageFuncPtrs(imagePtr); + } + } + } + + /* + * If the user has specified a width and/or height for the master + * which is different from our current width/height, set the size + * to the values specified by the user. If we have no pixmap, we + * do this also, since it has the side effect of allocating a + * pixmap for us. + */ + + if ((instancePtr->pixels == None) || (instancePtr->error == NULL) + || (instancePtr->width != masterPtr->width) + || (instancePtr->height != masterPtr->height)) { + ImgPhotoInstanceSetSize(instancePtr); + } + + /* + * Redither this instance if necessary. + */ + + if ((masterPtr->flags & IMAGE_CHANGED) + || (instancePtr->colorTablePtr != colorTablePtr)) { + TkClipBox(masterPtr->validRegion, &validBox); + if ((validBox.width > 0) && (validBox.height > 0)) { + DitherInstance(instancePtr, validBox.x, validBox.y, + validBox.width, validBox.height); + } + } + +} + +/* + *---------------------------------------------------------------------- + * + * ImgPhotoGet -- + * + * This procedure is called for each use of a photo image in a + * widget. + * + * Results: + * The return value is a token for the instance, which is passed + * back to us in calls to ImgPhotoDisplay and ImgPhotoFree. + * + * Side effects: + * A data structure is set up for the instance (or, an existing + * instance is re-used for the new one). + * + *---------------------------------------------------------------------- + */ + +static ClientData +ImgPhotoGet(tkwin, masterData) + Tk_Window tkwin; /* Window in which the instance will be + * used. */ + ClientData masterData; /* Pointer to our master structure for the + * image. */ +{ + PhotoMaster *masterPtr = (PhotoMaster *) masterData; + PhotoInstance *instancePtr; + Colormap colormap; + int mono, nRed, nGreen, nBlue; + XVisualInfo visualInfo, *visInfoPtr; + XRectangle validBox; + char buf[16]; + int numVisuals; + XColor *white, *black; + XGCValues gcValues; + + /* + * Table of "best" choices for palette for PseudoColor displays + * with between 3 and 15 bits/pixel. + */ + + static int paletteChoice[13][3] = { + /* #red, #green, #blue */ + {2, 2, 2, /* 3 bits, 8 colors */}, + {2, 3, 2, /* 4 bits, 12 colors */}, + {3, 4, 2, /* 5 bits, 24 colors */}, + {4, 5, 3, /* 6 bits, 60 colors */}, + {5, 6, 4, /* 7 bits, 120 colors */}, + {7, 7, 4, /* 8 bits, 198 colors */}, + {8, 10, 6, /* 9 bits, 480 colors */}, + {10, 12, 8, /* 10 bits, 960 colors */}, + {14, 15, 9, /* 11 bits, 1890 colors */}, + {16, 20, 12, /* 12 bits, 3840 colors */}, + {20, 24, 16, /* 13 bits, 7680 colors */}, + {26, 30, 20, /* 14 bits, 15600 colors */}, + {32, 32, 30, /* 15 bits, 30720 colors */} + }; + + /* + * See if there is already an instance for windows using + * the same colormap. If so then just re-use it. + */ + + colormap = Tk_Colormap(tkwin); + for (instancePtr = masterPtr->instancePtr; instancePtr != NULL; + instancePtr = instancePtr->nextPtr) { + if ((colormap == instancePtr->colormap) + && (Tk_Display(tkwin) == instancePtr->display)) { + + /* + * Re-use this instance. + */ + + if (instancePtr->refCount == 0) { + /* + * We are resurrecting this instance. + */ + + Tcl_CancelIdleCall(DisposeInstance, (ClientData) instancePtr); + if (instancePtr->colorTablePtr != NULL) { + FreeColorTable(instancePtr->colorTablePtr); + } + GetColorTable(instancePtr); + } + instancePtr->refCount++; + return (ClientData) instancePtr; + } + } + + /* + * The image isn't already in use in a window with the same colormap. + * Make a new instance of the image. + */ + + instancePtr = (PhotoInstance *) ckalloc(sizeof(PhotoInstance)); + instancePtr->masterPtr = masterPtr; + instancePtr->display = Tk_Display(tkwin); + instancePtr->colormap = Tk_Colormap(tkwin); + Tk_PreserveColormap(instancePtr->display, instancePtr->colormap); + instancePtr->refCount = 1; + instancePtr->colorTablePtr = NULL; + instancePtr->pixels = None; + instancePtr->error = NULL; + instancePtr->width = 0; + instancePtr->height = 0; + instancePtr->imagePtr = 0; + instancePtr->nextPtr = masterPtr->instancePtr; + masterPtr->instancePtr = instancePtr; + + /* + * Obtain information about the visual and decide on the + * default palette. + */ + + visualInfo.screen = Tk_ScreenNumber(tkwin); + visualInfo.visualid = XVisualIDFromVisual(Tk_Visual(tkwin)); + visInfoPtr = XGetVisualInfo(Tk_Display(tkwin), + VisualScreenMask | VisualIDMask, &visualInfo, &numVisuals); + nRed = 2; + nGreen = nBlue = 0; + mono = 1; + if (visInfoPtr != NULL) { + instancePtr->visualInfo = *visInfoPtr; + switch (visInfoPtr->class) { + case DirectColor: + case TrueColor: + nRed = 1 << CountBits(visInfoPtr->red_mask); + nGreen = 1 << CountBits(visInfoPtr->green_mask); + nBlue = 1 << CountBits(visInfoPtr->blue_mask); + mono = 0; + break; + case PseudoColor: + case StaticColor: + if (visInfoPtr->depth > 15) { + nRed = 32; + nGreen = 32; + nBlue = 32; + mono = 0; + } else if (visInfoPtr->depth >= 3) { + int *ip = paletteChoice[visInfoPtr->depth - 3]; + + nRed = ip[0]; + nGreen = ip[1]; + nBlue = ip[2]; + mono = 0; + } + break; + case GrayScale: + case StaticGray: + nRed = 1 << visInfoPtr->depth; + break; + } + XFree((char *) visInfoPtr); + + } else { + panic("ImgPhotoGet couldn't find visual for window"); + } + + sprintf(buf, ((mono) ? "%d": "%d/%d/%d"), nRed, nGreen, nBlue); + instancePtr->defaultPalette = Tk_GetUid(buf); + + /* + * Make a GC with background = black and foreground = white. + */ + + white = Tk_GetColor(masterPtr->interp, tkwin, "white"); + black = Tk_GetColor(masterPtr->interp, tkwin, "black"); + gcValues.foreground = (white != NULL)? white->pixel: + WhitePixelOfScreen(Tk_Screen(tkwin)); + gcValues.background = (black != NULL)? black->pixel: + BlackPixelOfScreen(Tk_Screen(tkwin)); + gcValues.graphics_exposures = False; + instancePtr->gc = Tk_GetGC(tkwin, + GCForeground|GCBackground|GCGraphicsExposures, &gcValues); + + /* + * Set configuration options and finish the initialization of the instance. + */ + + ImgPhotoConfigureInstance(instancePtr); + + /* + * If this is the first instance, must set the size of the image. + */ + + if (instancePtr->nextPtr == NULL) { + Tk_ImageChanged(masterPtr->tkMaster, 0, 0, 0, 0, + masterPtr->width, masterPtr->height); + } + + /* + * Dither the image to fill in this instance's pixmap. + */ + + TkClipBox(masterPtr->validRegion, &validBox); + if ((validBox.width > 0) && (validBox.height > 0)) { + DitherInstance(instancePtr, validBox.x, validBox.y, validBox.width, + validBox.height); + } + + return (ClientData) instancePtr; +} + +/* + *---------------------------------------------------------------------- + * + * ImgPhotoDisplay -- + * + * This procedure is invoked to draw a photo image. + * + * Results: + * None. + * + * Side effects: + * A portion of the image gets rendered in a pixmap or window. + * + *---------------------------------------------------------------------- + */ + +static void +ImgPhotoDisplay(clientData, display, drawable, imageX, imageY, width, + height, drawableX, drawableY) + ClientData clientData; /* Pointer to PhotoInstance structure for + * for instance to be displayed. */ + Display *display; /* Display on which to draw image. */ + Drawable drawable; /* Pixmap or window in which to draw image. */ + int imageX, imageY; /* Upper-left corner of region within image + * to draw. */ + int width, height; /* Dimensions of region within image to draw. */ + int drawableX, drawableY; /* Coordinates within drawable that + * correspond to imageX and imageY. */ +{ + PhotoInstance *instancePtr = (PhotoInstance *) clientData; + + /* + * If there's no pixmap, it means that an error occurred + * while creating the image instance so it can't be displayed. + */ + + if (instancePtr->pixels == None) { + return; + } + + /* + * masterPtr->region describes which parts of the image contain + * valid data. We set this region as the clip mask for the gc, + * setting its origin appropriately, and use it when drawing the + * image. + */ + + TkSetRegion(display, instancePtr->gc, instancePtr->masterPtr->validRegion); + XSetClipOrigin(display, instancePtr->gc, drawableX - imageX, + drawableY - imageY); + XCopyArea(display, instancePtr->pixels, drawable, instancePtr->gc, + imageX, imageY, (unsigned) width, (unsigned) height, + drawableX, drawableY); + XSetClipMask(display, instancePtr->gc, None); + XSetClipOrigin(display, instancePtr->gc, 0, 0); +} + +/* + *---------------------------------------------------------------------- + * + * ImgPhotoFree -- + * + * This procedure is called when a widget ceases to use a + * particular instance of an image. We don't actually get + * rid of the instance until later because we may be about + * to get this instance again. + * + * Results: + * None. + * + * Side effects: + * Internal data structures get cleaned up, later. + * + *---------------------------------------------------------------------- + */ + +static void +ImgPhotoFree(clientData, display) + ClientData clientData; /* Pointer to PhotoInstance structure for + * for instance to be displayed. */ + Display *display; /* Display containing window that used image. */ +{ + PhotoInstance *instancePtr = (PhotoInstance *) clientData; + ColorTable *colorPtr; + + instancePtr->refCount -= 1; + if (instancePtr->refCount > 0) { + return; + } + + /* + * There are no more uses of the image within this widget. + * Decrement the count of live uses of its color table, so + * that its colors can be reclaimed if necessary, and + * set up an idle call to free the instance structure. + */ + + colorPtr = instancePtr->colorTablePtr; + if (colorPtr != NULL) { + colorPtr->liveRefCount -= 1; + } + + Tcl_DoWhenIdle(DisposeInstance, (ClientData) instancePtr); +} + +/* + *---------------------------------------------------------------------- + * + * ImgPhotoDelete -- + * + * This procedure is called by the image code to delete the + * master structure for an image. + * + * Results: + * None. + * + * Side effects: + * Resources associated with the image get freed. + * + *---------------------------------------------------------------------- + */ + +static void +ImgPhotoDelete(masterData) + ClientData masterData; /* Pointer to PhotoMaster structure for + * image. Must not have any more instances. */ +{ + PhotoMaster *masterPtr = (PhotoMaster *) masterData; + PhotoInstance *instancePtr; + + while ((instancePtr = masterPtr->instancePtr) != NULL) { + if (instancePtr->refCount > 0) { + panic("tried to delete photo image when instances still exist"); + } + Tcl_CancelIdleCall(DisposeInstance, (ClientData) instancePtr); + DisposeInstance((ClientData) instancePtr); + } + masterPtr->tkMaster = NULL; + if (masterPtr->imageCmd != NULL) { + Tcl_DeleteCommand(masterPtr->interp, + Tcl_GetCommandName(masterPtr->interp, masterPtr->imageCmd)); + } + if (masterPtr->pix24 != NULL) { + ckfree((char *) masterPtr->pix24); + } + if (masterPtr->validRegion != NULL) { + TkDestroyRegion(masterPtr->validRegion); + } + Tk_FreeOptions(configSpecs, (char *) masterPtr, (Display *) NULL, 0); + ckfree((char *) masterPtr); +} + +/* + *---------------------------------------------------------------------- + * + * ImgPhotoCmdDeletedProc -- + * + * This procedure is invoked when the image command for an image + * is deleted. It deletes the image. + * + * Results: + * None. + * + * Side effects: + * The image is deleted. + * + *---------------------------------------------------------------------- + */ + +static void +ImgPhotoCmdDeletedProc(clientData) + ClientData clientData; /* Pointer to PhotoMaster structure for + * image. */ +{ + PhotoMaster *masterPtr = (PhotoMaster *) clientData; + + masterPtr->imageCmd = NULL; + if (masterPtr->tkMaster != NULL) { + Tk_DeleteImage(masterPtr->interp, Tk_NameOfImage(masterPtr->tkMaster)); + } +} + +/* + *---------------------------------------------------------------------- + * + * ImgPhotoSetSize -- + * + * This procedure reallocates the image storage and instance + * pixmaps for a photo image, as necessary, to change the + * image's size to `width' x `height' pixels. + * + * Results: + * None. + * + * Side effects: + * Storage gets reallocated, for the master and all its instances. + * + *---------------------------------------------------------------------- + */ + +static void +ImgPhotoSetSize(masterPtr, width, height) + PhotoMaster *masterPtr; + int width, height; +{ + unsigned char *newPix24; + int h, offset, pitch; + unsigned char *srcPtr, *destPtr; + XRectangle validBox, clipBox; + TkRegion clipRegion; + PhotoInstance *instancePtr; + + if (masterPtr->userWidth > 0) { + width = masterPtr->userWidth; + } + if (masterPtr->userHeight > 0) { + height = masterPtr->userHeight; + } + + /* + * We have to trim the valid region if it is currently + * larger than the new image size. + */ + + TkClipBox(masterPtr->validRegion, &validBox); + if ((validBox.x + validBox.width > (unsigned) width) + || (validBox.y + validBox.height > (unsigned) height)) { + clipBox.x = 0; + clipBox.y = 0; + clipBox.width = width; + clipBox.height = height; + clipRegion = TkCreateRegion(); + TkUnionRectWithRegion(&clipBox, clipRegion, clipRegion); + TkIntersectRegion(masterPtr->validRegion, clipRegion, + masterPtr->validRegion); + TkDestroyRegion(clipRegion); + TkClipBox(masterPtr->validRegion, &validBox); + } + + if ((width != masterPtr->width) || (height != masterPtr->height) + || (masterPtr->pix24 == NULL)) { + + /* + * Reallocate storage for the 24-bit image and copy + * over valid regions. + */ + + pitch = width * 3; + newPix24 = (unsigned char *) ckalloc((unsigned) (height * pitch)); + + /* + * Zero the new array. The dithering code shouldn't read the + * areas outside validBox, but they might be copied to another + * photo image or written to a file. + */ + + if ((masterPtr->pix24 != NULL) + && ((width == masterPtr->width) || (width == validBox.width))) { + if (validBox.y > 0) { + memset((VOID *) newPix24, 0, (size_t) (validBox.y * pitch)); + } + h = validBox.y + validBox.height; + if (h < height) { + memset((VOID *) (newPix24 + h * pitch), 0, + (size_t) ((height - h) * pitch)); + } + } else { + memset((VOID *) newPix24, 0, (size_t) (height * pitch)); + } + + if (masterPtr->pix24 != NULL) { + + /* + * Copy the common area over to the new array array and + * free the old array. + */ + + if (width == masterPtr->width) { + + /* + * The region to be copied is contiguous. + */ + + offset = validBox.y * pitch; + memcpy((VOID *) (newPix24 + offset), + (VOID *) (masterPtr->pix24 + offset), + (size_t) (validBox.height * pitch)); + + } else if ((validBox.width > 0) && (validBox.height > 0)) { + + /* + * Area to be copied is not contiguous - copy line by line. + */ + + destPtr = newPix24 + (validBox.y * width + validBox.x) * 3; + srcPtr = masterPtr->pix24 + (validBox.y * masterPtr->width + + validBox.x) * 3; + for (h = validBox.height; h > 0; h--) { + memcpy((VOID *) destPtr, (VOID *) srcPtr, + (size_t) (validBox.width * 3)); + destPtr += width * 3; + srcPtr += masterPtr->width * 3; + } + } + + ckfree((char *) masterPtr->pix24); + } + + masterPtr->pix24 = newPix24; + masterPtr->width = width; + masterPtr->height = height; + + /* + * Dithering will be correct up to the end of the last + * pre-existing complete scanline. + */ + + if ((validBox.x > 0) || (validBox.y > 0)) { + masterPtr->ditherX = 0; + masterPtr->ditherY = 0; + } else if (validBox.width == width) { + if ((int) validBox.height < masterPtr->ditherY) { + masterPtr->ditherX = 0; + masterPtr->ditherY = validBox.height; + } + } else { + if ((masterPtr->ditherY > 0) + || ((int) validBox.width < masterPtr->ditherX)) { + masterPtr->ditherX = validBox.width; + masterPtr->ditherY = 0; + } + } + } + + /* + * Now adjust the sizes of the pixmaps for all of the instances. + */ + + for (instancePtr = masterPtr->instancePtr; instancePtr != NULL; + instancePtr = instancePtr->nextPtr) { + ImgPhotoInstanceSetSize(instancePtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * ImgPhotoInstanceSetSize -- + * + * This procedure reallocates the instance pixmap and dithering + * error array for a photo instance, as necessary, to change the + * image's size to `width' x `height' pixels. + * + * Results: + * None. + * + * Side effects: + * Storage gets reallocated, here and in the X server. + * + *---------------------------------------------------------------------- + */ + +static void +ImgPhotoInstanceSetSize(instancePtr) + PhotoInstance *instancePtr; /* Instance whose size is to be + * changed. */ +{ + PhotoMaster *masterPtr; + schar *newError; + schar *errSrcPtr, *errDestPtr; + int h, offset; + XRectangle validBox; + Pixmap newPixmap; + + masterPtr = instancePtr->masterPtr; + TkClipBox(masterPtr->validRegion, &validBox); + + if ((instancePtr->width != masterPtr->width) + || (instancePtr->height != masterPtr->height) + || (instancePtr->pixels == None)) { + newPixmap = Tk_GetPixmap(instancePtr->display, + RootWindow(instancePtr->display, + instancePtr->visualInfo.screen), + (masterPtr->width > 0) ? masterPtr->width: 1, + (masterPtr->height > 0) ? masterPtr->height: 1, + instancePtr->visualInfo.depth); + + /* + * The following is a gross hack needed to properly support colormaps + * under Windows. Before the pixels can be copied to the pixmap, + * the relevent colormap must be associated with the drawable. + * Normally we can infer this association from the window that + * was used to create the pixmap. However, in this case we're + * using the root window, so we have to be more explicit. + */ + + TkSetPixmapColormap(newPixmap, instancePtr->colormap); + + if (instancePtr->pixels != None) { + /* + * Copy any common pixels from the old pixmap and free it. + */ + XCopyArea(instancePtr->display, instancePtr->pixels, newPixmap, + instancePtr->gc, validBox.x, validBox.y, + validBox.width, validBox.height, validBox.x, validBox.y); + Tk_FreePixmap(instancePtr->display, instancePtr->pixels); + } + instancePtr->pixels = newPixmap; + } + + if ((instancePtr->width != masterPtr->width) + || (instancePtr->height != masterPtr->height) + || (instancePtr->error == NULL)) { + + newError = (schar *) ckalloc((unsigned) + (masterPtr->height * masterPtr->width * 3 * sizeof(schar))); + + /* + * Zero the new array so that we don't get bogus error values + * propagating into areas we dither later. + */ + + if ((instancePtr->error != NULL) + && ((instancePtr->width == masterPtr->width) + || (validBox.width == masterPtr->width))) { + if (validBox.y > 0) { + memset((VOID *) newError, 0, (size_t) + (validBox.y * masterPtr->width * 3 * sizeof(schar))); + } + h = validBox.y + validBox.height; + if (h < masterPtr->height) { + memset((VOID *) (newError + h * masterPtr->width * 3), 0, + (size_t) ((masterPtr->height - h) + * masterPtr->width * 3 * sizeof(schar))); + } + } else { + memset((VOID *) newError, 0, (size_t) + (masterPtr->height * masterPtr->width * 3 * sizeof(schar))); + } + + if (instancePtr->error != NULL) { + + /* + * Copy the common area over to the new array + * and free the old array. + */ + + if (masterPtr->width == instancePtr->width) { + + offset = validBox.y * masterPtr->width * 3; + memcpy((VOID *) (newError + offset), + (VOID *) (instancePtr->error + offset), + (size_t) (validBox.height + * masterPtr->width * 3 * sizeof(schar))); + + } else if (validBox.width > 0 && validBox.height > 0) { + + errDestPtr = newError + + (validBox.y * masterPtr->width + validBox.x) * 3; + errSrcPtr = instancePtr->error + + (validBox.y * instancePtr->width + validBox.x) * 3; + for (h = validBox.height; h > 0; --h) { + memcpy((VOID *) errDestPtr, (VOID *) errSrcPtr, + validBox.width * 3 * sizeof(schar)); + errDestPtr += masterPtr->width * 3; + errSrcPtr += instancePtr->width * 3; + } + } + ckfree((char *) instancePtr->error); + } + + instancePtr->error = newError; + } + + instancePtr->width = masterPtr->width; + instancePtr->height = masterPtr->height; +} + +/* + *---------------------------------------------------------------------- + * + * IsValidPalette -- + * + * This procedure is called to check whether a value given for + * the -palette option is valid for a particular instance + * of a photo image. + * + * Results: + * A boolean value: 1 if the palette is acceptable, 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +IsValidPalette(instancePtr, palette) + PhotoInstance *instancePtr; /* Instance to which the palette + * specification is to be applied. */ + char *palette; /* Palette specification string. */ +{ + int nRed, nGreen, nBlue, mono, numColors; + char *endp; + + /* + * First parse the specification: it must be of the form + * %d or %d/%d/%d. + */ + + nRed = strtol(palette, &endp, 10); + if ((endp == palette) || ((*endp != 0) && (*endp != '/')) + || (nRed < 2) || (nRed > 256)) { + return 0; + } + + if (*endp == 0) { + mono = 1; + nGreen = nBlue = nRed; + } else { + palette = endp + 1; + nGreen = strtol(palette, &endp, 10); + if ((endp == palette) || (*endp != '/') || (nGreen < 2) + || (nGreen > 256)) { + return 0; + } + palette = endp + 1; + nBlue = strtol(palette, &endp, 10); + if ((endp == palette) || (*endp != 0) || (nBlue < 2) + || (nBlue > 256)) { + return 0; + } + mono = 0; + } + + switch (instancePtr->visualInfo.class) { + case DirectColor: + case TrueColor: + if ((nRed > (1 << CountBits(instancePtr->visualInfo.red_mask))) + || (nGreen > (1 + << CountBits(instancePtr->visualInfo.green_mask))) + || (nBlue > (1 + << CountBits(instancePtr->visualInfo.blue_mask)))) { + return 0; + } + break; + case PseudoColor: + case StaticColor: + numColors = nRed; + if (!mono) { + numColors *= nGreen*nBlue; + } + if (numColors > (1 << instancePtr->visualInfo.depth)) { + return 0; + } + break; + case GrayScale: + case StaticGray: + if (!mono || (nRed > (1 << instancePtr->visualInfo.depth))) { + return 0; + } + break; + } + + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * CountBits -- + * + * This procedure counts how many bits are set to 1 in `mask'. + * + * Results: + * The integer number of bits. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +CountBits(mask) + pixel mask; /* Value to count the 1 bits in. */ +{ + int n; + + for( n = 0; mask != 0; mask &= mask - 1 ) + n++; + return n; +} + +/* + *---------------------------------------------------------------------- + * + * GetColorTable -- + * + * This procedure is called to allocate a table of colormap + * information for an instance of a photo image. Only one such + * table is allocated for all photo instances using the same + * display, colormap, palette and gamma values, so that the + * application need only request a set of colors from the X + * server once for all such photo widgets. This procedure + * maintains a hash table to find previously-allocated + * ColorTables. + * + * Results: + * None. + * + * Side effects: + * A new ColorTable may be allocated and placed in the hash + * table, and have colors allocated for it. + * + *---------------------------------------------------------------------- + */ + +static void +GetColorTable(instancePtr) + PhotoInstance *instancePtr; /* Instance needing a color table. */ +{ + ColorTable *colorPtr; + Tcl_HashEntry *entry; + ColorTableId id; + int isNew; + + /* + * Look for an existing ColorTable in the hash table. + */ + + memset((VOID *) &id, 0, sizeof(id)); + id.display = instancePtr->display; + id.colormap = instancePtr->colormap; + id.palette = instancePtr->palette; + id.gamma = instancePtr->gamma; + if (!imgPhotoColorHashInitialized) { + Tcl_InitHashTable(&imgPhotoColorHash, N_COLOR_HASH); + imgPhotoColorHashInitialized = 1; + } + entry = Tcl_CreateHashEntry(&imgPhotoColorHash, (char *) &id, &isNew); + + if (!isNew) { + /* + * Re-use the existing entry. + */ + + colorPtr = (ColorTable *) Tcl_GetHashValue(entry); + + } else { + /* + * No color table currently available; need to make one. + */ + + colorPtr = (ColorTable *) ckalloc(sizeof(ColorTable)); + + /* + * The following line of code should not normally be needed due + * to the assignment in the following line. However, it compensates + * for bugs in some compilers (HP, for example) where + * sizeof(ColorTable) is 24 but the assignment only copies 20 bytes, + * leaving 4 bytes uninitialized; these cause problems when using + * the id for lookups in imgPhotoColorHash, and can result in + * core dumps. + */ + + memset((VOID *) &colorPtr->id, 0, sizeof(ColorTableId)); + colorPtr->id = id; + Tk_PreserveColormap(colorPtr->id.display, colorPtr->id.colormap); + colorPtr->flags = 0; + colorPtr->refCount = 0; + colorPtr->liveRefCount = 0; + colorPtr->numColors = 0; + colorPtr->visualInfo = instancePtr->visualInfo; + colorPtr->pixelMap = NULL; + Tcl_SetHashValue(entry, colorPtr); + } + + colorPtr->refCount++; + colorPtr->liveRefCount++; + instancePtr->colorTablePtr = colorPtr; + if (colorPtr->flags & DISPOSE_PENDING) { + Tcl_CancelIdleCall(DisposeColorTable, (ClientData) colorPtr); + colorPtr->flags &= ~DISPOSE_PENDING; + } + + /* + * Allocate colors for this color table if necessary. + */ + + if ((colorPtr->numColors == 0) + && ((colorPtr->flags & BLACK_AND_WHITE) == 0)) { + AllocateColors(colorPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * FreeColorTable -- + * + * This procedure is called when an instance ceases using a + * color table. + * + * Results: + * None. + * + * Side effects: + * If no other instances are using this color table, a when-idle + * handler is registered to free up the color table and the colors + * allocated for it. + * + *---------------------------------------------------------------------- + */ + +static void +FreeColorTable(colorPtr) + ColorTable *colorPtr; /* Pointer to the color table which is + * no longer required by an instance. */ +{ + colorPtr->refCount--; + if (colorPtr->refCount > 0) { + return; + } + if ((colorPtr->flags & DISPOSE_PENDING) == 0) { + Tcl_DoWhenIdle(DisposeColorTable, (ClientData) colorPtr); + colorPtr->flags |= DISPOSE_PENDING; + } +} + +/* + *---------------------------------------------------------------------- + * + * AllocateColors -- + * + * This procedure allocates the colors required by a color table, + * and sets up the fields in the color table data structure which + * are used in dithering. + * + * Results: + * None. + * + * Side effects: + * Colors are allocated from the X server. Fields in the + * color table data structure are updated. + * + *---------------------------------------------------------------------- + */ + +static void +AllocateColors(colorPtr) + ColorTable *colorPtr; /* Pointer to the color table requiring + * colors to be allocated. */ +{ + int i, r, g, b, rMult, mono; + int numColors, nRed, nGreen, nBlue; + double fr, fg, fb, igam; + XColor *colors; + unsigned long *pixels; + + /* 16-bit intensity value for i/n of full intensity. */ +# define CFRAC(i, n) ((i) * 65535 / (n)) + + /* As for CFRAC, but apply exponent of g. */ +# define CGFRAC(i, n, g) ((int)(65535 * pow((double)(i) / (n), (g)))) + + /* + * First parse the palette specification to get the required number of + * shades of each primary. + */ + + mono = sscanf(colorPtr->id.palette, "%d/%d/%d", &nRed, &nGreen, &nBlue) + <= 1; + igam = 1.0 / colorPtr->id.gamma; + + /* + * Each time around this loop, we reduce the number of colors we're + * trying to allocate until we succeed in allocating all of the colors + * we need. + */ + + for (;;) { + /* + * If we are using 1 bit/pixel, we don't need to allocate + * any colors (we just use the foreground and background + * colors in the GC). + */ + + if (mono && (nRed <= 2)) { + colorPtr->flags |= BLACK_AND_WHITE; + return; + } + + /* + * Calculate the RGB coordinates of the colors we want to + * allocate and store them in *colors. + */ + + if ((colorPtr->visualInfo.class == DirectColor) + || (colorPtr->visualInfo.class == TrueColor)) { + + /* + * Direct/True Color: allocate shades of red, green, blue + * independently. + */ + + if (mono) { + numColors = nGreen = nBlue = nRed; + } else { + numColors = MAX(MAX(nRed, nGreen), nBlue); + } + colors = (XColor *) ckalloc(numColors * sizeof(XColor)); + + for (i = 0; i < numColors; ++i) { + if (igam == 1.0) { + colors[i].red = CFRAC(i, nRed - 1); + colors[i].green = CFRAC(i, nGreen - 1); + colors[i].blue = CFRAC(i, nBlue - 1); + } else { + colors[i].red = CGFRAC(i, nRed - 1, igam); + colors[i].green = CGFRAC(i, nGreen - 1, igam); + colors[i].blue = CGFRAC(i, nBlue - 1, igam); + } + } + } else { + /* + * PseudoColor, StaticColor, GrayScale or StaticGray visual: + * we have to allocate each color in the color cube separately. + */ + + numColors = (mono) ? nRed: (nRed * nGreen * nBlue); + colors = (XColor *) ckalloc(numColors * sizeof(XColor)); + + if (!mono) { + /* + * Color display using a PseudoColor or StaticColor visual. + */ + + i = 0; + for (r = 0; r < nRed; ++r) { + for (g = 0; g < nGreen; ++g) { + for (b = 0; b < nBlue; ++b) { + if (igam == 1.0) { + colors[i].red = CFRAC(r, nRed - 1); + colors[i].green = CFRAC(g, nGreen - 1); + colors[i].blue = CFRAC(b, nBlue - 1); + } else { + colors[i].red = CGFRAC(r, nRed - 1, igam); + colors[i].green = CGFRAC(g, nGreen - 1, igam); + colors[i].blue = CGFRAC(b, nBlue - 1, igam); + } + i++; + } + } + } + } else { + /* + * Monochrome display - allocate the shades of grey we want. + */ + + for (i = 0; i < numColors; ++i) { + if (igam == 1.0) { + r = CFRAC(i, numColors - 1); + } else { + r = CGFRAC(i, numColors - 1, igam); + } + colors[i].red = colors[i].green = colors[i].blue = r; + } + } + } + + /* + * Now try to allocate the colors we've calculated. + */ + + pixels = (unsigned long *) ckalloc(numColors * sizeof(unsigned long)); + for (i = 0; i < numColors; ++i) { + if (!XAllocColor(colorPtr->id.display, colorPtr->id.colormap, + &colors[i])) { + + /* + * Can't get all the colors we want in the default colormap; + * first try freeing colors from other unused color tables. + */ + + if (!ReclaimColors(&colorPtr->id, numColors - i) + || !XAllocColor(colorPtr->id.display, + colorPtr->id.colormap, &colors[i])) { + /* + * Still can't allocate the color. + */ + break; + } + } + pixels[i] = colors[i].pixel; + } + + /* + * If we didn't get all of the colors, reduce the + * resolution of the color cube, free the ones we got, + * and try again. + */ + + if (i >= numColors) { + break; + } + XFreeColors(colorPtr->id.display, colorPtr->id.colormap, pixels, i, 0); + ckfree((char *) colors); + ckfree((char *) pixels); + + if (!mono) { + if ((nRed == 2) && (nGreen == 2) && (nBlue == 2)) { + /* + * Fall back to 1-bit monochrome display. + */ + + mono = 1; + } else { + /* + * Reduce the number of shades of each primary to about + * 3/4 of the previous value. This should reduce the + * total number of colors required to about half the + * previous value for PseudoColor displays. + */ + + nRed = (nRed * 3 + 2) / 4; + nGreen = (nGreen * 3 + 2) / 4; + nBlue = (nBlue * 3 + 2) / 4; + } + } else { + /* + * Reduce the number of shades of gray to about 1/2. + */ + + nRed = nRed / 2; + } + } + + /* + * We have allocated all of the necessary colors: + * fill in various fields of the ColorTable record. + */ + + if (!mono) { + colorPtr->flags |= COLOR_WINDOW; + + /* + * The following is a hairy hack. We only want to index into + * the pixelMap on colormap displays. However, if the display + * is on Windows, then we actually want to store the index not + * the value since we will be passing the color table into the + * TkPutImage call. + */ + +#ifndef __WIN32__ + if ((colorPtr->visualInfo.class != DirectColor) + && (colorPtr->visualInfo.class != TrueColor)) { + colorPtr->flags |= MAP_COLORS; + } +#endif /* __WIN32__ */ + } + + colorPtr->numColors = numColors; + colorPtr->pixelMap = pixels; + + /* + * Set up quantization tables for dithering. + */ + rMult = nGreen * nBlue; + for (i = 0; i < 256; ++i) { + r = (i * (nRed - 1) + 127) / 255; + if (mono) { + fr = (double) colors[r].red / 65535.0; + if (colorPtr->id.gamma != 1.0 ) { + fr = pow(fr, colorPtr->id.gamma); + } + colorPtr->colorQuant[0][i] = (int)(fr * 255.99); + colorPtr->redValues[i] = colors[r].pixel; + } else { + g = (i * (nGreen - 1) + 127) / 255; + b = (i * (nBlue - 1) + 127) / 255; + if ((colorPtr->visualInfo.class == DirectColor) + || (colorPtr->visualInfo.class == TrueColor)) { + colorPtr->redValues[i] = colors[r].pixel + & colorPtr->visualInfo.red_mask; + colorPtr->greenValues[i] = colors[g].pixel + & colorPtr->visualInfo.green_mask; + colorPtr->blueValues[i] = colors[b].pixel + & colorPtr->visualInfo.blue_mask; + } else { + r *= rMult; + g *= nBlue; + colorPtr->redValues[i] = r; + colorPtr->greenValues[i] = g; + colorPtr->blueValues[i] = b; + } + fr = (double) colors[r].red / 65535.0; + fg = (double) colors[g].green / 65535.0; + fb = (double) colors[b].blue / 65535.0; + if (colorPtr->id.gamma != 1.0) { + fr = pow(fr, colorPtr->id.gamma); + fg = pow(fg, colorPtr->id.gamma); + fb = pow(fb, colorPtr->id.gamma); + } + colorPtr->colorQuant[0][i] = (int)(fr * 255.99); + colorPtr->colorQuant[1][i] = (int)(fg * 255.99); + colorPtr->colorQuant[2][i] = (int)(fb * 255.99); + } + } + + ckfree((char *) colors); +} + +/* + *---------------------------------------------------------------------- + * + * DisposeColorTable -- + * + * + * Results: + * None. + * + * Side effects: + * The colors in the argument color table are freed, as is the + * color table structure itself. The color table is removed + * from the hash table which is used to locate color tables. + * + *---------------------------------------------------------------------- + */ + +static void +DisposeColorTable(clientData) + ClientData clientData; /* Pointer to the ColorTable whose + * colors are to be released. */ +{ + ColorTable *colorPtr; + Tcl_HashEntry *entry; + + colorPtr = (ColorTable *) clientData; + if (colorPtr->pixelMap != NULL) { + if (colorPtr->numColors > 0) { + XFreeColors(colorPtr->id.display, colorPtr->id.colormap, + colorPtr->pixelMap, colorPtr->numColors, 0); + Tk_FreeColormap(colorPtr->id.display, colorPtr->id.colormap); + } + ckfree((char *) colorPtr->pixelMap); + } + + entry = Tcl_FindHashEntry(&imgPhotoColorHash, (char *) &colorPtr->id); + if (entry == NULL) { + panic("DisposeColorTable couldn't find hash entry"); + } + Tcl_DeleteHashEntry(entry); + + ckfree((char *) colorPtr); +} + +/* + *---------------------------------------------------------------------- + * + * ReclaimColors -- + * + * This procedure is called to try to free up colors in the + * colormap used by a color table. It looks for other color + * tables with the same colormap and with a zero live reference + * count, and frees their colors. It only does so if there is + * the possibility of freeing up at least `numColors' colors. + * + * Results: + * The return value is TRUE if any colors were freed, FALSE + * otherwise. + * + * Side effects: + * ColorTables which are not currently in use may lose their + * color allocations. + * + *---------------------------------------------------------------------- */ + +static int +ReclaimColors(id, numColors) + ColorTableId *id; /* Pointer to information identifying + * the color table which needs more colors. */ + int numColors; /* Number of colors required. */ +{ + Tcl_HashSearch srch; + Tcl_HashEntry *entry; + ColorTable *colorPtr; + int nAvail; + + /* + * First scan through the color hash table to get an + * upper bound on how many colors we might be able to free. + */ + + nAvail = 0; + entry = Tcl_FirstHashEntry(&imgPhotoColorHash, &srch); + while (entry != NULL) { + colorPtr = (ColorTable *) Tcl_GetHashValue(entry); + if ((colorPtr->id.display == id->display) + && (colorPtr->id.colormap == id->colormap) + && (colorPtr->liveRefCount == 0 )&& (colorPtr->numColors != 0) + && ((colorPtr->id.palette != id->palette) + || (colorPtr->id.gamma != id->gamma))) { + + /* + * We could take this guy's colors off him. + */ + + nAvail += colorPtr->numColors; + } + entry = Tcl_NextHashEntry(&srch); + } + + /* + * nAvail is an (over)estimate of the number of colors we could free. + */ + + if (nAvail < numColors) { + return 0; + } + + /* + * Scan through a second time freeing colors. + */ + + entry = Tcl_FirstHashEntry(&imgPhotoColorHash, &srch); + while ((entry != NULL) && (numColors > 0)) { + colorPtr = (ColorTable *) Tcl_GetHashValue(entry); + if ((colorPtr->id.display == id->display) + && (colorPtr->id.colormap == id->colormap) + && (colorPtr->liveRefCount == 0) && (colorPtr->numColors != 0) + && ((colorPtr->id.palette != id->palette) + || (colorPtr->id.gamma != id->gamma))) { + + /* + * Free the colors that this ColorTable has. + */ + + XFreeColors(colorPtr->id.display, colorPtr->id.colormap, + colorPtr->pixelMap, colorPtr->numColors, 0); + numColors -= colorPtr->numColors; + colorPtr->numColors = 0; + ckfree((char *) colorPtr->pixelMap); + colorPtr->pixelMap = NULL; + } + + entry = Tcl_NextHashEntry(&srch); + } + return 1; /* we freed some colors */ +} + +/* + *---------------------------------------------------------------------- + * + * DisposeInstance -- + * + * This procedure is called to finally free up an instance + * of a photo image which is no longer required. + * + * Results: + * None. + * + * Side effects: + * The instance data structure and the resources it references + * are freed. + * + *---------------------------------------------------------------------- + */ + +static void +DisposeInstance(clientData) + ClientData clientData; /* Pointer to the instance whose resources + * are to be released. */ +{ + PhotoInstance *instancePtr = (PhotoInstance *) clientData; + PhotoInstance *prevPtr; + + if (instancePtr->pixels != None) { + Tk_FreePixmap(instancePtr->display, instancePtr->pixels); + } + if (instancePtr->gc != None) { + Tk_FreeGC(instancePtr->display, instancePtr->gc); + } + if (instancePtr->imagePtr != NULL) { + XFree((char *) instancePtr->imagePtr); + } + if (instancePtr->error != NULL) { + ckfree((char *) instancePtr->error); + } + if (instancePtr->colorTablePtr != NULL) { + FreeColorTable(instancePtr->colorTablePtr); + } + + if (instancePtr->masterPtr->instancePtr == instancePtr) { + instancePtr->masterPtr->instancePtr = instancePtr->nextPtr; + } else { + for (prevPtr = instancePtr->masterPtr->instancePtr; + prevPtr->nextPtr != instancePtr; prevPtr = prevPtr->nextPtr) { + /* Empty loop body */ + } + prevPtr->nextPtr = instancePtr->nextPtr; + } + Tk_FreeColormap(instancePtr->display, instancePtr->colormap); + ckfree((char *) instancePtr); +} + +/* + *---------------------------------------------------------------------- + * + * MatchFileFormat -- + * + * This procedure is called to find a photo image file format + * handler which can parse the image data in the given file. + * If a user-specified format string is provided, only handlers + * whose names match a prefix of the format string are tried. + * + * Results: + * A standard TCL return value. If the return value is TCL_OK, a + * pointer to the image format record is returned in + * *imageFormatPtr, and the width and height of the image are + * returned in *widthPtr and *heightPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +MatchFileFormat(interp, f, fileName, formatString, imageFormatPtr, + widthPtr, heightPtr) + Tcl_Interp *interp; /* Interpreter to use for reporting errors. */ + FILE *f; /* The image file, open for reading. */ + char *fileName; /* The name of the image file. */ + char *formatString; /* User-specified format string, or NULL. */ + Tk_PhotoImageFormat **imageFormatPtr; + /* A pointer to the photo image format + * record is returned here. */ + int *widthPtr, *heightPtr; /* The dimensions of the image are + * returned here. */ +{ + int matched; + Tk_PhotoImageFormat *formatPtr; + + /* + * Scan through the table of file format handlers to find + * one which can handle the image. + */ + + matched = 0; + for (formatPtr = formatList; formatPtr != NULL; + formatPtr = formatPtr->nextPtr) { + if (formatString != NULL) { + if (strncasecmp(formatString, formatPtr->name, + strlen(formatPtr->name)) != 0) { + continue; + } + matched = 1; + if (formatPtr->fileMatchProc == NULL) { + Tcl_AppendResult(interp, "-file option isn't supported for ", + formatString, " images", (char *) NULL); + return TCL_ERROR; + } + } + if (formatPtr->fileMatchProc != NULL) { + fseek(f, 0L, SEEK_SET); + if ((*formatPtr->fileMatchProc)(f, fileName, formatString, + widthPtr, heightPtr)) { + if (*widthPtr < 1) { + *widthPtr = 1; + } + if (*heightPtr < 1) { + *heightPtr = 1; + } + break; + } + } + } + + if (formatPtr == NULL) { + if ((formatString != NULL) && !matched) { + Tcl_AppendResult(interp, "image file format \"", formatString, + "\" is not supported", (char *) NULL); + } else { + Tcl_AppendResult(interp, + "couldn't recognize data in image file \"", + fileName, "\"", (char *) NULL); + } + return TCL_ERROR; + } + + *imageFormatPtr = formatPtr; + fseek(f, 0L, SEEK_SET); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * MatchStringFormat -- + * + * This procedure is called to find a photo image file format + * handler which can parse the image data in the given string. + * If a user-specified format string is provided, only handlers + * whose names match a prefix of the format string are tried. + * + * Results: + * A standard TCL return value. If the return value is TCL_OK, a + * pointer to the image format record is returned in + * *imageFormatPtr, and the width and height of the image are + * returned in *widthPtr and *heightPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +MatchStringFormat(interp, string, formatString, imageFormatPtr, + widthPtr, heightPtr) + Tcl_Interp *interp; /* Interpreter to use for reporting errors. */ + char *string; /* String containing the image data. */ + char *formatString; /* User-specified format string, or NULL. */ + Tk_PhotoImageFormat **imageFormatPtr; + /* A pointer to the photo image format + * record is returned here. */ + int *widthPtr, *heightPtr; /* The dimensions of the image are + * returned here. */ +{ + int matched; + Tk_PhotoImageFormat *formatPtr; + + /* + * Scan through the table of file format handlers to find + * one which can handle the image. + */ + + matched = 0; + for (formatPtr = formatList; formatPtr != NULL; + formatPtr = formatPtr->nextPtr) { + if (formatString != NULL) { + if (strncasecmp(formatString, formatPtr->name, + strlen(formatPtr->name)) != 0) { + continue; + } + matched = 1; + if (formatPtr->stringMatchProc == NULL) { + Tcl_AppendResult(interp, "-data option isn't supported for ", + formatString, " images", (char *) NULL); + return TCL_ERROR; + } + } + if ((formatPtr->stringMatchProc != NULL) + && (*formatPtr->stringMatchProc)(string, formatString, + widthPtr, heightPtr)) { + break; + } + } + + if (formatPtr == NULL) { + if ((formatString != NULL) && !matched) { + Tcl_AppendResult(interp, "image format \"", formatString, + "\" is not supported", (char *) NULL); + } else { + Tcl_AppendResult(interp, "couldn't recognize image data", + (char *) NULL); + } + return TCL_ERROR; + } + + *imageFormatPtr = formatPtr; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_FindPhoto -- + * + * This procedure is called to get an opaque handle (actually a + * PhotoMaster *) for a given image, which can be used in + * subsequent calls to Tk_PhotoPutBlock, etc. The `name' + * parameter is the name of the image. + * + * Results: + * The handle for the photo image, or NULL if there is no + * photo image with the name given. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tk_PhotoHandle +Tk_FindPhoto(imageName) + char *imageName; /* Name of the desired photo image. */ +{ + Tcl_HashEntry *entry; + + if (!imgPhotoHashInitialized) { + return NULL; + } + entry = Tcl_FindHashEntry(&imgPhotoHash, imageName); + if (entry == NULL) { + return NULL; + } + return (Tk_PhotoHandle) Tcl_GetHashValue(entry); +} + +/* + *---------------------------------------------------------------------- + * + * Tk_PhotoPutBlock -- + * + * This procedure is called to put image data into a photo image. + * + * Results: + * None. + * + * Side effects: + * The image data is stored. The image may be expanded. + * The Tk image code is informed that the image has changed. + * + *---------------------------------------------------------------------- */ + +void +Tk_PhotoPutBlock(handle, blockPtr, x, y, width, height) + Tk_PhotoHandle handle; /* Opaque handle for the photo image + * to be updated. */ + register Tk_PhotoImageBlock *blockPtr; + /* Pointer to a structure describing the + * pixel data to be copied into the image. */ + int x, y; /* Coordinates of the top-left pixel to + * be updated in the image. */ + int width, height; /* Dimensions of the area of the image + * to be updated. */ +{ + register PhotoMaster *masterPtr; + int xEnd, yEnd; + int greenOffset, blueOffset; + int wLeft, hLeft; + int wCopy, hCopy; + unsigned char *srcPtr, *srcLinePtr; + unsigned char *destPtr, *destLinePtr; + int pitch; + XRectangle rect; + + masterPtr = (PhotoMaster *) handle; + + if ((masterPtr->userWidth != 0) && ((x + width) > masterPtr->userWidth)) { + width = masterPtr->userWidth - x; + } + if ((masterPtr->userHeight != 0) + && ((y + height) > masterPtr->userHeight)) { + height = masterPtr->userHeight - y; + } + if ((width <= 0) || (height <= 0)) + return; + + xEnd = x + width; + yEnd = y + height; + if ((xEnd > masterPtr->width) || (yEnd > masterPtr->height)) { + ImgPhotoSetSize(masterPtr, MAX(xEnd, masterPtr->width), + MAX(yEnd, masterPtr->height)); + } + + if ((y < masterPtr->ditherY) || ((y == masterPtr->ditherY) + && (x < masterPtr->ditherX))) { + /* + * The dithering isn't correct past the start of this block. + */ + masterPtr->ditherX = x; + masterPtr->ditherY = y; + } + + /* + * If this image block could have different red, green and blue + * components, mark it as a color image. + */ + + greenOffset = blockPtr->offset[1] - blockPtr->offset[0]; + blueOffset = blockPtr->offset[2] - blockPtr->offset[0]; + if ((greenOffset != 0) || (blueOffset != 0)) { + masterPtr->flags |= COLOR_IMAGE; + } + + /* + * Copy the data into our local 24-bit/pixel array. + * If we can do it with a single memcpy, we do. + */ + + destLinePtr = masterPtr->pix24 + (y * masterPtr->width + x) * 3; + pitch = masterPtr->width * 3; + + if ((blockPtr->pixelSize == 3) && (greenOffset == 1) && (blueOffset == 2) + && (width <= blockPtr->width) && (height <= blockPtr->height) + && ((height == 1) || ((x == 0) && (width == masterPtr->width) + && (blockPtr->pitch == pitch)))) { + memcpy((VOID *) destLinePtr, + (VOID *) (blockPtr->pixelPtr + blockPtr->offset[0]), + (size_t) (height * width * 3)); + } else { + for (hLeft = height; hLeft > 0;) { + srcLinePtr = blockPtr->pixelPtr + blockPtr->offset[0]; + hCopy = MIN(hLeft, blockPtr->height); + hLeft -= hCopy; + for (; hCopy > 0; --hCopy) { + destPtr = destLinePtr; + for (wLeft = width; wLeft > 0;) { + wCopy = MIN(wLeft, blockPtr->width); + wLeft -= wCopy; + srcPtr = srcLinePtr; + for (; wCopy > 0; --wCopy) { + *destPtr++ = srcPtr[0]; + *destPtr++ = srcPtr[greenOffset]; + *destPtr++ = srcPtr[blueOffset]; + srcPtr += blockPtr->pixelSize; + } + } + srcLinePtr += blockPtr->pitch; + destLinePtr += pitch; + } + } + } + + /* + * Add this new block to the region which specifies which data is valid. + */ + + rect.x = x; + rect.y = y; + rect.width = width; + rect.height = height; + TkUnionRectWithRegion(&rect, masterPtr->validRegion, + masterPtr->validRegion); + + /* + * Update each instance. + */ + + Dither(masterPtr, x, y, width, height); + + /* + * Tell the core image code that this image has changed. + */ + + Tk_ImageChanged(masterPtr->tkMaster, x, y, width, height, masterPtr->width, + masterPtr->height); +} + +/* + *---------------------------------------------------------------------- + * + * Tk_PhotoPutZoomedBlock -- + * + * This procedure is called to put image data into a photo image, + * with possible subsampling and/or zooming of the pixels. + * + * Results: + * None. + * + * Side effects: + * The image data is stored. The image may be expanded. + * The Tk image code is informed that the image has changed. + * + *---------------------------------------------------------------------- + */ + +void +Tk_PhotoPutZoomedBlock(handle, blockPtr, x, y, width, height, zoomX, zoomY, + subsampleX, subsampleY) + Tk_PhotoHandle handle; /* Opaque handle for the photo image + * to be updated. */ + register Tk_PhotoImageBlock *blockPtr; + /* Pointer to a structure describing the + * pixel data to be copied into the image. */ + int x, y; /* Coordinates of the top-left pixel to + * be updated in the image. */ + int width, height; /* Dimensions of the area of the image + * to be updated. */ + int zoomX, zoomY; /* Zoom factors for the X and Y axes. */ + int subsampleX, subsampleY; /* Subsampling factors for the X and Y axes. */ +{ + register PhotoMaster *masterPtr; + int xEnd, yEnd; + int greenOffset, blueOffset; + int wLeft, hLeft; + int wCopy, hCopy; + int blockWid, blockHt; + unsigned char *srcPtr, *srcLinePtr, *srcOrigPtr; + unsigned char *destPtr, *destLinePtr; + int pitch; + int xRepeat, yRepeat; + int blockXSkip, blockYSkip; + XRectangle rect; + + if ((zoomX == 1) && (zoomY == 1) && (subsampleX == 1) + && (subsampleY == 1)) { + Tk_PhotoPutBlock(handle, blockPtr, x, y, width, height); + return; + } + + masterPtr = (PhotoMaster *) handle; + + if ((zoomX <= 0) || (zoomY <= 0)) + return; + if ((masterPtr->userWidth != 0) && ((x + width) > masterPtr->userWidth)) { + width = masterPtr->userWidth - x; + } + if ((masterPtr->userHeight != 0) + && ((y + height) > masterPtr->userHeight)) { + height = masterPtr->userHeight - y; + } + if ((width <= 0) || (height <= 0)) + return; + + xEnd = x + width; + yEnd = y + height; + if ((xEnd > masterPtr->width) || (yEnd > masterPtr->height)) { + int sameSrc = (blockPtr->pixelPtr == masterPtr->pix24); + ImgPhotoSetSize(masterPtr, MAX(xEnd, masterPtr->width), + MAX(yEnd, masterPtr->height)); + if (sameSrc) { + blockPtr->pixelPtr = masterPtr->pix24; + } + } + + if ((y < masterPtr->ditherY) || ((y == masterPtr->ditherY) + && (x < masterPtr->ditherX))) { + /* + * The dithering isn't correct past the start of this block. + */ + + masterPtr->ditherX = x; + masterPtr->ditherY = y; + } + + /* + * If this image block could have different red, green and blue + * components, mark it as a color image. + */ + + greenOffset = blockPtr->offset[1] - blockPtr->offset[0]; + blueOffset = blockPtr->offset[2] - blockPtr->offset[0]; + if ((greenOffset != 0) || (blueOffset != 0)) { + masterPtr->flags |= COLOR_IMAGE; + } + + /* + * Work out what area the pixel data in the block expands to after + * subsampling and zooming. + */ + + blockXSkip = subsampleX * blockPtr->pixelSize; + blockYSkip = subsampleY * blockPtr->pitch; + if (subsampleX > 0) + blockWid = ((blockPtr->width + subsampleX - 1) / subsampleX) * zoomX; + else if (subsampleX == 0) + blockWid = width; + else + blockWid = ((blockPtr->width - subsampleX - 1) / -subsampleX) * zoomX; + if (subsampleY > 0) + blockHt = ((blockPtr->height + subsampleY - 1) / subsampleY) * zoomY; + else if (subsampleY == 0) + blockHt = height; + else + blockHt = ((blockPtr->height - subsampleY - 1) / -subsampleY) * zoomY; + + /* + * Copy the data into our local 24-bit/pixel array. + */ + + destLinePtr = masterPtr->pix24 + (y * masterPtr->width + x) * 3; + srcOrigPtr = blockPtr->pixelPtr + blockPtr->offset[0]; + if (subsampleX < 0) { + srcOrigPtr += (blockPtr->width - 1) * blockPtr->pixelSize; + } + if (subsampleY < 0) { + srcOrigPtr += (blockPtr->height - 1) * blockPtr->pitch; + } + + pitch = masterPtr->width * 3; + for (hLeft = height; hLeft > 0; ) { + hCopy = MIN(hLeft, blockHt); + hLeft -= hCopy; + yRepeat = zoomY; + srcLinePtr = srcOrigPtr; + for (; hCopy > 0; --hCopy) { + destPtr = destLinePtr; + for (wLeft = width; wLeft > 0;) { + wCopy = MIN(wLeft, blockWid); + wLeft -= wCopy; + srcPtr = srcLinePtr; + for (; wCopy > 0; wCopy -= zoomX) { + for (xRepeat = MIN(wCopy, zoomX); xRepeat > 0; xRepeat--) { + *destPtr++ = srcPtr[0]; + *destPtr++ = srcPtr[greenOffset]; + *destPtr++ = srcPtr[blueOffset]; + } + srcPtr += blockXSkip; + } + } + destLinePtr += pitch; + yRepeat--; + if (yRepeat <= 0) { + srcLinePtr += blockYSkip; + yRepeat = zoomY; + } + } + } + + /* + * Add this new block to the region that specifies which data is valid. + */ + + rect.x = x; + rect.y = y; + rect.width = width; + rect.height = height; + TkUnionRectWithRegion(&rect, masterPtr->validRegion, + masterPtr->validRegion); + + /* + * Update each instance. + */ + + Dither(masterPtr, x, y, width, height); + + /* + * Tell the core image code that this image has changed. + */ + + Tk_ImageChanged(masterPtr->tkMaster, x, y, width, height, masterPtr->width, + masterPtr->height); +} + +/* + *---------------------------------------------------------------------- + * + * Dither -- + * + * This procedure is called to update an area of each instance's + * pixmap by dithering the corresponding area of the image master. + * + * Results: + * None. + * + * Side effects: + * The pixmap of each instance of this image gets updated. + * The fields in *masterPtr indicating which area of the image + * is correctly dithered get updated. + * + *---------------------------------------------------------------------- + */ + +static void +Dither(masterPtr, x, y, width, height) + PhotoMaster *masterPtr; /* Image master whose instances are + * to be updated. */ + int x, y; /* Coordinates of the top-left pixel + * in the area to be dithered. */ + int width, height; /* Dimensions of the area to be dithered. */ +{ + PhotoInstance *instancePtr; + + if ((width <= 0) || (height <= 0)) { + return; + } + + for (instancePtr = masterPtr->instancePtr; instancePtr != NULL; + instancePtr = instancePtr->nextPtr) { + DitherInstance(instancePtr, x, y, width, height); + } + + /* + * Work out whether this block will be correctly dithered + * and whether it will extend the correctly dithered region. + */ + + if (((y < masterPtr->ditherY) + || ((y == masterPtr->ditherY) && (x <= masterPtr->ditherX))) + && ((y + height) > (masterPtr->ditherY))) { + + /* + * This block starts inside (or immediately after) the correctly + * dithered region, so the first scan line at least will be right. + * Furthermore this block extends into scanline masterPtr->ditherY. + */ + + if ((x == 0) && (width == masterPtr->width)) { + /* + * We are doing the full width, therefore the dithering + * will be correct to the end. + */ + + masterPtr->ditherX = 0; + masterPtr->ditherY = y + height; + } else { + /* + * We are doing partial scanlines, therefore the + * correctly-dithered region will be extended by + * at most one scan line. + */ + + if (x <= masterPtr->ditherX) { + masterPtr->ditherX = x + width; + if (masterPtr->ditherX >= masterPtr->width) { + masterPtr->ditherX = 0; + masterPtr->ditherY++; + } + } + } + } + +} + +/* + *---------------------------------------------------------------------- + * + * DitherInstance -- + * + * This procedure is called to update an area of an instance's + * pixmap by dithering the corresponding area of the master. + * + * Results: + * None. + * + * Side effects: + * The instance's pixmap gets updated. + * + *---------------------------------------------------------------------- + */ + +static void +DitherInstance(instancePtr, xStart, yStart, width, height) + PhotoInstance *instancePtr; /* The instance to be updated. */ + int xStart, yStart; /* Coordinates of the top-left pixel in the + * block to be dithered. */ + int width, height; /* Dimensions of the block to be dithered. */ +{ + PhotoMaster *masterPtr; + ColorTable *colorPtr; + XImage *imagePtr; + int nLines, bigEndian; + int i, c, x, y; + int xEnd, yEnd; + int bitsPerPixel, bytesPerLine, lineLength; + unsigned char *srcLinePtr, *srcPtr; + schar *errLinePtr, *errPtr; + unsigned char *destBytePtr, *dstLinePtr; + pixel *destLongPtr; + pixel firstBit, word, mask; + int col[3]; + int doDithering = 1; + + colorPtr = instancePtr->colorTablePtr; + masterPtr = instancePtr->masterPtr; + + /* + * Turn dithering off in certain cases where it is not + * needed (TrueColor, DirectColor with many colors). + */ + + if ((colorPtr->visualInfo.class == DirectColor) + || (colorPtr->visualInfo.class == TrueColor)) { + int nRed, nGreen, nBlue, result; + + result = sscanf(colorPtr->id.palette, "%d/%d/%d", &nRed, + &nGreen, &nBlue); + if ((nRed >= 256) + && ((result == 1) || ((nGreen >= 256) && (nBlue >= 256)))) { + doDithering = 0; + } + } + + /* + * First work out how many lines to do at a time, + * then how many bytes we'll need for pixel storage, + * and allocate it. + */ + + nLines = (MAX_PIXELS + width - 1) / width; + if (nLines < 1) { + nLines = 1; + } + if (nLines > height ) { + nLines = height; + } + + imagePtr = instancePtr->imagePtr; + if (imagePtr == NULL) { + return; /* we must be really tight on memory */ + } + bitsPerPixel = imagePtr->bits_per_pixel; + bytesPerLine = ((bitsPerPixel * width + 31) >> 3) & ~3; + imagePtr->width = width; + imagePtr->height = nLines; + imagePtr->bytes_per_line = bytesPerLine; + imagePtr->data = (char *) ckalloc((unsigned) (imagePtr->bytes_per_line * nLines)); + bigEndian = imagePtr->bitmap_bit_order == MSBFirst; + firstBit = bigEndian? (1 << (imagePtr->bitmap_unit - 1)): 1; + + lineLength = masterPtr->width * 3; + srcLinePtr = masterPtr->pix24 + yStart * lineLength + xStart * 3; + errLinePtr = instancePtr->error + yStart * lineLength + xStart * 3; + xEnd = xStart + width; + + /* + * Loop over the image, doing at most nLines lines before + * updating the screen image. + */ + + for (; height > 0; height -= nLines) { + if (nLines > height) { + nLines = height; + } + dstLinePtr = (unsigned char *) imagePtr->data; + yEnd = yStart + nLines; + for (y = yStart; y < yEnd; ++y) { + srcPtr = srcLinePtr; + errPtr = errLinePtr; + destBytePtr = dstLinePtr; + destLongPtr = (pixel *) dstLinePtr; + if (colorPtr->flags & COLOR_WINDOW) { + /* + * Color window. We dither the three components + * independently, using Floyd-Steinberg dithering, + * which propagates errors from the quantization of + * pixels to the pixels below and to the right. + */ + + for (x = xStart; x < xEnd; ++x) { + if (doDithering) { + for (i = 0; i < 3; ++i) { + /* + * Compute the error propagated into this pixel + * for this component. + * If e[x,y] is the array of quantization error + * values, we compute + * 7/16 * e[x-1,y] + 1/16 * e[x-1,y-1] + * + 5/16 * e[x,y-1] + 3/16 * e[x+1,y-1] + * and round it to an integer. + * + * The expression ((c + 2056) >> 4) - 128 + * computes round(c / 16), and works correctly on + * machines without a sign-extending right shift. + */ + + c = (x > 0) ? errPtr[-3] * 7: 0; + if (y > 0) { + if (x > 0) { + c += errPtr[-lineLength-3]; + } + c += errPtr[-lineLength] * 5; + if ((x + 1) < masterPtr->width) { + c += errPtr[-lineLength+3] * 3; + } + } + + /* + * Add the propagated error to the value of this + * component, quantize it, and store the + * quantization error. + */ + + c = ((c + 2056) >> 4) - 128 + *srcPtr++; + if (c < 0) { + c = 0; + } else if (c > 255) { + c = 255; + } + col[i] = colorPtr->colorQuant[i][c]; + *errPtr++ = c - col[i]; + } + } else { + /* + * Output is virtually continuous in this case, + * so don't bother dithering. + */ + + col[0] = *srcPtr++; + col[1] = *srcPtr++; + col[2] = *srcPtr++; + } + + /* + * Translate the quantized component values into + * an X pixel value, and store it in the image. + */ + + i = colorPtr->redValues[col[0]] + + colorPtr->greenValues[col[1]] + + colorPtr->blueValues[col[2]]; + if (colorPtr->flags & MAP_COLORS) { + i = colorPtr->pixelMap[i]; + } + switch (bitsPerPixel) { + case NBBY: + *destBytePtr++ = i; + break; + case NBBY * sizeof(pixel): + *destLongPtr++ = i; + break; + default: + XPutPixel(imagePtr, x - xStart, y - yStart, + (unsigned) i); + } + } + + } else if (bitsPerPixel > 1) { + /* + * Multibit monochrome window. The operation here is similar + * to the color window case above, except that there is only + * one component. If the master image is in color, use the + * luminance computed as + * 0.344 * red + 0.5 * green + 0.156 * blue. + */ + + for (x = xStart; x < xEnd; ++x) { + c = (x > 0) ? errPtr[-1] * 7: 0; + if (y > 0) { + if (x > 0) { + c += errPtr[-lineLength-1]; + } + c += errPtr[-lineLength] * 5; + if (x + 1 < masterPtr->width) { + c += errPtr[-lineLength+1] * 3; + } + } + c = ((c + 2056) >> 4) - 128; + + if ((masterPtr->flags & COLOR_IMAGE) == 0) { + c += srcPtr[0]; + } else { + c += (unsigned)(srcPtr[0] * 11 + srcPtr[1] * 16 + + srcPtr[2] * 5 + 16) >> 5; + } + srcPtr += 3; + + if (c < 0) { + c = 0; + } else if (c > 255) { + c = 255; + } + i = colorPtr->colorQuant[0][c]; + *errPtr++ = c - i; + i = colorPtr->redValues[i]; + switch (bitsPerPixel) { + case NBBY: + *destBytePtr++ = i; + break; + case NBBY * sizeof(pixel): + *destLongPtr++ = i; + break; + default: + XPutPixel(imagePtr, x - xStart, y - yStart, + (unsigned) i); + } + } + } else { + /* + * 1-bit monochrome window. This is similar to the + * multibit monochrome case above, except that the + * quantization is simpler (we only have black = 0 + * and white = 255), and we produce an XY-Bitmap. + */ + + word = 0; + mask = firstBit; + for (x = xStart; x < xEnd; ++x) { + /* + * If we have accumulated a whole word, store it + * in the image and start a new word. + */ + + if (mask == 0) { + *destLongPtr++ = word; + mask = firstBit; + word = 0; + } + + c = (x > 0) ? errPtr[-1] * 7: 0; + if (y > 0) { + if (x > 0) { + c += errPtr[-lineLength-1]; + } + c += errPtr[-lineLength] * 5; + if (x + 1 < masterPtr->width) { + c += errPtr[-lineLength+1] * 3; + } + } + c = ((c + 2056) >> 4) - 128; + + if ((masterPtr->flags & COLOR_IMAGE) == 0) { + c += srcPtr[0]; + } else { + c += (unsigned)(srcPtr[0] * 11 + srcPtr[1] * 16 + + srcPtr[2] * 5 + 16) >> 5; + } + srcPtr += 3; + + if (c < 0) { + c = 0; + } else if (c > 255) { + c = 255; + } + if (c >= 128) { + word |= mask; + *errPtr++ = c - 255; + } else { + *errPtr++ = c; + } + mask = bigEndian? (mask >> 1): (mask << 1); + } + *destLongPtr = word; + } + srcLinePtr += lineLength; + errLinePtr += lineLength; + dstLinePtr += bytesPerLine; + } + + /* + * Update the pixmap for this instance with the block of + * pixels that we have just computed. + */ + + TkPutImage(colorPtr->pixelMap, colorPtr->numColors, + instancePtr->display, instancePtr->pixels, + instancePtr->gc, imagePtr, 0, 0, xStart, yStart, + (unsigned) width, (unsigned) nLines); + yStart = yEnd; + + } + + ckfree(imagePtr->data); + imagePtr->data = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_PhotoBlank -- + * + * This procedure is called to clear an entire photo image. + * + * Results: + * None. + * + * Side effects: + * The valid region for the image is set to the null region. + * The generic image code is notified that the image has changed. + * + *---------------------------------------------------------------------- + */ + +void +Tk_PhotoBlank(handle) + Tk_PhotoHandle handle; /* Handle for the image to be blanked. */ +{ + PhotoMaster *masterPtr; + PhotoInstance *instancePtr; + + masterPtr = (PhotoMaster *) handle; + masterPtr->ditherX = masterPtr->ditherY = 0; + masterPtr->flags = 0; + + /* + * The image has valid data nowhere. + */ + + if (masterPtr->validRegion != NULL) { + TkDestroyRegion(masterPtr->validRegion); + } + masterPtr->validRegion = TkCreateRegion(); + + /* + * Clear out the 24-bit pixel storage array. + * Clear out the dithering error arrays for each instance. + */ + + memset((VOID *) masterPtr->pix24, 0, + (size_t) (masterPtr->width * masterPtr->height)); + for (instancePtr = masterPtr->instancePtr; instancePtr != NULL; + instancePtr = instancePtr->nextPtr) { + memset((VOID *) instancePtr->error, 0, + (size_t) (masterPtr->width * masterPtr->height + * sizeof(schar))); + } + + /* + * Tell the core image code that this image has changed. + */ + + Tk_ImageChanged(masterPtr->tkMaster, 0, 0, masterPtr->width, + masterPtr->height, masterPtr->width, masterPtr->height); +} + +/* + *---------------------------------------------------------------------- + * + * Tk_PhotoExpand -- + * + * This procedure is called to request that a photo image be + * expanded if necessary to be at least `width' pixels wide and + * `height' pixels high. If the user has declared a definite + * image size (using the -width and -height configuration + * options) then this call has no effect. + * + * Results: + * None. + * + * Side effects: + * The size of the photo image may change; if so the generic + * image code is informed. + * + *---------------------------------------------------------------------- + */ + +void +Tk_PhotoExpand(handle, width, height) + Tk_PhotoHandle handle; /* Handle for the image to be expanded. */ + int width, height; /* Desired minimum dimensions of the image. */ +{ + PhotoMaster *masterPtr; + + masterPtr = (PhotoMaster *) handle; + + if (width <= masterPtr->width) { + width = masterPtr->width; + } + if (height <= masterPtr->height) { + height = masterPtr->height; + } + if ((width != masterPtr->width) || (height != masterPtr->height)) { + ImgPhotoSetSize(masterPtr, MAX(width, masterPtr->width), + MAX(height, masterPtr->height)); + Tk_ImageChanged(masterPtr->tkMaster, 0, 0, 0, 0, masterPtr->width, + masterPtr->height); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tk_PhotoGetSize -- + * + * This procedure is called to obtain the current size of a photo + * image. + * + * Results: + * The image's width and height are returned in *widthp + * and *heightp. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tk_PhotoGetSize(handle, widthPtr, heightPtr) + Tk_PhotoHandle handle; /* Handle for the image whose dimensions + * are requested. */ + int *widthPtr, *heightPtr; /* The dimensions of the image are returned + * here. */ +{ + PhotoMaster *masterPtr; + + masterPtr = (PhotoMaster *) handle; + *widthPtr = masterPtr->width; + *heightPtr = masterPtr->height; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_PhotoSetSize -- + * + * This procedure is called to set size of a photo image. + * This call is equivalent to using the -width and -height + * configuration options. + * + * Results: + * None. + * + * Side effects: + * The size of the image may change; if so the generic + * image code is informed. + * + *---------------------------------------------------------------------- + */ + +void +Tk_PhotoSetSize(handle, width, height) + Tk_PhotoHandle handle; /* Handle for the image whose size is to + * be set. */ + int width, height; /* New dimensions for the image. */ +{ + PhotoMaster *masterPtr; + + masterPtr = (PhotoMaster *) handle; + + masterPtr->userWidth = width; + masterPtr->userHeight = height; + ImgPhotoSetSize(masterPtr, ((width > 0) ? width: masterPtr->width), + ((height > 0) ? height: masterPtr->height)); + Tk_ImageChanged(masterPtr->tkMaster, 0, 0, 0, 0, + masterPtr->width, masterPtr->height); +} + +/* + *---------------------------------------------------------------------- + * + * Tk_PhotoGetImage -- + * + * This procedure is called to obtain image data from a photo + * image. This procedure fills in the Tk_PhotoImageBlock structure + * pointed to by `blockPtr' with details of the address and + * layout of the image data in memory. + * + * Results: + * TRUE (1) indicating that image data is available, + * for backwards compatibility with the old photo widget. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tk_PhotoGetImage(handle, blockPtr) + Tk_PhotoHandle handle; /* Handle for the photo image from which + * image data is desired. */ + Tk_PhotoImageBlock *blockPtr; + /* Information about the address and layout + * of the image data is returned here. */ +{ + PhotoMaster *masterPtr; + + masterPtr = (PhotoMaster *) handle; + blockPtr->pixelPtr = masterPtr->pix24; + blockPtr->width = masterPtr->width; + blockPtr->height = masterPtr->height; + blockPtr->pitch = masterPtr->width * 3; + blockPtr->pixelSize = 3; + blockPtr->offset[0] = 0; + blockPtr->offset[1] = 1; + blockPtr->offset[2] = 2; + return 1; +} diff --git a/tk4.2/generic/tkImgUtil.c b/tk4.2/generic/tkImgUtil.c new file mode 100644 index 0000000..31504b8 --- /dev/null +++ b/tk4.2/generic/tkImgUtil.c @@ -0,0 +1,78 @@ +/* + * tkImgUtil.c -- + * + * This file contains image related utility functions. + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkImgUtil.c 1.3 96/02/15 18:53:12 + */ + +#include "tkInt.h" +#include "tkPort.h" +#include "xbytes.h" + + +/* + *---------------------------------------------------------------------- + * + * TkAlignImageData -- + * + * This function takes an image and copies the data into an + * aligned buffer, performing any necessary bit swapping. + * + * Results: + * Returns a newly allocated buffer that should be freed by the + * caller. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +TkAlignImageData(image, alignment, bitOrder) + XImage *image; /* Image to be aligned. */ + int alignment; /* Number of bytes to which the data should + * be aligned (e.g. 2 or 4) */ + int bitOrder; /* Desired bit order: LSBFirst or MSBFirst. */ +{ + long dataWidth; + char *data, *srcPtr, *destPtr; + int i, j; + + if (image->bits_per_pixel != 1) { + panic("TkAlignImageData: Can't handle image depths greater than 1."); + } + + /* + * Compute line width for output data buffer. + */ + + dataWidth = image->bytes_per_line; + if (dataWidth % alignment) { + dataWidth += (alignment - (dataWidth % alignment)); + } + + data = ckalloc(dataWidth * image->height); + + destPtr = data; + for (i = 0; i < image->height; i++) { + srcPtr = &image->data[i * image->bytes_per_line]; + for (j = 0; j < dataWidth; j++) { + if (j >= image->bytes_per_line) { + *destPtr = 0; + } else if (image->bitmap_bit_order != bitOrder) { + *destPtr = xBitReverseTable[(unsigned char)(*(srcPtr++))]; + } else { + *destPtr = *(srcPtr++); + } + destPtr++; + } + } + return data; +} diff --git a/tk4.2/generic/tkInt.h b/tk4.2/generic/tkInt.h new file mode 100644 index 0000000..1d71cfc --- /dev/null +++ b/tk4.2/generic/tkInt.h @@ -0,0 +1,854 @@ +/* + * tkInt.h -- + * + * Declarations for things used internally by the Tk + * procedures but not exported outside the module. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkInt.h 1.172 96/10/12 17:29:48 + */ + +#ifndef _TKINT +#define _TKINT + +#ifndef _TK +#include "tk.h" +#endif +#ifndef _TCL +#include "tcl.h" +#endif +#ifndef _TKPORT +#include +#endif + +/* + * Opaque type declarations: + */ + +typedef struct TkColormap TkColormap; +typedef struct TkGrabEvent TkGrabEvent; +typedef struct Tk_PostscriptInfo Tk_PostscriptInfo; +typedef struct TkRegion_ *TkRegion; +typedef struct TkStressedCmap TkStressedCmap; + +/* + * One of the following structures is maintained for each cursor in + * use in the system. This structure is used by tkCursor.c and the + * various system specific cursor files. + */ + +typedef struct TkCursor { + Tk_Cursor cursor; /* System specific identifier for cursor. */ + int refCount; /* Number of active uses of cursor. */ + Tcl_HashTable *otherTable; /* Second table (other than idTable) used + * to index this entry. */ + Tcl_HashEntry *hashPtr; /* Entry in otherTable for this structure + * (needed when deleting). */ +} TkCursor; + +/* + * One of the following structures is maintained for each display + * containing a window managed by Tk: + */ + +typedef struct TkDisplay { + Display *display; /* Xlib's info about display. */ + struct TkDisplay *nextPtr; /* Next in list of all displays. */ + char *name; /* Name of display (with any screen + * identifier removed). Malloc-ed. */ + Time lastEventTime; /* Time of last event received for this + * display. */ + + /* + * Information used primarily by tkBind.c: + */ + + int bindInfoStale; /* Non-zero means the variables in this + * part of the structure are potentially + * incorrect and should be recomputed. */ + unsigned int modeModMask; /* Has one bit set to indicate the modifier + * corresponding to "mode shift". If no + * such modifier, than this is zero. */ + unsigned int metaModMask; /* Has one bit set to indicate the modifier + * corresponding to the "Meta" key. If no + * such modifier, then this is zero. */ + unsigned int altModMask; /* Has one bit set to indicate the modifier + * corresponding to the "Meta" key. If no + * such modifier, then this is zero. */ + enum {LU_IGNORE, LU_CAPS, LU_SHIFT} lockUsage; + /* Indicates how to interpret lock modifier. */ + int numModKeyCodes; /* Number of entries in modKeyCodes array + * below. */ + KeyCode *modKeyCodes; /* Pointer to an array giving keycodes for + * all of the keys that have modifiers + * associated with them. Malloc'ed, but + * may be NULL. */ + + /* + * Information used by tkError.c only: + */ + + struct TkErrorHandler *errorPtr; + /* First in list of error handlers + * for this display. NULL means + * no handlers exist at present. */ + int deleteCount; /* Counts # of handlers deleted since + * last time inactive handlers were + * garbage-collected. When this number + * gets big, handlers get cleaned up. */ + + /* + * Information used by tkSend.c only: + */ + + Tk_Window commTkwin; /* Window used for communication + * between interpreters during "send" + * commands. NULL means send info hasn't + * been initialized yet. */ + Atom commProperty; /* X's name for comm property. */ + Atom registryProperty; /* X's name for property containing + * registry of interpreter names. */ + Atom appNameProperty; /* X's name for property used to hold the + * application name on each comm window. */ + + /* + * Information used by tkSelect.c and tkClipboard.c only: + */ + + struct TkSelectionInfo *selectionInfoPtr; + /* First in list of selection information + * records. Each entry contains information + * about the current owner of a particular + * selection on this display. */ + Atom multipleAtom; /* Atom for MULTIPLE. None means + * selection stuff isn't initialized. */ + Atom incrAtom; /* Atom for INCR. */ + Atom targetsAtom; /* Atom for TARGETS. */ + Atom timestampAtom; /* Atom for TIMESTAMP. */ + Atom textAtom; /* Atom for TEXT. */ + Atom compoundTextAtom; /* Atom for COMPOUND_TEXT. */ + Atom applicationAtom; /* Atom for TK_APPLICATION. */ + Atom windowAtom; /* Atom for TK_WINDOW. */ + Atom clipboardAtom; /* Atom for CLIPBOARD. */ + + Tk_Window clipWindow; /* Window used for clipboard ownership and to + * retrieve selections between processes. NULL + * means clipboard info hasn't been + * initialized. */ + int clipboardActive; /* 1 means we currently own the clipboard + * selection, 0 means we don't. */ + struct TkMainInfo *clipboardAppPtr; + /* Last application that owned clipboard. */ + struct TkClipboardTarget *clipTargetPtr; + /* First in list of clipboard type information + * records. Each entry contains information + * about the buffers for a given selection + * target. */ + + /* + * Information used by tkAtom.c only: + */ + + int atomInit; /* 0 means stuff below hasn't been + * initialized yet. */ + Tcl_HashTable nameTable; /* Maps from names to Atom's. */ + Tcl_HashTable atomTable; /* Maps from Atom's back to names. */ + + /* + * Information used by tkCursor.c only: + */ + + Font cursorFont; /* Font to use for standard cursors. + * None means font not loaded yet. */ + + /* + * Information used by tkGrab.c only: + */ + + struct TkWindow *grabWinPtr; + /* Window in which the pointer is currently + * grabbed, or NULL if none. */ + struct TkWindow *eventualGrabWinPtr; + /* Value that grabWinPtr will have once the + * grab event queue (below) has been + * completely emptied. */ + struct TkWindow *buttonWinPtr; + /* Window in which first mouse button was + * pressed while grab was in effect, or NULL + * if no such press in effect. */ + struct TkWindow *serverWinPtr; + /* If no application contains the pointer then + * this is NULL. Otherwise it contains the + * last window for which we've gotten an + * Enter or Leave event from the server (i.e. + * the last window known to have contained + * the pointer). Doesn't reflect events + * that were synthesized in tkGrab.c. */ + TkGrabEvent *firstGrabEventPtr; + /* First in list of enter/leave events + * synthesized by grab code. These events + * must be processed in order before any other + * events are processed. NULL means no such + * events. */ + TkGrabEvent *lastGrabEventPtr; + /* Last in list of synthesized events, or NULL + * if list is empty. */ + int grabFlags; /* Miscellaneous flag values. See definitions + * in tkGrab.c. */ + + /* + * Information used by tkXId.c only: + */ + + struct TkIdStack *idStackPtr; + /* First in list of chunks of free resource + * identifiers, or NULL if there are no free + * resources. */ + XID (*defaultAllocProc) _ANSI_ARGS_((Display *display)); + /* Default resource allocator for display. */ + struct TkIdStack *windowStackPtr; + /* First in list of chunks of window + * identifers that can't be reused right + * now. */ + int idCleanupScheduled; /* 1 means a call to WindowIdCleanup has + * already been scheduled, 0 means it + * hasn't. */ + + /* + * Information maintained by tkWindow.c for use later on by tkXId.c: + */ + + + int destroyCount; /* Number of Tk_DestroyWindow operations + * in progress. */ + unsigned long lastDestroyRequest; + /* Id of most recent XDestroyWindow request; + * can re-use ids in windowStackPtr when + * server has seen this request and event + * queue is empty. */ + + /* + * Information used by tkVisual.c only: + */ + + TkColormap *cmapPtr; /* First in list of all non-default colormaps + * allocated for this display. */ + + /* + * Information used by tkFocus.c only: + */ + + struct TkWindow *focusWinPtr; + /* Window that currently has the focus for + * this display, or NULL if none. */ + struct TkWindow *implicitWinPtr; + /* If the focus arrived at a toplevel window + * implicitly via an Enter event (rather + * than via a FocusIn event), this points + * to the toplevel window. Otherwise it is + * NULL. */ + struct TkWindow *focusOnMapPtr; + /* This points to a toplevel window that is + * supposed to receive the X input focus as + * soon as it is mapped (needed to handle the + * fact that X won't allow the focus on an + * unmapped window). NULL means no delayed + * focus op in progress. */ + int forceFocus; /* Associated with focusOnMapPtr: non-zero + * means claim the focus even if some other + * application currently has it. */ + + /* + * Used by tkColor.c only: + */ + + TkStressedCmap *stressPtr; /* First in list of colormaps that have + * filled up, so we have to pick an + * approximate color. */ + + /* + * Used by tkEvent.c only: + */ + + struct TkWindowEvent *delayedMotionPtr; + /* Points to a malloc-ed motion event + * whose processing has been delayed in + * the hopes that another motion event + * will come along right away and we can + * merge the two of them together. NULL + * means that there is no delayed motion + * event. */ + + /* + * Miscellaneous information: + */ + +#ifdef TK_USE_INPUT_METHODS + XIM inputMethod; /* Input method for this display */ +#endif /* TK_USE_INPUT_METHODS */ + Tcl_HashTable winTable; /* Maps from X window ids to TkWindow ptrs. */ +} TkDisplay; + +/* + * One of the following structures exists for each error handler + * created by a call to Tk_CreateErrorHandler. The structure + * is managed by tkError.c. + */ + +typedef struct TkErrorHandler { + TkDisplay *dispPtr; /* Display to which handler applies. */ + unsigned long firstRequest; /* Only errors with serial numbers + * >= to this are considered. */ + unsigned long lastRequest; /* Only errors with serial numbers + * <= to this are considered. This + * field is filled in when XUnhandle + * is called. -1 means XUnhandle + * hasn't been called yet. */ + int error; /* Consider only errors with this + * error_code (-1 means consider + * all errors). */ + int request; /* Consider only errors with this + * major request code (-1 means + * consider all major codes). */ + int minorCode; /* Consider only errors with this + * minor request code (-1 means + * consider all minor codes). */ + Tk_ErrorProc *errorProc; /* Procedure to invoke when a matching + * error occurs. NULL means just ignore + * errors. */ + ClientData clientData; /* Arbitrary value to pass to + * errorProc. */ + struct TkErrorHandler *nextPtr; + /* Pointer to next older handler for + * this display, or NULL for end of + * list. */ +} TkErrorHandler; + +/* + * One of the following structures exists for each event handler + * created by calling Tk_CreateEventHandler. This information + * is used by tkEvent.c only. + */ + +typedef struct TkEventHandler { + unsigned long mask; /* Events for which to invoke + * proc. */ + Tk_EventProc *proc; /* Procedure to invoke when an event + * in mask occurs. */ + ClientData clientData; /* Argument to pass to proc. */ + struct TkEventHandler *nextPtr; + /* Next in list of handlers + * associated with window (NULL means + * end of list). */ +} TkEventHandler; + +/* + * Tk keeps one of the following data structures for each main + * window (created by a call to Tk_CreateMainWindow). It stores + * information that is shared by all of the windows associated + * with a particular main window. + */ + +typedef struct TkMainInfo { + int refCount; /* Number of windows whose "mainPtr" fields + * point here. When this becomes zero, can + * free up the structure (the reference + * count is zero because windows can get + * deleted in almost any order; the main + * window isn't necessarily the last one + * deleted). */ + struct TkWindow *winPtr; /* Pointer to main window. */ + Tcl_Interp *interp; /* Interpreter associated with application. */ + Tcl_HashTable nameTable; /* Hash table mapping path names to TkWindow + * structs for all windows related to this + * main window. Managed by tkWindow.c. */ + Tk_BindingTable bindingTable; + /* Used in conjunction with "bind" command + * to bind events to Tcl commands. */ + struct TkVirtualEventTable *vetPtr; + /* Hold definitions of virtual events. */ + struct TkFocusInfo *focusPtr; + /* First in list of records containing focus + * information for each top-level in the + * application. Used only by tkFocus.c. */ + unsigned long focusSerial; /* Serial number of last request we made to + * change the focus. Used to identify + * stale focus notifications coming from the + * X server. */ + struct TkWindow *lastFocusPtr; + /* The most recent window that was given the + * focus via "focus" command. Used to restore + * the focus when we get stale FocusIn + * events. */ + struct ElArray *optionRootPtr; + /* Top level of option hierarchy for this + * main window. NULL means uninitialized. + * Managed by tkOption.c. */ + Tcl_HashTable imageTable; /* Maps from image names to Tk_ImageMaster + * structures. Managed by tkImage.c. */ + int strictMotif; /* This is linked to the tk_strictMotif + * global variable. */ + struct TkMainInfo *nextPtr; /* Next in list of all main windows managed by + * this process. */ +} TkMainInfo; + +/* + * Tk keeps one of the following structures for each window. + * Some of the information (like size and location) is a shadow + * of information managed by the X server, and some is special + * information used here, such as event and geometry management + * information. This information is (mostly) managed by tkWindow.c. + * WARNING: the declaration below must be kept consistent with the + * Tk_FakeWin structure in tk.h. If you change one, be sure to + * change the other!! + */ + +typedef struct TkWindow { + + /* + * Structural information: + */ + + Display *display; /* Display containing window. */ + TkDisplay *dispPtr; /* Tk's information about display + * for window. */ + int screenNum; /* Index of screen for window, among all + * those for dispPtr. */ + Visual *visual; /* Visual to use for window. If not default, + * MUST be set before X window is created. */ + int depth; /* Number of bits/pixel. */ + Window window; /* X's id for window. NULL means window + * hasn't actually been created yet, or it's + * been deleted. */ + struct TkWindow *childList; /* First in list of child windows, + * or NULL if no children. */ + struct TkWindow *lastChildPtr; + /* Last in list of child windows, or NULL + * if no children. */ + struct TkWindow *parentPtr; /* Pointer to parent window (logical + * parent, not necessarily X parent). NULL + * means either this is the main window, or + * the window's parent has already been + * deleted. */ + struct TkWindow *nextPtr; /* Next in list of children with + * same parent (NULL if end of + * list). */ + TkMainInfo *mainPtr; /* Information shared by all windows + * associated with a particular main + * window. NULL means this window is + * a rogue that isn't associated with + * any application (at present, this + * only happens for the dummy windows + * used for "send" communication). */ + + /* + * Name and type information for the window: + */ + + char *pathName; /* Path name of window (concatenation + * of all names between this window and + * its top-level ancestor). This is a + * pointer into an entry in + * mainPtr->nameTable. NULL means that + * the window hasn't been completely + * created yet. */ + Tk_Uid nameUid; /* Name of the window within its parent + * (unique within the parent). */ + Tk_Uid classUid; /* Class of the window. NULL means window + * hasn't been given a class yet. */ + + /* + * Geometry and other attributes of window. This information + * may not be updated on the server immediately; stuff that + * hasn't been reflected in the server yet is called "dirty". + * At present, information can be dirty only if the window + * hasn't yet been created. + */ + + XWindowChanges changes; /* Geometry and other info about + * window. */ + unsigned int dirtyChanges; /* Bits indicate fields of "changes" + * that are dirty. */ + XSetWindowAttributes atts; /* Current attributes of window. */ + unsigned long dirtyAtts; /* Bits indicate fields of "atts" + * that are dirty. */ + + unsigned int flags; /* Various flag values: these are all + * defined in tk.h (confusing, but they're + * needed there for some query macros). */ + + /* + * Information kept by the event manager (tkEvent.c): + */ + + TkEventHandler *handlerList;/* First in list of event handlers + * declared for this window, or + * NULL if none. */ +#ifdef TK_USE_INPUT_METHODS + XIC inputContext; /* Input context (for input methods). */ +#endif /* TK_USE_INPUT_METHODS */ + + /* + * Information used for event bindings (see "bind" and "bindtags" + * commands in tkCmds.c): + */ + + ClientData *tagPtr; /* Points to array of tags used for bindings + * on this window. Each tag is a Tk_Uid. + * Malloc'ed. NULL means no tags. */ + int numTags; /* Number of tags at *tagPtr. */ + + /* + * Information used by tkOption.c to manage options for the + * window. + */ + + int optionLevel; /* -1 means no option information is + * currently cached for this window. + * Otherwise this gives the level in + * the option stack at which info is + * cached. */ + /* + * Information used by tkSelect.c to manage the selection. + */ + + struct TkSelHandler *selHandlerList; + /* First in list of handlers for + * returning the selection in various + * forms. */ + + /* + * Information used by tkGeometry.c for geometry management. + */ + + Tk_GeomMgr *geomMgrPtr; /* Information about geometry manager for + * this window. */ + ClientData geomData; /* Argument for geometry manager procedures. */ + int reqWidth, reqHeight; /* Arguments from last call to + * Tk_GeometryRequest, or 0's if + * Tk_GeometryRequest hasn't been + * called. */ + int internalBorderWidth; /* Width of internal border of window + * (0 means no internal border). Geometry + * managers should not normally place children + * on top of the border. */ + + /* + * Information maintained by tkWm.c for window manager communication. + */ + + struct TkWmInfo *wmInfoPtr; /* For top-level windows, points to + * structure with wm-related info (see + * tkWm.c). For other windows, this + * is NULL. */ + + /* + * Platform specific information private to each port. + */ + + struct TkWindowPrivate *privatePtr; +} TkWindow; + +/* + * The following structure is used as a two way map between integers + * and strings, usually to map between an internal C representation + * and the strings used in Tcl. + */ + +typedef struct TkStateMap { + int numKey; /* Integer representation of a value. */ + char *strKey; /* String representation of a value. */ +} TkStateMap; + +/* + * This structure is used by the Mac and Window porting layers as + * the internal representation of a clip_mask in a GC. + */ + +typedef struct TkpClipMask { + int type; /* One of TKP_CLIP_PIXMAP or TKP_CLIP_REGION */ + union { + Pixmap pixmap; + TkRegion region; + } value; +} TkpClipMask; + +#define TKP_CLIP_PIXMAP 0 +#define TKP_CLIP_REGION 1 + +/* + * Pointer to first entry in list of all displays currently known. + */ + +extern TkDisplay *tkDisplayList; + +/* + * Flags passed to TkMeasureChars: + */ + +#define TK_WHOLE_WORDS 1 +#define TK_AT_LEAST_ONE 2 +#define TK_PARTIAL_OK 4 +#define TK_NEWLINES_NOT_SPECIAL 8 +#define TK_IGNORE_TABS 16 + +/* + * Return values from TkGrabState: + */ + +#define TK_GRAB_NONE 0 +#define TK_GRAB_IN_TREE 1 +#define TK_GRAB_ANCESTOR 2 +#define TK_GRAB_EXCLUDED 3 + +/* + * 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)) + +/* + * Miscellaneous variables shared among Tk modules but not exported + * to the outside world: + */ + +extern Tk_Uid tkActiveUid; +extern Tk_ImageType tkBitmapImageType; +extern Tk_Uid tkDisabledUid; +extern Tk_PhotoImageFormat tkImgFmtGIF; +extern void (*tkHandleEventProc) _ANSI_ARGS_(( + XEvent* eventPtr)); +extern Tk_PhotoImageFormat tkImgFmtPPM; +extern TkMainInfo *tkMainWindowList; +extern Tk_Uid tkNormalUid; +extern Tk_ImageType tkPhotoImageType; +extern int tkSendSerial; + +/* + * Internal procedures shared among Tk modules but not exported + * to the outside world: + */ + +EXTERN char * TkAlignImageData _ANSI_ARGS_((XImage *image, + int alignment, int bitOrder)); +EXTERN int TkAreaToPolygon _ANSI_ARGS_((double *polyPtr, + int numPoints, double *rectPtr)); +EXTERN void TkBezierPoints _ANSI_ARGS_((double control[], + int numSteps, double *coordPtr)); +EXTERN void TkBezierScreenPoints _ANSI_ARGS_((Tk_Canvas canvas, + double control[], int numSteps, + XPoint *xPointPtr)); +EXTERN void TkBindEventProc _ANSI_ARGS_((TkWindow *winPtr, + XEvent *eventPtr)); +EXTERN void TkBindFree _ANSI_ARGS_((TkMainInfo *mainPtr)); +EXTERN void TkBindInit _ANSI_ARGS_((TkMainInfo *mainPtr)); +EXTERN void TkChangeEventWindow _ANSI_ARGS_((XEvent *eventPtr, + TkWindow *winPtr)); +#ifndef TkClipBox +EXTERN void TkClipBox _ANSI_ARGS_((TkRegion rgn, + XRectangle* rect_return)); +#endif +EXTERN int TkClipInit _ANSI_ARGS_((Tcl_Interp *interp, + TkDisplay *dispPtr)); +EXTERN int TkCmapStressed _ANSI_ARGS_((Tk_Window tkwin, + Colormap colormap)); +EXTERN void TkComputeTextGeometry _ANSI_ARGS_(( + XFontStruct *fontStructPtr, char *string, + int numChars, int wrapLength, int *widthPtr, + int *heightPtr)); +EXTERN void TkConsoleCreate _ANSI_ARGS_((void)); +EXTERN int TkConsoleInit _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN void TkConsolePrint _ANSI_ARGS_((Tcl_Interp *interp, + int devId, char *buffer, long size)); +EXTERN int TkCopyAndGlobalEval _ANSI_ARGS_((Tcl_Interp *interp, + char *script)); +EXTERN TkCursor * TkCreateCursorFromData _ANSI_ARGS_((Tk_Window tkwin, + char *source, char *mask, int width, int height, + int xHot, int yHot, XColor fg, XColor bg)); +EXTERN int TkCreateFrame _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv, + int toplevel, char *appName)); +EXTERN Tk_Window TkCreateMainWindow _ANSI_ARGS_((Tcl_Interp *interp, + char *screenName, char *baseName)); +#ifndef TkCreateRegion +EXTERN TkRegion TkCreateRegion _ANSI_ARGS_((void)); +#endif +EXTERN Time TkCurrentTime _ANSI_ARGS_((TkDisplay *dispPtr)); +EXTERN int TkDeadAppCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN void TkDeleteAllImages _ANSI_ARGS_((TkMainInfo *mainPtr)); +#ifndef TkDestroyRegion +EXTERN void TkDestroyRegion _ANSI_ARGS_((TkRegion rgn)); +#endif +EXTERN void TkDisplayChars _ANSI_ARGS_((Display *display, + Drawable drawable, GC gc, + XFontStruct *fontStructPtr, char *string, + int numChars, int x, int y, int tabOrigin, + int flags)); +EXTERN void TkDisplayText _ANSI_ARGS_((Display *display, + Drawable drawable, XFontStruct *fontStructPtr, + char *string, int numChars, int x, int y, + int length, Tk_Justify justify, int underline, + GC gc)); +EXTERN void TkEventCleanupProc _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp)); +EXTERN void TkEventDeadWindow _ANSI_ARGS_((TkWindow *winPtr)); +EXTERN void TkFillPolygon _ANSI_ARGS_((Tk_Canvas canvas, + double *coordPtr, int numPoints, Display *display, + Drawable drawable, GC gc, GC outlineGC)); +EXTERN int TkFindStateNum _ANSI_ARGS_((Tcl_Interp *interp, + CONST char *option, CONST TkStateMap *mapPtr, + CONST char *strKey)); +EXTERN char * TkFindStateString _ANSI_ARGS_(( + CONST TkStateMap *mapPtr, int numKey)); +EXTERN void TkFocusDeadWindow _ANSI_ARGS_((TkWindow *winPtr)); +EXTERN int TkFocusFilterEvent _ANSI_ARGS_((TkWindow *winPtr, + XEvent *eventPtr)); +EXTERN void TkFreeBindingTags _ANSI_ARGS_((TkWindow *winPtr)); +EXTERN void TkFreeWindowId _ANSI_ARGS_((TkDisplay *dispPtr, + Window w)); +EXTERN void TkFreeCursor _ANSI_ARGS_((TkCursor *cursorPtr)); +EXTERN char * TkGetBitmapData _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char *fileName, int *widthPtr, + int *heightPtr, int *hotXPtr, int *hotYPtr)); +EXTERN void TkGetButtPoints _ANSI_ARGS_((double p1[], double p2[], + double width, int project, double m1[], + double m2[])); +EXTERN TkCursor * TkGetCursorByName _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, Tk_Uid string)); +EXTERN char * TkGetDefaultScreenName _ANSI_ARGS_((Tcl_Interp *interp, + char *screenName)); +EXTERN TkDisplay * TkGetDisplay _ANSI_ARGS_((Display *display)); +EXTERN TkWindow * TkGetFocus _ANSI_ARGS_((TkWindow *winPtr)); +EXTERN int TkGetInterpNames _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin)); +EXTERN int TkGetMiterPoints _ANSI_ARGS_((double p1[], double p2[], + double p3[], double width, double m1[], + double m2[])); +#ifndef TkGetNativeProlog +EXTERN int TkGetNativeProlog _ANSI_ARGS_((Tcl_Interp *interp)); +#endif +EXTERN void TkGetPointerCoords _ANSI_ARGS_((Tk_Window tkwin, + int *xPtr, int *yPtr)); +EXTERN int TkGetProlog _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN void TkGetServerInfo _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin)); +EXTERN void TkGrabDeadWindow _ANSI_ARGS_((TkWindow *winPtr)); +EXTERN int TkGrabState _ANSI_ARGS_((TkWindow *winPtr)); +EXTERN TkWindow * TkIDToWindow _ANSI_ARGS_((Window window, + TkDisplay *display)); +EXTERN void TkIncludePoint _ANSI_ARGS_((Tk_Item *itemPtr, + double *pointPtr)); +EXTERN void TkInitXId _ANSI_ARGS_((TkDisplay *dispPtr)); +EXTERN void TkInOutEvents _ANSI_ARGS_((XEvent *eventPtr, + TkWindow *sourcePtr, TkWindow *destPtr, + int leaveType, int enterType, + Tcl_QueuePosition position)); +#ifndef TkIntersectRegion +EXTERN void TkIntersectRegion _ANSI_ARGS_((TkRegion sra, + TkRegion srcb, TkRegion dr_return)); +#endif +EXTERN char * TkKeysymToString _ANSI_ARGS_((KeySym keysym)); +EXTERN int TkLineToArea _ANSI_ARGS_((double end1Ptr[2], + double end2Ptr[2], double rectPtr[4])); +EXTERN double TkLineToPoint _ANSI_ARGS_((double end1Ptr[2], + double end2Ptr[2], double pointPtr[2])); +EXTERN int TkMakeBezierCurve _ANSI_ARGS_((Tk_Canvas canvas, + double *pointPtr, int numPoints, int numSteps, + XPoint xPoints[], double dblPoints[])); +EXTERN void TkMakeBezierPostscript _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, double *pointPtr, + int numPoints)); +EXTERN Window TkMakeWindow _ANSI_ARGS_((TkWindow *winPtr, + Window parent)); +EXTERN int TkMeasureChars _ANSI_ARGS_((XFontStruct *fontStructPtr, + char *source, int maxChars, int startX, int maxX, + int tabOrigin, int flags, int *nextXPtr)); +EXTERN void TkOptionClassChanged _ANSI_ARGS_((TkWindow *winPtr)); +EXTERN void TkOptionDeadWindow _ANSI_ARGS_((TkWindow *winPtr)); +EXTERN int TkOvalToArea _ANSI_ARGS_((double *ovalPtr, + double *rectPtr)); +EXTERN double TkOvalToPoint _ANSI_ARGS_((double ovalPtr[4], + double width, int filled, double pointPtr[2])); +EXTERN int TkPlatformInit _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int TkPointerEvent _ANSI_ARGS_((XEvent *eventPtr, + TkWindow *winPtr)); +EXTERN int TkPolygonToArea _ANSI_ARGS_((double *polyPtr, + int numPoints, double *rectPtr)); +EXTERN double TkPolygonToPoint _ANSI_ARGS_((double *polyPtr, + int numPoints, double *pointPtr)); +EXTERN int TkPositionInTree _ANSI_ARGS_((TkWindow *winPtr, + TkWindow *treePtr)); +#ifndef TkPutImage +EXTERN void TkPutImage _ANSI_ARGS_((unsigned long *colors, + int ncolors, Display* display, Drawable d, + GC gc, XImage* image, int src_x, int src_y, + int dest_x, int dest_y, unsigned int width, + unsigned int height)); +#endif +#ifndef TkRectInRegion +EXTERN int TkRectInRegion _ANSI_ARGS_((TkRegion rgn, + int x, int y, unsigned int width, + unsigned int height)); +#endif +EXTERN void TkQueueEventForAllChildren _ANSI_ARGS_(( + Tk_Window tkwin, XEvent *eventPtr)); +EXTERN int TkScrollWindow _ANSI_ARGS_((Tk_Window tkwin, GC gc, + int x, int y, int width, int height, int dx, + int dy, TkRegion damageRgn)); +EXTERN void TkSelDeadWindow _ANSI_ARGS_((TkWindow *winPtr)); +EXTERN void TkSelEventProc _ANSI_ARGS_((Tk_Window tkwin, + XEvent *eventPtr)); +EXTERN void TkSelInit _ANSI_ARGS_((Tk_Window tkwin)); +#ifndef TkSetPixmapColormap +EXTERN void TkSetPixmapColormap _ANSI_ARGS_((Pixmap pixmap, + Colormap colormap)); +#endif +#ifndef TkSetRegion +EXTERN void TkSetRegion _ANSI_ARGS_((Display* display, GC gc, + TkRegion rgn)); +#endif +EXTERN void TkSelPropProc _ANSI_ARGS_((XEvent *eventPtr)); +EXTERN int TkThickPolyLineToArea _ANSI_ARGS_((double *coordPtr, + int numPoints, double width, int capStyle, + int joinStyle, double *rectPtr)); +EXTERN KeySym TkStringToKeysym _ANSI_ARGS_((char *name)); +EXTERN void TkUnderlineChars _ANSI_ARGS_((Display *display, + Drawable drawable, GC gc, + XFontStruct *fontStructPtr, char *string, + int x, int y, int tabOrigin, int flags, + int firstChar, int lastChar)); +#ifndef TkUnionRectWithRegion +EXTERN void TkUnionRectWithRegion _ANSI_ARGS_((XRectangle* rect, + TkRegion src, TkRegion dr_return)); +#endif +EXTERN void TkWmAddToColormapWindows _ANSI_ARGS_(( + TkWindow *winPtr)); +EXTERN void TkWmDeadWindow _ANSI_ARGS_((TkWindow *winPtr)); +EXTERN void TkWmMapWindow _ANSI_ARGS_((TkWindow *winPtr)); +EXTERN void TkWmNewWindow _ANSI_ARGS_((TkWindow *winPtr)); +EXTERN void TkWmProtocolEventProc _ANSI_ARGS_((TkWindow *winPtr, + XEvent *evenvPtr)); +EXTERN void TkWmRemoveFromColormapWindows _ANSI_ARGS_(( + TkWindow *winPtr)); +EXTERN void TkWmRestackToplevel _ANSI_ARGS_((TkWindow *winPtr, + int aboveBelow, TkWindow *otherPtr)); +EXTERN void TkWmSetClass _ANSI_ARGS_((TkWindow *winPtr)); +EXTERN void TkWmUnmapWindow _ANSI_ARGS_((TkWindow *winPtr)); +EXTERN int TkXFileProc _ANSI_ARGS_((ClientData clientData, + int mask, int flags)); + +/* + * Unsupported commands. + */ +EXTERN int TkUnsupported1Cmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +#endif /* _TKINT */ diff --git a/tk3.6/tkListbox.c b/tk4.2/generic/tkListbox.c similarity index 57% rename from tk3.6/tkListbox.c rename to tk4.2/generic/tkListbox.c index 3cb21e2..3bdcc08 100644 --- a/tk3.6/tkListbox.c +++ b/tk4.2/generic/tkListbox.c @@ -5,32 +5,16 @@ * toolkit. A listbox displays a collection of strings, * one per line, and provides scrolling and selection. * - * Copyright (c) 1990-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tkListbox.c 1.109 96/05/17 16:26:55 */ -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkListbox.c,v 1.69 93/07/15 16:39:21 ouster Exp $ SPRITE (Berkeley)"; -#endif - -#include "tkConfig.h" +#include "tkPort.h" #include "default.h" #include "tkInt.h" @@ -45,6 +29,8 @@ typedef struct Element { * origin to left edge of character. */ int pixelWidth; /* Total width of element in pixels (including * left bearing and right bearing). */ + int selected; /* 1 means this item is selected, 0 means + * it isn't. */ struct Element *nextPtr; /* Next in list of all elements of this * listbox, or NULL for last element. */ char text[4]; /* Characters of this element, NULL- @@ -71,9 +57,12 @@ typedef struct { * other things, so that resources can be * freed even after tkwin has gone away. */ Tcl_Interp *interp; /* Interpreter associated with listbox. */ + Tcl_Command widgetCmd; /* Token for listbox's widget command. */ int numElements; /* Total number of elements in this listbox. */ - Element *elementPtr; /* First in list of elements (NULL if no - * elements. */ + Element *firstPtr; /* First in list of elements (NULL if no + * elements). */ + Element *lastPtr; /* Last in list of elements (NULL if no + * elements). */ /* * Information used when displaying widget: @@ -83,6 +72,18 @@ typedef struct { * window, plus used for background. */ int borderWidth; /* Width of 3-D border around window. */ int relief; /* 3-D effect: TK_RELIEF_RAISED, etc. */ + int highlightWidth; /* Width in pixels of highlight to draw + * around widget when it has the focus. + * <= 0 means don't draw a highlight. */ + XColor *highlightBgColorPtr; + /* Color for drawing traversal highlight + * area when highlight is off. */ + XColor *highlightColorPtr; /* Color for drawing traversal highlight. */ + int inset; /* Total width of all borders, including + * traversal highlight and 3-D border. + * Indicates how much interior stuff must + * be offset from outside edges to leave + * room for borders. */ XFontStruct *fontPtr; /* Information about text font, or NULL. */ XColor *fgColorPtr; /* Text color in normal mode. */ GC textGC; /* For drawing normal text. */ @@ -91,13 +92,20 @@ typedef struct { int selBorderWidth; /* Width of border around selection. */ XColor *selFgColorPtr; /* Foreground color for selected elements. */ GC selTextGC; /* For drawing selected text. */ - char *geometry; /* Desired geometry for window. Malloc'ed. */ + int width; /* Desired width of window, in characters. */ + int height; /* Desired height of window, in lines. */ int lineHeight; /* Number of pixels allocated for each line * in display. */ int topIndex; /* Index of top-most element visible in * window. */ - int numLines; /* Number of lines (elements) that fit - * in window at one time. */ + int fullLines; /* Number of lines that fit are completely + * visible in window. There may be one + * additional line at the bottom that is + * partially visible. */ + int partialLine; /* 0 means that the window holds exactly + * fullLines lines. 1 means that there is + * one additional line that is partially + * visble. */ int setGrid; /* Non-zero means pass gridding information * to window manager. */ @@ -117,16 +125,20 @@ typedef struct { * means there is an offset). */ /* - * Information about what's selected, if any. + * Information about what's selected or active, if any. */ - int selectFirst; /* Index of first selected element (-1 means - * nothing selected. */ - int selectLast; /* Index of last selected element. */ + Tk_Uid selectMode; /* Selection style: single, browse, multiple, + * or extended. This value isn't used in C + * code, but the Tcl bindings use it. */ + int numSelected; /* Number of elements currently selected. */ int selectAnchor; /* Fixed end of selection (i.e. element * at which selection was started.) */ int exportSelection; /* Non-zero means tie internal listbox * to X selection. */ + int active; /* Index of "active" element (the one that + * has been selected by keyboard traversal). + * -1 means none. */ /* * Information for scanning: @@ -145,7 +157,10 @@ typedef struct { * Miscellaneous information: */ - Cursor cursor; /* Current cursor for window, or None. */ + Tk_Cursor cursor; /* Current cursor for window, or None. */ + char *takeFocus; /* Value of -takefocus option; not used in + * the C code, but used by keyboard traversal + * scripts. Malloc'ed, but may be NULL. */ char *yScrollCmd; /* Command prefix for communicating with * vertical scrollbar. NULL means no command * to issue. Malloc'ed. */ @@ -157,7 +172,7 @@ typedef struct { } Listbox; /* - * Flag bits for buttons: + * Flag bits for listboxes: * * REDRAW_PENDING: Non-zero means a DoWhenIdle handler * has already been queued to redraw @@ -166,11 +181,14 @@ typedef struct { * to be updated. * UPDATE_H_SCROLLBAR: Non-zero means horizontal scrollbar needs * to be updated. + * GOT_FOCUS: Non-zero means this widget currently + * has the input focus. */ #define REDRAW_PENDING 1 #define UPDATE_V_SCROLLBAR 2 #define UPDATE_H_SCROLLBAR 4 +#define GOT_FOCUS 8 /* * Information used for argv parsing: @@ -200,8 +218,16 @@ static Tk_ConfigSpec configSpecs[] = { DEF_LISTBOX_FONT, Tk_Offset(Listbox, fontPtr), 0}, {TK_CONFIG_COLOR, "-foreground", "foreground", "Foreground", DEF_LISTBOX_FG, Tk_Offset(Listbox, fgColorPtr), 0}, - {TK_CONFIG_STRING, "-geometry", "geometry", "Geometry", - DEF_LISTBOX_GEOMETRY, Tk_Offset(Listbox, geometry), 0}, + {TK_CONFIG_INT, "-height", "height", "Height", + DEF_LISTBOX_HEIGHT, Tk_Offset(Listbox, height), 0}, + {TK_CONFIG_COLOR, "-highlightbackground", "highlightBackground", + "HighlightBackground", DEF_LISTBOX_HIGHLIGHT_BG, + Tk_Offset(Listbox, highlightBgColorPtr), 0}, + {TK_CONFIG_COLOR, "-highlightcolor", "highlightColor", "HighlightColor", + DEF_LISTBOX_HIGHLIGHT, Tk_Offset(Listbox, highlightColorPtr), 0}, + {TK_CONFIG_PIXELS, "-highlightthickness", "highlightThickness", + "HighlightThickness", + DEF_LISTBOX_HIGHLIGHT_WIDTH, Tk_Offset(Listbox, highlightWidth), 0}, {TK_CONFIG_RELIEF, "-relief", "relief", "Relief", DEF_LISTBOX_RELIEF, Tk_Offset(Listbox, relief), 0}, {TK_CONFIG_BORDER, "-selectbackground", "selectBackground", "Foreground", @@ -218,8 +244,15 @@ static Tk_ConfigSpec configSpecs[] = { {TK_CONFIG_COLOR, "-selectforeground", "selectForeground", "Background", DEF_LISTBOX_SELECT_FG_MONO, Tk_Offset(Listbox, selFgColorPtr), TK_CONFIG_MONO_ONLY}, + {TK_CONFIG_UID, "-selectmode", "selectMode", "SelectMode", + DEF_LISTBOX_SELECT_MODE, Tk_Offset(Listbox, selectMode), 0}, {TK_CONFIG_BOOLEAN, "-setgrid", "setGrid", "SetGrid", DEF_LISTBOX_SET_GRID, Tk_Offset(Listbox, setGrid), 0}, + {TK_CONFIG_STRING, "-takefocus", "takeFocus", "TakeFocus", + DEF_LISTBOX_TAKE_FOCUS, Tk_Offset(Listbox, takeFocus), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_INT, "-width", "width", "Width", + DEF_LISTBOX_WIDTH, Tk_Offset(Listbox, width), 0}, {TK_CONFIG_STRING, "-xscrollcommand", "xScrollCommand", "ScrollCommand", DEF_LISTBOX_SCROLL_COMMAND, Tk_Offset(Listbox, xScrollCmd), TK_CONFIG_NULL_OK}, @@ -243,15 +276,17 @@ static int ConfigureListbox _ANSI_ARGS_((Tcl_Interp *interp, int flags)); static void DeleteEls _ANSI_ARGS_((Listbox *listPtr, int first, int last)); -static void DestroyListbox _ANSI_ARGS_((ClientData clientData)); +static void DestroyListbox _ANSI_ARGS_((char *memPtr)); static void DisplayListbox _ANSI_ARGS_((ClientData clientData)); static int GetListboxIndex _ANSI_ARGS_((Tcl_Interp *interp, - Listbox *listPtr, char *string, int endAfter, + Listbox *listPtr, char *string, int numElsOK, int *indexPtr)); static void InsertEls _ANSI_ARGS_((Listbox *listPtr, int index, int argc, char **argv)); -static void ListboxComputeWidths _ANSI_ARGS_((Listbox *listPtr, - int fontChanged)); +static void ListboxCmdDeletedProc _ANSI_ARGS_(( + ClientData clientData)); +static void ListboxComputeGeometry _ANSI_ARGS_((Listbox *listPtr, + int fontChanged, int maxIsStale, int updateGrid)); static void ListboxEventProc _ANSI_ARGS_((ClientData clientData, XEvent *eventPtr)); static int ListboxFetchSelection _ANSI_ARGS_(( @@ -263,10 +298,8 @@ static void ListboxRedrawRange _ANSI_ARGS_((Listbox *listPtr, int first, int last)); static void ListboxScanTo _ANSI_ARGS_((Listbox *listPtr, int x, int y)); -static void ListboxSelectFrom _ANSI_ARGS_((Listbox *listPtr, - int index)); -static void ListboxSelectTo _ANSI_ARGS_((Listbox *listPtr, - int index)); +static void ListboxSelect _ANSI_ARGS_((Listbox *listPtr, + int first, int last, int select)); static void ListboxUpdateHScrollbar _ANSI_ARGS_((Listbox *listPtr)); static void ListboxUpdateVScrollbar _ANSI_ARGS_((Listbox *listPtr)); static int ListboxWidgetCmd _ANSI_ARGS_((ClientData clientData, @@ -325,11 +358,19 @@ Tk_ListboxCmd(clientData, interp, argc, argv) listPtr->tkwin = new; listPtr->display = Tk_Display(new); listPtr->interp = interp; + listPtr->widgetCmd = Tcl_CreateCommand(interp, + Tk_PathName(listPtr->tkwin), ListboxWidgetCmd, + (ClientData) listPtr, ListboxCmdDeletedProc); listPtr->numElements = 0; - listPtr->elementPtr = NULL; + listPtr->firstPtr = NULL; + listPtr->lastPtr = NULL; listPtr->normalBorder = NULL; listPtr->borderWidth = 0; listPtr->relief = TK_RELIEF_RAISED; + listPtr->highlightWidth = 0; + listPtr->highlightBgColorPtr = NULL; + listPtr->highlightColorPtr = NULL; + listPtr->inset = 0; listPtr->fontPtr = NULL; listPtr->fgColorPtr = NULL; listPtr->textGC = None; @@ -337,34 +378,37 @@ Tk_ListboxCmd(clientData, interp, argc, argv) listPtr->selBorderWidth = 0; listPtr->selFgColorPtr = None; listPtr->selTextGC = None; - listPtr->geometry = NULL; + listPtr->width = 0; + listPtr->height = 0; listPtr->lineHeight = 0; listPtr->topIndex = 0; - listPtr->numLines = 0; + listPtr->fullLines = 1; + listPtr->partialLine = 0; listPtr->setGrid = 0; listPtr->maxWidth = 0; listPtr->xScrollUnit = 0; listPtr->xOffset = 0; - listPtr->selectFirst = -1; - listPtr->selectLast = -1; + listPtr->selectMode = NULL; + listPtr->numSelected = 0; listPtr->selectAnchor = 0; listPtr->exportSelection = 1; + listPtr->active = 0; listPtr->scanMarkX = 0; listPtr->scanMarkY = 0; listPtr->scanMarkXOffset = 0; listPtr->scanMarkYIndex = 0; listPtr->cursor = None; + listPtr->takeFocus = NULL; listPtr->xScrollCmd = NULL; listPtr->yScrollCmd = NULL; listPtr->flags = 0; Tk_SetClass(listPtr->tkwin, "Listbox"); - Tk_CreateEventHandler(listPtr->tkwin, ExposureMask|StructureNotifyMask, + Tk_CreateEventHandler(listPtr->tkwin, + ExposureMask|StructureNotifyMask|FocusChangeMask, ListboxEventProc, (ClientData) listPtr); - Tk_CreateSelHandler(listPtr->tkwin, XA_STRING, ListboxFetchSelection, - (ClientData) listPtr, XA_STRING); - Tcl_CreateCommand(interp, Tk_PathName(listPtr->tkwin), ListboxWidgetCmd, - (ClientData) listPtr, (void (*)()) NULL); + Tk_CreateSelHandler(listPtr->tkwin, XA_PRIMARY, XA_STRING, + ListboxFetchSelection, (ClientData) listPtr, XA_STRING); if (ConfigureListbox(interp, listPtr, argc-2, argv+2, 0) != TCL_OK) { goto error; } @@ -404,18 +448,69 @@ ListboxWidgetCmd(clientData, interp, argc, argv) { register Listbox *listPtr = (Listbox *) clientData; int result = TCL_OK; - int length; - char c; + size_t length; + int c; if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " option ?arg arg ...?\"", (char *) NULL); return TCL_ERROR; } - Tk_Preserve((ClientData) listPtr); + Tcl_Preserve((ClientData) listPtr); c = argv[1][0]; length = strlen(argv[1]); - if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0) + if ((c == 'a') && (strncmp(argv[1], "activate", length) == 0)) { + int index; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " activate index\"", + (char *) NULL); + goto error; + } + ListboxRedrawRange(listPtr, listPtr->active, listPtr->active); + if (GetListboxIndex(interp, listPtr, argv[2], 0, &index) + != TCL_OK) { + goto error; + } + listPtr->active = index; + ListboxRedrawRange(listPtr, listPtr->active, listPtr->active); + } else if ((c == 'b') && (strncmp(argv[1], "bbox", length) == 0)) { + int index, x, y, i; + Element *elPtr; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " bbox index\"", (char *) NULL); + goto error; + } + if (GetListboxIndex(interp, listPtr, argv[2], 0, &index) != TCL_OK) { + goto error; + } + for (i = 0, elPtr = listPtr->firstPtr; i < index; + i++, elPtr = elPtr->nextPtr) { + /* Empty loop body. */ + } + if ((index >= listPtr->topIndex) && (index < listPtr->numElements) + && (index < (listPtr->topIndex + listPtr->fullLines + + listPtr->partialLine))) { + x = listPtr->inset - listPtr->xOffset; + y = ((index - listPtr->topIndex)*listPtr->lineHeight) + + listPtr->inset + listPtr->selBorderWidth; + sprintf(interp->result, "%d %d %d %d", x, y, elPtr->pixelWidth, + listPtr->fontPtr->ascent + listPtr->fontPtr->descent); + } + } else if ((c == 'c') && (strncmp(argv[1], "cget", length) == 0) + && (length >= 2)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " cget option\"", + (char *) NULL); + goto error; + } + result = Tk_ConfigureValue(interp, listPtr->tkwin, configSpecs, + (char *) listPtr, argv[2], 0); + } else if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0) && (length >= 2)) { if (argc == 2) { result = Tk_ConfigureInfo(interp, listPtr->tkwin, configSpecs, @@ -429,8 +524,9 @@ ListboxWidgetCmd(clientData, interp, argc, argv) } } else if ((c == 'c') && (strncmp(argv[1], "curselection", length) == 0) && (length >= 2)) { - int i; + int i, count; char index[20]; + Element *elPtr; if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", @@ -438,12 +534,18 @@ ListboxWidgetCmd(clientData, interp, argc, argv) (char *) NULL); goto error; } - if (listPtr->selectFirst != -1) { - for (i = listPtr->selectFirst; i <= listPtr->selectLast; i++) { + count = 0; + for (i = 0, elPtr = listPtr->firstPtr; elPtr != NULL; + i++, elPtr = elPtr->nextPtr) { + if (elPtr->selected) { sprintf(index, "%d", i); Tcl_AppendElement(interp, index); + count++; } } + if (count != listPtr->numSelected) { + panic("ListboxWidgetCmd: selection count incorrect"); + } } else if ((c == 'd') && (strncmp(argv[1], "delete", length) == 0)) { int first, last; @@ -465,31 +567,51 @@ ListboxWidgetCmd(clientData, interp, argc, argv) } DeleteEls(listPtr, first, last); } else if ((c == 'g') && (strncmp(argv[1], "get", length) == 0)) { - int index; - register Element *elPtr; + int first, last, i; + Element *elPtr; - if (argc != 3) { + if ((argc != 3) && (argc != 4)) { Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " get index\"", (char *) NULL); + argv[0], " get first ?last?\"", (char *) NULL); goto error; } - if (GetListboxIndex(interp, listPtr, argv[2], 0, &index) != TCL_OK) { + if (GetListboxIndex(interp, listPtr, argv[2], 0, &first) != TCL_OK) { goto error; } - if (index < 0) { - index = 0; + if ((argc == 4) && (GetListboxIndex(interp, listPtr, argv[3], + 0, &last) != TCL_OK)) { + goto error; } - if (index >= listPtr->numElements) { - index = listPtr->numElements-1; - } - for (elPtr = listPtr->elementPtr; index > 0; - index--, elPtr = elPtr->nextPtr) { + for (elPtr = listPtr->firstPtr, i = 0; i < first; + i++, elPtr = elPtr->nextPtr) { /* Empty loop body. */ } if (elPtr != NULL) { - interp->result = elPtr->text; + if (argc == 3) { + interp->result = elPtr->text; + } else { + for ( ; i <= last; i++, elPtr = elPtr->nextPtr) { + Tcl_AppendElement(interp, elPtr->text); + } + } } - } else if ((c == 'i') && (strncmp(argv[1], "insert", length) == 0)) { + } else if ((c == 'i') && (strncmp(argv[1], "index", length) == 0) + && (length >= 3)) { + int index; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " index index\"", + (char *) NULL); + goto error; + } + if (GetListboxIndex(interp, listPtr, argv[2], 1, &index) + != TCL_OK) { + goto error; + } + sprintf(interp->result, "%d", index); + } else if ((c == 'i') && (strncmp(argv[1], "insert", length) == 0) + && (length >= 3)) { int index; if (argc < 3) { @@ -540,107 +662,208 @@ ListboxWidgetCmd(clientData, interp, argc, argv) ListboxScanTo(listPtr, x, y); } else { Tcl_AppendResult(interp, "bad scan option \"", argv[2], - "\": must be mark or dragto", (char *) NULL); + "\": must be mark or dragto", (char *) NULL); goto error; } - } else if ((c == 's') && (length >= 2) - && (strncmp(argv[1], "select", length) == 0)) { - int index; - - if (argc < 3) { - Tcl_AppendResult(interp, "too few args: should be \"", - argv[0], " select option ?index?\"", (char *) NULL); - goto error; - } - length = strlen(argv[2]); - c = argv[2][0]; - if ((c == 'c') && (argv[2] != NULL) - && (strncmp(argv[2], "clear", length) == 0)) { - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " select clear\"", (char *) NULL); - goto error; - } - if (listPtr->selectFirst != -1) { - ListboxRedrawRange(listPtr, listPtr->selectFirst, - listPtr->selectLast); - listPtr->selectFirst = -1; - } - goto done; - } - if (argc != 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " select option index\"", (char *) NULL); - goto error; - } - if ((c == 'a') && (strncmp(argv[2], "adjust", length) == 0)) { - if (GetListboxIndex(interp, listPtr, argv[3], 1, &index) - != TCL_OK) { - goto error; - } - if (index < (listPtr->selectFirst + listPtr->selectLast)/2) { - listPtr->selectAnchor = listPtr->selectLast; - } else { - listPtr->selectAnchor = listPtr->selectFirst; - } - ListboxSelectTo(listPtr, index); - } else if ((c == 'f') && (strncmp(argv[2], "from", length) == 0)) { - if (GetListboxIndex(interp, listPtr, argv[3], 0, &index) - != TCL_OK) { - goto error; - } - ListboxSelectFrom(listPtr, index); - } else if ((c == 't') && (strncmp(argv[2], "to", length) == 0)) { - if (GetListboxIndex(interp, listPtr, argv[3], 1, &index) - != TCL_OK) { - goto error; - } - ListboxSelectTo(listPtr, index); - } else { - Tcl_AppendResult(interp, "bad select option \"", argv[2], - "\": must be adjust, clear, from, or to", (char *) NULL); - goto error; - } - } else if ((c == 's') && (length >= 2) - && (strncmp(argv[1], "size", length) == 0)) { - sprintf(interp->result, "%d", listPtr->numElements); - } else if ((c == 'x') && (strncmp(argv[1], "xview", length) == 0)) { - int index; - + } else if ((c == 's') && (strncmp(argv[1], "see", length) == 0) + && (length >= 3)) { + int index, diff; if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " xview index\"", (char *) NULL); - goto error; - } - if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) { - goto error; - } - ChangeListboxOffset(listPtr, index*listPtr->xScrollUnit); - } else if ((c == 'y') && (strncmp(argv[1], "yview", length) == 0)) { - int index; - - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " yview index\"", (char *) NULL); + argv[0], " see index\"", + (char *) NULL); goto error; } if (GetListboxIndex(interp, listPtr, argv[2], 0, &index) != TCL_OK) { goto error; } - ChangeListboxView(listPtr, index); + diff = listPtr->topIndex-index; + if (diff > 0) { + if (diff <= (listPtr->fullLines/3)) { + ChangeListboxView(listPtr, index); + } else { + ChangeListboxView(listPtr, index - (listPtr->fullLines-1)/2); + } + } else { + diff = index - (listPtr->topIndex + listPtr->fullLines - 1); + if (diff > 0) { + if (diff <= (listPtr->fullLines/3)) { + ChangeListboxView(listPtr, listPtr->topIndex + diff); + } else { + ChangeListboxView(listPtr, + index - (listPtr->fullLines-1)/2); + } + } + } + } else if ((c == 's') && (length >= 3) + && (strncmp(argv[1], "selection", length) == 0)) { + int first, last; + + if ((argc != 4) && (argc != 5)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " selection option index ?index?\"", + (char *) NULL); + goto error; + } + if (GetListboxIndex(interp, listPtr, argv[3], 0, &first) != TCL_OK) { + goto error; + } + if (argc == 5) { + if (GetListboxIndex(interp, listPtr, argv[4], 0, &last) != TCL_OK) { + goto error; + } + } else { + last = first; + } + length = strlen(argv[2]); + c = argv[2][0]; + if ((c == 'a') && (strncmp(argv[2], "anchor", length) == 0)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " selection anchor index\"", (char *) NULL); + goto error; + } + listPtr->selectAnchor = first; + } else if ((c == 'c') && (strncmp(argv[2], "clear", length) == 0)) { + ListboxSelect(listPtr, first, last, 0); + } else if ((c == 'i') && (strncmp(argv[2], "includes", length) == 0)) { + int i; + Element *elPtr; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " selection includes index\"", (char *) NULL); + goto error; + } + for (elPtr = listPtr->firstPtr, i = 0; i < first; + i++, elPtr = elPtr->nextPtr) { + /* Empty loop body. */ + } + if ((elPtr != NULL) && (elPtr->selected)) { + interp->result = "1"; + } else { + interp->result = "0"; + } + } else if ((c == 's') && (strncmp(argv[2], "set", length) == 0)) { + ListboxSelect(listPtr, first, last, 1); + } else { + Tcl_AppendResult(interp, "bad selection option \"", argv[2], + "\": must be anchor, clear, includes, or set", + (char *) NULL); + goto error; + } + } else if ((c == 's') && (length >= 2) + && (strncmp(argv[1], "size", length) == 0)) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " size\"", (char *) NULL); + goto error; + } + sprintf(interp->result, "%d", listPtr->numElements); + } else if ((c == 'x') && (strncmp(argv[1], "xview", length) == 0)) { + int index, count, type, windowWidth, windowUnits; + int offset = 0; /* Initialized to stop gcc warnings. */ + double fraction, fraction2; + + windowWidth = Tk_Width(listPtr->tkwin) + - 2*(listPtr->inset + listPtr->selBorderWidth); + if (argc == 2) { + if (listPtr->maxWidth == 0) { + interp->result = "0 1"; + } else { + fraction = listPtr->xOffset/((double) listPtr->maxWidth); + fraction2 = (listPtr->xOffset + windowWidth) + /((double) listPtr->maxWidth); + if (fraction2 > 1.0) { + fraction2 = 1.0; + } + sprintf(interp->result, "%g %g", fraction, fraction2); + } + } else if (argc == 3) { + if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) { + goto error; + } + ChangeListboxOffset(listPtr, index*listPtr->xScrollUnit); + } else { + type = Tk_GetScrollInfo(interp, argc, argv, &fraction, &count); + switch (type) { + case TK_SCROLL_ERROR: + goto error; + case TK_SCROLL_MOVETO: + offset = fraction*listPtr->maxWidth + 0.5; + break; + case TK_SCROLL_PAGES: + windowUnits = windowWidth/listPtr->xScrollUnit; + if (windowUnits > 2) { + offset = listPtr->xOffset + + count*listPtr->xScrollUnit*(windowUnits-2); + } else { + offset = listPtr->xOffset + count*listPtr->xScrollUnit; + } + break; + case TK_SCROLL_UNITS: + offset = listPtr->xOffset + count*listPtr->xScrollUnit; + break; + } + ChangeListboxOffset(listPtr, offset); + } + } else if ((c == 'y') && (strncmp(argv[1], "yview", length) == 0)) { + int index, count, type; + double fraction, fraction2; + + if (argc == 2) { + if (listPtr->numElements == 0) { + interp->result = "0 1"; + } else { + fraction = listPtr->topIndex/((double) listPtr->numElements); + fraction2 = (listPtr->topIndex+listPtr->fullLines) + /((double) listPtr->numElements); + if (fraction2 > 1.0) { + fraction2 = 1.0; + } + sprintf(interp->result, "%g %g", fraction, fraction2); + } + } else if (argc == 3) { + if (GetListboxIndex(interp, listPtr, argv[2], 0, &index) + != TCL_OK) { + goto error; + } + ChangeListboxView(listPtr, index); + } else { + type = Tk_GetScrollInfo(interp, argc, argv, &fraction, &count); + switch (type) { + case TK_SCROLL_ERROR: + goto error; + case TK_SCROLL_MOVETO: + index = listPtr->numElements*fraction + 0.5; + break; + case TK_SCROLL_PAGES: + if (listPtr->fullLines > 2) { + index = listPtr->topIndex + + count*(listPtr->fullLines-2); + } else { + index = listPtr->topIndex + count; + } + break; + case TK_SCROLL_UNITS: + index = listPtr->topIndex + count; + break; + } + ChangeListboxView(listPtr, index); + } } else { Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be configure, curselection, delete, get, ", - "insert, nearest, scan, select, size, ", + "\": must be activate, bbox, cget, configure, ", + "curselection, delete, get, index, insert, nearest, ", + "scan, see, selection, size, ", "xview, or yview", (char *) NULL); goto error; } - done: - Tk_Release((ClientData) listPtr); + Tcl_Release((ClientData) listPtr); return result; error: - Tk_Release((ClientData) listPtr); + Tcl_Release((ClientData) listPtr); return TCL_ERROR; } @@ -649,7 +872,7 @@ ListboxWidgetCmd(clientData, interp, argc, argv) * * DestroyListbox -- * - * This procedure is invoked by Tk_EventuallyFree or Tk_Release + * This procedure is invoked by Tcl_EventuallyFree or Tcl_Release * to clean up the internal structure of a listbox at a safe time * (when no-one is using it anymore). * @@ -663,17 +886,17 @@ ListboxWidgetCmd(clientData, interp, argc, argv) */ static void -DestroyListbox(clientData) - ClientData clientData; /* Info about listbox widget. */ +DestroyListbox(memPtr) + char *memPtr; /* Info about listbox widget. */ { - register Listbox *listPtr = (Listbox *) clientData; + register Listbox *listPtr = (Listbox *) memPtr; register Element *elPtr, *nextPtr; /* * Free up all of the list elements. */ - for (elPtr = listPtr->elementPtr; elPtr != NULL; ) { + for (elPtr = listPtr->firstPtr; elPtr != NULL; ) { nextPtr = elPtr->nextPtr; ckfree((char *) elPtr); elPtr = nextPtr; @@ -727,8 +950,7 @@ ConfigureListbox(interp, listPtr, argc, argv, flags) { XGCValues gcValues; GC new; - int width, height, fontHeight, oldExport; - int pixelWidth, pixelHeight; + int oldExport; oldExport = listPtr->exportSelection; if (Tk_ConfigureWidget(interp, listPtr->tkwin, configSpecs, @@ -737,12 +959,17 @@ ConfigureListbox(interp, listPtr, argc, argv, flags) } /* - * A few options need special processing, such as parsing the - * geometry and setting the background from a 3-D border. + * A few options need special processing, such as setting the + * background from a 3-D border. */ Tk_SetBackgroundFromBorder(listPtr->tkwin, listPtr->normalBorder); + if (listPtr->highlightWidth < 0) { + listPtr->highlightWidth = 0; + } + listPtr->inset = listPtr->highlightWidth + listPtr->borderWidth; + gcValues.foreground = listPtr->fgColorPtr->pixel; gcValues.font = listPtr->fontPtr->fid; gcValues.graphics_exposures = False; @@ -762,43 +989,22 @@ ConfigureListbox(interp, listPtr, argc, argv, flags) listPtr->selTextGC = new; /* - * Claim the selection if we've suddenly started exporting it. + * Claim the selection if we've suddenly started exporting it and + * there is a selection to export. */ - if (listPtr->exportSelection && (!oldExport) - && (listPtr->selectFirst !=-1)) { - Tk_OwnSelection(listPtr->tkwin, ListboxLostSelection, + if (listPtr->exportSelection && !oldExport + && (listPtr->numSelected != 0)) { + Tk_OwnSelection(listPtr->tkwin, XA_PRIMARY, ListboxLostSelection, (ClientData) listPtr); } /* - * Register the desired geometry for the window, and arrange for + * Register the desired geometry for the window and arrange for * the window to be redisplayed. */ - if ((sscanf(listPtr->geometry, "%dx%d", &width, &height) != 2) - || (width <= 0) || (height <= 0)) { - Tcl_AppendResult(interp, "bad geometry \"", - listPtr->geometry, "\"", (char *) NULL); - return TCL_ERROR; - } - fontHeight = listPtr->fontPtr->ascent + listPtr->fontPtr->descent; - listPtr->lineHeight = fontHeight + 1 + 2*listPtr->selBorderWidth; - listPtr->numLines = (Tk_Height(listPtr->tkwin) - 2*listPtr->borderWidth) - / listPtr->lineHeight; - if (listPtr->numLines < 0) { - listPtr->numLines = 0; - } - ListboxComputeWidths(listPtr, 1); - pixelWidth = width*listPtr->xScrollUnit + 2*listPtr->borderWidth - + 2*listPtr->selBorderWidth; - pixelHeight = height*listPtr->lineHeight + 2*listPtr->borderWidth; - Tk_GeometryRequest(listPtr->tkwin, pixelWidth, pixelHeight); - Tk_SetInternalBorder(listPtr->tkwin, listPtr->borderWidth); - if (listPtr->setGrid) { - Tk_SetGrid(listPtr->tkwin, width, height, listPtr->xScrollUnit, - listPtr->lineHeight); - } + ListboxComputeGeometry(listPtr, 1, 1, 1); listPtr->flags |= UPDATE_V_SCROLLBAR|UPDATE_H_SCROLLBAR; ListboxRedrawRange(listPtr, 0, listPtr->numElements-1); return TCL_OK; @@ -828,7 +1034,10 @@ DisplayListbox(clientData) register Tk_Window tkwin = listPtr->tkwin; register Element *elPtr; GC gc; - int i, limit, x, y, margin; + int i, limit, x, y, width, prevSelected; + int left, right; /* Non-zero values here indicate + * that the left or right edge of + * the listbox is off-screen. */ Pixmap pixmap; listPtr->flags &= ~REDRAW_PENDING; @@ -851,11 +1060,10 @@ DisplayListbox(clientData) * possible visual effects (no flashing on the screen). */ - pixmap = XCreatePixmap(listPtr->display, Tk_WindowId(tkwin), + pixmap = Tk_GetPixmap(listPtr->display, Tk_WindowId(tkwin), Tk_Width(tkwin), Tk_Height(tkwin), Tk_Depth(tkwin)); - Tk_Fill3DRectangle(listPtr->display, pixmap, listPtr->normalBorder, - 0, 0, Tk_Width(tkwin), Tk_Height(tkwin), listPtr->borderWidth, - listPtr->relief); + Tk_Fill3DRectangle(tkwin, pixmap, listPtr->normalBorder, 0, 0, + Tk_Width(tkwin), Tk_Height(tkwin), 0, TK_RELIEF_FLAT); /* * Iterate through all of the elements of the listbox, displaying each @@ -863,33 +1071,89 @@ DisplayListbox(clientData) * background. */ - limit = listPtr->topIndex + listPtr->numLines - 1; + limit = listPtr->topIndex + listPtr->fullLines + listPtr->partialLine - 1; if (limit >= listPtr->numElements) { limit = listPtr->numElements-1; } - margin = listPtr->selBorderWidth + listPtr->xScrollUnit/2; - for (elPtr = listPtr->elementPtr, i = 0; (elPtr != NULL) && (i <= limit); - elPtr = elPtr->nextPtr, i++) { + left = right = 0; + if (listPtr->xOffset > 0) { + left = listPtr->selBorderWidth+1; + } + if ((listPtr->maxWidth - listPtr->xOffset) > (Tk_Width(listPtr->tkwin) + - 2*(listPtr->inset + listPtr->selBorderWidth))) { + right = listPtr->selBorderWidth+1; + } + prevSelected = 0; + for (elPtr = listPtr->firstPtr, i = 0; (elPtr != NULL) && (i <= limit); + prevSelected = elPtr->selected, elPtr = elPtr->nextPtr, i++) { if (i < listPtr->topIndex) { continue; } - x = listPtr->borderWidth; + x = listPtr->inset; y = ((i - listPtr->topIndex) * listPtr->lineHeight) - + listPtr->borderWidth; + + listPtr->inset; gc = listPtr->textGC; - if ((listPtr->selectFirst >= 0) && (i >= listPtr->selectFirst) - && (i <= listPtr->selectLast)) { + if (elPtr->selected) { gc = listPtr->selTextGC; - Tk_Fill3DRectangle(listPtr->display, pixmap, - listPtr->selBorder, x, y, - Tk_Width(tkwin) - 2*listPtr->borderWidth, - listPtr->lineHeight, listPtr->selBorderWidth, - TK_RELIEF_RAISED); + width = Tk_Width(tkwin) - 2*listPtr->inset; + Tk_Fill3DRectangle(tkwin, pixmap, listPtr->selBorder, x, y, + width, listPtr->lineHeight, 0, TK_RELIEF_FLAT); + + /* + * Draw beveled edges around the selection, if there are visible + * edges next to this element. Special considerations: + * 1. The left and right bevels may not be visible if horizontal + * scrolling is enabled (the "left" and "right" variables + * are zero to indicate that the corresponding bevel is + * visible). + * 2. Top and bottom bevels are only drawn if this is the + * first or last seleted item. + * 3. If the left or right bevel isn't visible, then the "left" + * and "right" variables, computed above, have non-zero values + * that extend the top and bottom bevels so that the mitered + * corners are off-screen. + */ + + if (left == 0) { + Tk_3DVerticalBevel(tkwin, pixmap, listPtr->selBorder, + x, y, listPtr->selBorderWidth, listPtr->lineHeight, + 1, TK_RELIEF_RAISED); + } + if (right == 0) { + Tk_3DVerticalBevel(tkwin, pixmap, listPtr->selBorder, + x + width - listPtr->selBorderWidth, y, + listPtr->selBorderWidth, listPtr->lineHeight, + 0, TK_RELIEF_RAISED); + } + if (!prevSelected) { + Tk_3DHorizontalBevel(tkwin, pixmap, listPtr->selBorder, + x-left, y, width+left+right, listPtr->selBorderWidth, + 1, 1, 1, TK_RELIEF_RAISED); + } + if ((elPtr->nextPtr == NULL) || !elPtr->nextPtr->selected) { + Tk_3DHorizontalBevel(tkwin, pixmap, listPtr->selBorder, x-left, + y + listPtr->lineHeight - listPtr->selBorderWidth, + width+left+right, listPtr->selBorderWidth, 0, 0, 0, + TK_RELIEF_RAISED); + } } y += listPtr->fontPtr->ascent + listPtr->selBorderWidth; - x += margin - elPtr->lBearing - listPtr->xOffset; + x = listPtr->inset + listPtr->selBorderWidth - elPtr->lBearing + - listPtr->xOffset; XDrawString(listPtr->display, pixmap, gc, x, y, elPtr->text, elPtr->textLength); + + /* + * If this is the active element, underline it. + */ + + if ((i == listPtr->active) && (listPtr->flags & GOT_FOCUS)) { + XFillRectangle(listPtr->display, pixmap, gc, + listPtr->inset + listPtr->selBorderWidth + - listPtr->xOffset, + y + listPtr->fontPtr->descent - 1, + (unsigned) elPtr->pixelWidth, 1); + } } /* @@ -897,14 +1161,112 @@ DisplayListbox(clientData) * of any of the text of the listbox entries. */ - Tk_Draw3DRectangle(listPtr->display, pixmap, - listPtr->normalBorder, 0, 0, Tk_Width(tkwin), - Tk_Height(tkwin), listPtr->borderWidth, - listPtr->relief); + Tk_Draw3DRectangle(tkwin, pixmap, listPtr->normalBorder, + listPtr->highlightWidth, listPtr->highlightWidth, + Tk_Width(tkwin) - 2*listPtr->highlightWidth, + Tk_Height(tkwin) - 2*listPtr->highlightWidth, + listPtr->borderWidth, listPtr->relief); + if (listPtr->highlightWidth > 0) { + GC gc; + + if (listPtr->flags & GOT_FOCUS) { + gc = Tk_GCForColor(listPtr->highlightColorPtr, pixmap); + } else { + gc = Tk_GCForColor(listPtr->highlightBgColorPtr, pixmap); + } + Tk_DrawFocusHighlight(tkwin, gc, listPtr->highlightWidth, pixmap); + } XCopyArea(listPtr->display, pixmap, Tk_WindowId(tkwin), - listPtr->textGC, 0, 0, Tk_Width(tkwin), Tk_Height(tkwin), - 0, 0); - XFreePixmap(listPtr->display, pixmap); + listPtr->textGC, 0, 0, (unsigned) Tk_Width(tkwin), + (unsigned) Tk_Height(tkwin), 0, 0); + Tk_FreePixmap(listPtr->display, pixmap); +} + +/* + *---------------------------------------------------------------------- + * + * ListboxComputeGeometry -- + * + * This procedure is invoked to recompute geometry information + * such as the sizes of the elements and the overall dimensions + * desired for the listbox. + * + * Results: + * None. + * + * Side effects: + * Geometry information is updated and a new requested size is + * registered for the widget. Internal border and gridding + * information is also set. + * + *---------------------------------------------------------------------- + */ + +static void +ListboxComputeGeometry(listPtr, fontChanged, maxIsStale, updateGrid) + Listbox *listPtr; /* Listbox whose geometry is to be + * recomputed. */ + int fontChanged; /* Non-zero means the font may have changed + * so per-element width information also + * has to be computed. */ + int maxIsStale; /* Non-zero means the "maxWidth" field may + * no longer be up-to-date and must + * be recomputed. If fontChanged is 1 then + * this must be 1. */ + int updateGrid; /* Non-zero means call Tk_SetGrid or + * Tk_UnsetGrid to update gridding for + * the window. */ +{ + register Element *elPtr; + int dummy, fontHeight, width, height, pixelWidth, pixelHeight; + XCharStruct bbox; + + if (fontChanged || maxIsStale) { + listPtr->xScrollUnit = XTextWidth(listPtr->fontPtr, "0", 1); + listPtr->maxWidth = 0; + for (elPtr = listPtr->firstPtr; elPtr != NULL; elPtr = elPtr->nextPtr) { + if (fontChanged) { + XTextExtents(listPtr->fontPtr, elPtr->text, elPtr->textLength, + &dummy, &dummy, &dummy, &bbox); + elPtr->lBearing = bbox.lbearing; + elPtr->pixelWidth = bbox.rbearing - bbox.lbearing; + } + if (elPtr->pixelWidth > listPtr->maxWidth) { + listPtr->maxWidth = elPtr->pixelWidth; + } + } + } + + fontHeight = listPtr->fontPtr->ascent + listPtr->fontPtr->descent; + listPtr->lineHeight = fontHeight + 1 + 2*listPtr->selBorderWidth; + width = listPtr->width; + if (width <= 0) { + width = (listPtr->maxWidth + listPtr->xScrollUnit - 1) + /listPtr->xScrollUnit; + if (width < 1) { + width = 1; + } + } + pixelWidth = width*listPtr->xScrollUnit + 2*listPtr->inset + + 2*listPtr->selBorderWidth; + height = listPtr->height; + if (listPtr->height <= 0) { + height = listPtr->numElements; + if (height < 1) { + height = 1; + } + } + pixelHeight = height*listPtr->lineHeight + 2*listPtr->inset; + Tk_GeometryRequest(listPtr->tkwin, pixelWidth, pixelHeight); + Tk_SetInternalBorder(listPtr->tkwin, listPtr->inset); + if (updateGrid) { + if (listPtr->setGrid) { + Tk_SetGrid(listPtr->tkwin, width, height, listPtr->xScrollUnit, + listPtr->lineHeight); + } else { + Tk_UnsetGrid(listPtr->tkwin); + } + } } /* @@ -949,8 +1311,10 @@ InsertEls(listPtr, index, argc, argv) } if (index == 0) { prevPtr = NULL; + } else if (index == listPtr->numElements) { + prevPtr = listPtr->lastPtr; } else { - for (prevPtr = listPtr->elementPtr, i = index - 1; i > 0; i--) { + for (prevPtr = listPtr->firstPtr, i = index - 1; i > 0; i--) { prevPtr = prevPtr->nextPtr; } } @@ -973,31 +1337,44 @@ InsertEls(listPtr, index, argc, argv) if (newPtr->pixelWidth > listPtr->maxWidth) { listPtr->maxWidth = newPtr->pixelWidth; } + newPtr->selected = 0; if (prevPtr == NULL) { - newPtr->nextPtr = listPtr->elementPtr; - listPtr->elementPtr = newPtr; + newPtr->nextPtr = listPtr->firstPtr; + listPtr->firstPtr = newPtr; } else { newPtr->nextPtr = prevPtr->nextPtr; prevPtr->nextPtr = newPtr; } } + if ((prevPtr != NULL) && (prevPtr->nextPtr == NULL)) { + listPtr->lastPtr = prevPtr; + } listPtr->numElements += argc; /* - * Update the selection to account for the renumbering that has just - * occurred. Then arrange for the new information to be displayed. + * Update the selection and other indexes to account for the + * renumbering that has just occurred. Then arrange for the new + * information to be displayed. */ - if (index <= listPtr->selectFirst) { - listPtr->selectFirst += argc; + if (index <= listPtr->selectAnchor) { + listPtr->selectAnchor += argc; } - if (index <= listPtr->selectLast) { - listPtr->selectLast += argc; + if (index < listPtr->topIndex) { + listPtr->topIndex += argc; + } + if (index <= listPtr->active) { + listPtr->active += argc; + if ((listPtr->active >= listPtr->numElements) + && (listPtr->numElements > 0)) { + listPtr->active = listPtr->numElements-1; + } } listPtr->flags |= UPDATE_V_SCROLLBAR; if (listPtr->maxWidth != oldMaxWidth) { listPtr->flags |= UPDATE_H_SCROLLBAR; } + ListboxComputeGeometry(listPtr, 0, 0, 0); ListboxRedrawRange(listPtr, index, listPtr->numElements-1); } @@ -1050,7 +1427,7 @@ DeleteEls(listPtr, first, last) if (first == 0) { prevPtr = NULL; } else { - for (i = first-1, prevPtr = listPtr->elementPtr; i > 0; i--) { + for (i = first-1, prevPtr = listPtr->firstPtr; i > 0; i--) { prevPtr = prevPtr->nextPtr; } } @@ -1062,15 +1439,24 @@ DeleteEls(listPtr, first, last) widthChanged = 0; for (i = count; i > 0; i--) { if (prevPtr == NULL) { - elPtr = listPtr->elementPtr; - listPtr->elementPtr = elPtr->nextPtr; + elPtr = listPtr->firstPtr; + listPtr->firstPtr = elPtr->nextPtr; + if (listPtr->firstPtr == NULL) { + listPtr->lastPtr = NULL; + } } else { elPtr = prevPtr->nextPtr; prevPtr->nextPtr = elPtr->nextPtr; + if (prevPtr->nextPtr == NULL) { + listPtr->lastPtr = prevPtr; + } } if (elPtr->pixelWidth == listPtr->maxWidth) { widthChanged = 1; } + if (elPtr->selected) { + listPtr->numSelected -= 1; + } ckfree((char *) elPtr); } listPtr->numElements -= count; @@ -1081,30 +1467,36 @@ DeleteEls(listPtr, first, last) * the elements that were deleted. */ - if (first <= listPtr->selectFirst) { - listPtr->selectFirst -= count; - if (listPtr->selectFirst < first) { - listPtr->selectFirst = first; + if (first <= listPtr->selectAnchor) { + listPtr->selectAnchor -= count; + if (listPtr->selectAnchor < first) { + listPtr->selectAnchor = first; } } - if (first <= listPtr->selectLast) { - listPtr->selectLast -= count; - if (listPtr->selectLast < first) { - listPtr->selectLast = first-1; - } - } - if (listPtr->selectLast < listPtr->selectFirst) { - listPtr->selectFirst = -1; - } if (first <= listPtr->topIndex) { listPtr->topIndex -= count; if (listPtr->topIndex < first) { listPtr->topIndex = first; } } + if (listPtr->topIndex > (listPtr->numElements - listPtr->fullLines)) { + listPtr->topIndex = listPtr->numElements - listPtr->fullLines; + if (listPtr->topIndex < 0) { + listPtr->topIndex = 0; + } + } + if (listPtr->active > last) { + listPtr->active -= count; + } else if (listPtr->active >= first) { + listPtr->active = first; + if ((listPtr->active >= listPtr->numElements) + && (listPtr->numElements > 0)) { + listPtr->active = listPtr->numElements-1; + } + } listPtr->flags |= UPDATE_V_SCROLLBAR; + ListboxComputeGeometry(listPtr, 0, widthChanged, 0); if (widthChanged) { - ListboxComputeWidths(listPtr, 0); listPtr->flags |= UPDATE_H_SCROLLBAR; } ListboxRedrawRange(listPtr, first, listPtr->numElements-1); @@ -1141,19 +1533,91 @@ ListboxEventProc(clientData, eventPtr) NearestListboxElement(listPtr, eventPtr->xexpose.y + eventPtr->xexpose.height)); } else if (eventPtr->type == DestroyNotify) { - Tcl_DeleteCommand(listPtr->interp, Tk_PathName(listPtr->tkwin)); - listPtr->tkwin = NULL; - if (listPtr->flags & REDRAW_PENDING) { - Tk_CancelIdleCall(DisplayListbox, (ClientData) listPtr); + if (listPtr->tkwin != NULL) { + if (listPtr->setGrid) { + Tk_UnsetGrid(listPtr->tkwin); + } + listPtr->tkwin = NULL; + Tcl_DeleteCommand(listPtr->interp, + Tcl_GetCommandName(listPtr->interp, listPtr->widgetCmd)); } - Tk_EventuallyFree((ClientData) listPtr, DestroyListbox); + if (listPtr->flags & REDRAW_PENDING) { + Tcl_CancelIdleCall(DisplayListbox, (ClientData) listPtr); + } + Tcl_EventuallyFree((ClientData) listPtr, DestroyListbox); } else if (eventPtr->type == ConfigureNotify) { - Tk_Preserve((ClientData) listPtr); - listPtr->numLines = (Tk_Height(listPtr->tkwin) - - 2*listPtr->borderWidth) / listPtr->lineHeight; + int vertSpace; + + vertSpace = Tk_Height(listPtr->tkwin) - 2*listPtr->inset; + listPtr->fullLines = vertSpace / listPtr->lineHeight; + if ((listPtr->fullLines*listPtr->lineHeight) < vertSpace) { + listPtr->partialLine = 1; + } else { + listPtr->partialLine = 0; + } listPtr->flags |= UPDATE_V_SCROLLBAR|UPDATE_H_SCROLLBAR; + ChangeListboxView(listPtr, listPtr->topIndex); + ChangeListboxOffset(listPtr, listPtr->xOffset); + + /* + * Redraw the whole listbox. It's hard to tell what needs + * to be redrawn (e.g. if the listbox has shrunk then we + * may only need to redraw the borders), so just redraw + * everything for safety. + */ + ListboxRedrawRange(listPtr, 0, listPtr->numElements-1); - Tk_Release((ClientData) listPtr); + } else if (eventPtr->type == FocusIn) { + if (eventPtr->xfocus.detail != NotifyInferior) { + listPtr->flags |= GOT_FOCUS; + ListboxRedrawRange(listPtr, 0, listPtr->numElements-1); + } + } else if (eventPtr->type == FocusOut) { + if (eventPtr->xfocus.detail != NotifyInferior) { + listPtr->flags &= ~GOT_FOCUS; + ListboxRedrawRange(listPtr, 0, listPtr->numElements-1); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * ListboxCmdDeletedProc -- + * + * This procedure is invoked when a widget command is deleted. If + * the widget isn't already in the process of being destroyed, + * this command destroys it. + * + * Results: + * None. + * + * Side effects: + * The widget is destroyed. + * + *---------------------------------------------------------------------- + */ + +static void +ListboxCmdDeletedProc(clientData) + ClientData clientData; /* Pointer to widget record for widget. */ +{ + Listbox *listPtr = (Listbox *) clientData; + Tk_Window tkwin = listPtr->tkwin; + + /* + * This procedure could be invoked either because the window was + * destroyed and the command was then deleted (in which case tkwin + * is NULL) or because the command was deleted, and then this procedure + * destroys the widget. + */ + + if (tkwin != NULL) { + if (listPtr->setGrid) { + Tk_UnsetGrid(listPtr->tkwin); + } + listPtr->tkwin = NULL; + Tk_DestroyWindow(tkwin); } } @@ -1177,38 +1641,68 @@ ListboxEventProc(clientData, eventPtr) */ static int -GetListboxIndex(interp, listPtr, string, endAfter, indexPtr) +GetListboxIndex(interp, listPtr, string, numElsOK, indexPtr) Tcl_Interp *interp; /* For error messages. */ Listbox *listPtr; /* Listbox for which the index is being * specified. */ - char *string; /* Numerical index into listPtr's element - * list, or "end" to refer to last element. */ - int endAfter; /* 0 means "end" refers to the index of the - * last element, 1 means it refers to the - * element after the last one. */ + char *string; /* Specifies an element in the listbox. */ + int numElsOK; /* 0 means the return value must be less + * less than the number of entries in + * the listbox; 1 means it may also be + * equal to the number of entries. */ int *indexPtr; /* Where to store converted index. */ { - if (string[0] == 'e') { - if (strncmp(string, "end", strlen(string)) != 0) { - badIndex: - Tcl_AppendResult(interp, "bad listbox index \"", string, - "\"", (char *) NULL); - return TCL_ERROR; - } + int c; + size_t length; + + length = strlen(string); + c = string[0]; + if ((c == 'a') && (strncmp(string, "active", length) == 0) + && (length >= 2)) { + *indexPtr = listPtr->active; + } else if ((c == 'a') && (strncmp(string, "anchor", length) == 0) + && (length >= 2)) { + *indexPtr = listPtr->selectAnchor; + } else if ((c == 'e') && (strncmp(string, "end", length) == 0)) { *indexPtr = listPtr->numElements; - if (!endAfter) { - *indexPtr -= 1; + } else if (c == '@') { + int x, y; + char *p, *end; + + p = string+1; + x = strtol(p, &end, 0); + if ((end == p) || (*end != ',')) { + goto badIndex; } - if (listPtr->numElements <= 0) { - *indexPtr = 0; + p = end+1; + y = strtol(p, &end, 0); + if ((end == p) || (*end != 0)) { + goto badIndex; } + *indexPtr = NearestListboxElement(listPtr, y); } else { if (Tcl_GetInt(interp, string, indexPtr) != TCL_OK) { Tcl_ResetResult(interp); goto badIndex; } } + if (numElsOK) { + if (*indexPtr > listPtr->numElements) { + *indexPtr = listPtr->numElements; + } + } else if (*indexPtr >= listPtr->numElements) { + *indexPtr = listPtr->numElements-1; + } + if (*indexPtr < 0) { + *indexPtr = 0; + } return TCL_OK; + + badIndex: + Tcl_AppendResult(interp, "bad listbox index \"", string, + "\": must be active, anchor, end, @x,y, or a number", + (char *) NULL); + return TCL_ERROR; } /* @@ -1216,7 +1710,8 @@ GetListboxIndex(interp, listPtr, string, endAfter, indexPtr) * * ChangeListboxView -- * - * Change the view on a listbox widget. + * Change the view on a listbox widget so that a given element + * is displayed at the top. * * Results: * None. @@ -1232,10 +1727,12 @@ GetListboxIndex(interp, listPtr, string, endAfter, indexPtr) static void ChangeListboxView(listPtr, index) register Listbox *listPtr; /* Information about widget. */ - int index; /* Index of element in listPtr. */ + int index; /* Index of element in listPtr + * that should now appear at the + * top of the listbox. */ { - if (index >= listPtr->numElements) { - index = listPtr->numElements-1; + if (index >= (listPtr->numElements - listPtr->fullLines)) { + index = listPtr->numElements - listPtr->fullLines; } if (index < 0) { index = 0; @@ -1243,7 +1740,7 @@ ChangeListboxView(listPtr, index) if (listPtr->topIndex != index) { listPtr->topIndex = index; if (!(listPtr->flags & REDRAW_PENDING)) { - Tk_DoWhenIdle(DisplayListbox, (ClientData) listPtr); + Tcl_DoWhenIdle(DisplayListbox, (ClientData) listPtr); listPtr->flags |= REDRAW_PENDING; } listPtr->flags |= UPDATE_V_SCROLLBAR; @@ -1281,7 +1778,7 @@ ChangeListboxOffset(listPtr, offset) */ maxOffset = listPtr->maxWidth + (listPtr->xScrollUnit-1) - - (Tk_Width(listPtr->tkwin) - 2*listPtr->borderWidth + - (Tk_Width(listPtr->tkwin) - 2*listPtr->inset - 2*listPtr->selBorderWidth - listPtr->xScrollUnit); if (offset > maxOffset) { offset = maxOffset; @@ -1322,7 +1819,12 @@ ListboxScanTo(listPtr, x, y) int y; /* Y-coordinate to use for scan * operation. */ { - int newTopIndex, newOffset; + int newTopIndex, newOffset, maxIndex, maxOffset; + + maxIndex = listPtr->numElements - listPtr->fullLines; + maxOffset = listPtr->maxWidth + (listPtr->xScrollUnit-1) + - (Tk_Width(listPtr->tkwin) - 2*listPtr->inset + - 2*listPtr->selBorderWidth - listPtr->xScrollUnit); /* * Compute new top line for screen by amplifying the difference @@ -1337,8 +1839,8 @@ ListboxScanTo(listPtr, x, y) newTopIndex = listPtr->scanMarkYIndex - (10*(y - listPtr->scanMarkY))/listPtr->lineHeight; - if (newTopIndex >= listPtr->numElements) { - newTopIndex = listPtr->scanMarkYIndex = listPtr->numElements-1; + if (newTopIndex > maxIndex) { + newTopIndex = listPtr->scanMarkYIndex = maxIndex; listPtr->scanMarkY = y; } else if (newTopIndex < 0) { newTopIndex = listPtr->scanMarkYIndex = 0; @@ -1353,8 +1855,8 @@ ListboxScanTo(listPtr, x, y) */ newOffset = listPtr->scanMarkXOffset - (10*(x - listPtr->scanMarkX)); - if (newOffset >= listPtr->maxWidth) { - newOffset = listPtr->scanMarkXOffset = listPtr->maxWidth; + if (newOffset > maxOffset) { + newOffset = listPtr->scanMarkXOffset = maxOffset; listPtr->scanMarkX = x; } else if (newOffset < 0) { newOffset = listPtr->scanMarkXOffset = 0; @@ -1389,9 +1891,9 @@ NearestListboxElement(listPtr, y) { int index; - index = (y - listPtr->borderWidth)/listPtr->lineHeight; - if (index >= listPtr->numLines) { - index = listPtr->numLines-1; + index = (y - listPtr->inset)/listPtr->lineHeight; + if (index >= (listPtr->fullLines + listPtr->partialLine)) { + index = listPtr->fullLines + listPtr->partialLine - 1; } if (index < 0) { index = 0; @@ -1406,120 +1908,69 @@ NearestListboxElement(listPtr, y) /* *---------------------------------------------------------------------- * - * ListboxSelectFrom -- + * ListboxSelect -- * - * Start a new selection in a listbox. + * Select or deselect one or more elements in a listbox.. * * Results: * None. * * Side effects: - * ListPtr claims the selection, and the selection becomes the - * single element given by index. + * All of the elements in the range between first and last are + * marked as either selected or deselected, depending on the + * "select" argument. Any items whose state changes are redisplayed. + * The selection is claimed from X when the number of selected + * elements changes from zero to non-zero. * *---------------------------------------------------------------------- */ static void -ListboxSelectFrom(listPtr, index) +ListboxSelect(listPtr, first, last, select) register Listbox *listPtr; /* Information about widget. */ - int index; /* Index of element that is to - * become the new selection. */ + int first; /* Index of first element to + * select or deselect. */ + int last; /* Index of last element to + * select or deselect. */ + int select; /* 1 means select items, 0 means + * deselect them. */ { - /* - * Make sure the index is within the proper range for the listbox. - */ + int i, firstRedisplay, lastRedisplay, increment, oldCount; + Element *elPtr; - if (index <= 0) { - index = 0; + if (last < first) { + i = first; + first = last; + last = i; } - if (index >= listPtr->numElements) { - index = listPtr->numElements-1; - } - - if (listPtr->selectFirst != -1) { - ListboxRedrawRange(listPtr, listPtr->selectFirst, listPtr->selectLast); - } else if (listPtr->exportSelection) { - Tk_OwnSelection(listPtr->tkwin, ListboxLostSelection, - (ClientData) listPtr); - } - - listPtr->selectFirst = listPtr->selectLast = index; - listPtr->selectAnchor = index; - ListboxRedrawRange(listPtr, index, index); -} - -/* - *---------------------------------------------------------------------- - * - * ListboxSelectTo -- - * - * Modify the selection by moving its un-anchored end. This could - * make the selection either larger or smaller. - * - * Results: - * None. - * - * Side effects: - * The selection changes. - * - *---------------------------------------------------------------------- - */ - -static void -ListboxSelectTo(listPtr, index) - register Listbox *listPtr; /* Information about widget. */ - int index; /* Index of element that is to - * become the "other" end of the - * selection. */ -{ - int newFirst, newLast; - - /* - * Make sure the index is within the proper range for the listbox. - */ - - if (index <= 0) { - index = 0; - } - if (index >= listPtr->numElements) { - index = listPtr->numElements-1; - } - - /* - * We should already own the selection, but grab it if we don't. - */ - - if (listPtr->selectFirst == -1) { - ListboxSelectFrom(listPtr, index); - } - - if (listPtr->selectAnchor < index) { - newFirst = listPtr->selectAnchor; - newLast = index; - } else { - newFirst = index; - newLast = listPtr->selectAnchor; - } - if ((listPtr->selectFirst == newFirst) - && (listPtr->selectLast == newLast)) { + if (first >= listPtr->numElements) { return; } - if (listPtr->selectFirst != newFirst) { - if (listPtr->selectFirst < newFirst) { - ListboxRedrawRange(listPtr, listPtr->selectFirst, newFirst-1); - } else { - ListboxRedrawRange(listPtr, newFirst, listPtr->selectFirst-1); - } - listPtr->selectFirst = newFirst; + oldCount = listPtr->numSelected; + firstRedisplay = -1; + increment = select ? 1 : -1; + for (i = 0, elPtr = listPtr->firstPtr; i < first; + i++, elPtr = elPtr->nextPtr) { + /* Empty loop body. */ } - if (listPtr->selectLast != newLast) { - if (listPtr->selectLast < newLast) { - ListboxRedrawRange(listPtr, listPtr->selectLast+1, newLast); - } else { - ListboxRedrawRange(listPtr, newLast+1, listPtr->selectLast); + for ( ; i <= last; i++, elPtr = elPtr->nextPtr) { + if (elPtr->selected == select) { + continue; } - listPtr->selectLast = newLast; + listPtr->numSelected += increment; + elPtr->selected = select; + if (firstRedisplay < 0) { + firstRedisplay = i; + } + lastRedisplay = i; + } + if (firstRedisplay >= 0) { + ListboxRedrawRange(listPtr, first, last); + } + if ((oldCount == 0) && (listPtr->numSelected > 0) + && (listPtr->exportSelection)) { + Tk_OwnSelection(listPtr->tkwin, XA_PRIMARY, ListboxLostSelection, + (ClientData) listPtr); } } @@ -1559,52 +2010,51 @@ ListboxFetchSelection(clientData, offset, buffer, maxBytes) { register Listbox *listPtr = (Listbox *) clientData; register Element *elPtr; - char **argv, *selection; - int src, dst, length, count, argc; + Tcl_DString selection; + int length, count, needNewline; - if ((listPtr->selectFirst == -1) || !listPtr->exportSelection) { + if (!listPtr->exportSelection) { return -1; } /* - * Use Tcl_Merge to format the listbox elements into a suitable - * Tcl list. + * Use a dynamic string to accumulate the contents of the selection. */ - argc = listPtr->selectLast - listPtr->selectFirst + 1; - argv = (char **) ckalloc((unsigned) (argc*sizeof(char *))); - for (src = 0, dst = 0, elPtr = listPtr->elementPtr; ; - src++, elPtr = elPtr->nextPtr) { - if (src < listPtr->selectFirst) { - continue; + needNewline = 0; + Tcl_DStringInit(&selection); + for (elPtr = listPtr->firstPtr; elPtr != NULL; elPtr = elPtr->nextPtr) { + if (elPtr->selected) { + if (needNewline) { + Tcl_DStringAppend(&selection, "\n", 1); + } + Tcl_DStringAppend(&selection, elPtr->text, elPtr->textLength); + needNewline = 1; } - if (src > listPtr->selectLast) { - break; - } - argv[dst] = elPtr->text; - dst++; } - selection = Tcl_Merge(argc, argv); + + length = Tcl_DStringLength(&selection); + if (length == 0) { + return -1; + } /* * Copy the requested portion of the selection to the buffer. */ - length = strlen(selection); count = length - offset; if (count <= 0) { count = 0; - goto done; + } else { + if (count > maxBytes) { + count = maxBytes; + } + memcpy((VOID *) buffer, + (VOID *) (Tcl_DStringValue(&selection) + offset), + (size_t) count); } - if (count > maxBytes) { - count = maxBytes; - } - memcpy((VOID *) buffer, (VOID *) (selection + offset), count); - - done: buffer[count] = '\0'; - ckfree(selection); - ckfree((char *) argv); + Tcl_DStringFree(&selection); return count; } @@ -1632,9 +2082,8 @@ ListboxLostSelection(clientData) { register Listbox *listPtr = (Listbox *) clientData; - if ((listPtr->selectFirst >= 0) && listPtr->exportSelection) { - ListboxRedrawRange(listPtr, listPtr->selectFirst, listPtr->selectLast); - listPtr->selectFirst = -1; + if ((listPtr->exportSelection) && (listPtr->numElements > 0)) { + ListboxSelect(listPtr, 0, listPtr->numElements-1, 0); } } @@ -1670,7 +2119,7 @@ ListboxRedrawRange(listPtr, first, last) || (listPtr->flags & REDRAW_PENDING)) { return; } - Tk_DoWhenIdle(DisplayListbox, (ClientData) listPtr); + Tcl_DoWhenIdle(DisplayListbox, (ClientData) listPtr); listPtr->flags |= REDRAW_PENDING; } @@ -1698,28 +2147,42 @@ static void ListboxUpdateVScrollbar(listPtr) register Listbox *listPtr; /* Information about widget. */ { - char string[60]; - int result, last; + char string[100]; + double first, last; + int result; + Tcl_Interp *interp; if (listPtr->yScrollCmd == NULL) { return; } - last = listPtr->topIndex + listPtr->numLines - 1; - if (last >= listPtr->numElements) { - last = listPtr->numElements-1; + if (listPtr->numElements == 0) { + first = 0.0; + last = 1.0; + } else { + first = listPtr->topIndex/((double) listPtr->numElements); + last = (listPtr->topIndex+listPtr->fullLines) + /((double) listPtr->numElements); + if (last > 1.0) { + last = 1.0; + } } - if (last < listPtr->topIndex) { - last = listPtr->topIndex; - } - sprintf(string, " %d %d %d %d", listPtr->numElements, listPtr->numLines, - listPtr->topIndex, last); - result = Tcl_VarEval(listPtr->interp, listPtr->yScrollCmd, string, + sprintf(string, " %g %g", first, last); + + /* + * We must hold onto the interpreter from the listPtr because the data + * at listPtr might be freed as a result of the Tcl_VarEval. + */ + + interp = listPtr->interp; + Tcl_Preserve((ClientData) interp); + result = Tcl_VarEval(interp, listPtr->yScrollCmd, string, (char *) NULL); if (result != TCL_OK) { - Tcl_AddErrorInfo(listPtr->interp, + Tcl_AddErrorInfo(interp, "\n (vertical scrolling command executed by listbox)"); - Tk_BackgroundError(listPtr->interp); + Tcl_BackgroundError(interp); } + Tcl_Release((ClientData) interp); } /* @@ -1747,73 +2210,41 @@ ListboxUpdateHScrollbar(listPtr) register Listbox *listPtr; /* Information about widget. */ { char string[60]; - int result, totalUnits, windowUnits, first, last; + int result, windowWidth; + double first, last; + Tcl_Interp *interp; if (listPtr->xScrollCmd == NULL) { return; } - totalUnits = 1 + (listPtr->maxWidth-1)/listPtr->xScrollUnit; - windowUnits = 1 + (Tk_Width(listPtr->tkwin) - - 2*(listPtr->borderWidth + listPtr->selBorderWidth)-1) - /listPtr->xScrollUnit; - first = listPtr->xOffset/listPtr->xScrollUnit; - last = first + windowUnits - 1; - if (last < first) { - last = first; + windowWidth = Tk_Width(listPtr->tkwin) - 2*(listPtr->inset + + listPtr->selBorderWidth); + if (listPtr->maxWidth == 0) { + first = 0; + last = 1.0; + } else { + first = listPtr->xOffset/((double) listPtr->maxWidth); + last = (listPtr->xOffset + windowWidth) + /((double) listPtr->maxWidth); + if (last > 1.0) { + last = 1.0; + } } - sprintf(string, " %d %d %d %d", totalUnits, windowUnits, first, last); - result = Tcl_VarEval(listPtr->interp, listPtr->xScrollCmd, string, + sprintf(string, " %g %g", first, last); + + /* + * We must hold onto the interpreter because the data referred to at + * listPtr might be freed as a result of the call to Tcl_VarEval. + */ + + interp = listPtr->interp; + Tcl_Preserve((ClientData) interp); + result = Tcl_VarEval(interp, listPtr->xScrollCmd, string, (char *) NULL); if (result != TCL_OK) { - Tcl_AddErrorInfo(listPtr->interp, + Tcl_AddErrorInfo(interp, "\n (horizontal scrolling command executed by listbox)"); - Tk_BackgroundError(listPtr->interp); - } -} - -/* - *---------------------------------------------------------------------- - * - * ListboxComputeWidths -- - * - * This procedure is invoked to completely recompute width - * information used for displaying listboxes and for horizontal - * scrolling. - * - * Results: - * None. - * - * Side effects: - * If "fontChanged" is non-zero then the widths of the individual - * elements are all recomputed. In addition, listPtr->maxWidth is - * recomputed. - * - *---------------------------------------------------------------------- - */ - -static void -ListboxComputeWidths(listPtr, fontChanged) - Listbox *listPtr; /* Listbox whose geometry is to be - * recomputed. */ - int fontChanged; /* Non-zero means the font may have changed - * so per-element width information also - * has to be computed. */ -{ - register Element *elPtr; - int dummy; - XCharStruct bbox; - - listPtr->xScrollUnit = XTextWidth(listPtr->fontPtr, "0", 1); - listPtr->maxWidth = 0; - for (elPtr = listPtr->elementPtr; elPtr != NULL; elPtr = elPtr->nextPtr) { - if (fontChanged) { - XTextExtents(listPtr->fontPtr, elPtr->text, elPtr->textLength, - &dummy, &dummy, &dummy, &bbox); - elPtr->lBearing = bbox.lbearing; - elPtr->pixelWidth = bbox.rbearing - bbox.lbearing; - } - if (elPtr->pixelWidth > listPtr->maxWidth) { - listPtr->maxWidth = elPtr->pixelWidth; - } + Tcl_BackgroundError(interp); } + Tcl_Release((ClientData) interp); } diff --git a/tk4.2/generic/tkMain.c b/tk4.2/generic/tkMain.c new file mode 100644 index 0000000..16a8c05 --- /dev/null +++ b/tk4.2/generic/tkMain.c @@ -0,0 +1,401 @@ +/* + * tkMain.c -- + * + * This file contains a generic main program for Tk-based applications. + * It can be used as-is for many applications, just by supplying a + * different appInitProc procedure for each specific application. + * Or, it can be used as a template for creating new main programs + * for Tk applications. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkMain.c 1.150 96/09/05 18:42:25 + */ + +#include +#include +#include +#include +#include +#ifdef NO_STDLIB_H +# include "../compat/stdlib.h" +#else +# include +#endif + +/* + * Declarations for various library procedures and variables (don't want + * to include tkInt.h or tkPort.h here, because people might copy this + * file out of the Tk source directory to make their own modified versions). + * Note: don't declare "exit" here even though a declaration is really + * needed, because it will conflict with a declaration elsewhere on + * some systems. + */ + +extern int isatty _ANSI_ARGS_((int fd)); +extern int read _ANSI_ARGS_((int fd, char *buf, size_t size)); +extern char * strrchr _ANSI_ARGS_((CONST char *string, int c)); + +/* + * Global variables used by the main program: + */ + +static Tcl_Interp *interp; /* Interpreter for this application. */ +static Tcl_DString command; /* Used to assemble lines of terminal input + * into Tcl commands. */ +static Tcl_DString line; /* Used to read the next line from the + * terminal input. */ +static int tty; /* Non-zero means standard input is a + * terminal-like device. Zero means it's + * a file. */ + +/* + * Forward declarations for procedures defined later in this file. + */ + +static void Prompt _ANSI_ARGS_((Tcl_Interp *interp, int partial)); +static void StdinProc _ANSI_ARGS_((ClientData clientData, + int mask)); + +/* + *---------------------------------------------------------------------- + * + * Tk_Main -- + * + * Main program for Wish and most other Tk-based applications. + * + * Results: + * None. This procedure never returns (it exits the process when + * it's done. + * + * Side effects: + * This procedure initializes the Tk world and then starts + * interpreting commands; almost anything could happen, depending + * on the script being interpreted. + * + *---------------------------------------------------------------------- + */ + +void +Tk_Main(argc, argv, appInitProc) + int argc; /* Number of arguments. */ + char **argv; /* Array of argument strings. */ + Tcl_AppInitProc *appInitProc; /* Application-specific initialization + * procedure to call after most + * initialization but before starting + * to execute commands. */ +{ + char *args, *fileName; + char buf[20]; + int code; + size_t length; + Tcl_Channel inChannel, outChannel, errChannel; + + Tcl_FindExecutable(argv[0]); + interp = Tcl_CreateInterp(); +#ifdef TCL_MEM_DEBUG + Tcl_InitMemory(interp); +#endif + + /* + * Parse command-line arguments. A leading "-file" argument is + * ignored (a historical relic from the distant past). If the + * next 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) { + length = strlen(argv[1]); + if ((length >= 2) && (strncmp(argv[1], "-file", length) == 0)) { + argc--; + argv++; + } + } + if ((argc > 1) && (argv[1][0] != '-')) { + fileName = argv[1]; + argc--; + argv++; + } + + /* + * Make command-line arguments available in the Tcl variables "argc" + * and "argv". + */ + + args = Tcl_Merge(argc-1, argv+1); + Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY); + ckfree(args); + sprintf(buf, "%d", argc-1); + Tcl_SetVar(interp, "argc", buf, TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0], + TCL_GLOBAL_ONLY); + + /* + * Set the "tcl_interactive" variable. + */ + + /* + * For now, under Windows, we assume we are not running as a console mode + * app, so we need to use the GUI console. In order to enable this, we + * always claim to be running on a tty. This probably isn't the right + * way to do it. + */ + +#ifdef __WIN32__ + tty = 1; +#else + tty = isatty(0); +#endif + Tcl_SetVar(interp, "tcl_interactive", + ((fileName == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY); + + /* + * Invoke application-specific initialization. + */ + + if ((*appInitProc)(interp) != TCL_OK) { + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel) { + Tcl_Write(errChannel, + "application-specific initialization failed: ", -1); + Tcl_Write(errChannel, interp->result, -1); + Tcl_Write(errChannel, "\n", 1); + } + } + + /* + * Invoke the script specified on the command line, if any. + */ + + if (fileName != NULL) { + code = Tcl_EvalFile(interp, fileName); + if (code != TCL_OK) { + goto error; + } + tty = 0; + } else { + + /* + * Evaluate the .rc file, if one has been specified. + */ + + Tcl_SourceRCFile(interp); + + /* + * Establish a channel handler for stdin. + */ + + inChannel = Tcl_GetStdChannel(TCL_STDIN); + if (inChannel) { + Tcl_CreateChannelHandler(inChannel, TCL_READABLE, StdinProc, + (ClientData) inChannel); + } + if (tty) { + Prompt(interp, 0); + } + } + + outChannel = Tcl_GetStdChannel(TCL_STDOUT); + if (outChannel) { + Tcl_Flush(outChannel); + } + Tcl_DStringInit(&command); + Tcl_DStringInit(&line); + Tcl_ResetResult(interp); + + /* + * Loop infinitely, waiting for commands to execute. When there + * are no windows left, Tk_MainLoop returns and we exit. + */ + + Tk_MainLoop(); + Tcl_DeleteInterp(interp); + Tcl_Exit(0); + +error: + /* + * The following statement guarantees that the errorInfo + * variable is set properly. + */ + + Tcl_AddErrorInfo(interp, ""); + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel) { + Tcl_Write(errChannel, Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY), + -1); + Tcl_Write(errChannel, "\n", 1); + } + Tcl_DeleteInterp(interp); + Tcl_Exit(1); +} + +/* + *---------------------------------------------------------------------- + * + * StdinProc -- + * + * This procedure is invoked by the event dispatcher whenever + * standard input becomes readable. It grabs the next line of + * input characters, adds them to a command being assembled, and + * executes the command if it's complete. + * + * Results: + * None. + * + * Side effects: + * Could be almost arbitrary, depending on the command that's + * typed. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +StdinProc(clientData, mask) + ClientData clientData; /* Not used. */ + int mask; /* Not used. */ +{ + static int gotPartial = 0; + char *cmd; + int code, count; + Tcl_Channel chan = (Tcl_Channel) clientData; + + count = Tcl_Gets(chan, &line); + + if (count < 0) { + if (!gotPartial) { + if (tty) { + Tcl_Exit(0); + } else { + Tcl_DeleteChannelHandler(chan, StdinProc, (ClientData) chan); + } + return; + } else { + count = 0; + } + } + + (void) Tcl_DStringAppend(&command, Tcl_DStringValue(&line), -1); + cmd = Tcl_DStringAppend(&command, "\n", -1); + Tcl_DStringFree(&line); + + if (!Tcl_CommandComplete(cmd)) { + gotPartial = 1; + goto prompt; + } + gotPartial = 0; + + /* + * Disable the stdin channel handler while evaluating the command; + * otherwise if the command re-enters the event loop we might + * process commands from stdin before the current command is + * finished. Among other things, this will trash the text of the + * command being evaluated. + */ + + Tcl_CreateChannelHandler(chan, 0, StdinProc, (ClientData) chan); + code = Tcl_RecordAndEval(interp, cmd, TCL_EVAL_GLOBAL); + Tcl_CreateChannelHandler(chan, TCL_READABLE, StdinProc, + (ClientData) chan); + Tcl_DStringFree(&command); + if (*interp->result != 0) { + if ((code != TCL_OK) || (tty)) { + /* + * The statement below used to call "printf", but that resulted + * in core dumps under Solaris 2.3 if the result was very long. + * + * NOTE: This probably will not work under Windows either. + */ + + puts(interp->result); + } + } + + /* + * Output a prompt. + */ + + prompt: + if (tty) { + Prompt(interp, gotPartial); + } + Tcl_ResetResult(interp); +} + +/* + *---------------------------------------------------------------------- + * + * Prompt -- + * + * Issue a prompt on standard output, or invoke a script + * to issue the prompt. + * + * Results: + * None. + * + * Side effects: + * A prompt gets output, and a Tcl script may be evaluated + * in interp. + * + *---------------------------------------------------------------------- + */ + +static void +Prompt(interp, partial) + Tcl_Interp *interp; /* Interpreter to use for prompting. */ + int partial; /* Non-zero means there already + * exists a partial command, so use + * the secondary prompt. */ +{ + char *promptCmd; + int code; + Tcl_Channel outChannel, errChannel; + + errChannel = Tcl_GetChannel(interp, "stderr", NULL); + + promptCmd = Tcl_GetVar(interp, + partial ? "tcl_prompt2" : "tcl_prompt1", TCL_GLOBAL_ONLY); + if (promptCmd == NULL) { +defaultPrompt: + if (!partial) { + + /* + * We must check that outChannel is a real channel - it + * is possible that someone has transferred stdout out of + * this interpreter with "interp transfer". + */ + + outChannel = Tcl_GetChannel(interp, "stdout", NULL); + if (outChannel != (Tcl_Channel) NULL) { + Tcl_Write(outChannel, "% ", 2); + } + } + } else { + code = Tcl_Eval(interp, promptCmd); + if (code != TCL_OK) { + Tcl_AddErrorInfo(interp, + "\n (script that generates prompt)"); + /* + * We must check that errChannel is a real channel - it + * is possible that someone has transferred stderr out of + * this interpreter with "interp transfer". + */ + + errChannel = Tcl_GetChannel(interp, "stderr", NULL); + if (errChannel != (Tcl_Channel) NULL) { + Tcl_Write(errChannel, interp->result, -1); + Tcl_Write(errChannel, "\n", 1); + } + goto defaultPrompt; + } + } + outChannel = Tcl_GetChannel(interp, "stdout", NULL); + if (outChannel != (Tcl_Channel) NULL) { + Tcl_Flush(outChannel); + } +} diff --git a/tk3.6/tkMenu.c b/tk4.2/generic/tkMenu.c similarity index 62% rename from tk3.6/tkMenu.c rename to tk4.2/generic/tkMenu.c index e54ea16..de84a1b 100644 --- a/tk3.6/tkMenu.c +++ b/tk4.2/generic/tkMenu.c @@ -6,32 +6,16 @@ * buttons, iconic forms of all of the above, and separator * entries. * - * Copyright (c) 1990-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tkMenu.c 1.102 96/03/26 16:07:08 */ -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkMenu.c,v 1.55 93/08/18 16:25:41 ouster Exp $ SPRITE (Berkeley)"; -#endif - -#include "tkConfig.h" +#include "tkPort.h" #include "default.h" #include "tkInt.h" @@ -50,6 +34,16 @@ typedef struct MenuEntry { int underline; /* Index of character to underline. */ Pixmap bitmap; /* Bitmap to display in menu entry, or None. * If not None then label is ignored. */ + char *imageString; /* Name of image to display (malloc'ed), or + * NULL. If non-NULL, bitmap, text, and + * textVarName are ignored. */ + Tk_Image image; /* Image to display in menu entry, or NULL if + * none. */ + char *selectImageString; /* Name of image to display when selected + * (malloc'ed), or NULL. */ + Tk_Image selectImage; /* Image to display in entry when selected, + * or NULL if none. Ignored if image is + * NULL. */ char *accel; /* Accelerator string displayed at right * of menu entry. NULL means no such * accelerator. Malloc'ed. */ @@ -63,15 +57,23 @@ typedef struct MenuEntry { Tk_Uid state; /* State of button for display purposes: * normal, active, or disabled. */ int height; /* Number of pixels occupied by entry in - * vertical dimension. */ + * vertical dimension, including raised + * border drawn around entry when active. */ int y; /* Y-coordinate of topmost pixel in entry. */ - int selectorDiameter; /* Size of selector display, in pixels. */ + int indicatorOn; /* True means draw indicator, false means + * don't draw it. */ + int indicatorDiameter; /* Size of indicator display, in pixels. */ Tk_3DBorder border; /* Structure used to draw background for * entry. NULL means use overall border * for menu. */ + XColor *fg; /* Foreground color to use for entry. NULL + * means use foreground color from menu. */ Tk_3DBorder activeBorder; /* Used to draw background and border when * element is active. NULL means use * activeBorder from menu. */ + XColor *activeFg; /* Foreground color to use when entry is + * active. NULL means use active foreground + * from menu. */ XFontStruct *fontPtr; /* Text font for menu entries. NULL means * use overall font for menu. */ GC textGC; /* GC for drawing text in entry. NULL means @@ -84,6 +86,11 @@ typedef struct MenuEntry { * menu structure. See comments for * disabledFg in menu structure for more * information. */ + XColor *indicatorFg; /* Color for indicators in radio and check + * button entries. NULL means use indicatorFg + * GC from menu. */ + GC indicatorGC; /* For drawing indicators. None means use + * GC from menu. */ /* * Information used to implement this entry's action: @@ -129,6 +136,7 @@ typedef struct MenuEntry { #define CHECK_BUTTON_ENTRY 2 #define RADIO_BUTTON_ENTRY 3 #define CASCADE_ENTRY 4 +#define TEAROFF_ENTRY 5 /* * Mask bits for above types: @@ -139,8 +147,9 @@ typedef struct MenuEntry { #define CHECK_BUTTON_MASK (TK_CONFIG_USER_BIT << 2) #define RADIO_BUTTON_MASK (TK_CONFIG_USER_BIT << 3) #define CASCADE_MASK (TK_CONFIG_USER_BIT << 4) +#define TEAROFF_MASK (TK_CONFIG_USER_BIT << 5) #define ALL_MASK (COMMAND_MASK | SEPARATOR_MASK \ - | CHECK_BUTTON_MASK | RADIO_BUTTON_MASK | CASCADE_MASK) + | CHECK_BUTTON_MASK | RADIO_BUTTON_MASK | CASCADE_MASK | TEAROFF_MASK) /* * Configuration specs for individual menu entries: @@ -151,6 +160,10 @@ static Tk_ConfigSpec entryConfigSpecs[] = { DEF_MENU_ENTRY_ACTIVE_BG, Tk_Offset(MenuEntry, activeBorder), COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK |TK_CONFIG_NULL_OK}, + {TK_CONFIG_COLOR, "-activeforeground", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_ACTIVE_FG, Tk_Offset(MenuEntry, activeFg), + COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK + |TK_CONFIG_NULL_OK}, {TK_CONFIG_STRING, "-accelerator", (char *) NULL, (char *) NULL, DEF_MENU_ENTRY_ACCELERATOR, Tk_Offset(MenuEntry, accel), COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK @@ -158,7 +171,7 @@ static Tk_ConfigSpec entryConfigSpecs[] = { {TK_CONFIG_BORDER, "-background", (char *) NULL, (char *) NULL, DEF_MENU_ENTRY_BG, Tk_Offset(MenuEntry, border), COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK - |TK_CONFIG_NULL_OK}, + |SEPARATOR_MASK|TEAROFF_MASK|TK_CONFIG_NULL_OK}, {TK_CONFIG_BITMAP, "-bitmap", (char *) NULL, (char *) NULL, DEF_MENU_ENTRY_BITMAP, Tk_Offset(MenuEntry, bitmap), COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK @@ -171,6 +184,17 @@ static Tk_ConfigSpec entryConfigSpecs[] = { DEF_MENU_ENTRY_FONT, Tk_Offset(MenuEntry, fontPtr), COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK |TK_CONFIG_NULL_OK}, + {TK_CONFIG_COLOR, "-foreground", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_FG, Tk_Offset(MenuEntry, fg), + COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK + |TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-image", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_IMAGE, Tk_Offset(MenuEntry, imageString), + COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK + |TK_CONFIG_NULL_OK}, + {TK_CONFIG_BOOLEAN, "-indicatoron", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_INDICATOR, Tk_Offset(MenuEntry, indicatorOn), + CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|TK_CONFIG_DONT_SET_DEFAULT}, {TK_CONFIG_STRING, "-label", (char *) NULL, (char *) NULL, DEF_MENU_ENTRY_LABEL, Tk_Offset(MenuEntry, label), COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK}, @@ -180,13 +204,19 @@ static Tk_ConfigSpec entryConfigSpecs[] = { {TK_CONFIG_STRING, "-offvalue", (char *) NULL, (char *) NULL, DEF_MENU_ENTRY_OFF_VALUE, Tk_Offset(MenuEntry, offValue), CHECK_BUTTON_MASK}, - {TK_CONFIG_UID, "-state", (char *) NULL, (char *) NULL, - DEF_MENU_ENTRY_STATE, Tk_Offset(MenuEntry, state), - COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK - |TK_CONFIG_DONT_SET_DEFAULT}, {TK_CONFIG_STRING, "-onvalue", (char *) NULL, (char *) NULL, DEF_MENU_ENTRY_ON_VALUE, Tk_Offset(MenuEntry, onValue), CHECK_BUTTON_MASK}, + {TK_CONFIG_COLOR, "-selectcolor", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_SELECT, Tk_Offset(MenuEntry, indicatorFg), + CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-selectimage", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_SELECT_IMAGE, Tk_Offset(MenuEntry, selectImageString), + CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|TK_CONFIG_NULL_OK}, + {TK_CONFIG_UID, "-state", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_STATE, Tk_Offset(MenuEntry, state), + COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK + |TEAROFF_MASK|TK_CONFIG_DONT_SET_DEFAULT}, {TK_CONFIG_STRING, "-value", (char *) NULL, (char *) NULL, DEF_MENU_ENTRY_VALUE, Tk_Offset(MenuEntry, onValue), RADIO_BUTTON_MASK|TK_CONFIG_NULL_OK}, @@ -218,6 +248,7 @@ typedef struct Menu { * other things, so that resources can be * freed up even after tkwin has gone away. */ Tcl_Interp *interp; /* Interpreter associated with menu. */ + Tcl_Command widgetCmd; /* Token for menu's widget command. */ MenuEntry **entries; /* Array of pointers to all the entries * in the menu. NULL means no entries. */ int numEntries; /* Number of elements in entries. */ @@ -234,6 +265,7 @@ typedef struct Menu { Tk_3DBorder activeBorder; /* Used to draw background and border for * active element (if any). */ int activeBorderWidth; /* Width of border around active element. */ + int relief; /* 3-d effect: TK_RELIEF_RAISED, etc. */ XFontStruct *fontPtr; /* Text font for menu entries. */ XColor *fg; /* Foreground color for entries. */ GC textGC; /* GC for drawing text and other features @@ -252,12 +284,12 @@ typedef struct Menu { * background across them. */ XColor *activeFg; /* Foreground color for active entry. */ GC activeGC; /* GC for drawing active entry. */ - XColor *selectorFg; /* Color for selectors in radio and check + XColor *indicatorFg; /* Color for indicators in radio and check * button entries. */ - GC selectorGC; /* For drawing selectors. */ - int selectorSpace; /* Number of pixels to allow for displaying - * selectors in menu entries (includes extra - * space around selector). */ + GC indicatorGC; /* For drawing indicators. */ + int indicatorSpace; /* Number of pixels to allow for displaying + * indicators in menu entries (includes extra + * space around indicator). */ int labelWidth; /* Number of pixels to allow for displaying * labels in menu entries. */ @@ -265,7 +297,20 @@ typedef struct Menu { * Miscellaneous information: */ - Cursor cursor; /* Current cursor for window, or None. */ + int tearOff; /* 1 means this is a tear-off menu, so the + * first entry always shows a dashed stripe + * for tearing off. */ + char *tearOffCommand; /* If non-NULL, points to a command to + * run whenever the menu is torn-off. */ + int transient; /* 1 means menu is only posted briefly as + * a popup or pulldown or cascade. 0 means + * menu is always visible, e.g. as a torn-off + * menu. Determines whether save_under and + * override_redirect should be set. */ + Tk_Cursor cursor; /* Current cursor for window, or None. */ + char *takeFocus; /* Value of -takefocus option; not used in + * the C code, but used by keyboard traversal + * scripts. Malloc'ed, but may be NULL. */ char *postCommand; /* Command to execute just before posting * this menu, or NULL. Malloc-ed. */ MenuEntry *postedCascade; /* Points to menu entry for cascaded @@ -333,12 +378,23 @@ static Tk_ConfigSpec configSpecs[] = { DEF_MENU_FG, Tk_Offset(Menu, fg), 0}, {TK_CONFIG_STRING, "-postcommand", "postCommand", "Command", DEF_MENU_POST_COMMAND, Tk_Offset(Menu, postCommand), TK_CONFIG_NULL_OK}, - {TK_CONFIG_COLOR, "-selector", "selector", "Foreground", - DEF_MENU_SELECTOR_COLOR, Tk_Offset(Menu, selectorFg), + {TK_CONFIG_RELIEF, "-relief", "relief", "Relief", + DEF_MENU_RELIEF, Tk_Offset(Menu, relief), 0}, + {TK_CONFIG_COLOR, "-selectcolor", "selectColor", "Background", + DEF_MENU_SELECT_COLOR, Tk_Offset(Menu, indicatorFg), TK_CONFIG_COLOR_ONLY}, - {TK_CONFIG_COLOR, "-selector", "selector", "Foreground", - DEF_MENU_SELECTOR_MONO, Tk_Offset(Menu, selectorFg), + {TK_CONFIG_COLOR, "-selectcolor", "selectColor", "Background", + DEF_MENU_SELECT_MONO, Tk_Offset(Menu, indicatorFg), TK_CONFIG_MONO_ONLY}, + {TK_CONFIG_STRING, "-takefocus", "takeFocus", "TakeFocus", + DEF_MENU_TAKE_FOCUS, Tk_Offset(Menu, takeFocus), TK_CONFIG_NULL_OK}, + {TK_CONFIG_BOOLEAN, "-tearoff", "tearOff", "TearOff", + DEF_MENU_TEAROFF, Tk_Offset(Menu, tearOff), 0}, + {TK_CONFIG_STRING, "-tearoffcommand", "tearOffCommand", "TearOffCommand", + DEF_MENU_TEAROFF_CMD, Tk_Offset(Menu, tearOffCommand), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_BOOLEAN, "-transient", "transient", "Transient", + DEF_MENU_TRANSIENT, Tk_Offset(Menu, transient), 0}, {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, (char *) NULL, 0, 0} }; @@ -349,6 +405,7 @@ static Tk_ConfigSpec configSpecs[] = { #define CASCADE_ARROW_HEIGHT 10 #define CASCADE_ARROW_WIDTH 8 +#define DECORATION_BORDER_WIDTH 2 #define MARGIN_WIDTH 2 /* @@ -365,15 +422,29 @@ static int ConfigureMenu _ANSI_ARGS_((Tcl_Interp *interp, static int ConfigureMenuEntry _ANSI_ARGS_((Tcl_Interp *interp, Menu *menuPtr, MenuEntry *mePtr, int index, int argc, char **argv, int flags)); -static void DestroyMenu _ANSI_ARGS_((ClientData clientData)); -static void DestroyMenuEntry _ANSI_ARGS_((ClientData clientData)); +static void DestroyMenu _ANSI_ARGS_((char *memPtr)); +static void DestroyMenuEntry _ANSI_ARGS_((char *memPtr)); static void DisplayMenu _ANSI_ARGS_((ClientData clientData)); static void EventuallyRedrawMenu _ANSI_ARGS_((Menu *menuPtr, MenuEntry *mePtr)); static int GetMenuIndex _ANSI_ARGS_((Tcl_Interp *interp, - Menu *menuPtr, char *string, int *indexPtr)); + Menu *menuPtr, char *string, int lastOK, + int *indexPtr)); +static int MenuAddOrInsert _ANSI_ARGS_((Tcl_Interp *interp, + Menu *menuPtr, char *indexString, int argc, + char **argv)); +static void MenuCmdDeletedProc _ANSI_ARGS_(( + ClientData clientData)); static void MenuEventProc _ANSI_ARGS_((ClientData clientData, XEvent *eventPtr)); +static void MenuImageProc _ANSI_ARGS_((ClientData clientData, + int x, int y, int width, int height, int imgWidth, + int imgHeight)); +static MenuEntry * MenuNewEntry _ANSI_ARGS_((Menu *menuPtr, int index, + int type)); +static void MenuSelectImageProc _ANSI_ARGS_((ClientData clientData, + int x, int y, int width, int height, int imgWidth, + int imgHeight)); static char * MenuVarProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, char *name1, char *name2, int flags)); @@ -411,7 +482,6 @@ Tk_MenuCmd(clientData, interp, argc, argv) Tk_Window tkwin = (Tk_Window) clientData; Tk_Window new; register Menu *menuPtr; - XSetWindowAttributes atts; if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", @@ -430,9 +500,6 @@ Tk_MenuCmd(clientData, interp, argc, argv) if (new == NULL) { return TCL_ERROR; } - atts.override_redirect = True; - atts.save_under = True; - Tk_ChangeWindowAttributes(new, CWOverrideRedirect|CWSaveUnder, &atts); /* * Initialize the data structure for the menu. @@ -442,11 +509,15 @@ Tk_MenuCmd(clientData, interp, argc, argv) menuPtr->tkwin = new; menuPtr->display = Tk_Display(new); menuPtr->interp = interp; + menuPtr->widgetCmd = Tcl_CreateCommand(interp, + Tk_PathName(menuPtr->tkwin), MenuWidgetCmd, + (ClientData) menuPtr, MenuCmdDeletedProc); menuPtr->entries = NULL; menuPtr->numEntries = 0; menuPtr->active = -1; menuPtr->border = NULL; menuPtr->borderWidth = 0; + menuPtr->relief = TK_RELIEF_FLAT; menuPtr->activeBorder = NULL; menuPtr->activeBorderWidth = 0; menuPtr->fontPtr = NULL; @@ -457,11 +528,14 @@ Tk_MenuCmd(clientData, interp, argc, argv) menuPtr->disabledGC = None; menuPtr->activeFg = NULL; menuPtr->activeGC = None; - menuPtr->selectorFg = NULL; - menuPtr->selectorGC = None; - menuPtr->selectorSpace = 0; + menuPtr->indicatorFg = NULL; + menuPtr->indicatorGC = None; + menuPtr->indicatorSpace = 0; menuPtr->labelWidth = 0; + menuPtr->tearOff = 1; + menuPtr->tearOffCommand = NULL; menuPtr->cursor = None; + menuPtr->takeFocus = NULL; menuPtr->postCommand = NULL; menuPtr->postedCascade = NULL; menuPtr->flags = 0; @@ -469,8 +543,6 @@ Tk_MenuCmd(clientData, interp, argc, argv) Tk_SetClass(new, "Menu"); Tk_CreateEventHandler(menuPtr->tkwin, ExposureMask|StructureNotifyMask, MenuEventProc, (ClientData) menuPtr); - Tcl_CreateCommand(interp, Tk_PathName(menuPtr->tkwin), MenuWidgetCmd, - (ClientData) menuPtr, (void (*)()) NULL); if (ConfigureMenu(interp, menuPtr, argc-2, argv+2, 0) != TCL_OK) { goto error; } @@ -511,15 +583,15 @@ MenuWidgetCmd(clientData, interp, argc, argv) register Menu *menuPtr = (Menu *) clientData; register MenuEntry *mePtr; int result = TCL_OK; - int length, type; - char c; + size_t length; + int c; if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " option ?arg arg ...?\"", (char *) NULL); return TCL_ERROR; } - Tk_Preserve((ClientData) menuPtr); + Tcl_Preserve((ClientData) menuPtr); c = argv[1][0]; length = strlen(argv[1]); if ((c == 'a') && (strncmp(argv[1], "activate", length) == 0) @@ -531,7 +603,7 @@ MenuWidgetCmd(clientData, interp, argc, argv) argv[0], " activate index\"", (char *) NULL); goto error; } - if (GetMenuIndex(interp, menuPtr, argv[2], &index) != TCL_OK) { + if (GetMenuIndex(interp, menuPtr, argv[2], 0, &index) != TCL_OK) { goto error; } if (menuPtr->active == index) { @@ -546,92 +618,27 @@ MenuWidgetCmd(clientData, interp, argc, argv) result = ActivateMenuEntry(menuPtr, index); } else if ((c == 'a') && (strncmp(argv[1], "add", length) == 0) && (length >= 2)) { - MenuEntry **newEntries; - if (argc < 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " add type ?options?\"", (char *) NULL); goto error; } - - /* - * Figure out the type of the new entry. - */ - - c = argv[2][0]; - length = strlen(argv[2]); - if ((c == 'c') && (strncmp(argv[2], "cascade", length) == 0) - && (length >= 2)) { - type = CASCADE_ENTRY; - } else if ((c == 'c') && (strncmp(argv[2], "checkbutton", length) == 0) - && (length >= 2)) { - type = CHECK_BUTTON_ENTRY; - } else if ((c == 'c') && (strncmp(argv[2], "command", length) == 0) - && (length >= 2)) { - type = COMMAND_ENTRY; - } else if ((c == 'r') - && (strncmp(argv[2], "radiobutton", length) == 0)) { - type = RADIO_BUTTON_ENTRY; - } else if ((c == 's') - && (strncmp(argv[2], "separator", length) == 0)) { - type = SEPARATOR_ENTRY; - } else { - Tcl_AppendResult(interp, "bad menu entry type \"", - argv[2], "\": must be cascade, checkbutton, ", - "command, radiobutton, or separator", (char *) NULL); + if (MenuAddOrInsert(interp, menuPtr, (char *) NULL, + argc-2, argv+2) != TCL_OK) { goto error; } - - /* - * Add a new entry to the end of the menu's array of entries, - * and process options for it. Be sure to initialize even - * fields that look like they should be initialized by - * Tk_ConfigureWidget, because not all fields are processed - * for all kinds of entries, yet they all need to be - * initialized. - */ - - mePtr = (MenuEntry *) ckalloc(sizeof(MenuEntry)); - newEntries = (MenuEntry **) ckalloc((unsigned) - ((menuPtr->numEntries+1)*sizeof(MenuEntry *))); - if (menuPtr->numEntries != 0) { - memcpy((VOID *) newEntries, (VOID *) menuPtr->entries, - menuPtr->numEntries*sizeof(MenuEntry *)); - ckfree((char *) menuPtr->entries); - } - menuPtr->entries = newEntries; - menuPtr->entries[menuPtr->numEntries] = mePtr; - menuPtr->numEntries++; - mePtr->type = type; - mePtr->menuPtr = menuPtr; - mePtr->label = NULL; - mePtr->labelLength = 0; - mePtr->underline = -1; - mePtr->bitmap = None; - mePtr->accel = NULL; - mePtr->accelLength = 0; - mePtr->state = tkNormalUid; - mePtr->height = 0; - mePtr->y = 0; - mePtr->selectorDiameter = 0; - mePtr->border = NULL; - mePtr->activeBorder = NULL; - mePtr->fontPtr = NULL; - mePtr->textGC = None; - mePtr->activeGC = None; - mePtr->disabledGC = None; - mePtr->command = NULL; - mePtr->name = NULL; - mePtr->onValue = NULL; - mePtr->offValue = NULL; - mePtr->flags = 0; - if (ConfigureMenuEntry(interp, menuPtr, mePtr, menuPtr->numEntries-1, - argc-3, argv+3, 0) != TCL_OK) { - DestroyMenuEntry((ClientData) mePtr); - menuPtr->numEntries--; + } else if ((c == 'c') && (strncmp(argv[1], "cget", length) == 0) + && (length >= 2)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " cget option\"", + (char *) NULL); goto error; } - } else if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0)) { + result = Tk_ConfigureValue(interp, menuPtr->tkwin, configSpecs, + (char *) menuPtr, argv[2], 0); + } else if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0) + && (length >= 2)) { if (argc == 2) { result = Tk_ConfigureInfo(interp, menuPtr->tkwin, configSpecs, (char *) menuPtr, (char *) NULL, 0); @@ -642,8 +649,7 @@ MenuWidgetCmd(clientData, interp, argc, argv) result = ConfigureMenu(interp, menuPtr, argc-2, argv+2, TK_CONFIG_ARGV_ONLY); } - } else if ((c == 'd') && (strncmp(argv[1], "delete", length) == 0) - && (length >= 2)) { + } else if ((c == 'd') && (strncmp(argv[1], "delete", length) == 0)) { int first, last, i, numDeleted; if ((argc != 3) && (argc != 4)) { @@ -651,22 +657,29 @@ MenuWidgetCmd(clientData, interp, argc, argv) argv[0], " delete first ?last?\"", (char *) NULL); goto error; } - if (GetMenuIndex(interp, menuPtr, argv[2], &first) != TCL_OK) { + if (GetMenuIndex(interp, menuPtr, argv[2], 0, &first) != TCL_OK) { goto error; } if (argc == 3) { last = first; } else { - if (GetMenuIndex(interp, menuPtr, argv[3], &last) != TCL_OK) { + if (GetMenuIndex(interp, menuPtr, argv[3], 0, &last) != TCL_OK) { goto error; } } + if (menuPtr->tearOff && (first == 0)) { + /* + * Sorry, can't delete the tearoff entry; must reconfigure + * the menu. + */ + first = 1; + } if ((first < 0) || (last < first)) { goto done; } numDeleted = last + 1 - first; for (i = first; i <= last; i++) { - Tk_EventuallyFree((ClientData) menuPtr->entries[i], + Tcl_EventuallyFree((ClientData) menuPtr->entries[i], DestroyMenuEntry); } for (i = last+1; i < menuPtr->numEntries; i++) { @@ -680,46 +693,30 @@ MenuWidgetCmd(clientData, interp, argc, argv) } if (!(menuPtr->flags & RESIZE_PENDING)) { menuPtr->flags |= RESIZE_PENDING; - Tk_DoWhenIdle(ComputeMenuGeometry, (ClientData) menuPtr); + Tcl_DoWhenIdle(ComputeMenuGeometry, (ClientData) menuPtr); } - } else if ((c == 'd') && (strncmp(argv[1], "disable", length) == 0) - && (length >= 2)) { + } else if ((c == 'e') && (length >= 7) + && (strncmp(argv[1], "entrycget", length) == 0)) { int index; - if (argc != 3) { + if (argc != 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " disable index\"", (char *) NULL); + argv[0], " entrycget index option\"", + (char *) NULL); goto error; } - if (GetMenuIndex(interp, menuPtr, argv[2], &index) != TCL_OK) { + if (GetMenuIndex(interp, menuPtr, argv[2], 0, &index) != TCL_OK) { goto error; } if (index < 0) { goto done; } - menuPtr->entries[index]->state = tkDisabledUid; - if (menuPtr->active == index) { - menuPtr->active = -1; - } - EventuallyRedrawMenu(menuPtr, menuPtr->entries[index]); - } else if ((c == 'e') && (length >= 3) - && (strncmp(argv[1], "enable", length) == 0)) { - int index; - - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " enable index\"", (char *) NULL); - goto error; - } - if (GetMenuIndex(interp, menuPtr, argv[2], &index) != TCL_OK) { - goto error; - } - if (index < 0) { - goto done; - } - menuPtr->entries[index]->state = tkNormalUid; - EventuallyRedrawMenu(menuPtr, menuPtr->entries[index]); - } else if ((c == 'e') && (length >= 3) + mePtr = menuPtr->entries[index]; + Tcl_Preserve((ClientData) mePtr); + result = Tk_ConfigureValue(interp, menuPtr->tkwin, entryConfigSpecs, + (char *) mePtr, argv[3], COMMAND_MASK << mePtr->type); + Tcl_Release((ClientData) mePtr); + } else if ((c == 'e') && (length >= 7) && (strncmp(argv[1], "entryconfigure", length) == 0)) { int index; @@ -729,14 +726,14 @@ MenuWidgetCmd(clientData, interp, argc, argv) (char *) NULL); goto error; } - if (GetMenuIndex(interp, menuPtr, argv[2], &index) != TCL_OK) { + if (GetMenuIndex(interp, menuPtr, argv[2], 0, &index) != TCL_OK) { goto error; } if (index < 0) { goto done; } mePtr = menuPtr->entries[index]; - Tk_Preserve((ClientData) mePtr); + Tcl_Preserve((ClientData) mePtr); if (argc == 3) { result = Tk_ConfigureInfo(interp, menuPtr->tkwin, entryConfigSpecs, (char *) mePtr, (char *) NULL, @@ -748,7 +745,7 @@ MenuWidgetCmd(clientData, interp, argc, argv) result = ConfigureMenuEntry(interp, menuPtr, mePtr, index, argc-3, argv+3, TK_CONFIG_ARGV_ONLY | COMMAND_MASK << mePtr->type); } - Tk_Release((ClientData) mePtr); + Tcl_Release((ClientData) mePtr); } else if ((c == 'i') && (strncmp(argv[1], "index", length) == 0) && (length >= 3)) { int index; @@ -758,7 +755,7 @@ MenuWidgetCmd(clientData, interp, argc, argv) argv[0], " index string\"", (char *) NULL); goto error; } - if (GetMenuIndex(interp, menuPtr, argv[2], &index) != TCL_OK) { + if (GetMenuIndex(interp, menuPtr, argv[2], 0, &index) != TCL_OK) { goto error; } if (index < 0) { @@ -766,6 +763,17 @@ MenuWidgetCmd(clientData, interp, argc, argv) } else { sprintf(interp->result, "%d", index); } + } else if ((c == 'i') && (strncmp(argv[1], "insert", length) == 0) + && (length >= 3)) { + if (argc < 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " insert index type ?options?\"", (char *) NULL); + goto error; + } + if (MenuAddOrInsert(interp, menuPtr, argv[2], + argc-3, argv+3) != TCL_OK) { + goto error; + } } else if ((c == 'i') && (strncmp(argv[1], "invoke", length) == 0) && (length >= 3)) { int index; @@ -775,7 +783,7 @@ MenuWidgetCmd(clientData, interp, argc, argv) argv[0], " invoke index\"", (char *) NULL); goto error; } - if (GetMenuIndex(interp, menuPtr, argv[2], &index) != TCL_OK) { + if (GetMenuIndex(interp, menuPtr, argv[2], 0, &index) != TCL_OK) { goto error; } if (index < 0) { @@ -785,25 +793,36 @@ MenuWidgetCmd(clientData, interp, argc, argv) if (mePtr->state == tkDisabledUid) { goto done; } - Tk_Preserve((ClientData) mePtr); + Tcl_Preserve((ClientData) mePtr); if (mePtr->type == CHECK_BUTTON_ENTRY) { if (mePtr->flags & ENTRY_SELECTED) { - Tcl_SetVar(interp, mePtr->name, mePtr->offValue, - TCL_GLOBAL_ONLY); + if (Tcl_SetVar(interp, mePtr->name, mePtr->offValue, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { + result = TCL_ERROR; + } } else { - Tcl_SetVar(interp, mePtr->name, mePtr->onValue, - TCL_GLOBAL_ONLY); + if (Tcl_SetVar(interp, mePtr->name, mePtr->onValue, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { + result = TCL_ERROR; + } } } else if (mePtr->type == RADIO_BUTTON_ENTRY) { - Tcl_SetVar(interp, mePtr->name, mePtr->onValue, TCL_GLOBAL_ONLY); + if (Tcl_SetVar(interp, mePtr->name, mePtr->onValue, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { + result = TCL_ERROR; + } } - if ((mePtr->command != NULL) && (mePtr->type != CASCADE_ENTRY)) { + if ((result == TCL_OK) && (mePtr->command != NULL)) { result = TkCopyAndGlobalEval(interp, mePtr->command); } - Tk_Release((ClientData) mePtr); - } else if ((c == 'p') && (strncmp(argv[1], "post", length) == 0)) { + if ((result == TCL_OK) && (mePtr->type == CASCADE_ENTRY)) { + result = PostSubmenu(menuPtr->interp, menuPtr, mePtr); + } + Tcl_Release((ClientData) mePtr); + } else if ((c == 'p') && (strncmp(argv[1], "post", length) == 0) + && (length == 4)) { int x, y, tmp, vRootX, vRootY; - unsigned int vRootWidth, vRootHeight; + int vRootWidth, vRootHeight; if (argc != 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", @@ -816,7 +835,15 @@ MenuWidgetCmd(clientData, interp, argc, argv) } /* - * If there is a command for the menu, execute it. + * De-activate any active element. + */ + + ActivateMenuEntry(menuPtr, -1); + + /* + * If there is a command for the menu, execute it. This + * may change the size of the menu, so be sure to recompute + * the menu's geometry if needed. */ if (menuPtr->postCommand != NULL) { @@ -825,6 +852,10 @@ MenuWidgetCmd(clientData, interp, argc, argv) if (result != TCL_OK) { return result; } + if (menuPtr->flags & RESIZE_PENDING) { + Tcl_CancelIdleCall(ComputeMenuGeometry, (ClientData) menuPtr); + ComputeMenuGeometry((ClientData) menuPtr); + } } /* @@ -873,6 +904,56 @@ MenuWidgetCmd(clientData, interp, argc, argv) Tk_MapWindow(menuPtr->tkwin); } XRaiseWindow(menuPtr->display, Tk_WindowId(menuPtr->tkwin)); + } else if ((c == 'p') && (strncmp(argv[1], "postcascade", length) == 0) + && (length > 4)) { + int index; + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " postcascade index\"", (char *) NULL); + goto error; + } + if (GetMenuIndex(interp, menuPtr, argv[2], 0, &index) != TCL_OK) { + goto error; + } + if ((index < 0) || (menuPtr->entries[index]->type != CASCADE_ENTRY)) { + result = PostSubmenu(interp, menuPtr, (MenuEntry *) NULL); + } else { + result = PostSubmenu(interp, menuPtr, menuPtr->entries[index]); + } + } else if ((c == 't') && (strncmp(argv[1], "type", length) == 0)) { + int index; + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " type index\"", (char *) NULL); + goto error; + } + if (GetMenuIndex(interp, menuPtr, argv[2], 0, &index) != TCL_OK) { + goto error; + } + if (index < 0) { + goto done; + } + mePtr = menuPtr->entries[index]; + switch (mePtr->type) { + case COMMAND_ENTRY: + interp->result = "command"; + break; + case SEPARATOR_ENTRY: + interp->result = "separator"; + break; + case CHECK_BUTTON_ENTRY: + interp->result = "checkbutton"; + break; + case RADIO_BUTTON_ENTRY: + interp->result = "radiobutton"; + break; + case CASCADE_ENTRY: + interp->result = "cascade"; + break; + case TEAROFF_ENTRY: + interp->result = "tearoff"; + break; + } } else if ((c == 'u') && (strncmp(argv[1], "unpost", length) == 0)) { if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", @@ -891,7 +972,7 @@ MenuWidgetCmd(clientData, interp, argc, argv) argv[0], " yposition index\"", (char *) NULL); goto error; } - if (GetMenuIndex(interp, menuPtr, argv[2], &index) != TCL_OK) { + if (GetMenuIndex(interp, menuPtr, argv[2], 0, &index) != TCL_OK) { goto error; } if (index < 0) { @@ -901,17 +982,18 @@ MenuWidgetCmd(clientData, interp, argc, argv) } } else { Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be activate, add, configure, delete, disable, ", - "enable, entryconfigure, index, invoke, post, ", - "unpost, or yposition", (char *) NULL); + "\": must be activate, add, cget, configure, delete, ", + "entrycget, entryconfigure, index, insert, invoke, ", + "post, postcascade, type, unpost, or yposition", + (char *) NULL); goto error; } done: - Tk_Release((ClientData) menuPtr); + Tcl_Release((ClientData) menuPtr); return result; error: - Tk_Release((ClientData) menuPtr); + Tcl_Release((ClientData) menuPtr); return TCL_ERROR; } @@ -920,7 +1002,7 @@ MenuWidgetCmd(clientData, interp, argc, argv) * * DestroyMenu -- * - * This procedure is invoked by Tk_EventuallyFree or Tk_Release + * This procedure is invoked by Tcl_EventuallyFree or Tcl_Release * to clean up the internal structure of a menu at a safe time * (when no-one is using it anymore). * @@ -934,10 +1016,10 @@ MenuWidgetCmd(clientData, interp, argc, argv) */ static void -DestroyMenu(clientData) - ClientData clientData; /* Info about menu widget. */ +DestroyMenu(memPtr) + char *memPtr; /* Info about menu widget. */ { - register Menu *menuPtr = (Menu *) clientData; + register Menu *menuPtr = (Menu *) memPtr; int i; /* @@ -947,7 +1029,7 @@ DestroyMenu(clientData) */ for (i = 0; i < menuPtr->numEntries; i++) { - DestroyMenuEntry((ClientData) menuPtr->entries[i]); + DestroyMenuEntry((char *) menuPtr->entries[i]); } if (menuPtr->entries != NULL) { ckfree((char *) menuPtr->entries); @@ -964,8 +1046,8 @@ DestroyMenu(clientData) if (menuPtr->activeGC != None) { Tk_FreeGC(menuPtr->display, menuPtr->activeGC); } - if (menuPtr->selectorGC != None) { - Tk_FreeGC(menuPtr->display, menuPtr->selectorGC); + if (menuPtr->indicatorGC != None) { + Tk_FreeGC(menuPtr->display, menuPtr->indicatorGC); } Tk_FreeOptions(configSpecs, (char *) menuPtr, menuPtr->display, 0); ckfree((char *) menuPtr); @@ -976,7 +1058,7 @@ DestroyMenu(clientData) * * DestroyMenuEntry -- * - * This procedure is invoked by Tk_EventuallyFree or Tk_Release + * This procedure is invoked by Tcl_EventuallyFree or Tcl_Release * to clean up the internal structure of a menu entry at a safe time * (when no-one is using it anymore). * @@ -990,10 +1072,10 @@ DestroyMenu(clientData) */ static void -DestroyMenuEntry(clientData) - ClientData clientData; /* Pointer to entry to be freed. */ +DestroyMenuEntry(memPtr) + char *memPtr; /* Pointer to entry to be freed. */ { - register MenuEntry *mePtr = (MenuEntry *) clientData; + register MenuEntry *mePtr = (MenuEntry *) memPtr; Menu *menuPtr = mePtr->menuPtr; /* @@ -1002,11 +1084,6 @@ DestroyMenuEntry(clientData) * stuff. */ - if (mePtr->name != NULL) { - Tcl_UntraceVar(menuPtr->interp, mePtr->name, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - MenuVarProc, (ClientData) mePtr); - } if (menuPtr->postedCascade == mePtr) { /* * Ignore errors while unposting the menu, since it's possible @@ -1016,6 +1093,9 @@ DestroyMenuEntry(clientData) PostSubmenu(menuPtr->interp, menuPtr, (MenuEntry *) NULL); } + if (mePtr->image != NULL) { + Tk_FreeImage(mePtr->image); + } if (mePtr->textGC != None) { Tk_FreeGC(menuPtr->display, mePtr->textGC); } @@ -1025,6 +1105,14 @@ DestroyMenuEntry(clientData) if (mePtr->disabledGC != None) { Tk_FreeGC(menuPtr->display, mePtr->disabledGC); } + if (mePtr->indicatorGC != None) { + Tk_FreeGC(menuPtr->display, mePtr->indicatorGC); + } + if (mePtr->name != NULL) { + Tcl_UntraceVar(menuPtr->interp, mePtr->name, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + MenuVarProc, (ClientData) mePtr); + } Tk_FreeOptions(entryConfigSpecs, (char *) mePtr, menuPtr->display, (COMMAND_MASK << mePtr->type)); ckfree((char *) mePtr); @@ -1063,6 +1151,7 @@ ConfigureMenu(interp, menuPtr, argc, argv, flags) GC newGC; unsigned long mask; int i; + XSetWindowAttributes atts; if (Tk_ConfigureWidget(interp, menuPtr->tkwin, configSpecs, argc, argv, (char *) menuPtr, flags) != TCL_OK) { @@ -1119,12 +1208,27 @@ ConfigureMenu(interp, menuPtr, argc, argv, flags) } menuPtr->activeGC = newGC; - gcValues.foreground = menuPtr->selectorFg->pixel; + gcValues.foreground = menuPtr->indicatorFg->pixel; newGC = Tk_GetGC(menuPtr->tkwin, GCForeground|GCFont, &gcValues); - if (menuPtr->selectorGC != None) { - Tk_FreeGC(menuPtr->display, menuPtr->selectorGC); + if (menuPtr->indicatorGC != None) { + Tk_FreeGC(menuPtr->display, menuPtr->indicatorGC); + } + menuPtr->indicatorGC = newGC; + + if (menuPtr->transient) { + atts.override_redirect = True; + atts.save_under = True; + } else { + atts.override_redirect = False; + atts.save_under = False; + } + if ((atts.override_redirect + != Tk_Attributes(menuPtr->tkwin)->override_redirect) + || (atts.save_under + != Tk_Attributes(menuPtr->tkwin)->save_under)) { + Tk_ChangeWindowAttributes(menuPtr->tkwin, + CWOverrideRedirect|CWSaveUnder, &atts); } - menuPtr->selectorGC = newGC; /* * After reconfiguring a menu, we need to reconfigure all of the @@ -1141,9 +1245,29 @@ ConfigureMenu(interp, menuPtr, argc, argv, flags) TK_CONFIG_ARGV_ONLY | COMMAND_MASK << mePtr->type); } + /* + * Depending on the -tearOff option, make sure that there is or + * isn't an initial tear-off entry at the beginning of the menu. + */ + + if (menuPtr->tearOff) { + if ((menuPtr->numEntries == 0) + || (menuPtr->entries[0]->type != TEAROFF_ENTRY)) { + MenuNewEntry(menuPtr, 0, TEAROFF_ENTRY); + } + } else if ((menuPtr->numEntries > 0) + && (menuPtr->entries[0]->type == TEAROFF_ENTRY)) { + Tcl_EventuallyFree((ClientData) menuPtr->entries[0], + DestroyMenuEntry); + for (i = 1; i < menuPtr->numEntries; i++) { + menuPtr->entries[i-1] = menuPtr->entries[i]; + } + menuPtr->numEntries--; + } + if (!(menuPtr->flags & RESIZE_PENDING)) { menuPtr->flags |= RESIZE_PENDING; - Tk_DoWhenIdle(ComputeMenuGeometry, (ClientData) menuPtr); + Tcl_DoWhenIdle(ComputeMenuGeometry, (ClientData) menuPtr); } return TCL_OK; @@ -1186,6 +1310,7 @@ ConfigureMenuEntry(interp, menuPtr, mePtr, index, argc, argv, flags) XGCValues gcValues; GC newGC, newActiveGC, newDisabledGC; unsigned long mask; + Tk_Image image; /* * If this entry is a cascade and the cascade is posted, then unpost @@ -1197,7 +1322,7 @@ ConfigureMenuEntry(interp, menuPtr, mePtr, index, argc, argv, flags) if (menuPtr->postedCascade == mePtr) { if (PostSubmenu(menuPtr->interp, menuPtr, (MenuEntry *) NULL) != TCL_OK) { - Tk_BackgroundError(menuPtr->interp); + Tcl_BackgroundError(menuPtr->interp); } } @@ -1247,18 +1372,22 @@ ConfigureMenuEntry(interp, menuPtr, mePtr, index, argc, argv, flags) } if ((mePtr->state != tkNormalUid) && (mePtr->state != tkDisabledUid)) { Tcl_AppendResult(interp, "bad state value \"", mePtr->state, - "\": must be normal, active, or disabled", (char *) NULL); + "\": must be normal, active, or disabled", (char *) NULL); mePtr->state = tkNormalUid; return TCL_ERROR; } } - if (mePtr->fontPtr != NULL) { - gcValues.foreground = menuPtr->fg->pixel; + if ((mePtr->fontPtr != NULL) || (mePtr->border != NULL) + || (mePtr->fg != NULL) || (mePtr->activeBorder != NULL) + || (mePtr->activeFg != NULL)) { + gcValues.foreground = (mePtr->fg != NULL) ? mePtr->fg->pixel + : menuPtr->fg->pixel; gcValues.background = Tk_3DBorderColor( (mePtr->border != NULL) ? mePtr->border : menuPtr->border) ->pixel; - gcValues.font = mePtr->fontPtr->fid; + gcValues.font = (mePtr->fontPtr != NULL) ? mePtr->fontPtr->fid + : menuPtr->fontPtr->fid; /* * Note: disable GraphicsExpose events; we know there won't be @@ -1282,7 +1411,8 @@ ConfigureMenuEntry(interp, menuPtr, mePtr, index, argc, argv, flags) } newDisabledGC = Tk_GetGC(menuPtr->tkwin, mask, &gcValues); - gcValues.foreground = menuPtr->activeFg->pixel; + gcValues.foreground = (mePtr->activeFg != NULL) + ? mePtr->activeFg->pixel : menuPtr->activeFg->pixel; gcValues.background = Tk_3DBorderColor( (mePtr->activeBorder != NULL) ? mePtr->activeBorder : menuPtr->activeBorder)->pixel; @@ -1306,18 +1436,29 @@ ConfigureMenuEntry(interp, menuPtr, mePtr, index, argc, argv, flags) Tk_FreeGC(menuPtr->display, mePtr->disabledGC); } mePtr->disabledGC = newDisabledGC; + if (mePtr->indicatorFg != NULL) { + gcValues.foreground = mePtr->indicatorFg->pixel; + newGC = Tk_GetGC(menuPtr->tkwin, GCForeground, &gcValues); + } else { + newGC = None; + } + if (mePtr->indicatorGC != None) { + Tk_FreeGC(menuPtr->display, mePtr->indicatorGC); + } + mePtr->indicatorGC = newGC; if ((mePtr->type == CHECK_BUTTON_ENTRY) || (mePtr->type == RADIO_BUTTON_ENTRY)) { char *value; if (mePtr->name == NULL) { - mePtr->name = ckalloc((unsigned) (strlen(mePtr->label) + 1)); - strcpy(mePtr->name, mePtr->label); + mePtr->name = (char *) ckalloc((unsigned) (mePtr->labelLength + 1)); + strcpy(mePtr->name, (mePtr->label == NULL) ? "" : mePtr->label); } if (mePtr->onValue == NULL) { - mePtr->onValue = ckalloc((unsigned) (strlen(mePtr->label) + 1)); - strcpy(mePtr->onValue, mePtr->label); + mePtr->onValue = (char *) ckalloc((unsigned) + (mePtr->labelLength + 1)); + strcpy(mePtr->onValue, (mePtr->label == NULL) ? "" : mePtr->label); } /* @@ -1328,7 +1469,7 @@ ConfigureMenuEntry(interp, menuPtr, mePtr, index, argc, argv, flags) */ value = Tcl_GetVar(interp, mePtr->name, TCL_GLOBAL_ONLY); - mePtr->flags &= ENTRY_SELECTED; + mePtr->flags &= ~ENTRY_SELECTED; if (value != NULL) { if (strcmp(value, mePtr->onValue) == 0) { mePtr->flags |= ENTRY_SELECTED; @@ -1343,9 +1484,42 @@ ConfigureMenuEntry(interp, menuPtr, mePtr, index, argc, argv, flags) MenuVarProc, (ClientData) mePtr); } + /* + * Get the images for the entry, if there are any. Allocate the + * new images before freeing the old ones, so that the reference + * counts don't go to zero and cause image data to be discarded. + */ + + if (mePtr->imageString != NULL) { + image = Tk_GetImage(interp, menuPtr->tkwin, mePtr->imageString, + MenuImageProc, (ClientData) mePtr); + if (image == NULL) { + return TCL_ERROR; + } + } else { + image = NULL; + } + if (mePtr->image != NULL) { + Tk_FreeImage(mePtr->image); + } + mePtr->image = image; + if (mePtr->selectImageString != NULL) { + image = Tk_GetImage(interp, menuPtr->tkwin, mePtr->selectImageString, + MenuSelectImageProc, (ClientData) mePtr); + if (image == NULL) { + return TCL_ERROR; + } + } else { + image = NULL; + } + if (mePtr->selectImage != NULL) { + Tk_FreeImage(mePtr->selectImage); + } + mePtr->selectImage = image; + if (!(menuPtr->flags & RESIZE_PENDING)) { menuPtr->flags |= RESIZE_PENDING; - Tk_DoWhenIdle(ComputeMenuGeometry, (ClientData) menuPtr); + Tcl_DoWhenIdle(ComputeMenuGeometry, (ClientData) menuPtr); } return TCL_OK; } @@ -1378,20 +1552,21 @@ ComputeMenuGeometry(clientData) Menu *menuPtr = (Menu *) clientData; register MenuEntry *mePtr; XFontStruct *fontPtr; - int maxLabelWidth, maxSelectorWidth, maxAccelWidth; - int width, height, selectorSpace; + int maxLabelWidth, maxIndicatorWidth, maxAccelWidth; + int width, height, indicatorSpace; int i, y; + int imageWidth, imageHeight; if (menuPtr->tkwin == NULL) { return; } - maxLabelWidth = maxSelectorWidth = maxAccelWidth = 0; + maxLabelWidth = maxIndicatorWidth = maxAccelWidth = 0; y = menuPtr->borderWidth; for (i = 0; i < menuPtr->numEntries; i++) { mePtr = menuPtr->entries[i]; - selectorSpace = 0; + indicatorSpace = 0; fontPtr = mePtr->fontPtr; if (fontPtr == NULL) { fontPtr = menuPtr->fontPtr; @@ -1400,42 +1575,49 @@ ComputeMenuGeometry(clientData) /* * For each entry, compute the height required by that * particular entry, plus three widths: the width of the - * label, the width to allow for a selector to be displayed + * label, the width to allow for an indicator to be displayed * to the left of the label (if any), and the width of the * accelerator to be displayed to the right of the label * (if any). These sizes depend, of course, on the type * of the entry. */ - if (mePtr->bitmap != None) { - unsigned int bitmapWidth, bitmapHeight; + if (mePtr->image != NULL) { + Tk_SizeOfImage(mePtr->image, &imageWidth, &imageHeight); - Tk_SizeOfBitmap(menuPtr->display, mePtr->bitmap, - &bitmapWidth, &bitmapHeight); - mePtr->height = bitmapHeight; - width = bitmapWidth; - if (mePtr->type == CHECK_BUTTON_ENTRY) { - selectorSpace = (14*mePtr->height)/10; - mePtr->selectorDiameter = (65*mePtr->height)/100; - } else if (mePtr->type == RADIO_BUTTON_ENTRY) { - selectorSpace = (14*mePtr->height)/10; - mePtr->selectorDiameter = (75*mePtr->height)/100; + imageOrBitmap: + mePtr->height = imageHeight; + width = imageWidth; + if (mePtr->indicatorOn) { + if (mePtr->type == CHECK_BUTTON_ENTRY) { + indicatorSpace = (14*mePtr->height)/10; + mePtr->indicatorDiameter = (65*mePtr->height)/100; + } else if (mePtr->type == RADIO_BUTTON_ENTRY) { + indicatorSpace = (14*mePtr->height)/10; + mePtr->indicatorDiameter = (75*mePtr->height)/100; + } } + } else if (mePtr->bitmap != None) { + Tk_SizeOfBitmap(menuPtr->display, mePtr->bitmap, + &imageWidth, &imageHeight); + goto imageOrBitmap; } else { mePtr->height = fontPtr->ascent + fontPtr->descent; if (mePtr->label != NULL) { (void) TkMeasureChars(fontPtr, mePtr->label, - mePtr->labelLength, 0, (int) 100000, + mePtr->labelLength, 0, (int) 100000, 0, TK_NEWLINES_NOT_SPECIAL, &width); } else { width = 0; } - if (mePtr->type == CHECK_BUTTON_ENTRY) { - selectorSpace = mePtr->height; - mePtr->selectorDiameter = (80*mePtr->height)/100; - } else if (mePtr->type == RADIO_BUTTON_ENTRY) { - selectorSpace = mePtr->height; - mePtr->selectorDiameter = mePtr->height; + if (mePtr->indicatorOn) { + if (mePtr->type == CHECK_BUTTON_ENTRY) { + indicatorSpace = mePtr->height; + mePtr->indicatorDiameter = (80*mePtr->height)/100; + } else if (mePtr->type == RADIO_BUTTON_ENTRY) { + indicatorSpace = mePtr->height; + mePtr->indicatorDiameter = mePtr->height; + } } } mePtr->height += 2*menuPtr->activeBorderWidth + 2; @@ -1446,7 +1628,7 @@ ComputeMenuGeometry(clientData) width = 2*CASCADE_ARROW_WIDTH; } else if (mePtr->accel != NULL) { (void) TkMeasureChars(fontPtr, mePtr->accel, mePtr->accelLength, - 0, (int) 100000, TK_NEWLINES_NOT_SPECIAL, &width); + 0, (int) 100000, 0, TK_NEWLINES_NOT_SPECIAL, &width); } else { width = 0; } @@ -1454,10 +1636,13 @@ ComputeMenuGeometry(clientData) maxAccelWidth = width; } if (mePtr->type == SEPARATOR_ENTRY) { - mePtr->height = 4*menuPtr->borderWidth; + mePtr->height = 8; } - if (selectorSpace > maxSelectorWidth) { - maxSelectorWidth = selectorSpace; + if (mePtr->type == TEAROFF_ENTRY) { + mePtr->height = 12; + } + if (indicatorSpace > maxIndicatorWidth) { + maxIndicatorWidth = indicatorSpace; } mePtr->y = y; y += mePtr->height; @@ -1466,17 +1651,17 @@ ComputeMenuGeometry(clientData) /* * Got all the sizes. Update fields in the menu structure, then * resize the window if necessary. Leave margins on either side - * of the selector (or just one margin if there is no selector). + * of the indicator (or just one margin if there is no indicator). * Leave another margin on the right side of the label, plus yet * another margin to the right of the accelerator (if there is one). */ - menuPtr->selectorSpace = maxSelectorWidth + MARGIN_WIDTH; - if (maxSelectorWidth != 0) { - menuPtr->selectorSpace += MARGIN_WIDTH; + menuPtr->indicatorSpace = maxIndicatorWidth + MARGIN_WIDTH; + if (maxIndicatorWidth != 0) { + menuPtr->indicatorSpace += MARGIN_WIDTH; } menuPtr->labelWidth = maxLabelWidth + MARGIN_WIDTH; - width = menuPtr->selectorSpace + menuPtr->labelWidth + maxAccelWidth + width = menuPtr->indicatorSpace + menuPtr->labelWidth + maxAccelWidth + 2*menuPtr->borderWidth + 2*menuPtr->activeBorderWidth; if (maxAccelWidth != 0) { width += MARGIN_WIDTH; @@ -1537,7 +1722,7 @@ DisplayMenu(clientData) register Tk_Window tkwin = menuPtr->tkwin; Tk_3DBorder bgBorder, activeBorder; XFontStruct *fontPtr; - int index, baseline; + int index, baseline, strictMotif, leftEdge, y, height; GC gc; XPoint points[3]; @@ -1550,6 +1735,9 @@ DisplayMenu(clientData) * Loop through all of the entries, drawing them one at a time. */ + strictMotif = Tk_StrictMotif(menuPtr->tkwin); + leftEdge = menuPtr->borderWidth + menuPtr->indicatorSpace + + menuPtr->activeBorderWidth; for (index = 0; index < menuPtr->numEntries; index++) { mePtr = menuPtr->entries[index]; if (!(mePtr->flags & ENTRY_NEEDS_REDISPLAY)) { @@ -1561,30 +1749,41 @@ DisplayMenu(clientData) * Background. */ - activeBorder = mePtr->activeBorder; - if (activeBorder == NULL) { - activeBorder = menuPtr->activeBorder; + bgBorder = mePtr->border; + if (bgBorder == NULL) { + bgBorder = menuPtr->border; } - if ((mePtr->state == tkActiveUid) - || (menuPtr->postedCascade == mePtr)) { + if (strictMotif) { + activeBorder = bgBorder; + } else { + activeBorder = mePtr->activeBorder; + if (activeBorder == NULL) { + activeBorder = menuPtr->activeBorder; + } + } + if (mePtr->state == tkActiveUid) { bgBorder = activeBorder; - Tk_Fill3DRectangle(menuPtr->display, Tk_WindowId(tkwin), + Tk_Fill3DRectangle(menuPtr->tkwin, Tk_WindowId(tkwin), bgBorder, menuPtr->borderWidth, mePtr->y, Tk_Width(tkwin) - 2*menuPtr->borderWidth, mePtr->height, menuPtr->activeBorderWidth, TK_RELIEF_RAISED); + } else { + Tk_Fill3DRectangle(menuPtr->tkwin, Tk_WindowId(tkwin), + bgBorder, menuPtr->borderWidth, mePtr->y, + Tk_Width(tkwin) - 2*menuPtr->borderWidth, mePtr->height, + 0, TK_RELIEF_FLAT); + } + + /* + * Choose the gc for drawing the foreground part of the entry. + */ + + if ((mePtr->state == tkActiveUid) && !strictMotif) { gc = mePtr->activeGC; if (gc == NULL) { gc = menuPtr->activeGC; } } else { - bgBorder = mePtr->border; - if (bgBorder == NULL) { - bgBorder = menuPtr->border; - } - Tk_Fill3DRectangle(menuPtr->display, Tk_WindowId(tkwin), - bgBorder, menuPtr->borderWidth, mePtr->y, - Tk_Width(tkwin) - 2*menuPtr->borderWidth, mePtr->height, - 0, TK_RELIEF_FLAT); if ((mePtr->state == tkDisabledUid) && (menuPtr->disabledFg != NULL)) { gc = mePtr->disabledGC; @@ -1600,7 +1799,7 @@ DisplayMenu(clientData) } /* - * Draw label or bitmap for entry. + * Draw label or bitmap or image for entry. */ fontPtr = mePtr->fontPtr; @@ -1609,13 +1808,26 @@ DisplayMenu(clientData) } baseline = mePtr->y + (mePtr->height + fontPtr->ascent - fontPtr->descent)/2; - if (mePtr->bitmap != None) { - unsigned int width, height; + if (mePtr->image != NULL) { + int width, height; + + Tk_SizeOfImage(mePtr->image, &width, &height); + if ((mePtr->selectImage != NULL) + && (mePtr->flags & ENTRY_SELECTED)) { + Tk_RedrawImage(mePtr->selectImage, 0, 0, width, height, + Tk_WindowId(tkwin), leftEdge, + (int) (mePtr->y + (mePtr->height - height)/2)); + } else { + Tk_RedrawImage(mePtr->image, 0, 0, width, height, + Tk_WindowId(tkwin), leftEdge, + (int) (mePtr->y + (mePtr->height - height)/2)); + } + } else if (mePtr->bitmap != None) { + int width, height; Tk_SizeOfBitmap(menuPtr->display, mePtr->bitmap, &width, &height); XCopyPlane(menuPtr->display, mePtr->bitmap, Tk_WindowId(tkwin), - gc, 0, 0, width, height, - menuPtr->borderWidth + menuPtr->selectorSpace, + gc, 0, 0, (unsigned) width, (unsigned) height, leftEdge, (int) (mePtr->y + (mePtr->height - height)/2), 1); } else { baseline = mePtr->y + (mePtr->height + fontPtr->ascent @@ -1623,13 +1835,12 @@ DisplayMenu(clientData) if (mePtr->label != NULL) { TkDisplayChars(menuPtr->display, Tk_WindowId(tkwin), gc, fontPtr, mePtr->label, mePtr->labelLength, - menuPtr->borderWidth + menuPtr->selectorSpace, - baseline, TK_NEWLINES_NOT_SPECIAL); + leftEdge, baseline, leftEdge, + TK_NEWLINES_NOT_SPECIAL); if (mePtr->underline >= 0) { TkUnderlineChars(menuPtr->display, Tk_WindowId(tkwin), gc, - fontPtr, mePtr->label, - menuPtr->borderWidth + menuPtr->selectorSpace, - baseline, TK_NEWLINES_NOT_SPECIAL, + fontPtr, mePtr->label, leftEdge, baseline, + leftEdge, TK_NEWLINES_NOT_SPECIAL, mePtr->underline, mePtr->underline); } } @@ -1640,58 +1851,63 @@ DisplayMenu(clientData) */ if (mePtr->type == CASCADE_ENTRY) { - points[0].x = Tk_Width(tkwin) - 2*menuPtr->borderWidth - - MARGIN_WIDTH - CASCADE_ARROW_WIDTH; + points[0].x = Tk_Width(tkwin) - menuPtr->borderWidth + - menuPtr->activeBorderWidth - MARGIN_WIDTH + - CASCADE_ARROW_WIDTH; points[0].y = mePtr->y + (mePtr->height - CASCADE_ARROW_HEIGHT)/2; points[1].x = points[0].x; points[1].y = points[0].y + CASCADE_ARROW_HEIGHT; points[2].x = points[0].x + CASCADE_ARROW_WIDTH; points[2].y = points[0].y + CASCADE_ARROW_HEIGHT/2; - Tk_Fill3DPolygon(menuPtr->display, Tk_WindowId(tkwin), activeBorder, - points, 3, menuPtr->activeBorderWidth, + Tk_Fill3DPolygon(menuPtr->tkwin, Tk_WindowId(tkwin), activeBorder, + points, 3, DECORATION_BORDER_WIDTH, (menuPtr->postedCascade == mePtr) ? TK_RELIEF_SUNKEN : TK_RELIEF_RAISED); } else if (mePtr->accel != NULL) { TkDisplayChars(menuPtr->display, Tk_WindowId(tkwin), gc, fontPtr, mePtr->accel, mePtr->accelLength, - menuPtr->borderWidth + menuPtr->selectorSpace - + menuPtr->labelWidth, baseline, TK_NEWLINES_NOT_SPECIAL); + leftEdge + menuPtr->labelWidth, baseline, + leftEdge + menuPtr->labelWidth, TK_NEWLINES_NOT_SPECIAL); } /* - * Draw check-button selector. + * Draw check-button indicator. */ - if (mePtr->type == CHECK_BUTTON_ENTRY) { + gc = mePtr->indicatorGC; + if (gc == None) { + gc = menuPtr->indicatorGC; + } + if ((mePtr->type == CHECK_BUTTON_ENTRY) && mePtr->indicatorOn) { int dim, x, y; - dim = mePtr->selectorDiameter; - x = menuPtr->borderWidth + (menuPtr->selectorSpace - dim)/2; + dim = mePtr->indicatorDiameter; + x = menuPtr->borderWidth + menuPtr->activeBorderWidth + + (menuPtr->indicatorSpace - dim)/2; y = mePtr->y + (mePtr->height - dim)/2; - Tk_Fill3DRectangle(menuPtr->display, Tk_WindowId(tkwin), + Tk_Fill3DRectangle(menuPtr->tkwin, Tk_WindowId(tkwin), menuPtr->border, x, y, dim, dim, - menuPtr->activeBorderWidth, TK_RELIEF_SUNKEN); - x += menuPtr->activeBorderWidth; - y += menuPtr->activeBorderWidth; - dim -= 2*menuPtr->activeBorderWidth; + DECORATION_BORDER_WIDTH, TK_RELIEF_SUNKEN); + x += DECORATION_BORDER_WIDTH; + y += DECORATION_BORDER_WIDTH; + dim -= 2*DECORATION_BORDER_WIDTH; if ((dim > 0) && (mePtr->flags & ENTRY_SELECTED)) { - XFillRectangle(menuPtr->display, Tk_WindowId(tkwin), - menuPtr->selectorGC, x, y, (unsigned int) dim, - (unsigned int) dim); + XFillRectangle(menuPtr->display, Tk_WindowId(tkwin), gc, + x, y, (unsigned int) dim, (unsigned int) dim); } } /* - * Draw radio-button selector. + * Draw radio-button indicator. */ - if (mePtr->type == RADIO_BUTTON_ENTRY) { + if ((mePtr->type == RADIO_BUTTON_ENTRY) && mePtr->indicatorOn) { XPoint points[4]; int radius; - radius = mePtr->selectorDiameter/2; - points[0].x = menuPtr->borderWidth - + (menuPtr->selectorSpace - mePtr->selectorDiameter)/2; + radius = mePtr->indicatorDiameter/2; + points[0].x = menuPtr->borderWidth + menuPtr->activeBorderWidth + + (menuPtr->indicatorSpace - mePtr->indicatorDiameter)/2; points[0].y = mePtr->y + (mePtr->height)/2; points[1].x = points[0].x + radius; points[1].y = points[0].y + radius; @@ -1700,16 +1916,15 @@ DisplayMenu(clientData) points[3].x = points[1].x; points[3].y = points[0].y - radius; if (mePtr->flags & ENTRY_SELECTED) { - XFillPolygon(menuPtr->display, Tk_WindowId(tkwin), - menuPtr->selectorGC, points, 4, Convex, - CoordModeOrigin); + XFillPolygon(menuPtr->display, Tk_WindowId(tkwin), gc, + points, 4, Convex, CoordModeOrigin); } else { - Tk_Fill3DPolygon(menuPtr->display, Tk_WindowId(tkwin), - menuPtr->border, points, 4, menuPtr->activeBorderWidth, + Tk_Fill3DPolygon(menuPtr->tkwin, Tk_WindowId(tkwin), + menuPtr->border, points, 4, DECORATION_BORDER_WIDTH, TK_RELIEF_FLAT); } - Tk_Draw3DPolygon(menuPtr->display, Tk_WindowId(tkwin), - menuPtr->border, points, 4, menuPtr->activeBorderWidth, + Tk_Draw3DPolygon(menuPtr->tkwin, Tk_WindowId(tkwin), + menuPtr->border, points, 4, DECORATION_BORDER_WIDTH, TK_RELIEF_SUNKEN); } @@ -1722,14 +1937,40 @@ DisplayMenu(clientData) int margin; margin = (fontPtr->ascent + fontPtr->descent)/2; - points[0].x = 2*menuPtr->borderWidth + margin; + points[0].x = 0; points[0].y = mePtr->y + mePtr->height/2; - points[1].x = Tk_Width(tkwin) - 2*menuPtr->borderWidth - margin; + points[1].x = Tk_Width(tkwin) - 1; points[1].y = points[0].y; - Tk_Draw3DPolygon(menuPtr->display, Tk_WindowId(tkwin), + Tk_Draw3DPolygon(menuPtr->tkwin, Tk_WindowId(tkwin), menuPtr->border, points, 2, 1, TK_RELIEF_RAISED); } + /* + * Draw tear-off line. + */ + + if (mePtr->type == TEAROFF_ENTRY) { + XPoint points[2]; + int margin, width, maxX; + + margin = (fontPtr->ascent + fontPtr->descent)/2; + points[0].x = 0; + points[0].y = mePtr->y + mePtr->height/2; + points[1].y = points[0].y; + width = 6; + maxX = Tk_Width(tkwin) - 1; + + while (points[0].x < maxX) { + points[1].x = points[0].x + width; + if (points[1].x > maxX) { + points[1].x = maxX; + } + Tk_Draw3DPolygon(menuPtr->tkwin, Tk_WindowId(tkwin), + menuPtr->border, points, 2, 1, TK_RELIEF_RAISED); + points[0].x += 2*width; + } + } + /* * If the entry is disabled with a stipple rather than a special * foreground color, generate the stippled effect. @@ -1744,9 +1985,28 @@ DisplayMenu(clientData) } } - Tk_Draw3DRectangle(menuPtr->display, Tk_WindowId(tkwin), + /* + * If there is extra space after the last entry in the menu, + * clear it. + */ + + if (menuPtr->numEntries >= 1) { + mePtr = menuPtr->entries[menuPtr->numEntries-1]; + y = mePtr->y + mePtr->height; + } else { + y = menuPtr->borderWidth; + } + height = Tk_Height(tkwin) - menuPtr->borderWidth - y; + if (height > 0) { + Tk_Fill3DRectangle(tkwin, Tk_WindowId(tkwin), + menuPtr->border, menuPtr->borderWidth, y, + Tk_Width(tkwin) - 2*menuPtr->borderWidth, + height, 0, TK_RELIEF_FLAT); + } + + Tk_Draw3DRectangle(menuPtr->tkwin, Tk_WindowId(tkwin), menuPtr->border, 0, 0, Tk_Width(tkwin), Tk_Height(tkwin), - menuPtr->borderWidth, TK_RELIEF_RAISED); + menuPtr->borderWidth, menuPtr->relief); } /* @@ -1770,12 +2030,14 @@ DisplayMenu(clientData) */ static int -GetMenuIndex(interp, menuPtr, string, indexPtr) +GetMenuIndex(interp, menuPtr, string, lastOK, indexPtr) Tcl_Interp *interp; /* For error messages. */ Menu *menuPtr; /* Menu for which the index is being * specified. */ char *string; /* Specification of an entry in menu. See * manual entry for valid .*/ + int lastOK; /* Non-zero means its OK to return index + * just *after* last entry. */ int *indexPtr; /* Where to store converted relief. */ { int i, y; @@ -1785,8 +2047,9 @@ GetMenuIndex(interp, menuPtr, string, indexPtr) return TCL_OK; } - if ((string[0] == 'l') && (strcmp(string, "last") == 0)) { - *indexPtr = menuPtr->numEntries-1; + if (((string[0] == 'l') && (strcmp(string, "last") == 0)) + || ((string[0] == 'e') && (strcmp(string, "end") == 0))) { + *indexPtr = menuPtr->numEntries - ((lastOK) ? 0 : 1); return TCL_OK; } @@ -1797,18 +2060,15 @@ GetMenuIndex(interp, menuPtr, string, indexPtr) if (string[0] == '@') { if (Tcl_GetInt(interp, string+1, &y) == TCL_OK) { - if (y < 0) { - *indexPtr = -1; - return TCL_OK; - } for (i = 0; i < menuPtr->numEntries; i++) { - y -= menuPtr->entries[i]->height; - if (y < 0) { + MenuEntry *mePtr = menuPtr->entries[i]; + + if (y < (mePtr->y + mePtr->height)) { break; } } if (i >= menuPtr->numEntries) { - i = -1; + i = menuPtr->numEntries-1; } *indexPtr = i; return TCL_OK; @@ -1820,7 +2080,11 @@ GetMenuIndex(interp, menuPtr, string, indexPtr) if (isdigit(UCHAR(string[0]))) { if (Tcl_GetInt(interp, string, &i) == TCL_OK) { if (i >= menuPtr->numEntries) { - i = menuPtr->numEntries - 1; + if (lastOK) { + i = menuPtr->numEntries; + } else { + i = menuPtr->numEntries-1; + } } else if (i < 0) { i = -1; } @@ -1872,19 +2136,235 @@ MenuEventProc(clientData, eventPtr) Menu *menuPtr = (Menu *) clientData; if ((eventPtr->type == Expose) && (eventPtr->xexpose.count == 0)) { EventuallyRedrawMenu(menuPtr, (MenuEntry *) NULL); + } else if (eventPtr->type == ConfigureNotify) { + EventuallyRedrawMenu(menuPtr, (MenuEntry *) NULL); } else if (eventPtr->type == DestroyNotify) { - Tcl_DeleteCommand(menuPtr->interp, Tk_PathName(menuPtr->tkwin)); - menuPtr->tkwin = NULL; + if (menuPtr->tkwin != NULL) { + menuPtr->tkwin = NULL; + Tcl_DeleteCommand(menuPtr->interp, + Tcl_GetCommandName(menuPtr->interp, menuPtr->widgetCmd)); + } if (menuPtr->flags & REDRAW_PENDING) { - Tk_CancelIdleCall(DisplayMenu, (ClientData) menuPtr); + Tcl_CancelIdleCall(DisplayMenu, (ClientData) menuPtr); } if (menuPtr->flags & RESIZE_PENDING) { - Tk_CancelIdleCall(ComputeMenuGeometry, (ClientData) menuPtr); + Tcl_CancelIdleCall(ComputeMenuGeometry, (ClientData) menuPtr); } - Tk_EventuallyFree((ClientData) menuPtr, DestroyMenu); + Tcl_EventuallyFree((ClientData) menuPtr, DestroyMenu); } } +/* + *---------------------------------------------------------------------- + * + * MenuCmdDeletedProc -- + * + * This procedure is invoked when a widget command is deleted. If + * the widget isn't already in the process of being destroyed, + * this command destroys it. + * + * Results: + * None. + * + * Side effects: + * The widget is destroyed. + * + *---------------------------------------------------------------------- + */ + +static void +MenuCmdDeletedProc(clientData) + ClientData clientData; /* Pointer to widget record for widget. */ +{ + Menu *menuPtr = (Menu *) clientData; + Tk_Window tkwin = menuPtr->tkwin; + + /* + * This procedure could be invoked either because the window was + * destroyed and the command was then deleted (in which case tkwin + * is NULL) or because the command was deleted, and then this procedure + * destroys the widget. + */ + + if (tkwin != NULL) { + menuPtr->tkwin = NULL; + Tk_DestroyWindow(tkwin); + } +} + +/* + *---------------------------------------------------------------------- + * + * MenuNewEntry -- + * + * This procedure allocates and initializes a new menu entry. + * + * Results: + * The return value is a pointer to a new menu entry structure, + * which has been malloc-ed, initialized, and entered into the + * entry array for the menu. + * + * Side effects: + * Storage gets allocated. + * + *---------------------------------------------------------------------- + */ + +static MenuEntry * +MenuNewEntry(menuPtr, index, type) + Menu *menuPtr; /* Menu that will hold the new entry. */ + int index; /* Where in the menu the new entry is to + * go. */ + int type; /* The type of the new entry. */ +{ + MenuEntry *mePtr; + MenuEntry **newEntries; + int i; + + /* + * Create a new array of entries with an empty slot for the + * new entry. + */ + + newEntries = (MenuEntry **) ckalloc((unsigned) + ((menuPtr->numEntries+1)*sizeof(MenuEntry *))); + for (i = 0; i < index; i++) { + newEntries[i] = menuPtr->entries[i]; + } + for ( ; i < menuPtr->numEntries; i++) { + newEntries[i+1] = menuPtr->entries[i]; + } + if (menuPtr->numEntries != 0) { + ckfree((char *) menuPtr->entries); + } + menuPtr->entries = newEntries; + menuPtr->numEntries++; + menuPtr->entries[index] = mePtr = (MenuEntry *) ckalloc(sizeof(MenuEntry)); + mePtr->type = type; + mePtr->menuPtr = menuPtr; + mePtr->label = NULL; + mePtr->labelLength = 0; + mePtr->underline = -1; + mePtr->bitmap = None; + mePtr->imageString = NULL; + mePtr->image = NULL; + mePtr->selectImageString = NULL; + mePtr->selectImage = NULL; + mePtr->accel = NULL; + mePtr->accelLength = 0; + mePtr->state = tkNormalUid; + mePtr->height = 0; + mePtr->y = 0; + mePtr->indicatorDiameter = 0; + mePtr->border = NULL; + mePtr->fg = NULL; + mePtr->activeBorder = NULL; + mePtr->activeFg = NULL; + mePtr->fontPtr = NULL; + mePtr->textGC = None; + mePtr->activeGC = None; + mePtr->disabledGC = None; + mePtr->indicatorOn = 1; + mePtr->indicatorFg = NULL; + mePtr->indicatorGC = None; + mePtr->command = NULL; + mePtr->name = NULL; + mePtr->onValue = NULL; + mePtr->offValue = NULL; + mePtr->flags = 0; + return mePtr; +} + +/* + *---------------------------------------------------------------------- + * + * MenuAddOrInsert -- + * + * This procedure does all of the work of the "add" and "insert" + * widget commands, allowing the code for these to be shared. + * + * Results: + * A standard Tcl return value. + * + * Side effects: + * A new menu entry is created in menuPtr. + * + *---------------------------------------------------------------------- + */ + +static int +MenuAddOrInsert(interp, menuPtr, indexString, argc, argv) + Tcl_Interp *interp; /* Used for error reporting. */ + Menu *menuPtr; /* Widget in which to create new + * entry. */ + char *indexString; /* String describing index at which + * to insert. NULL means insert at + * end. */ + int argc; /* Number of elements in argv. */ + char **argv; /* Arguments to command: first arg + * is type of entry, others are + * config options. */ +{ + int c, type, i, index; + size_t length; + MenuEntry *mePtr; + + if (indexString != NULL) { + if (GetMenuIndex(interp, menuPtr, indexString, 1, &index) != TCL_OK) { + return TCL_ERROR; + } + } else { + index = menuPtr->numEntries; + } + if (index < 0) { + Tcl_AppendResult(interp, "bad index \"", indexString, "\"", + (char *) NULL); + return TCL_ERROR; + } + if (menuPtr->tearOff && (index == 0)) { + index = 1; + } + + /* + * Figure out the type of the new entry. + */ + + c = argv[0][0]; + length = strlen(argv[0]); + if ((c == 'c') && (strncmp(argv[0], "cascade", length) == 0) + && (length >= 2)) { + type = CASCADE_ENTRY; + } else if ((c == 'c') && (strncmp(argv[0], "checkbutton", length) == 0) + && (length >= 2)) { + type = CHECK_BUTTON_ENTRY; + } else if ((c == 'c') && (strncmp(argv[0], "command", length) == 0) + && (length >= 2)) { + type = COMMAND_ENTRY; + } else if ((c == 'r') + && (strncmp(argv[0], "radiobutton", length) == 0)) { + type = RADIO_BUTTON_ENTRY; + } else if ((c == 's') + && (strncmp(argv[0], "separator", length) == 0)) { + type = SEPARATOR_ENTRY; + } else { + Tcl_AppendResult(interp, "bad menu entry type \"", + argv[0], "\": must be cascade, checkbutton, ", + "command, radiobutton, or separator", (char *) NULL); + return TCL_ERROR; + } + mePtr = MenuNewEntry(menuPtr, index, type); + if (ConfigureMenuEntry(interp, menuPtr, mePtr, index, + argc-1, argv+1, 0) != TCL_OK) { + DestroyMenuEntry((ClientData) mePtr); + for (i = index+1; i < menuPtr->numEntries; i++) { + menuPtr->entries[i-1] = menuPtr->entries[i]; + } + menuPtr->numEntries--; + return TCL_ERROR; + } + return TCL_OK; +} + /* *-------------------------------------------------------------- * @@ -1927,7 +2407,7 @@ MenuVarProc(clientData, interp, name1, name2, flags) if (flags & TCL_TRACE_UNSETS) { mePtr->flags &= ~ENTRY_SELECTED; if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) { - Tcl_TraceVar2(interp, name1, name2, + Tcl_TraceVar(interp, mePtr->name, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, MenuVarProc, clientData); } @@ -1940,7 +2420,10 @@ MenuVarProc(clientData, interp, name1, name2, flags) * the menu entry. */ - value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY); + value = Tcl_GetVar(interp, mePtr->name, TCL_GLOBAL_ONLY); + if (value == NULL) { + value = ""; + } if (strcmp(value, mePtr->onValue) == 0) { if (mePtr->flags & ENTRY_SELECTED) { return (char *) NULL; @@ -1994,7 +2477,7 @@ EventuallyRedrawMenu(menuPtr, mePtr) || (menuPtr->flags & REDRAW_PENDING)) { return; } - Tk_DoWhenIdle(DisplayMenu, (ClientData) menuPtr); + Tcl_DoWhenIdle(DisplayMenu, (ClientData) menuPtr); menuPtr->flags |= REDRAW_PENDING; } @@ -2029,13 +2512,31 @@ PostSubmenu(interp, menuPtr, mePtr) { char string[30]; int result, x, y; + Tk_Window tkwin; if (mePtr == menuPtr->postedCascade) { return TCL_OK; } if (menuPtr->postedCascade != NULL) { - EventuallyRedrawMenu(menuPtr, menuPtr->postedCascade); + /* + * Note: when unposting a submenu, we have to redraw the entire + * parent menu. This is because of a combination of the following + * things: + * (a) the submenu partially overlaps the parent. + * (b) the submenu specifies "save under", which causes the X + * server to make a copy of the information under it when it + * is posted. When the submenu is unposted, the X server + * copies this data back and doesn't generate any Expose + * events for the parent. + * (c) the parent may have redisplayed itself after the submenu + * was posted, in which case the saved information is no + * longer correct. + * The simplest solution is just force a complete redisplay of + * the parent. + */ + + EventuallyRedrawMenu(menuPtr, (MenuEntry *) NULL); result = Tcl_VarEval(interp, menuPtr->postedCascade->name, " unpost", (char *) NULL); menuPtr->postedCascade = NULL; @@ -2044,10 +2545,33 @@ PostSubmenu(interp, menuPtr, mePtr) } } - if ((mePtr != NULL) && (mePtr->name != NULL)) { + if ((mePtr != NULL) && (mePtr->name != NULL) + && Tk_IsMapped(menuPtr->tkwin)) { + /* + * Make sure that the cascaded submenu is a child of the + * parent menu. + */ + + tkwin = Tk_NameToWindow(interp, mePtr->name, menuPtr->tkwin); + if (tkwin == NULL) { + return TCL_ERROR; + } + if (Tk_Parent(tkwin) != menuPtr->tkwin) { + Tcl_AppendResult(interp, "cascaded sub-menu ", + Tk_PathName(tkwin), " must be a child of ", + Tk_PathName(menuPtr->tkwin), (char *) NULL); + return TCL_ERROR; + } + + /* + * Position the cascade with its upper left corner slightly + * below and to the left of the upper right corner of the + * menu entry (this is an attempt to match Motif behavior). + */ Tk_GetRootCoords(menuPtr->tkwin, &x, &y); - x += Tk_Width(menuPtr->tkwin); - y += mePtr->y; + x += Tk_Width(menuPtr->tkwin) - menuPtr->borderWidth + - menuPtr->activeBorderWidth - 2; + y += mePtr->y + menuPtr->activeBorderWidth + 2; sprintf(string, "%d %d", x, y); result = Tcl_VarEval(interp, mePtr->name, " post ", string, (char *) NULL); @@ -2106,18 +2630,77 @@ ActivateMenuEntry(menuPtr, index) mePtr = menuPtr->entries[index]; mePtr->state = tkActiveUid; EventuallyRedrawMenu(menuPtr, mePtr); - Tk_Preserve((ClientData) mePtr); - if (mePtr->type == CASCADE_ENTRY) { - if (mePtr->command != NULL) { - result = TkCopyAndGlobalEval(menuPtr->interp, mePtr->command); - } - if (result == TCL_OK) { - result = PostSubmenu(menuPtr->interp, menuPtr, mePtr); - } - } else { - result = PostSubmenu(menuPtr->interp, menuPtr, (MenuEntry *) NULL); - } - Tk_Release((ClientData) mePtr); } return result; } + +/* + *---------------------------------------------------------------------- + * + * MenuImageProc -- + * + * This procedure is invoked by the image code whenever the manager + * for an image does something that affects the size of contents + * of an image displayed in a menu entry. + * + * Results: + * None. + * + * Side effects: + * Arranges for the menu to get redisplayed. + * + *---------------------------------------------------------------------- + */ + +static void +MenuImageProc(clientData, x, y, width, height, imgWidth, imgHeight) + ClientData clientData; /* Pointer to widget record. */ + int x, y; /* Upper left pixel (within image) + * that must be redisplayed. */ + int width, height; /* Dimensions of area to redisplay + * (may be <= 0). */ + int imgWidth, imgHeight; /* New dimensions of image. */ +{ + register Menu *menuPtr = ((MenuEntry *) clientData)->menuPtr; + + if ((menuPtr->tkwin != NULL) && !(menuPtr->flags & RESIZE_PENDING)) { + menuPtr->flags |= RESIZE_PENDING; + Tcl_DoWhenIdle(ComputeMenuGeometry, (ClientData) menuPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * MenuSelectImageProc -- + * + * This procedure is invoked by the image code whenever the manager + * for an image does something that affects the size of contents + * of an image displayed in a menu entry when it is selected. + * + * Results: + * None. + * + * Side effects: + * Arranges for the menu to get redisplayed. + * + *---------------------------------------------------------------------- + */ + +static void +MenuSelectImageProc(clientData, x, y, width, height, imgWidth, imgHeight) + ClientData clientData; /* Pointer to widget record. */ + int x, y; /* Upper left pixel (within image) + * that must be redisplayed. */ + int width, height; /* Dimensions of area to redisplay + * (may be <= 0). */ + int imgWidth, imgHeight; /* New dimensions of image. */ +{ + register MenuEntry *mePtr = (MenuEntry *) clientData; + + if ((mePtr->flags & ENTRY_SELECTED) + && !(mePtr->menuPtr->flags & REDRAW_PENDING)) { + mePtr->menuPtr->flags |= REDRAW_PENDING; + Tcl_DoWhenIdle(DisplayMenu, (ClientData) mePtr->menuPtr); + } +} diff --git a/tk3.6/tkMenubutton.c b/tk4.2/generic/tkMenubutton.c similarity index 60% rename from tk3.6/tkMenubutton.c rename to tk4.2/generic/tkMenubutton.c index 7add4ec..aea0911 100644 --- a/tk3.6/tkMenubutton.c +++ b/tk4.2/generic/tkMenubutton.c @@ -4,32 +4,16 @@ * This module implements button-like widgets that are used * to invoke pull-down menus. * - * Copyright (c) 1990-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tkMenubutton.c 1.77 96/02/15 18:52:22 */ -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkMenubutton.c,v 1.41 93/07/15 16:39:43 ouster Exp $ SPRITE (Berkeley)"; -#endif - -#include "tkConfig.h" +#include "tkPort.h" #include "default.h" #include "tkInt.h" @@ -46,7 +30,8 @@ typedef struct { Display *display; /* Display containing widget. Needed, among * other things, so that resources can bee * freed up even after tkwin has gone away. */ - Tcl_Interp *interp; /* Interpreter associated with menu button. */ + Tcl_Interp *interp; /* Interpreter associated with menubutton. */ + Tcl_Command widgetCmd; /* Token for menubutton's widget command. */ char *menuName; /* Name of menu associated with widget. * Malloc-ed. */ @@ -56,7 +41,7 @@ typedef struct { char *text; /* Text to display in button (malloc'ed) * or NULL. */ - int textLength; /* # of characters in text. */ + int numChars; /* # of characters in text. */ int underline; /* Index of character to underline. */ char *textVarName; /* Name of variable (malloc'ed) or NULL. * If non-NULL, button displays the contents @@ -64,6 +49,11 @@ typedef struct { Pixmap bitmap; /* Bitmap to display or None. If not None * then text and textVar and underline * are ignored. */ + char *imageString; /* Name of image to display (malloc'ed), or + * NULL. If non-NULL, bitmap, text, and + * textVarName are ignored. */ + Tk_Image image; /* Image to display in window, or NULL if + * none. */ /* * Information used when displaying widget: @@ -81,6 +71,18 @@ typedef struct { * border exists. */ int borderWidth; /* Width of border. */ int relief; /* 3-d effect: TK_RELIEF_RAISED, etc. */ + int highlightWidth; /* Width in pixels of highlight to draw + * around widget when it has the focus. + * <= 0 means don't draw a highlight. */ + XColor *highlightBgColorPtr; + /* Color for drawing traversal highlight + * area when highlight is off. */ + XColor *highlightColorPtr; /* Color for drawing traversal highlight. */ + int inset; /* Total width of all borders, including + * traversal highlight and 3-D border. + * Indicates how much interior stuff must + * be offset from outside edges to leave + * room for borders. */ XFontStruct *fontPtr; /* Information about text font, or NULL. */ XColor *normalFg; /* Foreground color in normal mode. */ XColor *activeFg; /* Foreground color in active mode. NULL @@ -102,21 +104,42 @@ typedef struct { int leftBearing; /* Distance from text origin to leftmost drawn * pixel (positive means to right). */ int rightBearing; /* Amount text sticks right from its origin. */ + char *widthString; /* Value of -width option. Malloc'ed. */ + char *heightString; /* Value of -height option. Malloc'ed. */ int width, height; /* If > 0, these specify dimensions to request * for window, in characters for text and in * pixels for bitmaps. In this case the actual * size of the text string or bitmap is * ignored in computing desired window size. */ + int wrapLength; /* Line length (in pixels) at which to wrap + * onto next line. <= 0 means don't wrap + * except at newlines. */ int padX, padY; /* Extra space around text or bitmap (pixels * on each side). */ Tk_Anchor anchor; /* Where text/bitmap should be displayed * inside window region. */ + Tk_Justify justify; /* Justification to use for multi-line text. */ + int textWidth; /* Width needed to display text as requested, + * in pixels. */ + int textHeight; /* Height needed to display text as requested, + * in pixels. */ + int indicatorOn; /* Non-zero means display indicator; 0 means + * don't display. */ + int indicatorHeight; /* Height of indicator in pixels. This same + * amount of extra space is also left on each + * side of the indicator. 0 if no indicator. */ + int indicatorWidth; /* Width of indicator in pixels, including + * indicatorHeight in padding on each side. + * 0 if no indicator. */ /* * Miscellaneous information: */ - Cursor cursor; /* Current cursor for window, or None. */ + Tk_Cursor cursor; /* Current cursor for window, or None. */ + char *takeFocus; /* Value of -takefocus option; not used in + * the C code, but used by keyboard traversal + * scripts. Malloc'ed, but may be NULL. */ int flags; /* Various flags; see below for * definitions. */ } MenuButton; @@ -130,10 +153,22 @@ typedef struct { * POSTED: Non-zero means that the menu associated * with this button has been posted (typically * because of an active button press). + * GOT_FOCUS: Non-zero means this button currently + * has the input focus. */ #define REDRAW_PENDING 1 #define POSTED 2 +#define GOT_FOCUS 4 + +/* + * The following constants define the dimensions of the cascade indicator, + * which is displayed if the "-indicatoron" option is true. The units for + * these options are 1/10 millimeters. + */ + +#define INDICATOR_WIDTH 40 +#define INDICATOR_HEIGHT 17 /* * Information used for parsing configuration specs: @@ -186,8 +221,23 @@ static Tk_ConfigSpec configSpecs[] = { DEF_MENUBUTTON_FONT, Tk_Offset(MenuButton, fontPtr), 0}, {TK_CONFIG_COLOR, "-foreground", "foreground", "Foreground", DEF_MENUBUTTON_FG, Tk_Offset(MenuButton, normalFg), 0}, - {TK_CONFIG_INT, "-height", "height", "Height", - DEF_MENUBUTTON_HEIGHT, Tk_Offset(MenuButton, height), 0}, + {TK_CONFIG_STRING, "-height", "height", "Height", + DEF_MENUBUTTON_HEIGHT, Tk_Offset(MenuButton, heightString), 0}, + {TK_CONFIG_COLOR, "-highlightbackground", "highlightBackground", + "HighlightBackground", DEF_MENUBUTTON_HIGHLIGHT_BG, + Tk_Offset(MenuButton, highlightBgColorPtr), 0}, + {TK_CONFIG_COLOR, "-highlightcolor", "highlightColor", "HighlightColor", + DEF_MENUBUTTON_HIGHLIGHT, Tk_Offset(MenuButton, highlightColorPtr), 0}, + {TK_CONFIG_PIXELS, "-highlightthickness", "highlightThickness", + "HighlightThickness", DEF_MENUBUTTON_HIGHLIGHT_WIDTH, + Tk_Offset(MenuButton, highlightWidth), 0}, + {TK_CONFIG_STRING, "-image", "image", "Image", + DEF_MENUBUTTON_IMAGE, Tk_Offset(MenuButton, imageString), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_BOOLEAN, "-indicatoron", "indicatorOn", "IndicatorOn", + DEF_MENUBUTTON_INDICATOR, Tk_Offset(MenuButton, indicatorOn), 0}, + {TK_CONFIG_JUSTIFY, "-justify", "justify", "Justify", + DEF_MENUBUTTON_JUSTIFY, Tk_Offset(MenuButton, justify), 0}, {TK_CONFIG_STRING, "-menu", "menu", "Menu", DEF_MENUBUTTON_MENU, Tk_Offset(MenuButton, menuName), TK_CONFIG_NULL_OK}, @@ -199,6 +249,9 @@ static Tk_ConfigSpec configSpecs[] = { DEF_MENUBUTTON_RELIEF, Tk_Offset(MenuButton, relief), 0}, {TK_CONFIG_UID, "-state", "state", "State", DEF_MENUBUTTON_STATE, Tk_Offset(MenuButton, state), 0}, + {TK_CONFIG_STRING, "-takefocus", "takeFocus", "TakeFocus", + DEF_MENUBUTTON_TAKE_FOCUS, Tk_Offset(MenuButton, takeFocus), + TK_CONFIG_NULL_OK}, {TK_CONFIG_STRING, "-text", "text", "Text", DEF_MENUBUTTON_TEXT, Tk_Offset(MenuButton, text), 0}, {TK_CONFIG_STRING, "-textvariable", "textVariable", "Variable", @@ -206,8 +259,10 @@ static Tk_ConfigSpec configSpecs[] = { TK_CONFIG_NULL_OK}, {TK_CONFIG_INT, "-underline", "underline", "Underline", DEF_MENUBUTTON_UNDERLINE, Tk_Offset(MenuButton, underline), 0}, - {TK_CONFIG_INT, "-width", "width", "Width", - DEF_MENUBUTTON_WIDTH, Tk_Offset(MenuButton, width), 0}, + {TK_CONFIG_STRING, "-width", "width", "Width", + DEF_MENUBUTTON_WIDTH, Tk_Offset(MenuButton, widthString), 0}, + {TK_CONFIG_PIXELS, "-wraplength", "wrapLength", "WrapLength", + DEF_MENUBUTTON_WRAP_LENGTH, Tk_Offset(MenuButton, wrapLength), 0}, {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, (char *) NULL, 0, 0} }; @@ -218,8 +273,13 @@ static Tk_ConfigSpec configSpecs[] = { static void ComputeMenuButtonGeometry _ANSI_ARGS_(( MenuButton *mbPtr)); +static void MenuButtonCmdDeletedProc _ANSI_ARGS_(( + ClientData clientData)); static void MenuButtonEventProc _ANSI_ARGS_((ClientData clientData, XEvent *eventPtr)); +static void MenuButtonImageProc _ANSI_ARGS_((ClientData clientData, + int x, int y, int width, int height, int imgWidth, + int imgHeight)); static char * MenuButtonTextVarProc _ANSI_ARGS_(( ClientData clientData, Tcl_Interp *interp, char *name1, char *name2, int flags)); @@ -228,7 +288,7 @@ static int MenuButtonWidgetCmd _ANSI_ARGS_((ClientData clientData, static int ConfigureMenuButton _ANSI_ARGS_((Tcl_Interp *interp, MenuButton *mbPtr, int argc, char **argv, int flags)); -static void DestroyMenuButton _ANSI_ARGS_((ClientData clientData)); +static void DestroyMenuButton _ANSI_ARGS_((char *memPtr)); static void DisplayMenuButton _ANSI_ARGS_((ClientData clientData)); /* @@ -262,7 +322,7 @@ Tk_MenubuttonCmd(clientData, interp, argc, argv) Tk_Window new; if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " pathName ?options?\"", (char *) NULL); return TCL_ERROR; } @@ -284,17 +344,25 @@ Tk_MenubuttonCmd(clientData, interp, argc, argv) mbPtr->tkwin = new; mbPtr->display = Tk_Display (new); mbPtr->interp = interp; + mbPtr->widgetCmd = Tcl_CreateCommand(interp, Tk_PathName(mbPtr->tkwin), + MenuButtonWidgetCmd, (ClientData) mbPtr, MenuButtonCmdDeletedProc); mbPtr->menuName = NULL; mbPtr->text = NULL; - mbPtr->textLength = 0; + mbPtr->numChars = 0; mbPtr->underline = -1; mbPtr->textVarName = NULL; mbPtr->bitmap = None; + mbPtr->imageString = NULL; + mbPtr->image = NULL; mbPtr->state = tkNormalUid; mbPtr->normalBorder = NULL; mbPtr->activeBorder = NULL; mbPtr->borderWidth = 0; mbPtr->relief = TK_RELIEF_FLAT; + mbPtr->highlightWidth = 0; + mbPtr->highlightBgColorPtr = NULL; + mbPtr->highlightColorPtr = NULL; + mbPtr->inset = 0; mbPtr->fontPtr = NULL; mbPtr->normalFg = NULL; mbPtr->activeFg = NULL; @@ -305,19 +373,26 @@ Tk_MenubuttonCmd(clientData, interp, argc, argv) mbPtr->disabledGC = None; mbPtr->leftBearing = 0; mbPtr->rightBearing = 0; + mbPtr->widthString = NULL; + mbPtr->heightString = NULL; mbPtr->width = 0; mbPtr->width = 0; + mbPtr->wrapLength = 0; mbPtr->padX = 0; mbPtr->padY = 0; mbPtr->anchor = TK_ANCHOR_CENTER; + mbPtr->justify = TK_JUSTIFY_CENTER; + mbPtr->indicatorOn = 0; + mbPtr->indicatorWidth = 0; + mbPtr->indicatorHeight = 0; mbPtr->cursor = None; + mbPtr->takeFocus = NULL; mbPtr->flags = 0; Tk_SetClass(mbPtr->tkwin, "Menubutton"); - Tk_CreateEventHandler(mbPtr->tkwin, ExposureMask|StructureNotifyMask, + Tk_CreateEventHandler(mbPtr->tkwin, + ExposureMask|StructureNotifyMask|FocusChangeMask, MenuButtonEventProc, (ClientData) mbPtr); - Tcl_CreateCommand(interp, Tk_PathName(mbPtr->tkwin), MenuButtonWidgetCmd, - (ClientData) mbPtr, (void (*)()) NULL); if (ConfigureMenuButton(interp, mbPtr, argc-2, argv+2, 0) != TCL_OK) { Tk_DestroyWindow(mbPtr->tkwin); return TCL_ERROR; @@ -354,29 +429,29 @@ MenuButtonWidgetCmd(clientData, interp, argc, argv) { register MenuButton *mbPtr = (MenuButton *) clientData; int result = TCL_OK; - int length; - char c; + size_t length; + int c; if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " option ?arg arg ...?\"", (char *) NULL); return TCL_ERROR; } - Tk_Preserve((ClientData) mbPtr); + Tcl_Preserve((ClientData) mbPtr); c = argv[1][0]; length = strlen(argv[1]); - if ((c == 'a') && (strncmp(argv[1], "activate", length) == 0)) { - if (argc > 2) { + if ((c == 'c') && (strncmp(argv[1], "cget", length) == 0) + && (length >= 2)) { + if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " activate\"", (char *) NULL); + argv[0], " cget option\"", + (char *) NULL); goto error; } - if (mbPtr->state != tkDisabledUid) { - mbPtr->state = tkActiveUid; - Tk_SetBackgroundFromBorder(mbPtr->tkwin, mbPtr->activeBorder); - goto redisplay; - } - } else if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0)) { + result = Tk_ConfigureValue(interp, mbPtr->tkwin, configSpecs, + (char *) mbPtr, argv[2], 0); + } else if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0) + && (length >= 2)) { if (argc == 2) { result = Tk_ConfigureInfo(interp, mbPtr->tkwin, configSpecs, (char *) mbPtr, (char *) NULL, 0); @@ -387,36 +462,17 @@ MenuButtonWidgetCmd(clientData, interp, argc, argv) result = ConfigureMenuButton(interp, mbPtr, argc-2, argv+2, TK_CONFIG_ARGV_ONLY); } - } else if ((c == 'd') && (strncmp(argv[1], "deactivate", length) == 0)) { - if (argc > 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " deactivate\"", (char *) NULL); - goto error; - } - if (mbPtr->state != tkDisabledUid) { - mbPtr->state = tkNormalUid; - Tk_SetBackgroundFromBorder(mbPtr->tkwin, mbPtr->normalBorder); - goto redisplay; - } } else { Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be activate, configure, or deactivate", + "\": must be cget or configure", (char *) NULL); goto error; } - done: - Tk_Release((ClientData) mbPtr); + Tcl_Release((ClientData) mbPtr); return result; - redisplay: - if (Tk_IsMapped(mbPtr->tkwin) && !(mbPtr->flags & REDRAW_PENDING)) { - Tk_DoWhenIdle(DisplayMenuButton, (ClientData) mbPtr); - mbPtr->flags |= REDRAW_PENDING; - } - goto done; - error: - Tk_Release((ClientData) mbPtr); + Tcl_Release((ClientData) mbPtr); return TCL_ERROR; } @@ -440,10 +496,10 @@ MenuButtonWidgetCmd(clientData, interp, argc, argv) */ static void -DestroyMenuButton(clientData) - ClientData clientData; /* Info about button widget. */ +DestroyMenuButton(memPtr) + char *memPtr; /* Info about button widget. */ { - register MenuButton *mbPtr = (MenuButton *) clientData; + register MenuButton *mbPtr = (MenuButton *) memPtr; /* * Free up all the stuff that requires special handling, then @@ -456,6 +512,9 @@ DestroyMenuButton(clientData) TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, MenuButtonTextVarProc, (ClientData) mbPtr); } + if (mbPtr->image != NULL) { + Tk_FreeImage(mbPtr->image); + } if (mbPtr->normalTextGC != None) { Tk_FreeGC(mbPtr->display, mbPtr->normalTextGC); } @@ -506,9 +565,10 @@ ConfigureMenuButton(interp, mbPtr, argc, argv, flags) GC newGC; unsigned long mask; int result; + Tk_Image image; /* - * Eliminate any existing traces on variables monitored by the button. + * Eliminate any existing trace on variables monitored by the menubutton. */ if (mbPtr->textVarName != NULL) { @@ -529,18 +589,23 @@ ConfigureMenuButton(interp, mbPtr, argc, argv, flags) * defaults that couldn't be specified to Tk_ConfigureWidget. */ - if (mbPtr->state == tkActiveUid) { + if ((mbPtr->state == tkActiveUid) && !Tk_StrictMotif(mbPtr->tkwin)) { Tk_SetBackgroundFromBorder(mbPtr->tkwin, mbPtr->activeBorder); } else { Tk_SetBackgroundFromBorder(mbPtr->tkwin, mbPtr->normalBorder); - if ((mbPtr->state != tkNormalUid) && (mbPtr->state != tkDisabledUid)) { + if ((mbPtr->state != tkNormalUid) && (mbPtr->state != tkActiveUid) + && (mbPtr->state != tkDisabledUid)) { Tcl_AppendResult(interp, "bad state value \"", mbPtr->state, - "\": must be normal, active, or disabled", (char *) NULL); + "\": must be normal, active, or disabled", (char *) NULL); mbPtr->state = tkNormalUid; return TCL_ERROR; } } + if (mbPtr->highlightWidth < 0) { + mbPtr->highlightWidth = 0; + } + gcValues.font = mbPtr->fontPtr->fid; gcValues.foreground = mbPtr->normalFg->pixel; gcValues.background = Tk_3DBorderColor(mbPtr->normalBorder)->pixel; @@ -571,7 +636,7 @@ ConfigureMenuButton(interp, mbPtr, argc, argv, flags) gcValues.font = mbPtr->fontPtr->fid; gcValues.background = Tk_3DBorderColor(mbPtr->normalBorder)->pixel; - if (mbPtr->disabledFg != NULL) { + if ((mbPtr->disabledFg != NULL) && (mbPtr->imageString == NULL)) { gcValues.foreground = mbPtr->disabledFg->pixel; mask = GCForeground|GCBackground|GCFont; } else { @@ -601,11 +666,32 @@ ConfigureMenuButton(interp, mbPtr, argc, argv, flags) } /* - * Set up a trace on the variable that determines what's displayed - * in the menu button, if such a trace has been requested. + * Get the image for the widget, if there is one. Allocate the + * new image before freeing the old one, so that the reference + * count doesn't go to zero and cause image data to be discarded. */ - if ((mbPtr->bitmap == None) && (mbPtr->textVarName != NULL)) { + if (mbPtr->imageString != NULL) { + image = Tk_GetImage(mbPtr->interp, mbPtr->tkwin, + mbPtr->imageString, MenuButtonImageProc, (ClientData) mbPtr); + if (image == NULL) { + return TCL_ERROR; + } + } else { + image = NULL; + } + if (mbPtr->image != NULL) { + Tk_FreeImage(mbPtr->image); + } + mbPtr->image = image; + + if ((mbPtr->image == NULL) && (mbPtr->bitmap == None) + && (mbPtr->textVarName != NULL)) { + /* + * The menubutton displays a variable. Set up a trace to watch + * for any changes in it. + */ + char *value; value = Tcl_GetVar(interp, mbPtr->textVarName, TCL_GLOBAL_ONLY); @@ -616,7 +702,7 @@ ConfigureMenuButton(interp, mbPtr, argc, argv, flags) if (mbPtr->text != NULL) { ckfree(mbPtr->text); } - mbPtr->text = ckalloc((unsigned) (strlen(value) + 1)); + mbPtr->text = (char *) ckalloc((unsigned) (strlen(value) + 1)); strcpy(mbPtr->text, value); } Tcl_TraceVar(interp, mbPtr->textVarName, @@ -628,6 +714,29 @@ ConfigureMenuButton(interp, mbPtr, argc, argv, flags) * Recompute the geometry for the button. */ + if ((mbPtr->bitmap != None) || (mbPtr->image != NULL)) { + if (Tk_GetPixels(interp, mbPtr->tkwin, mbPtr->widthString, + &mbPtr->width) != TCL_OK) { + widthError: + Tcl_AddErrorInfo(interp, "\n (processing -width option)"); + return TCL_ERROR; + } + if (Tk_GetPixels(interp, mbPtr->tkwin, mbPtr->heightString, + &mbPtr->height) != TCL_OK) { + heightError: + Tcl_AddErrorInfo(interp, "\n (processing -height option)"); + return TCL_ERROR; + } + } else { + if (Tcl_GetInt(interp, mbPtr->widthString, &mbPtr->width) + != TCL_OK) { + goto widthError; + } + if (Tcl_GetInt(interp, mbPtr->heightString, &mbPtr->height) + != TCL_OK) { + goto heightError; + } + } ComputeMenuButtonGeometry(mbPtr); /* @@ -635,7 +744,7 @@ ConfigureMenuButton(interp, mbPtr, argc, argv, flags) */ if (Tk_IsMapped(mbPtr->tkwin) && !(mbPtr->flags & REDRAW_PENDING)) { - Tk_DoWhenIdle(DisplayMenuButton, (ClientData) mbPtr); + Tcl_DoWhenIdle(DisplayMenuButton, (ClientData) mbPtr); mbPtr->flags |= REDRAW_PENDING; } @@ -671,6 +780,7 @@ DisplayMenuButton(clientData) * compiler warning. */ int y; register Tk_Window tkwin = mbPtr->tkwin; + int width, height; mbPtr->flags &= ~REDRAW_PENDING; if ((mbPtr->tkwin == NULL) || !Tk_IsMapped(tkwin)) { @@ -680,7 +790,7 @@ DisplayMenuButton(clientData) if ((mbPtr->state == tkDisabledUid) && (mbPtr->disabledFg != NULL)) { gc = mbPtr->disabledGC; border = mbPtr->normalBorder; - } else if (mbPtr->state == tkActiveUid) { + } else if ((mbPtr->state == tkActiveUid) && !Tk_StrictMotif(mbPtr->tkwin)) { gc = mbPtr->activeTextGC; border = mbPtr->activeBorder; } else { @@ -695,80 +805,83 @@ DisplayMenuButton(clientData) * point in time where the on-sreen image has been cleared. */ - pixmap = XCreatePixmap(mbPtr->display, Tk_WindowId(tkwin), + pixmap = Tk_GetPixmap(mbPtr->display, Tk_WindowId(tkwin), Tk_Width(tkwin), Tk_Height(tkwin), Tk_Depth(tkwin)); - Tk_Fill3DRectangle(mbPtr->display, pixmap, border, - 0, 0, Tk_Width(tkwin), Tk_Height(tkwin), 0, TK_RELIEF_FLAT); + Tk_Fill3DRectangle(tkwin, pixmap, border, 0, 0, Tk_Width(tkwin), + Tk_Height(tkwin), 0, TK_RELIEF_FLAT); /* - * Display bitmap or text for button. + * Display image or bitmap or text for button. */ - if (mbPtr->bitmap != None) { - unsigned int width, height; + if (mbPtr->image != None) { + Tk_SizeOfImage(mbPtr->image, &width, &height); + imageOrBitmap: + switch (mbPtr->anchor) { + case TK_ANCHOR_NW: case TK_ANCHOR_W: case TK_ANCHOR_SW: + x += mbPtr->inset; + break; + case TK_ANCHOR_N: case TK_ANCHOR_CENTER: case TK_ANCHOR_S: + x += ((int) (Tk_Width(tkwin) - width + - mbPtr->indicatorWidth))/2; + break; + default: + x += Tk_Width(tkwin) - mbPtr->inset - width + - mbPtr->indicatorWidth; + break; + } + switch (mbPtr->anchor) { + case TK_ANCHOR_NW: case TK_ANCHOR_N: case TK_ANCHOR_NE: + y = mbPtr->inset; + break; + case TK_ANCHOR_W: case TK_ANCHOR_CENTER: case TK_ANCHOR_E: + y = ((int) (Tk_Height(tkwin) - height))/2; + break; + default: + y = Tk_Height(tkwin) - mbPtr->inset - height; + break; + } + if (mbPtr->image != NULL) { + Tk_RedrawImage(mbPtr->image, 0, 0, width, height, pixmap, + x, y); + } else { + XCopyPlane(mbPtr->display, mbPtr->bitmap, pixmap, + gc, 0, 0, (unsigned) width, (unsigned) height, x, y, 1); + } + } else if (mbPtr->bitmap != None) { Tk_SizeOfBitmap(mbPtr->display, mbPtr->bitmap, &width, &height); - switch (mbPtr->anchor) { - case TK_ANCHOR_NW: case TK_ANCHOR_W: case TK_ANCHOR_SW: - x += mbPtr->borderWidth + mbPtr->padX; - break; - case TK_ANCHOR_N: case TK_ANCHOR_CENTER: case TK_ANCHOR_S: - x += (Tk_Width(tkwin) - width)/2; - break; - default: - x += Tk_Width(tkwin) - mbPtr->borderWidth - mbPtr->padX - - width; - break; - } - switch (mbPtr->anchor) { - case TK_ANCHOR_NW: case TK_ANCHOR_N: case TK_ANCHOR_NE: - y = mbPtr->borderWidth + mbPtr->padY; - break; - case TK_ANCHOR_W: case TK_ANCHOR_CENTER: case TK_ANCHOR_E: - y = (Tk_Height(tkwin) - height)/2; - break; - default: - y = Tk_Height(tkwin) - mbPtr->borderWidth - mbPtr->padY - - height; - break; - } - XCopyPlane(mbPtr->display, mbPtr->bitmap, pixmap, - gc, 0, 0, width, height, x, y, 1); + goto imageOrBitmap; } else { + width = mbPtr->textWidth; + height = mbPtr->textHeight; switch (mbPtr->anchor) { case TK_ANCHOR_NW: case TK_ANCHOR_W: case TK_ANCHOR_SW: - x = mbPtr->borderWidth + mbPtr->padX - mbPtr->leftBearing; + x = mbPtr->inset + mbPtr->padX; break; case TK_ANCHOR_N: case TK_ANCHOR_CENTER: case TK_ANCHOR_S: - x = (Tk_Width(tkwin) - mbPtr->leftBearing - - mbPtr->rightBearing)/2; + x = ((int) (Tk_Width(tkwin) - width + - mbPtr->indicatorWidth))/2; break; default: - x = Tk_Width(tkwin) - mbPtr->borderWidth - mbPtr->padX - - mbPtr->rightBearing; + x = Tk_Width(tkwin) - width - mbPtr->padX - mbPtr->inset + - mbPtr->indicatorWidth; break; } switch (mbPtr->anchor) { case TK_ANCHOR_NW: case TK_ANCHOR_N: case TK_ANCHOR_NE: - y = mbPtr->borderWidth + mbPtr->fontPtr->ascent - + mbPtr->padY; + y = mbPtr->inset + mbPtr->padY; break; case TK_ANCHOR_W: case TK_ANCHOR_CENTER: case TK_ANCHOR_E: - y = (Tk_Height(tkwin) + mbPtr->fontPtr->ascent - - mbPtr->fontPtr->descent)/2; + y = ((int) (Tk_Height(tkwin) - height))/2; break; default: - y = Tk_Height(tkwin) - mbPtr->borderWidth - mbPtr->padY - - mbPtr->fontPtr->descent; + y = Tk_Height(tkwin) - mbPtr->inset - mbPtr->padY - height; break; } - XDrawString(mbPtr->display, pixmap, gc, x, y, mbPtr->text, - mbPtr->textLength); - if (mbPtr->underline >= 0) { - TkUnderlineChars(mbPtr->display, pixmap, gc, mbPtr->fontPtr, - mbPtr->text, x, y, TK_NEWLINES_NOT_SPECIAL, - mbPtr->underline, mbPtr->underline); - } + TkDisplayText(mbPtr->display, pixmap, mbPtr->fontPtr, + mbPtr->text, mbPtr->numChars, x, y, mbPtr->textWidth, + mbPtr->justify, mbPtr->underline, gc); } /* @@ -776,23 +889,57 @@ DisplayMenuButton(clientData) * foreground color, generate the stippled effect. */ - if ((mbPtr->state == tkDisabledUid) && (mbPtr->disabledFg == NULL)) { + if ((mbPtr->state == tkDisabledUid) + && ((mbPtr->disabledFg == NULL) || (mbPtr->image != NULL))) { XFillRectangle(mbPtr->display, pixmap, mbPtr->disabledGC, - mbPtr->borderWidth, mbPtr->borderWidth, - (unsigned) (Tk_Width(tkwin) - 2*mbPtr->borderWidth), - (unsigned) (Tk_Height(tkwin) - 2*mbPtr->borderWidth)); + mbPtr->inset, mbPtr->inset, + (unsigned) (Tk_Width(tkwin) - 2*mbPtr->inset), + (unsigned) (Tk_Height(tkwin) - 2*mbPtr->inset)); } /* - * Draw the border last. This way, if the menu button's contents - * overflow onto the border they'll be covered up by the border. + * Draw the cascade indicator for the menu button on the + * right side of the window, if desired. + */ + + if (mbPtr->indicatorOn) { + int borderWidth; + + borderWidth = (mbPtr->indicatorHeight+1)/3; + if (borderWidth < 1) { + borderWidth = 1; + } + Tk_Fill3DRectangle(tkwin, pixmap, border, + Tk_Width(tkwin) - mbPtr->inset - mbPtr->indicatorWidth + + mbPtr->indicatorHeight, + y + ((int) (height - mbPtr->indicatorHeight))/2, + mbPtr->indicatorWidth - 2*mbPtr->indicatorHeight, + mbPtr->indicatorHeight, borderWidth, TK_RELIEF_RAISED); + } + + /* + * Draw the border and traversal highlight last. This way, if the + * menu button's contents overflow onto the border they'll be covered + * up by the border. */ if (mbPtr->relief != TK_RELIEF_FLAT) { - Tk_Draw3DRectangle(mbPtr->display, pixmap, border, - 0, 0, Tk_Width(tkwin), Tk_Height(tkwin), + Tk_Draw3DRectangle(tkwin, pixmap, border, + mbPtr->highlightWidth, mbPtr->highlightWidth, + Tk_Width(tkwin) - 2*mbPtr->highlightWidth, + Tk_Height(tkwin) - 2*mbPtr->highlightWidth, mbPtr->borderWidth, mbPtr->relief); } + if (mbPtr->highlightWidth != 0) { + GC gc; + + if (mbPtr->flags & GOT_FOCUS) { + gc = Tk_GCForColor(mbPtr->highlightColorPtr, pixmap); + } else { + gc = Tk_GCForColor(mbPtr->highlightBgColorPtr, pixmap); + } + Tk_DrawFocusHighlight(tkwin, gc, mbPtr->highlightWidth, pixmap); + } /* * Copy the information from the off-screen pixmap onto the screen, @@ -800,8 +947,9 @@ DisplayMenuButton(clientData) */ XCopyArea(mbPtr->display, pixmap, Tk_WindowId(tkwin), - mbPtr->normalTextGC, 0, 0, Tk_Width(tkwin), Tk_Height(tkwin), 0, 0); - XFreePixmap(mbPtr->display, pixmap); + mbPtr->normalTextGC, 0, 0, (unsigned) Tk_Width(tkwin), + (unsigned) Tk_Height(tkwin), 0, 0); + Tk_FreePixmap(mbPtr->display, pixmap); } /* @@ -829,17 +977,83 @@ MenuButtonEventProc(clientData, eventPtr) { MenuButton *mbPtr = (MenuButton *) clientData; if ((eventPtr->type == Expose) && (eventPtr->xexpose.count == 0)) { - if ((mbPtr->tkwin != NULL) && !(mbPtr->flags & REDRAW_PENDING)) { - Tk_DoWhenIdle(DisplayMenuButton, (ClientData) mbPtr); - mbPtr->flags |= REDRAW_PENDING; - } + goto redraw; + } else if (eventPtr->type == ConfigureNotify) { + /* + * Must redraw after size changes, since layout could have changed + * and borders will need to be redrawn. + */ + + goto redraw; } else if (eventPtr->type == DestroyNotify) { - Tcl_DeleteCommand(mbPtr->interp, Tk_PathName(mbPtr->tkwin)); - mbPtr->tkwin = NULL; - if (mbPtr->flags & REDRAW_PENDING) { - Tk_CancelIdleCall(DisplayMenuButton, (ClientData) mbPtr); + if (mbPtr->tkwin != NULL) { + mbPtr->tkwin = NULL; + Tcl_DeleteCommand(mbPtr->interp, + Tcl_GetCommandName(mbPtr->interp, mbPtr->widgetCmd)); } - Tk_EventuallyFree((ClientData) mbPtr, DestroyMenuButton); + if (mbPtr->flags & REDRAW_PENDING) { + Tcl_CancelIdleCall(DisplayMenuButton, (ClientData) mbPtr); + } + Tcl_EventuallyFree((ClientData) mbPtr, DestroyMenuButton); + } else if (eventPtr->type == FocusIn) { + if (eventPtr->xfocus.detail != NotifyInferior) { + mbPtr->flags |= GOT_FOCUS; + if (mbPtr->highlightWidth > 0) { + goto redraw; + } + } + } else if (eventPtr->type == FocusOut) { + if (eventPtr->xfocus.detail != NotifyInferior) { + mbPtr->flags &= ~GOT_FOCUS; + if (mbPtr->highlightWidth > 0) { + goto redraw; + } + } + } + return; + + redraw: + if ((mbPtr->tkwin != NULL) && !(mbPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(DisplayMenuButton, (ClientData) mbPtr); + mbPtr->flags |= REDRAW_PENDING; + } +} + +/* + *---------------------------------------------------------------------- + * + * MenuButtonCmdDeletedProc -- + * + * This procedure is invoked when a widget command is deleted. If + * the widget isn't already in the process of being destroyed, + * this command destroys it. + * + * Results: + * None. + * + * Side effects: + * The widget is destroyed. + * + *---------------------------------------------------------------------- + */ + +static void +MenuButtonCmdDeletedProc(clientData) + ClientData clientData; /* Pointer to widget record for widget. */ +{ + MenuButton *mbPtr = (MenuButton *) clientData; + Tk_Window tkwin = mbPtr->tkwin; + + /* + * This procedure could be invoked either because the window was + * destroyed and the command was then deleted (in which case tkwin + * is NULL) or because the command was deleted, and then this procedure + * destroys the widget. + */ + + if (tkwin != NULL) { + mbPtr->tkwin = NULL; + Tk_DestroyWindow(tkwin); } } @@ -865,11 +1079,18 @@ static void ComputeMenuButtonGeometry(mbPtr) register MenuButton *mbPtr; /* Widget record for menu button. */ { - XCharStruct bbox; - int dummy; - unsigned int width, height; + int width, height, mm, pixels; - if (mbPtr->bitmap != None) { + mbPtr->inset = mbPtr->highlightWidth + mbPtr->borderWidth; + if (mbPtr->image != None) { + Tk_SizeOfImage(mbPtr->image, &width, &height); + if (mbPtr->width > 0) { + width = mbPtr->width; + } + if (mbPtr->height > 0) { + height = mbPtr->height; + } + } else if (mbPtr->bitmap != None) { Tk_SizeOfBitmap(mbPtr->display, mbPtr->bitmap, &width, &height); if (mbPtr->width > 0) { width = mbPtr->width; @@ -878,26 +1099,38 @@ ComputeMenuButtonGeometry(mbPtr) height = mbPtr->height; } } else { - mbPtr->textLength = strlen(mbPtr->text); - XTextExtents(mbPtr->fontPtr, mbPtr->text, mbPtr->textLength, - &dummy, &dummy, &dummy, &bbox); - mbPtr->leftBearing = bbox.lbearing; - mbPtr->rightBearing = bbox.rbearing; - width = bbox.rbearing - bbox.lbearing; - height = mbPtr->fontPtr->ascent + mbPtr->fontPtr->descent; + mbPtr->numChars = strlen(mbPtr->text); + TkComputeTextGeometry(mbPtr->fontPtr, mbPtr->text, + mbPtr->numChars, mbPtr->wrapLength, &mbPtr->textWidth, + &mbPtr->textHeight); + width = mbPtr->textWidth; + height = mbPtr->textHeight; if (mbPtr->width > 0) { width = mbPtr->width * XTextWidth(mbPtr->fontPtr, "0", 1); } if (mbPtr->height > 0) { - height *= mbPtr->height; + height = mbPtr->height * (mbPtr->fontPtr->ascent + + mbPtr->fontPtr->descent); } + width += 2*mbPtr->padX; + height += 2*mbPtr->padY; } - width += 2*mbPtr->padX; - height += 2*mbPtr->padY; - Tk_GeometryRequest(mbPtr->tkwin, (int) (width + 2*mbPtr->borderWidth), - (int) (height + 2*mbPtr->borderWidth)); - Tk_SetInternalBorder(mbPtr->tkwin, mbPtr->borderWidth); + if (mbPtr->indicatorOn) { + mm = WidthMMOfScreen(Tk_Screen(mbPtr->tkwin)); + pixels = WidthOfScreen(Tk_Screen(mbPtr->tkwin)); + mbPtr->indicatorHeight= (INDICATOR_HEIGHT * pixels)/(10*mm); + mbPtr->indicatorWidth = (INDICATOR_WIDTH * pixels)/(10*mm) + + 2*mbPtr->indicatorHeight; + width += mbPtr->indicatorWidth; + } else { + mbPtr->indicatorHeight = 0; + mbPtr->indicatorWidth = 0; + } + + Tk_GeometryRequest(mbPtr->tkwin, (int) (width + 2*mbPtr->inset), + (int) (height + 2*mbPtr->inset)); + Tk_SetInternalBorder(mbPtr->tkwin, mbPtr->inset); } /* @@ -937,30 +1170,68 @@ MenuButtonTextVarProc(clientData, interp, name1, name2, flags) if (flags & TCL_TRACE_UNSETS) { if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) { - Tcl_SetVar2(interp, name1, name2, mbPtr->text, - flags & TCL_GLOBAL_ONLY); - Tcl_TraceVar2(interp, name1, name2, + Tcl_SetVar(interp, mbPtr->textVarName, mbPtr->text, + TCL_GLOBAL_ONLY); + Tcl_TraceVar(interp, mbPtr->textVarName, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, MenuButtonTextVarProc, clientData); } return (char *) NULL; } - value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY); + value = Tcl_GetVar(interp, mbPtr->textVarName, TCL_GLOBAL_ONLY); if (value == NULL) { value = ""; } if (mbPtr->text != NULL) { ckfree(mbPtr->text); } - mbPtr->text = ckalloc((unsigned) (strlen(value) + 1)); + mbPtr->text = (char *) ckalloc((unsigned) (strlen(value) + 1)); strcpy(mbPtr->text, value); ComputeMenuButtonGeometry(mbPtr); if ((mbPtr->tkwin != NULL) && Tk_IsMapped(mbPtr->tkwin) && !(mbPtr->flags & REDRAW_PENDING)) { - Tk_DoWhenIdle(DisplayMenuButton, (ClientData) mbPtr); + Tcl_DoWhenIdle(DisplayMenuButton, (ClientData) mbPtr); mbPtr->flags |= REDRAW_PENDING; } return (char *) NULL; } + +/* + *---------------------------------------------------------------------- + * + * MenuButtonImageProc -- + * + * This procedure is invoked by the image code whenever the manager + * for an image does something that affects the size of contents + * of an image displayed in a button. + * + * Results: + * None. + * + * Side effects: + * Arranges for the button to get redisplayed. + * + *---------------------------------------------------------------------- + */ + +static void +MenuButtonImageProc(clientData, x, y, width, height, imgWidth, imgHeight) + ClientData clientData; /* Pointer to widget record. */ + int x, y; /* Upper left pixel (within image) + * that must be redisplayed. */ + int width, height; /* Dimensions of area to redisplay + * (may be <= 0). */ + int imgWidth, imgHeight; /* New dimensions of image. */ +{ + register MenuButton *mbPtr = (MenuButton *) clientData; + + if (mbPtr->tkwin != NULL) { + ComputeMenuButtonGeometry(mbPtr); + if (Tk_IsMapped(mbPtr->tkwin) && !(mbPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(DisplayMenuButton, (ClientData) mbPtr); + mbPtr->flags |= REDRAW_PENDING; + } + } +} diff --git a/tk3.6/tkMessage.c b/tk4.2/generic/tkMessage.c similarity index 73% rename from tk3.6/tkMessage.c rename to tk4.2/generic/tkMessage.c index 3a7d5f6..93bc8f1 100644 --- a/tk3.6/tkMessage.c +++ b/tk4.2/generic/tkMessage.c @@ -5,32 +5,16 @@ * toolkit. A message widget displays a multi-line string * in a window according to a particular aspect ratio. * - * Copyright (c) 1990-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tkMessage.c 1.66 96/02/15 18:52:28 */ -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkMessage.c,v 1.41 93/08/18 16:25:32 ouster Exp $ SPRITE (Berkeley)"; -#endif - -#include "tkConfig.h" +#include "tkPort.h" #include "default.h" #include "tkInt.h" @@ -48,6 +32,7 @@ typedef struct { * other things, so that resources can be * freed even after tkwin has gone away. */ Tcl_Interp *interp; /* Interpreter associated with message. */ + Tcl_Command widgetCmd; /* Token for message's widget command. */ Tk_Uid string; /* String displayed in message. */ int numChars; /* Number of characters in string, not * including terminating NULL character. */ @@ -64,6 +49,18 @@ typedef struct { * been created yet. */ int borderWidth; /* Width of border. */ int relief; /* 3-D effect: TK_RELIEF_RAISED, etc. */ + int highlightWidth; /* Width in pixels of highlight to draw + * around widget when it has the focus. + * <= 0 means don't draw a highlight. */ + XColor *highlightBgColorPtr; + /* Color for drawing traversal highlight + * area when highlight is off. */ + XColor *highlightColorPtr; /* Color for drawing traversal highlight. */ + int inset; /* Total width of all borders, including + * traversal highlight and 3-D border. + * Indicates how much interior stuff must + * be offset from outside edges to leave + * room for borders. */ XFontStruct *fontPtr; /* Information about text font, or NULL. */ XColor *fgColorPtr; /* Foreground color in normal mode. */ GC textGC; /* GC for drawing text in normal mode. */ @@ -85,7 +82,10 @@ typedef struct { * Miscellaneous information: */ - Cursor cursor; /* Current cursor for window, or None. */ + Tk_Cursor cursor; /* Current cursor for window, or None. */ + char *takeFocus; /* Value of -takefocus option; not used in + * the C code, but used by keyboard traversal + * scripts. Malloc'ed, but may be NULL. */ int flags; /* Various flags; see below for * definitions. */ } Message; @@ -96,17 +96,17 @@ typedef struct { * REDRAW_PENDING: Non-zero means a DoWhenIdle handler * has already been queued to redraw * this window. - * CLEAR_NEEDED; Need to clear the window when redrawing. + * GOT_FOCUS: Non-zero means this button currently + * has the input focus. */ #define REDRAW_PENDING 1 -#define CLEAR_NEEDED 2 +#define GOT_FOCUS 4 /* * Information used for argv parsing. */ - static Tk_ConfigSpec configSpecs[] = { {TK_CONFIG_ANCHOR, "-anchor", "anchor", "Anchor", DEF_MESSAGE_ANCHOR, Tk_Offset(Message, anchor), 0}, @@ -132,6 +132,14 @@ static Tk_ConfigSpec configSpecs[] = { DEF_MESSAGE_FONT, Tk_Offset(Message, fontPtr), 0}, {TK_CONFIG_COLOR, "-foreground", "foreground", "Foreground", DEF_MESSAGE_FG, Tk_Offset(Message, fgColorPtr), 0}, + {TK_CONFIG_COLOR, "-highlightbackground", "highlightBackground", + "HighlightBackground", DEF_MESSAGE_HIGHLIGHT_BG, + Tk_Offset(Message, highlightBgColorPtr), 0}, + {TK_CONFIG_COLOR, "-highlightcolor", "highlightColor", "HighlightColor", + DEF_MESSAGE_HIGHLIGHT, Tk_Offset(Message, highlightColorPtr), 0}, + {TK_CONFIG_PIXELS, "-highlightthickness", "highlightThickness", + "HighlightThickness", + DEF_MESSAGE_HIGHLIGHT_WIDTH, Tk_Offset(Message, highlightWidth), 0}, {TK_CONFIG_JUSTIFY, "-justify", "justify", "Justify", DEF_MESSAGE_JUSTIFY, Tk_Offset(Message, justify), 0}, {TK_CONFIG_PIXELS, "-padx", "padX", "Pad", @@ -140,6 +148,9 @@ static Tk_ConfigSpec configSpecs[] = { DEF_MESSAGE_PADY, Tk_Offset(Message, padY), 0}, {TK_CONFIG_RELIEF, "-relief", "relief", "Relief", DEF_MESSAGE_RELIEF, Tk_Offset(Message, relief), 0}, + {TK_CONFIG_STRING, "-takefocus", "takeFocus", "TakeFocus", + DEF_MESSAGE_TAKE_FOCUS, Tk_Offset(Message, takeFocus), + TK_CONFIG_NULL_OK}, {TK_CONFIG_STRING, "-text", "text", "Text", DEF_MESSAGE_TEXT, Tk_Offset(Message, string), 0}, {TK_CONFIG_STRING, "-textvariable", "textVariable", "Variable", @@ -155,6 +166,8 @@ static Tk_ConfigSpec configSpecs[] = { * Forward declarations for procedures defined later in this file: */ +static void MessageCmdDeletedProc _ANSI_ARGS_(( + ClientData clientData)); static void MessageEventProc _ANSI_ARGS_((ClientData clientData, XEvent *eventPtr)); static char * MessageTextVarProc _ANSI_ARGS_((ClientData clientData, @@ -166,7 +179,7 @@ static void ComputeMessageGeometry _ANSI_ARGS_((Message *msgPtr)); static int ConfigureMessage _ANSI_ARGS_((Tcl_Interp *interp, Message *msgPtr, int argc, char **argv, int flags)); -static void DestroyMessage _ANSI_ARGS_((ClientData clientData)); +static void DestroyMessage _ANSI_ARGS_((char *memPtr)); static void DisplayMessage _ANSI_ARGS_((ClientData clientData)); /* @@ -200,7 +213,7 @@ Tk_MessageCmd(clientData, interp, argc, argv) Tk_Window tkwin = (Tk_Window) clientData; if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " pathName ?options?\"", (char *) NULL); return TCL_ERROR; } @@ -214,12 +227,18 @@ Tk_MessageCmd(clientData, interp, argc, argv) msgPtr->tkwin = new; msgPtr->display = Tk_Display(new); msgPtr->interp = interp; + msgPtr->widgetCmd = Tcl_CreateCommand(interp, Tk_PathName(msgPtr->tkwin), + MessageWidgetCmd, (ClientData) msgPtr, MessageCmdDeletedProc); msgPtr->string = NULL; msgPtr->numChars = 0; msgPtr->textVarName = NULL; msgPtr->border = NULL; msgPtr->borderWidth = 0; msgPtr->relief = TK_RELIEF_FLAT; + msgPtr->highlightWidth = 0; + msgPtr->highlightBgColorPtr = NULL; + msgPtr->highlightColorPtr = NULL; + msgPtr->inset = 0; msgPtr->fontPtr = NULL; msgPtr->fgColorPtr = NULL; msgPtr->textGC = None; @@ -232,13 +251,13 @@ Tk_MessageCmd(clientData, interp, argc, argv) msgPtr->msgHeight = 0; msgPtr->justify = TK_JUSTIFY_LEFT; msgPtr->cursor = None; + msgPtr->takeFocus = NULL; msgPtr->flags = 0; Tk_SetClass(msgPtr->tkwin, "Message"); - Tk_CreateEventHandler(msgPtr->tkwin, ExposureMask|StructureNotifyMask, + Tk_CreateEventHandler(msgPtr->tkwin, + ExposureMask|StructureNotifyMask|FocusChangeMask, MessageEventProc, (ClientData) msgPtr); - Tcl_CreateCommand(interp, Tk_PathName(msgPtr->tkwin), MessageWidgetCmd, - (ClientData) msgPtr, (void (*)()) NULL); if (ConfigureMessage(interp, msgPtr, argc-2, argv+2, 0) != TCL_OK) { goto error; } @@ -277,8 +296,8 @@ MessageWidgetCmd(clientData, interp, argc, argv) char **argv; /* Argument strings. */ { register Message *msgPtr = (Message *) clientData; - int length; - char c; + size_t length; + int c; if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], @@ -287,7 +306,18 @@ MessageWidgetCmd(clientData, interp, argc, argv) } c = argv[1][0]; length = strlen(argv[1]); - if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0)) { + if ((c == 'c') && (strncmp(argv[1], "cget", length) == 0) + && (length >= 2)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " cget option\"", + (char *) NULL); + return TCL_ERROR; + } + return Tk_ConfigureValue(interp, msgPtr->tkwin, configSpecs, + (char *) msgPtr, argv[2], 0); + } else if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0) + && (length >= 2)) { if (argc == 2) { return Tk_ConfigureInfo(interp, msgPtr->tkwin, configSpecs, (char *) msgPtr, (char *) NULL, 0); @@ -300,7 +330,7 @@ MessageWidgetCmd(clientData, interp, argc, argv) } } else { Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be configure", (char *) NULL); + "\": must be cget or configure", (char *) NULL); return TCL_ERROR; } } @@ -310,7 +340,7 @@ MessageWidgetCmd(clientData, interp, argc, argv) * * DestroyMessage -- * - * This procedure is invoked by Tk_EventuallyFree or Tk_Release + * This procedure is invoked by Tcl_EventuallyFree or Tcl_Release * to clean up the internal structure of a message at a safe time * (when no-one is using it anymore). * @@ -324,10 +354,10 @@ MessageWidgetCmd(clientData, interp, argc, argv) */ static void -DestroyMessage(clientData) - ClientData clientData; /* Info about message widget. */ +DestroyMessage(memPtr) + char *memPtr; /* Info about message widget. */ { - register Message *msgPtr = (Message *) clientData; + register Message *msgPtr = (Message *) memPtr; /* * Free up all the stuff that requires special handling, then @@ -412,7 +442,7 @@ ConfigureMessage(interp, msgPtr, argc, argv, flags) if (msgPtr->string != NULL) { ckfree(msgPtr->string); } - msgPtr->string = ckalloc((unsigned) (strlen(value) + 1)); + msgPtr->string = (char *) ckalloc((unsigned) (strlen(value) + 1)); strcpy(msgPtr->string, value); } Tcl_TraceVar(interp, msgPtr->textVarName, @@ -430,6 +460,10 @@ ConfigureMessage(interp, msgPtr, argc, argv, flags) Tk_SetBackgroundFromBorder(msgPtr->tkwin, msgPtr->border); + if (msgPtr->highlightWidth < 0) { + msgPtr->highlightWidth = 0; + } + gcValues.font = msgPtr->fontPtr->fid; gcValues.foreground = msgPtr->fgColorPtr->pixel; newGC = Tk_GetGC(msgPtr->tkwin, GCForeground|GCFont, @@ -447,11 +481,6 @@ ConfigureMessage(interp, msgPtr, argc, argv, flags) msgPtr->padY = msgPtr->fontPtr->ascent/4; } - if (msgPtr->justify == TK_JUSTIFY_FILL) { - interp->result = "can't use \"fill\" justify style in messages"; - return TCL_ERROR; - } - /* * Recompute the desired geometry for the window, and arrange for * the window to be redisplayed. @@ -460,8 +489,8 @@ ConfigureMessage(interp, msgPtr, argc, argv, flags) ComputeMessageGeometry(msgPtr); if ((msgPtr->tkwin != NULL) && Tk_IsMapped(msgPtr->tkwin) && !(msgPtr->flags & REDRAW_PENDING)) { - Tk_DoWhenIdle(DisplayMessage, (ClientData) msgPtr); - msgPtr->flags |= REDRAW_PENDING|CLEAR_NEEDED; + Tcl_DoWhenIdle(DisplayMessage, (ClientData) msgPtr); + msgPtr->flags |= REDRAW_PENDING; } return TCL_OK; @@ -495,9 +524,12 @@ ComputeMessageGeometry(msgPtr) int thisWidth, maxWidth; int aspect, lowerBound, upperBound; + msgPtr->inset = msgPtr->borderWidth + msgPtr->highlightWidth; + /* * Compute acceptable bounds for the final aspect ratio. */ + aspect = msgPtr->aspect/10; if (aspect < 5) { aspect = 5; @@ -529,7 +561,7 @@ ComputeMessageGeometry(msgPtr) continue; } p += TkMeasureChars(msgPtr->fontPtr, p, - msgPtr->numChars - (p - msgPtr->string), 0, width, + msgPtr->numChars - (p - msgPtr->string), 0, width, 0, TK_WHOLE_WORDS|TK_AT_LEAST_ONE, &thisWidth); if (thisWidth > maxWidth) { maxWidth = thisWidth; @@ -553,13 +585,12 @@ ComputeMessageGeometry(msgPtr) } height = numLines * (msgPtr->fontPtr->ascent - + msgPtr->fontPtr->descent) + 2*msgPtr->borderWidth + + msgPtr->fontPtr->descent) + 2*msgPtr->inset + 2*msgPtr->padY; if (inc <= 2) { break; } - aspect = (100*(maxWidth + 2*msgPtr->borderWidth - + 2*msgPtr->padX))/height; + aspect = (100*(maxWidth + 2*msgPtr->inset + 2*msgPtr->padX))/height; if (aspect < lowerBound) { width += inc; } else if (aspect > upperBound) { @@ -572,8 +603,8 @@ ComputeMessageGeometry(msgPtr) msgPtr->msgHeight = numLines * (msgPtr->fontPtr->ascent + msgPtr->fontPtr->descent); Tk_GeometryRequest(msgPtr->tkwin, - maxWidth + 2*msgPtr->borderWidth + 2*msgPtr->padX, height); - Tk_SetInternalBorder(msgPtr->tkwin, msgPtr->borderWidth); + maxWidth + 2*msgPtr->inset + 2*msgPtr->padX, height); + Tk_SetInternalBorder(msgPtr->tkwin, msgPtr->inset); } /* @@ -605,10 +636,8 @@ DisplayMessage(clientData) if ((msgPtr->tkwin == NULL) || !Tk_IsMapped(tkwin)) { return; } - if (msgPtr->flags & CLEAR_NEEDED) { - XClearWindow(msgPtr->display, Tk_WindowId(tkwin)); - msgPtr->flags &= ~CLEAR_NEEDED; - } + Tk_Fill3DRectangle(tkwin, Tk_WindowId(tkwin), msgPtr->border, 0, 0, + Tk_Width(tkwin), Tk_Height(tkwin), 0, TK_RELIEF_FLAT); /* * Compute starting y-location for message based on message size @@ -617,13 +646,13 @@ DisplayMessage(clientData) switch (msgPtr->anchor) { case TK_ANCHOR_NW: case TK_ANCHOR_N: case TK_ANCHOR_NE: - y = msgPtr->borderWidth + msgPtr->padY; + y = msgPtr->inset + msgPtr->padY; break; case TK_ANCHOR_W: case TK_ANCHOR_CENTER: case TK_ANCHOR_E: - y = (Tk_Height(tkwin) - msgPtr->msgHeight)/2; + y = ((int) (Tk_Height(tkwin) - msgPtr->msgHeight))/2; break; default: - y = Tk_Height(tkwin) - msgPtr->borderWidth - msgPtr->padY + y = Tk_Height(tkwin) - msgPtr->inset - msgPtr->padY - msgPtr->msgHeight; break; } @@ -644,17 +673,17 @@ DisplayMessage(clientData) continue; } numChars = TkMeasureChars(msgPtr->fontPtr, p, charsLeft, 0, - msgPtr->lineLength, TK_WHOLE_WORDS|TK_AT_LEAST_ONE, + msgPtr->lineLength, 0, TK_WHOLE_WORDS|TK_AT_LEAST_ONE, &lineLength); switch (msgPtr->anchor) { case TK_ANCHOR_NW: case TK_ANCHOR_W: case TK_ANCHOR_SW: - x = msgPtr->borderWidth + msgPtr->padX; + x = msgPtr->inset + msgPtr->padX; break; case TK_ANCHOR_N: case TK_ANCHOR_CENTER: case TK_ANCHOR_S: - x = (Tk_Width(tkwin) - msgPtr->lineLength)/2; + x = ((int) (Tk_Width(tkwin) - msgPtr->lineLength))/2; break; default: - x = Tk_Width(tkwin) - msgPtr->borderWidth - msgPtr->padX + x = Tk_Width(tkwin) - msgPtr->inset - msgPtr->padX - msgPtr->lineLength; break; } @@ -664,7 +693,7 @@ DisplayMessage(clientData) x += msgPtr->lineLength - lineLength; } TkDisplayChars(msgPtr->display, Tk_WindowId(tkwin), - msgPtr->textGC, msgPtr->fontPtr, p, numChars, x, y, 0); + msgPtr->textGC, msgPtr->fontPtr, p, numChars, x, y, x, 0); p += numChars; charsLeft -= numChars; @@ -684,10 +713,23 @@ DisplayMessage(clientData) } if (msgPtr->relief != TK_RELIEF_FLAT) { - Tk_Draw3DRectangle(msgPtr->display, Tk_WindowId(tkwin), - msgPtr->border, 0, 0, Tk_Width(tkwin), Tk_Height(tkwin), + Tk_Draw3DRectangle(tkwin, Tk_WindowId(tkwin), msgPtr->border, + msgPtr->highlightWidth, msgPtr->highlightWidth, + Tk_Width(tkwin) - 2*msgPtr->highlightWidth, + Tk_Height(tkwin) - 2*msgPtr->highlightWidth, msgPtr->borderWidth, msgPtr->relief); } + if (msgPtr->highlightWidth != 0) { + GC gc; + + if (msgPtr->flags & GOT_FOCUS) { + gc = Tk_GCForColor(msgPtr->highlightColorPtr, Tk_WindowId(tkwin)); + } else { + gc = Tk_GCForColor(msgPtr->highlightBgColorPtr, Tk_WindowId(tkwin)); + } + Tk_DrawFocusHighlight(tkwin, gc, msgPtr->highlightWidth, + Tk_WindowId(tkwin)); + } } /* @@ -715,18 +757,78 @@ MessageEventProc(clientData, eventPtr) { Message *msgPtr = (Message *) clientData; - if ((eventPtr->type == Expose) && (eventPtr->xexpose.count == 0)) { - if ((msgPtr->tkwin != NULL) && !(msgPtr->flags & REDRAW_PENDING)) { - Tk_DoWhenIdle(DisplayMessage, (ClientData) msgPtr); - msgPtr->flags |= REDRAW_PENDING; - } + if (((eventPtr->type == Expose) && (eventPtr->xexpose.count == 0)) + || (eventPtr->type == ConfigureNotify)) { + goto redraw; } else if (eventPtr->type == DestroyNotify) { - Tcl_DeleteCommand(msgPtr->interp, Tk_PathName(msgPtr->tkwin)); - msgPtr->tkwin = NULL; - if (msgPtr->flags & REDRAW_PENDING) { - Tk_CancelIdleCall(DisplayMessage, (ClientData) msgPtr); + if (msgPtr->tkwin != NULL) { + msgPtr->tkwin = NULL; + Tcl_DeleteCommand(msgPtr->interp, + Tcl_GetCommandName(msgPtr->interp, msgPtr->widgetCmd)); } - Tk_EventuallyFree((ClientData) msgPtr, DestroyMessage); + if (msgPtr->flags & REDRAW_PENDING) { + Tcl_CancelIdleCall(DisplayMessage, (ClientData) msgPtr); + } + Tcl_EventuallyFree((ClientData) msgPtr, DestroyMessage); + } else if (eventPtr->type == FocusIn) { + if (eventPtr->xfocus.detail != NotifyInferior) { + msgPtr->flags |= GOT_FOCUS; + if (msgPtr->highlightWidth > 0) { + goto redraw; + } + } + } else if (eventPtr->type == FocusOut) { + if (eventPtr->xfocus.detail != NotifyInferior) { + msgPtr->flags &= ~GOT_FOCUS; + if (msgPtr->highlightWidth > 0) { + goto redraw; + } + } + } + return; + + redraw: + if ((msgPtr->tkwin != NULL) && !(msgPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(DisplayMessage, (ClientData) msgPtr); + msgPtr->flags |= REDRAW_PENDING; + } +} + +/* + *---------------------------------------------------------------------- + * + * MessageCmdDeletedProc -- + * + * This procedure is invoked when a widget command is deleted. If + * the widget isn't already in the process of being destroyed, + * this command destroys it. + * + * Results: + * None. + * + * Side effects: + * The widget is destroyed. + * + *---------------------------------------------------------------------- + */ + +static void +MessageCmdDeletedProc(clientData) + ClientData clientData; /* Pointer to widget record for widget. */ +{ + Message *msgPtr = (Message *) clientData; + Tk_Window tkwin = msgPtr->tkwin; + + /* + * This procedure could be invoked either because the window was + * destroyed and the command was then deleted (in which case tkwin + * is NULL) or because the command was deleted, and then this procedure + * destroys the widget. + */ + + if (tkwin != NULL) { + msgPtr->tkwin = NULL; + Tk_DestroyWindow(tkwin); } } @@ -767,16 +869,16 @@ MessageTextVarProc(clientData, interp, name1, name2, flags) if (flags & TCL_TRACE_UNSETS) { if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) { - Tcl_SetVar2(interp, name1, name2, msgPtr->string, - flags & TCL_GLOBAL_ONLY); - Tcl_TraceVar2(interp, name1, name2, + Tcl_SetVar(interp, msgPtr->textVarName, msgPtr->string, + TCL_GLOBAL_ONLY); + Tcl_TraceVar(interp, msgPtr->textVarName, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, MessageTextVarProc, clientData); } return (char *) NULL; } - value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY); + value = Tcl_GetVar(interp, msgPtr->textVarName, TCL_GLOBAL_ONLY); if (value == NULL) { value = ""; } @@ -784,14 +886,13 @@ MessageTextVarProc(clientData, interp, name1, name2, flags) ckfree(msgPtr->string); } msgPtr->numChars = strlen(value); - msgPtr->string = ckalloc((unsigned) (msgPtr->numChars + 1)); + msgPtr->string = (char *) ckalloc((unsigned) (msgPtr->numChars + 1)); strcpy(msgPtr->string, value); ComputeMessageGeometry(msgPtr); - msgPtr->flags |= CLEAR_NEEDED; if ((msgPtr->tkwin != NULL) && Tk_IsMapped(msgPtr->tkwin) && !(msgPtr->flags & REDRAW_PENDING)) { - Tk_DoWhenIdle(DisplayMessage, (ClientData) msgPtr); + Tcl_DoWhenIdle(DisplayMessage, (ClientData) msgPtr); msgPtr->flags |= REDRAW_PENDING; } return (char *) NULL; diff --git a/tk3.6/tkOption.c b/tk4.2/generic/tkOption.c similarity index 91% rename from tk3.6/tkOption.c rename to tk4.2/generic/tkOption.c index bbaedcf..7ae85eb 100644 --- a/tk3.6/tkOption.c +++ b/tk4.2/generic/tkOption.c @@ -5,32 +5,16 @@ * database, which allows various strings to be associated * with windows either by name or by class or both. * - * Copyright (c) 1990-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tkOption.c 1.56 96/10/09 15:18:02 */ -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkOption.c,v 1.29 93/09/09 17:00:23 ouster Exp $ SPRITE (Berkeley)"; -#endif - -#include "tkConfig.h" +#include "tkPort.h" #include "tkInt.h" /* @@ -67,7 +51,7 @@ typedef struct Element { } Element; /* - * Flags in NodeElement structures: + * Flags in Element structures: * * CLASS - Non-zero means this element refers to a class, * Zero means this element refers to a name. @@ -187,7 +171,9 @@ typedef struct StackLevel { static StackLevel *levels = NULL; /* Array describing current stack. */ static int numLevels = 0; /* Total space allocated. */ -static int curLevel = 0; /* Highest level currently in use. */ +static int curLevel = -1; /* Highest level currently in use. Note: + * curLevel is never 0! (I don't remember + * why anymore...) */ /* * The variable below is a serial number for all options entered into @@ -310,7 +296,7 @@ Tk_AddOption(tkwin, name, value, priority) if (length > TMP_SIZE) { length = TMP_SIZE; } - strncpy(tmp, field, length); + strncpy(tmp, field, (size_t) length); tmp[length] = 0; newEl.nameUid = Tk_GetUid(tmp); if (isupper(UCHAR(*field))) { @@ -486,7 +472,7 @@ Tk_OptionCmd(clientData, interp, argc, argv) char **argv; /* Argument strings. */ { Tk_Window tkwin = (Tk_Window) clientData; - int length; + size_t length; char c; if (argc < 2) { @@ -551,7 +537,7 @@ Tk_OptionCmd(clientData, interp, argc, argv) int priority; if ((argc != 3) && (argc != 4)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " readfile fileName ?priority?\"", (char *) NULL); return TCL_ERROR; @@ -603,9 +589,9 @@ TkOptionDeadWindow(winPtr) int i; for (i = 1; i <= curLevel; i++) { - levels[curLevel].winPtr->optionLevel = -1; + levels[i].winPtr->optionLevel = -1; } - curLevel = 0; + curLevel = -1; cachedWindow = NULL; } @@ -621,6 +607,63 @@ TkOptionDeadWindow(winPtr) } } +/* + *---------------------------------------------------------------------- + * + * TkOptionClassChanged -- + * + * This procedure is invoked when a window's class changes. If + * the window is on the option cache, this procedure flushes + * any information for the window, since the new class could change + * what is relevant. + * + * Results: + * None. + * + * Side effects: + * The option cache may be flushed in part or in whole. + * + *---------------------------------------------------------------------- + */ + +void +TkOptionClassChanged(winPtr) + TkWindow *winPtr; /* Window whose class changed. */ +{ + int i, j, *basePtr; + ElArray *arrayPtr; + + if (winPtr->optionLevel == -1) { + return; + } + + /* + * Find the lowest stack level that refers to this window, then + * flush all of the levels above the matching one. + */ + + for (i = 1; i <= curLevel; i++) { + if (levels[i].winPtr == winPtr) { + for (j = i; j <= curLevel; j++) { + levels[j].winPtr->optionLevel = -1; + } + curLevel = i-1; + basePtr = levels[i].bases; + for (j = 0; j < NUM_STACKS; j++) { + arrayPtr = stacks[j]; + arrayPtr->numUsed = basePtr[j]; + arrayPtr->nextToUse = &arrayPtr->els[arrayPtr->numUsed]; + } + if (curLevel <= 0) { + cachedWindow = NULL; + } else { + cachedWindow = levels[curLevel].winPtr; + } + break; + } + } +} + /* *---------------------------------------------------------------------- * @@ -645,8 +688,8 @@ ParsePriority(interp, string) char *string; /* Describes a priority level, either * symbolically or numerically. */ { - char c; - int length, priority; + int priority, c; + size_t length; c = string[0]; length = strlen(string); @@ -856,36 +899,48 @@ ReadOptionFile(interp, tkwin, fileName, priority) * 0 and TK_MAX_PRIO. */ { char *realName, *buffer; - int fileId, result; - struct stat statBuf; + int result, bufferSize; + Tcl_Channel chan; Tcl_DString newName; - realName = Tcl_TildeSubst(interp, fileName, &newName); + realName = Tcl_TranslateFileName(interp, fileName, &newName); if (realName == NULL) { return TCL_ERROR; } - fileId = open(realName, O_RDONLY, 0); + chan = Tcl_OpenFileChannel(interp, realName, "r", 0); Tcl_DStringFree(&newName); - if (fileId < 0) { - Tcl_AppendResult(interp, "couldn't read file \"", fileName, "\"", - (char *) NULL); + if (chan == NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "couldn't open \"", fileName, + "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } - if (fstat(fileId, &statBuf) == -1) { - Tcl_AppendResult(interp, "couldn't stat file \"", fileName, "\"", - (char *) NULL); - close(fileId); + + /* + * Compute size of file by seeking to the end of the file. This will + * overallocate if we are performing CRLF translation. + */ + + bufferSize = Tcl_Seek(chan, 0L, SEEK_END); + (void) Tcl_Seek(chan, 0L, SEEK_SET); + + if (bufferSize < 0) { + Tcl_AppendResult(interp, "error seeking to end of file \"", + fileName, "\":", Tcl_PosixError(interp), (char *) NULL); + Tcl_Close(NULL, chan); + return TCL_ERROR; + + } + buffer = (char *) ckalloc((unsigned) bufferSize+1); + bufferSize = Tcl_Read(chan, buffer, bufferSize); + if (bufferSize < 0) { + Tcl_AppendResult(interp, "error reading file \"", fileName, "\":", + Tcl_PosixError(interp), (char *) NULL); + Tcl_Close(NULL, chan); return TCL_ERROR; } - buffer = (char *) ckalloc((unsigned) statBuf.st_size+1); - if (read(fileId, buffer, (int) statBuf.st_size) != statBuf.st_size) { - Tcl_AppendResult(interp, "error reading file \"", fileName, "\"", - (char *) NULL); - close(fileId); - return TCL_ERROR; - } - close(fileId); - buffer[statBuf.st_size] = 0; + Tcl_Close(NULL, chan); + buffer[bufferSize] = 0; result = AddFromString(interp, tkwin, buffer, priority); ckfree(buffer); return result; @@ -1294,7 +1349,7 @@ GetDefaultOptions(interp, winPtr) TkWindow *winPtr; /* Fetch option defaults for main window * associated with this. */ { - char *regProp, *home, *fileName; + char *regProp; int result, actualFormat; unsigned long numItems, bytesAfter; Atom actualType; @@ -1326,16 +1381,7 @@ GetDefaultOptions(interp, winPtr) if (regProp != NULL) { XFree(regProp); } - home = getenv("HOME"); - if (home == NULL) { - sprintf(interp->result, - "no RESOURCE_MANAGER property and no HOME envariable"); - return TCL_ERROR; - } - fileName = (char *) ckalloc((unsigned) (strlen(home) + 20)); - sprintf(fileName, "%s/.Xdefaults", home); - result = ReadOptionFile(interp, (Tk_Window) winPtr, fileName, + result = ReadOptionFile(interp, (Tk_Window) winPtr, "~/.Xdefaults", TK_USER_DEFAULT_PRIO); - ckfree(fileName); return result; } diff --git a/tk3.6/tkPack.c b/tk4.2/generic/tkPack.c similarity index 88% rename from tk3.6/tkPack.c rename to tk4.2/generic/tkPack.c index f5a9149..b246e5f 100644 --- a/tk3.6/tkPack.c +++ b/tk4.2/generic/tkPack.c @@ -4,32 +4,16 @@ * This file contains code to implement the "packer" * geometry manager for Tk. * - * Copyright (c) 1990-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tkPack.c 1.63 96/02/15 18:52:33 */ -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkPack.c,v 1.42 93/09/30 09:03:22 ouster Exp $ SPRITE (Berkeley)"; -#endif - -#include "tkConfig.h" +#include "tkPort.h" #include "tkInt.h" typedef enum {TOP, BOTTOM, LEFT, RIGHT} Side; @@ -84,7 +68,7 @@ typedef struct Packer { /* * Flag values for Packer structures: * - * REQUESTED_REPACK: 1 means a Tk_DoWhenIdle request + * REQUESTED_REPACK: 1 means a Tcl_DoWhenIdle request * has already been made to repack * all the slaves of this window. * FILLX: 1 means if frame allocated for window @@ -122,7 +106,23 @@ static Tcl_HashTable packerHashTable; * Have statics in this module been initialized? */ -static initialized = 0; +static int initialized = 0; + +/* + * The following structure is the official type record for the + * packer: + */ + +static void PackReqProc _ANSI_ARGS_((ClientData clientData, + Tk_Window tkwin)); +static void PackLostSlaveProc _ANSI_ARGS_((ClientData clientData, + Tk_Window tkwin)); + +static Tk_GeomMgr packerType = { + "pack", /* name */ + PackReqProc, /* requestProc */ + PackLostSlaveProc, /* lostSlaveProc */ +}; /* * Forward declarations for procedures defined later in this file: @@ -171,8 +171,8 @@ Tk_PackCmd(clientData, interp, argc, argv) char **argv; /* Argument strings. */ { Tk_Window tkwin = (Tk_Window) clientData; - int length; - char c; + size_t length; + int c; if ((argc >= 2) && (argv[1][0] == '.')) { return ConfigureSlaves(interp, tkwin, argc-1, argv+1); @@ -267,62 +267,17 @@ Tk_PackCmd(clientData, interp, argc, argv) } slavePtr = GetPacker(slave); if ((slavePtr != NULL) && (slavePtr->masterPtr != NULL)) { - Tk_ManageGeometry(slave, (Tk_GeometryProc *) NULL, + Tk_ManageGeometry(slave, (Tk_GeomMgr *) NULL, (ClientData) NULL); + if (slavePtr->masterPtr->tkwin != Tk_Parent(slavePtr->tkwin)) { + Tk_UnmaintainGeometry(slavePtr->tkwin, + slavePtr->masterPtr->tkwin); + } Unlink(slavePtr); Tk_UnmapWindow(slavePtr->tkwin); } } } else if ((c == 'i') && (strncmp(argv[1], "info", length) == 0)) { - char *prefix; - register Packer *slavePtr; - Tk_Window tkwin2; - char tmp[20]; - static char *sideNames[] = {"top", "bottom", "left", "right"}; - int pad; - - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " info window\"", (char *) NULL); - return TCL_ERROR; - } - tkwin2 = Tk_NameToWindow(interp, argv[2], tkwin); - if (tkwin2 == NULL) { - return TCL_ERROR; - } - slavePtr = GetPacker(tkwin2); - prefix = ""; - for (slavePtr = slavePtr->slavePtr; slavePtr != NULL; - slavePtr = slavePtr->nextPtr) { - Tcl_AppendResult(interp, prefix, Tk_PathName(slavePtr->tkwin), - " {", sideNames[(int) slavePtr->side], - " frame ", Tk_NameOfAnchor(slavePtr->anchor), - (char *) NULL); - pad = slavePtr->padX + slavePtr->iPadX; - if (pad != 0) { - sprintf(tmp, "%d", pad); - Tcl_AppendResult(interp, " padx ", tmp, (char *) NULL); - } - pad = slavePtr->padY + slavePtr->iPadY; - if (pad != 0) { - sprintf(tmp, "%d", pad); - Tcl_AppendResult(interp, " pady ", tmp, (char *) NULL); - } - if (slavePtr->flags & EXPAND) { - Tcl_AppendResult(interp, " expand", (char *) NULL); - } - if ((slavePtr->flags & (FILLX|FILLY)) == (FILLX|FILLY)) { - Tcl_AppendResult(interp, " fill", (char *) NULL); - } else if (slavePtr->flags & FILLX) { - Tcl_AppendResult(interp, " fillx", (char *) NULL); - } else if (slavePtr->flags & FILLY) { - Tcl_AppendResult(interp, " filly", (char *) NULL); - } - Tcl_AppendResult(interp, "}", (char *) NULL); - prefix = " "; - } - return TCL_OK; - } else if ((c == 'n') && (strncmp(argv[1], "newinfo", length) == 0)) { register Packer *slavePtr; Tk_Window slave; char buffer[300]; @@ -408,7 +363,7 @@ Tk_PackCmd(clientData, interp, argc, argv) } if (!(masterPtr->flags & REQUESTED_REPACK)) { masterPtr->flags |= REQUESTED_REPACK; - Tk_DoWhenIdle(ArrangePacking, (ClientData) masterPtr); + Tcl_DoWhenIdle(ArrangePacking, (ClientData) masterPtr); } } else { masterPtr->flags |= DONT_PROPAGATE; @@ -446,14 +401,18 @@ Tk_PackCmd(clientData, interp, argc, argv) } packPtr = GetPacker(tkwin2); if ((packPtr != NULL) && (packPtr->masterPtr != NULL)) { - Tk_ManageGeometry(tkwin2, (Tk_GeometryProc *) NULL, + Tk_ManageGeometry(tkwin2, (Tk_GeomMgr *) NULL, (ClientData) NULL); + if (packPtr->masterPtr->tkwin != Tk_Parent(packPtr->tkwin)) { + Tk_UnmaintainGeometry(packPtr->tkwin, + packPtr->masterPtr->tkwin); + } Unlink(packPtr); Tk_UnmapWindow(packPtr->tkwin); } } else { Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be configure, forget, info, newinfo, ", + "\": must be configure, forget, info, ", "propagate, or slaves", (char *) NULL); return TCL_ERROR; } @@ -492,16 +451,49 @@ PackReqProc(clientData, tkwin) packPtr = packPtr->masterPtr; if (!(packPtr->flags & REQUESTED_REPACK)) { packPtr->flags |= REQUESTED_REPACK; - Tk_DoWhenIdle(ArrangePacking, (ClientData) packPtr); + Tcl_DoWhenIdle(ArrangePacking, (ClientData) packPtr); } } +/* + *-------------------------------------------------------------- + * + * PackLostSlaveProc -- + * + * This procedure is invoked by Tk whenever some other geometry + * claims control over a slave that used to be managed by us. + * + * Results: + * None. + * + * Side effects: + * Forgets all packer-related information about the slave. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +PackLostSlaveProc(clientData, tkwin) + ClientData clientData; /* Packer structure for slave window that + * was stolen away. */ + Tk_Window tkwin; /* Tk's handle for the slave window. */ +{ + register Packer *slavePtr = (Packer *) clientData; + + if (slavePtr->masterPtr->tkwin != Tk_Parent(slavePtr->tkwin)) { + Tk_UnmaintainGeometry(slavePtr->tkwin, slavePtr->masterPtr->tkwin); + } + Unlink(slavePtr); + Tk_UnmapWindow(slavePtr->tkwin); +} + /* *-------------------------------------------------------------- * * ArrangePacking -- * - * This procedure is invoked (using the Tk_DoWhenIdle + * This procedure is invoked (using the Tcl_DoWhenIdle * mechanism) to re-layout a set of windows managed by * the packer. It is invoked at idle time so that a * series of packer requests can be merged into a single @@ -539,7 +531,6 @@ ArrangePacking(clientData) * repacking operation. */ int borderX, borderY; int maxWidth, maxHeight, tmp; - Tk_Window parent, ancestor; masterPtr->flags &= ~REQUESTED_REPACK; @@ -563,7 +554,7 @@ ArrangePacking(clientData) } masterPtr->abortPtr = &abort; abort = 0; - Tk_Preserve((ClientData) masterPtr); + Tcl_Preserve((ClientData) masterPtr); /* * Pass #1: scan all the slaves to figure out the total amount @@ -627,18 +618,7 @@ ArrangePacking(clientData) && !(masterPtr->flags & DONT_PROPAGATE)) { Tk_GeometryRequest(masterPtr->tkwin, maxWidth, maxHeight); masterPtr->flags |= REQUESTED_REPACK; - Tk_DoWhenIdle(ArrangePacking, (ClientData) masterPtr); - goto done; - } - - /* - * If the parent isn't mapped then don't do anything more: wait - * until it gets mapped again. Need to get at least to here to - * reflect size needs up the window hierarchy, but there's no - * point in actually mapping the slaves. - */ - - if (!Tk_IsMapped(masterPtr->tkwin)) { + Tcl_DoWhenIdle(ArrangePacking, (ClientData) masterPtr); goto done; } @@ -772,38 +752,42 @@ ArrangePacking(clientData) height -= slavePtr->doubleBw; /* - * If the window in which slavePtr is packed is not its - * parent in the window hierarchy, translate the coordinates - * to the coordinate system of the real X parent. + * The final step is to set the position, size, and mapped/unmapped + * state of the slave. If the slave is a child of the master, then + * do this here. Otherwise let Tk_MaintainGeometry do the work. */ - parent= Tk_Parent(slavePtr->tkwin); - for (ancestor = masterPtr->tkwin; ancestor != parent; - ancestor = Tk_Parent(ancestor)) { - x += Tk_X(ancestor) + Tk_Changes(ancestor)->border_width; - y += Tk_Y(ancestor) + Tk_Changes(ancestor)->border_width; - } + if (masterPtr->tkwin == Tk_Parent(slavePtr->tkwin)) { + if ((width <= 0) || (height <= 0)) { + Tk_UnmapWindow(slavePtr->tkwin); + } else { + if ((x != Tk_X(slavePtr->tkwin)) + || (y != Tk_Y(slavePtr->tkwin)) + || (width != Tk_Width(slavePtr->tkwin)) + || (height != Tk_Height(slavePtr->tkwin))) { + Tk_MoveResizeWindow(slavePtr->tkwin, x, y, width, height); + } + if (abort) { + goto done; + } - /* - * If the window is too small to be interesting then - * unmap it. Otherwise configure it and then make sure - * it's mapped. - */ + /* + * Don't map the slave if the master isn't mapped: wait + * until the master gets mapped later. + */ - if ((width <= 0) || (height <= 0)) { - Tk_UnmapWindow(slavePtr->tkwin); + if (Tk_IsMapped(masterPtr->tkwin)) { + Tk_MapWindow(slavePtr->tkwin); + } + } } else { - if ((x != Tk_X(slavePtr->tkwin)) - || (y != Tk_Y(slavePtr->tkwin)) - || (width != Tk_Width(slavePtr->tkwin)) - || (height != Tk_Height(slavePtr->tkwin))) { - Tk_MoveResizeWindow(slavePtr->tkwin, x, y, - (unsigned int) width, (unsigned int) height); + if ((width <= 0) || (height <= 0)) { + Tk_UnmaintainGeometry(slavePtr->tkwin, masterPtr->tkwin); + Tk_UnmapWindow(slavePtr->tkwin); + } else { + Tk_MaintainGeometry(slavePtr->tkwin, masterPtr->tkwin, + x, y, width, height); } - if (abort) { - goto done; - } - Tk_MapWindow(slavePtr->tkwin); } /* @@ -819,7 +803,7 @@ ArrangePacking(clientData) done: masterPtr->abortPtr = NULL; - Tk_Release((ClientData) masterPtr); + Tcl_Release((ClientData) masterPtr); } /* @@ -1037,10 +1021,9 @@ PackAfter(interp, prevPtr, masterPtr, argc, argv) { register Packer *packPtr; Tk_Window tkwin, ancestor, parent; - int length, optionCount; + size_t length; char **options; - int index, tmp; - char c; + int index, tmp, optionCount, c; /* * Iterate over all of the window specifiers, each consisting of @@ -1143,7 +1126,7 @@ PackAfter(interp, prevPtr, masterPtr, argc, argv) badPad: Tcl_AppendResult(interp, "bad pad value \"", options[index+1], - "\": must be positive screen distance", + "\": must be positive screen distance", (char *) NULL); goto error; } @@ -1176,7 +1159,7 @@ PackAfter(interp, prevPtr, masterPtr, argc, argv) index++; } else { Tcl_AppendResult(interp, "bad option \"", curOpt, - "\": should be top, bottom, left, right, ", + "\": should be top, bottom, left, right, ", "expand, fill, fillx, filly, padx, pady, or frame", (char *) NULL); goto error; @@ -1188,8 +1171,14 @@ PackAfter(interp, prevPtr, masterPtr, argc, argv) /* * Unpack this window if it's currently packed. */ - + if (packPtr->masterPtr != NULL) { + if ((packPtr->masterPtr != masterPtr) && + (packPtr->masterPtr->tkwin + != Tk_Parent(packPtr->tkwin))) { + Tk_UnmaintainGeometry(packPtr->tkwin, + packPtr->masterPtr->tkwin); + } Unlink(packPtr); } @@ -1207,7 +1196,7 @@ PackAfter(interp, prevPtr, masterPtr, argc, argv) packPtr->nextPtr = prevPtr->nextPtr; prevPtr->nextPtr = packPtr; } - Tk_ManageGeometry(tkwin, PackReqProc, (ClientData) packPtr); + Tk_ManageGeometry(tkwin, &packerType, (ClientData) packPtr); } ckfree((char *) options); } @@ -1222,7 +1211,7 @@ PackAfter(interp, prevPtr, masterPtr, argc, argv) } if (!(masterPtr->flags & REQUESTED_REPACK)) { masterPtr->flags |= REQUESTED_REPACK; - Tk_DoWhenIdle(ArrangePacking, (ClientData) masterPtr); + Tcl_DoWhenIdle(ArrangePacking, (ClientData) masterPtr); } return TCL_OK; @@ -1272,7 +1261,7 @@ Unlink(packPtr) } if (!(masterPtr->flags & REQUESTED_REPACK)) { masterPtr->flags |= REQUESTED_REPACK; - Tk_DoWhenIdle(ArrangePacking, (ClientData) masterPtr); + Tcl_DoWhenIdle(ArrangePacking, (ClientData) masterPtr); } if (masterPtr->abortPtr != NULL) { *masterPtr->abortPtr = 1; @@ -1286,7 +1275,7 @@ Unlink(packPtr) * * DestroyPacker -- * - * This procedure is invoked by Tk_EventuallyFree or Tk_Release + * This procedure is invoked by Tcl_EventuallyFree or Tcl_Release * to clean up the internal structure of a packer at a safe time * (when no-one is using it anymore). * @@ -1300,11 +1289,11 @@ Unlink(packPtr) */ static void -DestroyPacker(clientData) - ClientData clientData; /* Info about packed window that - * is now dead. */ +DestroyPacker(memPtr) + char *memPtr; /* Info about packed window that + * is now dead. */ { - register Packer *packPtr = (Packer *) clientData; + register Packer *packPtr = (Packer *) memPtr; ckfree((char *) packPtr); } @@ -1338,44 +1327,57 @@ PackStructureProc(clientData, eventPtr) if ((packPtr->slavePtr != NULL) && !(packPtr->flags & REQUESTED_REPACK)) { packPtr->flags |= REQUESTED_REPACK; - Tk_DoWhenIdle(ArrangePacking, (ClientData) packPtr); + Tcl_DoWhenIdle(ArrangePacking, (ClientData) packPtr); } if (packPtr->doubleBw != 2*Tk_Changes(packPtr->tkwin)->border_width) { if ((packPtr->masterPtr != NULL) && !(packPtr->masterPtr->flags & REQUESTED_REPACK)) { packPtr->doubleBw = 2*Tk_Changes(packPtr->tkwin)->border_width; packPtr->masterPtr->flags |= REQUESTED_REPACK; - Tk_DoWhenIdle(ArrangePacking, (ClientData) packPtr->masterPtr); + Tcl_DoWhenIdle(ArrangePacking, (ClientData) packPtr->masterPtr); } } } else if (eventPtr->type == DestroyNotify) { - register Packer *packPtr2, *nextPtr; + register Packer *slavePtr, *nextPtr; if (packPtr->masterPtr != NULL) { Unlink(packPtr); } - for (packPtr2 = packPtr->slavePtr; packPtr2 != NULL; - packPtr2 = nextPtr) { - Tk_UnmapWindow(packPtr2->tkwin); - packPtr2->masterPtr = NULL; - nextPtr = packPtr2->nextPtr; - packPtr2->nextPtr = NULL; + for (slavePtr = packPtr->slavePtr; slavePtr != NULL; + slavePtr = nextPtr) { + Tk_ManageGeometry(slavePtr->tkwin, (Tk_GeomMgr *) NULL, + (ClientData) NULL); + Tk_UnmapWindow(slavePtr->tkwin); + slavePtr->masterPtr = NULL; + nextPtr = slavePtr->nextPtr; + slavePtr->nextPtr = NULL; } Tcl_DeleteHashEntry(Tcl_FindHashEntry(&packerHashTable, (char *) packPtr->tkwin)); if (packPtr->flags & REQUESTED_REPACK) { - Tk_CancelIdleCall(ArrangePacking, (ClientData) packPtr); + Tcl_CancelIdleCall(ArrangePacking, (ClientData) packPtr); } packPtr->tkwin = NULL; - Tk_EventuallyFree((ClientData) packPtr, DestroyPacker); + Tcl_EventuallyFree((ClientData) packPtr, DestroyPacker); } else if (eventPtr->type == MapNotify) { + /* + * When a master gets mapped, must redo the geometry computation + * so that all of its slaves get remapped. + */ + if ((packPtr->slavePtr != NULL) && !(packPtr->flags & REQUESTED_REPACK)) { packPtr->flags |= REQUESTED_REPACK; - Tk_DoWhenIdle(ArrangePacking, (ClientData) packPtr); + Tcl_DoWhenIdle(ArrangePacking, (ClientData) packPtr); } } else if (eventPtr->type == UnmapNotify) { - register Packer *packPtr2; + Packer *packPtr2; + + /* + * Unmap all of the slaves when the master gets unmapped, + * so that they don't bother to keep redisplaying + * themselves. + */ for (packPtr2 = packPtr->slavePtr; packPtr2 != NULL; packPtr2 = packPtr2->nextPtr) { @@ -1417,7 +1419,8 @@ ConfigureSlaves(interp, tkwin, argc, argv) { Packer *masterPtr, *slavePtr, *prevPtr, *otherPtr; Tk_Window other, slave, parent, ancestor; - int i, j, numWindows, c, length, tmp, positionGiven; + int i, j, numWindows, c, tmp, positionGiven; + size_t length; /* * Find out how many windows are specified. @@ -1658,7 +1661,8 @@ ConfigureSlaves(interp, tkwin, argc, argv) /* * Make sure that the slave's parent is either the master or - * an ancestor of the master. + * an ancestor of the master, and that the master and slave + * aren't the same. */ parent = Tk_Parent(slave); @@ -1673,6 +1677,11 @@ ConfigureSlaves(interp, tkwin, argc, argv) return TCL_ERROR; } } + if (slave == masterPtr->tkwin) { + Tcl_AppendResult(interp, "can't pack ", argv[j], + " inside itself", (char *) NULL); + return TCL_ERROR; + } /* * Unpack the slave if it's currently packed, then position it @@ -1680,6 +1689,12 @@ ConfigureSlaves(interp, tkwin, argc, argv) */ if (slavePtr->masterPtr != NULL) { + if ((slavePtr->masterPtr != masterPtr) && + (slavePtr->masterPtr->tkwin + != Tk_Parent(slavePtr->tkwin))) { + Tk_UnmaintainGeometry(slavePtr->tkwin, + slavePtr->masterPtr->tkwin); + } Unlink(slavePtr); } slavePtr->masterPtr = masterPtr; @@ -1690,7 +1705,7 @@ ConfigureSlaves(interp, tkwin, argc, argv) slavePtr->nextPtr = prevPtr->nextPtr; prevPtr->nextPtr = slavePtr; } - Tk_ManageGeometry(slave, PackReqProc, (ClientData) slavePtr); + Tk_ManageGeometry(slave, &packerType, (ClientData) slavePtr); prevPtr = slavePtr; /* @@ -1704,7 +1719,7 @@ ConfigureSlaves(interp, tkwin, argc, argv) } if (!(masterPtr->flags & REQUESTED_REPACK)) { masterPtr->flags |= REQUESTED_REPACK; - Tk_DoWhenIdle(ArrangePacking, (ClientData) masterPtr); + Tcl_DoWhenIdle(ArrangePacking, (ClientData) masterPtr); } } return TCL_OK; diff --git a/tk4.2/generic/tkPatch.h b/tk4.2/generic/tkPatch.h new file mode 100644 index 0000000..c36ed20 --- /dev/null +++ b/tk4.2/generic/tkPatch.h @@ -0,0 +1,23 @@ +/* + * tkPatch.h -- + * + * This file does nothing except define a "patch level" for Tk. + * The patch level has the form "X.YpZ" where X.Y is the base + * release, and Z is a serial number that is used to sequence + * patches for a given release. Thus 4.0p1 is the first patch + * to release 4.0, 4.0p2 is the patch that follows 4.0p1, and + * so on. The "pZ" is omitted in an original new release, and + * it is replaced with "bZ" for beta releases or "aZ" for alpha + * releases (e.g. 4.0b1 is the first beta release of Tk 4.0). + * The patch level ensures that patches are applied in the + * correct order and only to appropriate sources. + * + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkPatch.h 1.22 96/10/02 14:36:36 + */ + +#define TK_PATCH_LEVEL "4.2" diff --git a/tk3.6/tkPlace.c b/tk4.2/generic/tkPlace.c similarity index 75% rename from tk3.6/tkPlace.c rename to tk4.2/generic/tkPlace.c index 86de847..0cf338b 100644 --- a/tk3.6/tkPlace.c +++ b/tk4.2/generic/tkPlace.c @@ -4,32 +4,16 @@ * This file contains code to implement a simple geometry manager * for Tk based on absolute placement or "rubber-sheet" placement. * - * Copyright (c) 1992-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1992-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tkPlace.c 1.25 96/02/15 18:52:32 */ -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkPlace.c,v 1.10 93/06/16 17:16:24 ouster Exp $ SPRITE (Berkeley)"; -#endif /* not lint */ - -#include "tkConfig.h" +#include "tkPort.h" #include "tkInt.h" /* @@ -82,24 +66,16 @@ typedef struct Slave { /* * Flag definitions for Slave structures: * - * CHILD_REL_X - 1 means use relX field; 0 means use x. - * CHILD_REL_Y - 1 means use relY field; 0 means use y; - * CHILD_WIDTH - 1 means use width field; - * CHILD_REL_WIDTH - 1 means use relWidth; if neither this nor - * CHILD_WIDTH is 1, use window's requested - * width. - * CHILD_HEIGHT - 1 means use height field; - * CHILD_REL_HEIGHT - 1 means use relHeight; if neither this nor - * CHILD_HEIGHT is 1, use window's requested - * height. + * CHILD_WIDTH - 1 means -width was specified; + * CHILD_REL_WIDTH - 1 means -relwidth was specified. + * CHILD_HEIGHT - 1 means -height was specified; + * CHILD_REL_HEIGHT - 1 means -relheight was specified. */ -#define CHILD_REL_X 1 -#define CHILD_REL_Y 2 -#define CHILD_WIDTH 4 -#define CHILD_REL_WIDTH 8 -#define CHILD_HEIGHT 0x10 -#define CHILD_REL_HEIGHT 0x20 +#define CHILD_WIDTH 1 +#define CHILD_REL_WIDTH 2 +#define CHILD_HEIGHT 4 +#define CHILD_REL_HEIGHT 8 /* * For each master window that has a slave managed by the placer there @@ -131,6 +107,21 @@ typedef struct Master { static int initialized = 0; static Tcl_HashTable masterTable; static Tcl_HashTable slaveTable; +/* + * The following structure is the official type record for the + * placer: + */ + +static void PlaceRequestProc _ANSI_ARGS_((ClientData clientData, + Tk_Window tkwin)); +static void PlaceLostSlaveProc _ANSI_ARGS_((ClientData clientData, + Tk_Window tkwin)); + +static Tk_GeomMgr placerType = { + "place", /* name */ + PlaceRequestProc, /* requestProc */ + PlaceLostSlaveProc, /* lostSlaveProc */ +}; /* * Forward declarations for procedures defined later in this file: @@ -144,8 +135,6 @@ static Slave * FindSlave _ANSI_ARGS_((Tk_Window tkwin)); static Master * FindMaster _ANSI_ARGS_((Tk_Window tkwin)); static void MasterStructureProc _ANSI_ARGS_((ClientData clientData, XEvent *eventPtr)); -static void PlaceRequestProc _ANSI_ARGS_((ClientData clientData, - Tk_Window tkwin)); static void RecomputePlacement _ANSI_ARGS_((ClientData clientData)); static void UnlinkSlave _ANSI_ARGS_((Slave *slavePtr)); @@ -177,8 +166,8 @@ Tk_PlaceCmd(clientData, interp, argc, argv) Tk_Window tkwin; Slave *slavePtr; Tcl_HashEntry *hPtr; - int length; - char c; + size_t length; + int c; /* * Initialize, if that hasn't been done yet. @@ -241,11 +230,16 @@ Tk_PlaceCmd(clientData, interp, argc, argv) return TCL_OK; } slavePtr = (Slave *) Tcl_GetHashValue(hPtr); + if ((slavePtr->masterPtr != NULL) && + (slavePtr->masterPtr->tkwin != Tk_Parent(slavePtr->tkwin))) { + Tk_UnmaintainGeometry(slavePtr->tkwin, + slavePtr->masterPtr->tkwin); + } UnlinkSlave(slavePtr); Tcl_DeleteHashEntry(hPtr); Tk_DeleteEventHandler(tkwin, StructureNotifyMask, SlaveStructureProc, (ClientData) slavePtr); - Tk_ManageGeometry(tkwin, (Tk_GeometryProc *) NULL, (ClientData) NULL); + Tk_ManageGeometry(tkwin, (Tk_GeomMgr *) NULL, (ClientData) NULL); Tk_UnmapWindow(tkwin); ckfree((char *) slavePtr); } else if ((c == 'i') && (strncmp(argv[1], "info", length) == 0)) { @@ -261,32 +255,39 @@ Tk_PlaceCmd(clientData, interp, argc, argv) return TCL_OK; } slavePtr = (Slave *) Tcl_GetHashValue(hPtr); - if (slavePtr->flags & CHILD_REL_X) { - sprintf(buffer, "-relx %.4g", slavePtr->relX); - } else { - sprintf(buffer, "-x %d", slavePtr->x); - } + sprintf(buffer, "-x %d", slavePtr->x); Tcl_AppendResult(interp, buffer, (char *) NULL); - if (slavePtr->flags & CHILD_REL_Y) { - sprintf(buffer, " -rely %.4g", slavePtr->relY); - } else { - sprintf(buffer, " -y %d", slavePtr->y); - } + sprintf(buffer, " -relx %.4g", slavePtr->relX); Tcl_AppendResult(interp, buffer, (char *) NULL); + sprintf(buffer, " -y %d", slavePtr->y); + Tcl_AppendResult(interp, buffer, (char *) NULL); + sprintf(buffer, " -rely %.4g", slavePtr->relY); + Tcl_AppendResult(interp, buffer, (char *) NULL); + if (slavePtr->flags & CHILD_WIDTH) { + sprintf(buffer, " -width %d", slavePtr->width); + Tcl_AppendResult(interp, buffer, (char *) NULL); + } else { + Tcl_AppendResult(interp, " -width {}", (char *) NULL); + } if (slavePtr->flags & CHILD_REL_WIDTH) { sprintf(buffer, " -relwidth %.4g", slavePtr->relWidth); Tcl_AppendResult(interp, buffer, (char *) NULL); - } else if (slavePtr->flags & CHILD_WIDTH) { - sprintf(buffer, " -width %d", slavePtr->width); + } else { + Tcl_AppendResult(interp, " -relwidth {}", (char *) NULL); + } + if (slavePtr->flags & CHILD_HEIGHT) { + sprintf(buffer, " -height %d", slavePtr->height); Tcl_AppendResult(interp, buffer, (char *) NULL); + } else { + Tcl_AppendResult(interp, " -height {}", (char *) NULL); } if (slavePtr->flags & CHILD_REL_HEIGHT) { sprintf(buffer, " -relheight %.4g", slavePtr->relHeight); Tcl_AppendResult(interp, buffer, (char *) NULL); - } else if (slavePtr->flags & CHILD_HEIGHT) { - sprintf(buffer, " -height %d", slavePtr->height); - Tcl_AppendResult(interp, buffer, (char *) NULL); + } else { + Tcl_AppendResult(interp, " -relheight {}", (char *) NULL); } + Tcl_AppendResult(interp, " -anchor ", Tk_NameOfAnchor(slavePtr->anchor), (char *) NULL); if (slavePtr->borderMode == BM_OUTSIDE) { @@ -364,7 +365,7 @@ FindSlave(tkwin) Tcl_SetHashValue(hPtr, slavePtr); Tk_CreateEventHandler(tkwin, StructureNotifyMask, SlaveStructureProc, (ClientData) slavePtr); - Tk_ManageGeometry(tkwin, PlaceRequestProc, (ClientData) slavePtr); + Tk_ManageGeometry(tkwin, &placerType, (ClientData) slavePtr); } else { slavePtr = (Slave *) Tcl_GetHashValue(hPtr); } @@ -484,7 +485,8 @@ ConfigureSlave(interp, slavePtr, argc, argv) char **argv; /* String values for arguments. */ { register Master *masterPtr; - int c, length, result; + int c, result; + size_t length; double d; result = TCL_OK; @@ -530,14 +532,13 @@ ConfigureSlave(interp, slavePtr, argc, argv) } } else if ((c == 'h') && (strncmp(argv[0], "-height", length) == 0)) { if (argv[1][0] == 0) { - slavePtr->flags &= ~(CHILD_REL_HEIGHT|CHILD_HEIGHT); + slavePtr->flags &= ~CHILD_HEIGHT; } else { if (Tk_GetPixels(interp, slavePtr->tkwin, argv[1], &slavePtr->height) != TCL_OK) { result = TCL_ERROR; goto done; } - slavePtr->flags &= ~CHILD_REL_HEIGHT; slavePtr->flags |= CHILD_HEIGHT; } } else if ((c == 'i') && (strncmp(argv[0], "-in", length) == 0)) { @@ -552,7 +553,8 @@ ConfigureSlave(interp, slavePtr, argc, argv) /* * Make sure that the new master is either the logical parent - * of the slave or a descendant of that window. + * of the slave or a descendant of that window, and that the + * master and slave aren't the same. */ for (ancestor = tkwin; ; ancestor = Tk_Parent(ancestor)) { @@ -567,28 +569,54 @@ ConfigureSlave(interp, slavePtr, argc, argv) goto done; } } - UnlinkSlave(slavePtr); - slavePtr->masterPtr = FindMaster(tkwin); - slavePtr->nextPtr = slavePtr->masterPtr->slavePtr; - slavePtr->masterPtr->slavePtr = slavePtr; + if (slavePtr->tkwin == tkwin) { + Tcl_AppendResult(interp, "can't place ", + Tk_PathName(slavePtr->tkwin), " relative to itself", + (char *) NULL); + result = TCL_ERROR; + goto done; + } + if ((slavePtr->masterPtr != NULL) + && (slavePtr->masterPtr->tkwin == tkwin)) { + /* + * Re-using same old master. Nothing to do. + */ + } else { + if ((slavePtr->masterPtr != NULL) + && (slavePtr->masterPtr->tkwin + != Tk_Parent(slavePtr->tkwin))) { + Tk_UnmaintainGeometry(slavePtr->tkwin, + slavePtr->masterPtr->tkwin); + } + UnlinkSlave(slavePtr); + slavePtr->masterPtr = FindMaster(tkwin); + slavePtr->nextPtr = slavePtr->masterPtr->slavePtr; + slavePtr->masterPtr->slavePtr = slavePtr; + } } else if ((c == 'r') && (strncmp(argv[0], "-relheight", length) == 0) && (length >= 5)) { - if (Tcl_GetDouble(interp, argv[1], &d) != TCL_OK) { - result = TCL_ERROR; - goto done; + if (argv[1][0] == 0) { + slavePtr->flags &= ~CHILD_REL_HEIGHT; + } else { + if (Tcl_GetDouble(interp, argv[1], &d) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + slavePtr->relHeight = d; + slavePtr->flags |= CHILD_REL_HEIGHT; } - slavePtr->relHeight = d; - slavePtr->flags |= CHILD_REL_HEIGHT; - slavePtr->flags &= ~CHILD_HEIGHT; } else if ((c == 'r') && (strncmp(argv[0], "-relwidth", length) == 0) && (length >= 5)) { - if (Tcl_GetDouble(interp, argv[1], &d) != TCL_OK) { - result = TCL_ERROR; - goto done; + if (argv[1][0] == 0) { + slavePtr->flags &= ~CHILD_REL_WIDTH; + } else { + if (Tcl_GetDouble(interp, argv[1], &d) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + slavePtr->relWidth = d; + slavePtr->flags |= CHILD_REL_WIDTH; } - slavePtr->relWidth = d; - slavePtr->flags |= CHILD_REL_WIDTH; - slavePtr->flags &= ~CHILD_WIDTH; } else if ((c == 'r') && (strncmp(argv[0], "-relx", length) == 0) && (length >= 5)) { if (Tcl_GetDouble(interp, argv[1], &d) != TCL_OK) { @@ -596,7 +624,6 @@ ConfigureSlave(interp, slavePtr, argc, argv) goto done; } slavePtr->relX = d; - slavePtr->flags |= CHILD_REL_X; } else if ((c == 'r') && (strncmp(argv[0], "-rely", length) == 0) && (length >= 5)) { if (Tcl_GetDouble(interp, argv[1], &d) != TCL_OK) { @@ -604,17 +631,15 @@ ConfigureSlave(interp, slavePtr, argc, argv) goto done; } slavePtr->relY = d; - slavePtr->flags |= CHILD_REL_Y; } else if ((c == 'w') && (strncmp(argv[0], "-width", length) == 0)) { if (argv[1][0] == 0) { - slavePtr->flags &= ~(CHILD_REL_WIDTH|CHILD_WIDTH); + slavePtr->flags &= ~CHILD_WIDTH; } else { if (Tk_GetPixels(interp, slavePtr->tkwin, argv[1], &slavePtr->width) != TCL_OK) { result = TCL_ERROR; goto done; } - slavePtr->flags &= ~CHILD_REL_WIDTH; slavePtr->flags |= CHILD_WIDTH; } } else if ((c == 'x') && (strncmp(argv[0], "-x", length) == 0)) { @@ -623,14 +648,12 @@ ConfigureSlave(interp, slavePtr, argc, argv) result = TCL_ERROR; goto done; } - slavePtr->flags &= ~CHILD_REL_X; } else if ((c == 'y') && (strncmp(argv[0], "-y", length) == 0)) { if (Tk_GetPixels(interp, slavePtr->tkwin, argv[1], &slavePtr->y) != TCL_OK) { result = TCL_ERROR; goto done; } - slavePtr->flags &= ~CHILD_REL_Y; } else { Tcl_AppendResult(interp, "unknown or ambiguous option \"", argv[0], "\": must be -anchor, -bordermode, -height, ", @@ -656,7 +679,7 @@ ConfigureSlave(interp, slavePtr, argc, argv) } if (!(masterPtr->flags & PARENT_RECONFIG_PENDING)) { masterPtr->flags |= PARENT_RECONFIG_PENDING; - Tk_DoWhenIdle(RecomputePlacement, (ClientData) masterPtr); + Tcl_DoWhenIdle(RecomputePlacement, (ClientData) masterPtr); } return result; } @@ -684,9 +707,9 @@ RecomputePlacement(clientData) { register Master *masterPtr = (Master *) clientData; register Slave *slavePtr; - Tk_Window ancestor, realMaster; - int x, y, width, height; + int x, y, width, height, tmp; int masterWidth, masterHeight, masterBW; + double x1, y1, x2, y2; masterPtr->flags &= ~PARENT_RECONFIG_PENDING; @@ -718,30 +741,46 @@ RecomputePlacement(clientData) * border) and location of anchor point within master. */ - x = slavePtr->x; - if (slavePtr->flags & CHILD_REL_X) { - x = (slavePtr->relX*masterWidth) + - ((slavePtr->relX > 0) ? 0.5 : -0.5); - } - x += masterBW; - y = slavePtr->y; - if (slavePtr->flags & CHILD_REL_Y) { - y = (slavePtr->relY*masterHeight) + - ((slavePtr->relY > 0) ? 0.5 : -0.5); - } - y += masterBW; - if (slavePtr->flags & CHILD_REL_WIDTH) { - width = (slavePtr->relWidth*masterWidth) + 0.5; - } else if (slavePtr->flags & CHILD_WIDTH) { - width = slavePtr->width; + x1 = slavePtr->x + masterBW + (slavePtr->relX*masterWidth); + x = x1 + ((x1 > 0) ? 0.5 : -0.5); + y1 = slavePtr->y + masterBW + (slavePtr->relY*masterHeight); + y = y1 + ((y1 > 0) ? 0.5 : -0.5); + if (slavePtr->flags & (CHILD_WIDTH|CHILD_REL_WIDTH)) { + width = 0; + if (slavePtr->flags & CHILD_WIDTH) { + width += slavePtr->width; + } + if (slavePtr->flags & CHILD_REL_WIDTH) { + /* + * The code below is a bit tricky. In order to round + * correctly when both relX and relWidth are specified, + * compute the location of the right edge and round that, + * then compute width. If we compute the width and round + * it, rounding errors in relX and relWidth accumulate. + */ + + x2 = x1 + (slavePtr->relWidth*masterWidth); + tmp = x2 + ((x2 > 0) ? 0.5 : -0.5); + width += tmp - x; + } } else { width = Tk_ReqWidth(slavePtr->tkwin) + 2*Tk_Changes(slavePtr->tkwin)->border_width; } - if (slavePtr->flags & CHILD_REL_HEIGHT) { - height = (slavePtr->relHeight*masterHeight) + 0.5; - } else if (slavePtr->flags & CHILD_HEIGHT) { - height = slavePtr->height; + if (slavePtr->flags & (CHILD_HEIGHT|CHILD_REL_HEIGHT)) { + height = 0; + if (slavePtr->flags & CHILD_HEIGHT) { + height += slavePtr->height; + } + if (slavePtr->flags & CHILD_REL_HEIGHT) { + /* + * See note above for rounding errors in width computation. + */ + + y2 = y1 + (slavePtr->relHeight*masterHeight); + tmp = y2 + ((y2 > 0) ? 0.5 : -0.5); + height += tmp - y; + } } else { height = Tk_ReqHeight(slavePtr->tkwin) + 2*Tk_Changes(slavePtr->tkwin)->border_width; @@ -787,20 +826,7 @@ RecomputePlacement(clientData) } /* - * Step 4: if masterPtr isn't actually the X master of slavePtr, - * then translate the x and y coordinates back into the coordinate - * system of masterPtr. - */ - - for (ancestor = masterPtr->tkwin, - realMaster = Tk_Parent(slavePtr->tkwin); - ancestor != realMaster; ancestor = Tk_Parent(ancestor)) { - x += Tk_X(ancestor) + Tk_Changes(ancestor)->border_width; - y += Tk_Y(ancestor) + Tk_Changes(ancestor)->border_width; - } - - /* - * Step 5: adjust width and height again to reflect inside dimensions + * Step 4: adjust width and height again to reflect inside dimensions * of window rather than outside. Also make sure that the width and * height aren't zero. */ @@ -815,18 +841,38 @@ RecomputePlacement(clientData) } /* - * Step 6: see if the window's size or location has changed; if - * so then tell X to reconfigure it. + * Step 5: reconfigure the window and map it if needed. If the + * slave is a child of the master, we do this ourselves. If the + * slave isn't a child of the master, let Tk_MaintainWindow do + * the work (it will re-adjust things as relevant windows map, + * unmap, and move). */ - if ((x != Tk_X(slavePtr->tkwin)) - || (y != Tk_Y(slavePtr->tkwin)) - || (width != Tk_Width(slavePtr->tkwin)) - || (height != Tk_Height(slavePtr->tkwin))) { - Tk_MoveResizeWindow(slavePtr->tkwin, x, y, - (unsigned int) width, (unsigned int) height); + if (masterPtr->tkwin == Tk_Parent(slavePtr->tkwin)) { + if ((x != Tk_X(slavePtr->tkwin)) + || (y != Tk_Y(slavePtr->tkwin)) + || (width != Tk_Width(slavePtr->tkwin)) + || (height != Tk_Height(slavePtr->tkwin))) { + Tk_MoveResizeWindow(slavePtr->tkwin, x, y, width, height); + } + + /* + * Don't map the slave unless the master is mapped: the slave + * will get mapped later, when the master is mapped. + */ + + if (Tk_IsMapped(masterPtr->tkwin)) { + Tk_MapWindow(slavePtr->tkwin); + } + } else { + if ((width <= 0) || (height <= 0)) { + Tk_UnmaintainGeometry(slavePtr->tkwin, masterPtr->tkwin); + Tk_UnmapWindow(slavePtr->tkwin); + } else { + Tk_MaintainGeometry(slavePtr->tkwin, masterPtr->tkwin, + x, y, width, height); + } } - Tk_MapWindow(slavePtr->tkwin); } } @@ -861,7 +907,7 @@ MasterStructureProc(clientData, eventPtr) if ((masterPtr->slavePtr != NULL) && !(masterPtr->flags & PARENT_RECONFIG_PENDING)) { masterPtr->flags |= PARENT_RECONFIG_PENDING; - Tk_DoWhenIdle(RecomputePlacement, (ClientData) masterPtr); + Tcl_DoWhenIdle(RecomputePlacement, (ClientData) masterPtr); } } else if (eventPtr->type == DestroyNotify) { for (slavePtr = masterPtr->slavePtr; slavePtr != NULL; @@ -873,10 +919,31 @@ MasterStructureProc(clientData, eventPtr) Tcl_DeleteHashEntry(Tcl_FindHashEntry(&masterTable, (char *) masterPtr->tkwin)); if (masterPtr->flags & PARENT_RECONFIG_PENDING) { - Tk_CancelIdleCall(RecomputePlacement, (ClientData) masterPtr); + Tcl_CancelIdleCall(RecomputePlacement, (ClientData) masterPtr); } masterPtr->tkwin = NULL; ckfree((char *) masterPtr); + } else if (eventPtr->type == MapNotify) { + /* + * When a master gets mapped, must redo the geometry computation + * so that all of its slaves get remapped. + */ + + if ((masterPtr->slavePtr != NULL) + && !(masterPtr->flags & PARENT_RECONFIG_PENDING)) { + masterPtr->flags |= PARENT_RECONFIG_PENDING; + Tcl_DoWhenIdle(RecomputePlacement, (ClientData) masterPtr); + } + } else if (eventPtr->type == UnmapNotify) { + /* + * Unmap all of the slaves when the master gets unmapped, + * so that they don't keep redisplaying themselves. + */ + + for (slavePtr = masterPtr->slavePtr; slavePtr != NULL; + slavePtr = slavePtr->nextPtr) { + Tk_UnmapWindow(slavePtr->tkwin); + } } } @@ -951,6 +1018,43 @@ PlaceRequestProc(clientData, tkwin) } if (!(masterPtr->flags & PARENT_RECONFIG_PENDING)) { masterPtr->flags |= PARENT_RECONFIG_PENDING; - Tk_DoWhenIdle(RecomputePlacement, (ClientData) masterPtr); + Tcl_DoWhenIdle(RecomputePlacement, (ClientData) masterPtr); } } + +/* + *-------------------------------------------------------------- + * + * PlaceLostSlaveProc -- + * + * This procedure is invoked by Tk whenever some other geometry + * claims control over a slave that used to be managed by us. + * + * Results: + * None. + * + * Side effects: + * Forgets all placer-related information about the slave. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +PlaceLostSlaveProc(clientData, tkwin) + ClientData clientData; /* Slave structure for slave window that + * was stolen away. */ + Tk_Window tkwin; /* Tk's handle for the slave window. */ +{ + register Slave *slavePtr = (Slave *) clientData; + + if (slavePtr->masterPtr->tkwin != Tk_Parent(slavePtr->tkwin)) { + Tk_UnmaintainGeometry(slavePtr->tkwin, slavePtr->masterPtr->tkwin); + } + Tk_UnmapWindow(tkwin); + UnlinkSlave(slavePtr); + Tcl_DeleteHashEntry(Tcl_FindHashEntry(&slaveTable, (char *) tkwin)); + Tk_DeleteEventHandler(tkwin, StructureNotifyMask, SlaveStructureProc, + (ClientData) slavePtr); + ckfree((char *) slavePtr); +} diff --git a/tk4.2/generic/tkPort.h b/tk4.2/generic/tkPort.h new file mode 100644 index 0000000..7051aa0 --- /dev/null +++ b/tk4.2/generic/tkPort.h @@ -0,0 +1,36 @@ +/* + * tkPort.h -- + * + * This header file handles porting issues that occur because of + * differences between systems. It reads in platform specific + * portability files. + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkPort.h 1.7 96/02/11 16:42:10 + */ + +#ifndef _TKPORT +#define _TKPORT + +#ifndef _TK +#include "tk.h" +#endif +#ifndef _TCL +#include "tcl.h" +#endif + +#if defined(__WIN32__) || defined(_WIN32) +# include "tkWinPort.h" +#else +# if defined(MAC_TCL) +# include "tkMacPort.h" +# else +# include "../unix/tkUnixPort.h" +# endif +#endif + +#endif /* _TKPORT */ diff --git a/tk3.6/tkRectOval.c b/tk4.2/generic/tkRectOval.c similarity index 70% rename from tk3.6/tkRectOval.c rename to tk4.2/generic/tkRectOval.c index 4d109aa..78f122e 100644 --- a/tk3.6/tkRectOval.c +++ b/tk4.2/generic/tkRectOval.c @@ -4,35 +4,19 @@ * This file implements rectangle and oval items for canvas * widgets. * - * Copyright (c) 1991-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tkRectOval.c 1.39 96/03/02 17:28:06 */ -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkRectOval.c,v 1.23 93/09/15 08:19:31 ouster Exp $ SPRITE (Berkeley)"; -#endif - #include -#include "tkConfig.h" +#include "tk.h" #include "tkInt.h" -#include "tkCanvas.h" +#include "tkPort.h" /* * The structure below defines the record for each rectangle/oval item. @@ -56,6 +40,10 @@ typedef struct RectOvalItem { * Information used for parsing configuration specs: */ +static Tk_CustomOption tagsOption = {Tk_CanvasTagsParseProc, + Tk_CanvasTagsPrintProc, (ClientData) NULL +}; + static Tk_ConfigSpec configSpecs[] = { {TK_CONFIG_COLOR, "-fill", (char *) NULL, (char *) NULL, (char *) NULL, Tk_Offset(RectOvalItem, fillColor), TK_CONFIG_NULL_OK}, @@ -64,7 +52,7 @@ static Tk_ConfigSpec configSpecs[] = { {TK_CONFIG_BITMAP, "-stipple", (char *) NULL, (char *) NULL, (char *) NULL, Tk_Offset(RectOvalItem, fillStipple), TK_CONFIG_NULL_OK}, {TK_CONFIG_CUSTOM, "-tags", (char *) NULL, (char *) NULL, - (char *) NULL, 0, TK_CONFIG_NULL_OK, &tkCanvasTagsOption}, + (char *) NULL, 0, TK_CONFIG_NULL_OK, &tagsOption}, {TK_CONFIG_PIXELS, "-width", (char *) NULL, (char *) NULL, "1", Tk_Offset(RectOvalItem, width), TK_CONFIG_DONT_SET_DEFAULT}, {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, @@ -75,33 +63,36 @@ static Tk_ConfigSpec configSpecs[] = { * Prototypes for procedures defined in this file: */ -static void ComputeRectOvalBbox _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static void ComputeRectOvalBbox _ANSI_ARGS_((Tk_Canvas canvas, RectOvalItem *rectOvalPtr)); -static int ConfigureRectOval _ANSI_ARGS_(( - Tk_Canvas *canvasPtr, Tk_Item *itemPtr, int argc, +static int ConfigureRectOval _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int argc, char **argv, int flags)); -static int CreateRectOval _ANSI_ARGS_((Tk_Canvas *canvasPtr, - struct Tk_Item *itemPtr, int argc, char **argv)); -static void DeleteRectOval _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr)); -static void DisplayRectOval _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, Drawable dst)); -static int OvalToArea _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static int CreateRectOval _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, struct Tk_Item *itemPtr, + int argc, char **argv)); +static void DeleteRectOval _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, Display *display)); +static void DisplayRectOval _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, Display *display, Drawable dst, + int x, int y, int width, int height)); +static int OvalToArea _ANSI_ARGS_((Tk_Canvas canvas, Tk_Item *itemPtr, double *areaPtr)); -static double OvalToPoint _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static double OvalToPoint _ANSI_ARGS_((Tk_Canvas canvas, Tk_Item *itemPtr, double *pointPtr)); -static int RectOvalCoords _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, int argc, char **argv)); -static int RectOvalToPostscript _ANSI_ARGS_((Tk_Canvas *canvasPtr, - Tk_Item *itemPtr, Tk_PostscriptInfo *psInfoPtr)); -static int RectToArea _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static int RectOvalCoords _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int argc, + char **argv)); +static int RectOvalToPostscript _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int prepass)); +static int RectToArea _ANSI_ARGS_((Tk_Canvas canvas, Tk_Item *itemPtr, double *areaPtr)); -static double RectToPoint _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static double RectToPoint _ANSI_ARGS_((Tk_Canvas canvas, Tk_Item *itemPtr, double *pointPtr)); -static void ScaleRectOval _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static void ScaleRectOval _ANSI_ARGS_((Tk_Canvas canvas, Tk_Item *itemPtr, double originX, double originY, double scaleX, double scaleY)); -static void TranslateRectOval _ANSI_ARGS_((Tk_Canvas *canvasPtr, +static void TranslateRectOval _ANSI_ARGS_((Tk_Canvas canvas, Tk_Item *itemPtr, double deltaX, double deltaY)); /* @@ -109,7 +100,7 @@ static void TranslateRectOval _ANSI_ARGS_((Tk_Canvas *canvasPtr, * by means of procedures that can be invoked by generic item code. */ -Tk_ItemType TkRectangleType = { +Tk_ItemType tkRectangleType = { "rectangle", /* name */ sizeof(RectOvalItem), /* itemSize */ CreateRectOval, /* createProc */ @@ -132,7 +123,7 @@ Tk_ItemType TkRectangleType = { (Tk_ItemType *) NULL /* nextPtr */ }; -Tk_ItemType TkOvalType = { +Tk_ItemType tkOvalType = { "oval", /* name */ sizeof(RectOvalItem), /* itemSize */ CreateRectOval, /* createProc */ @@ -166,9 +157,8 @@ Tk_ItemType TkOvalType = { * Results: * A standard Tcl return value. If an error occurred in * creating the item, then an error message is left in - * canvasPtr->interp->result; in this case itemPtr is - * left uninitialized, so it can be safely freed by the - * caller. + * interp->result; in this case itemPtr is left uninitialized, + * so it can be safely freed by the caller. * * Side effects: * A new rectangle or oval item is created. @@ -177,19 +167,20 @@ Tk_ItemType TkOvalType = { */ static int -CreateRectOval(canvasPtr, itemPtr, argc, argv) - register Tk_Canvas *canvasPtr; /* Canvas to hold new item. */ +CreateRectOval(interp, canvas, itemPtr, argc, argv) + Tcl_Interp *interp; /* For error reporting. */ + Tk_Canvas canvas; /* Canvas to hold new item. */ Tk_Item *itemPtr; /* Record to hold new item; header * has been initialized by caller. */ int argc; /* Number of arguments in argv. */ char **argv; /* Arguments describing rectangle. */ { - register RectOvalItem *rectOvalPtr = (RectOvalItem *) itemPtr; + RectOvalItem *rectOvalPtr = (RectOvalItem *) itemPtr; if (argc < 4) { - Tcl_AppendResult(canvasPtr->interp, "wrong # args: should be \"", - Tk_PathName(canvasPtr->tkwin), "\" create ", - itemPtr->typePtr->name, " x1 y1 x2 y2 ?options?", + Tcl_AppendResult(interp, "wrong # args: should be \"", + Tk_PathName(Tk_CanvasTkwin(canvas)), " create ", + itemPtr->typePtr->name, " x1 y1 x2 y2 ?options?\"", (char *) NULL); return TCL_ERROR; } @@ -210,18 +201,20 @@ CreateRectOval(canvasPtr, itemPtr, argc, argv) * Process the arguments to fill in the item record. */ - if ((TkGetCanvasCoord(canvasPtr, argv[0], &rectOvalPtr->bbox[0]) != TCL_OK) - || (TkGetCanvasCoord(canvasPtr, argv[1], + if ((Tk_CanvasGetCoord(interp, canvas, argv[0], + &rectOvalPtr->bbox[0]) != TCL_OK) + || (Tk_CanvasGetCoord(interp, canvas, argv[1], &rectOvalPtr->bbox[1]) != TCL_OK) - || (TkGetCanvasCoord(canvasPtr, argv[2], + || (Tk_CanvasGetCoord(interp, canvas, argv[2], &rectOvalPtr->bbox[2]) != TCL_OK) - || (TkGetCanvasCoord(canvasPtr, argv[3], + || (Tk_CanvasGetCoord(interp, canvas, argv[3], &rectOvalPtr->bbox[3]) != TCL_OK)) { return TCL_ERROR; } - if (ConfigureRectOval(canvasPtr, itemPtr, argc-4, argv+4, 0) != TCL_OK) { - DeleteRectOval(canvasPtr, itemPtr); + if (ConfigureRectOval(interp, canvas, itemPtr, argc-4, argv+4, 0) + != TCL_OK) { + DeleteRectOval(canvas, itemPtr, Tk_Display(Tk_CanvasTkwin(canvas))); return TCL_ERROR; } return TCL_OK; @@ -237,7 +230,7 @@ CreateRectOval(canvasPtr, itemPtr, argc, argv) * for details on what it does. * * Results: - * Returns TCL_OK or TCL_ERROR, and sets canvasPtr->interp->result. + * Returns TCL_OK or TCL_ERROR, and sets interp->result. * * Side effects: * The coordinates for the given item may be changed. @@ -246,8 +239,9 @@ CreateRectOval(canvasPtr, itemPtr, argc, argv) */ static int -RectOvalCoords(canvasPtr, itemPtr, argc, argv) - register Tk_Canvas *canvasPtr; /* Canvas containing item. */ +RectOvalCoords(interp, canvas, itemPtr, argc, argv) + Tcl_Interp *interp; /* Used for error reporting. */ + Tk_Canvas canvas; /* Canvas containing item. */ Tk_Item *itemPtr; /* Item whose coordinates are to be * read or modified. */ int argc; /* Number of coordinates supplied in @@ -255,32 +249,32 @@ RectOvalCoords(canvasPtr, itemPtr, argc, argv) char **argv; /* Array of coordinates: x1, y1, * x2, y2, ... */ { - register RectOvalItem *rectOvalPtr = (RectOvalItem *) itemPtr; + RectOvalItem *rectOvalPtr = (RectOvalItem *) itemPtr; char c0[TCL_DOUBLE_SPACE], c1[TCL_DOUBLE_SPACE]; char c2[TCL_DOUBLE_SPACE], c3[TCL_DOUBLE_SPACE]; if (argc == 0) { - Tcl_PrintDouble(canvasPtr->interp, rectOvalPtr->bbox[0], c0); - Tcl_PrintDouble(canvasPtr->interp, rectOvalPtr->bbox[1], c1); - Tcl_PrintDouble(canvasPtr->interp, rectOvalPtr->bbox[2], c2); - Tcl_PrintDouble(canvasPtr->interp, rectOvalPtr->bbox[3], c3); - Tcl_AppendResult(canvasPtr->interp, c0, " ", c1, " ", - c2, " ", c3, (char *) NULL); + Tcl_PrintDouble(interp, rectOvalPtr->bbox[0], c0); + Tcl_PrintDouble(interp, rectOvalPtr->bbox[1], c1); + Tcl_PrintDouble(interp, rectOvalPtr->bbox[2], c2); + Tcl_PrintDouble(interp, rectOvalPtr->bbox[3], c3); + Tcl_AppendResult(interp, c0, " ", c1, " ", c2, " ", c3, + (char *) NULL); } else if (argc == 4) { - if ((TkGetCanvasCoord(canvasPtr, argv[0], + if ((Tk_CanvasGetCoord(interp, canvas, argv[0], &rectOvalPtr->bbox[0]) != TCL_OK) - || (TkGetCanvasCoord(canvasPtr, argv[1], + || (Tk_CanvasGetCoord(interp, canvas, argv[1], &rectOvalPtr->bbox[1]) != TCL_OK) - || (TkGetCanvasCoord(canvasPtr, argv[2], + || (Tk_CanvasGetCoord(interp, canvas, argv[2], &rectOvalPtr->bbox[2]) != TCL_OK) - || (TkGetCanvasCoord(canvasPtr, argv[3], + || (Tk_CanvasGetCoord(interp, canvas, argv[3], &rectOvalPtr->bbox[3]) != TCL_OK)) { return TCL_ERROR; } - ComputeRectOvalBbox(canvasPtr, rectOvalPtr); + ComputeRectOvalBbox(canvas, rectOvalPtr); } else { - sprintf(canvasPtr->interp->result, - "wrong # coordinates: expected 0 or 4, got %d", + sprintf(interp->result, + "wrong # coordinates: expected 0 or 4, got %d", argc); return TCL_ERROR; } @@ -298,7 +292,7 @@ RectOvalCoords(canvasPtr, itemPtr, argc, argv) * * Results: * A standard Tcl result code. If an error occurs, then - * an error message is left in canvasPtr->interp->result. + * an error message is left in interp->result. * * Side effects: * Configuration information, such as colors and stipple @@ -308,20 +302,23 @@ RectOvalCoords(canvasPtr, itemPtr, argc, argv) */ static int -ConfigureRectOval(canvasPtr, itemPtr, argc, argv, flags) - Tk_Canvas *canvasPtr; /* Canvas containing itemPtr. */ +ConfigureRectOval(interp, canvas, itemPtr, argc, argv, flags) + Tcl_Interp *interp; /* Used for error reporting. */ + Tk_Canvas canvas; /* Canvas containing itemPtr. */ Tk_Item *itemPtr; /* Rectangle item to reconfigure. */ int argc; /* Number of elements in argv. */ char **argv; /* Arguments describing things to configure. */ int flags; /* Flags to pass to Tk_ConfigureWidget. */ { - register RectOvalItem *rectOvalPtr = (RectOvalItem *) itemPtr; + RectOvalItem *rectOvalPtr = (RectOvalItem *) itemPtr; XGCValues gcValues; GC newGC; unsigned long mask; + Tk_Window tkwin; - if (Tk_ConfigureWidget(canvasPtr->interp, canvasPtr->tkwin, - configSpecs, argc, argv, (char *) rectOvalPtr, flags) != TCL_OK) { + tkwin = Tk_CanvasTkwin(canvas); + if (Tk_ConfigureWidget(interp, tkwin, configSpecs, argc, argv, + (char *) rectOvalPtr, flags) != TCL_OK) { return TCL_ERROR; } @@ -330,20 +327,20 @@ ConfigureRectOval(canvasPtr, itemPtr, argc, argv, flags) * graphics contexts. */ + if (rectOvalPtr->width < 1) { + rectOvalPtr->width = 1; + } if (rectOvalPtr->outlineColor == NULL) { newGC = None; } else { gcValues.foreground = rectOvalPtr->outlineColor->pixel; gcValues.cap_style = CapProjecting; - if (rectOvalPtr->width < 0) { - rectOvalPtr->width = 1; - } gcValues.line_width = rectOvalPtr->width; mask = GCForeground|GCCapStyle|GCLineWidth; - newGC = Tk_GetGC(canvasPtr->tkwin, mask, &gcValues); + newGC = Tk_GetGC(tkwin, mask, &gcValues); } if (rectOvalPtr->outlineGC != None) { - Tk_FreeGC(canvasPtr->display, rectOvalPtr->outlineGC); + Tk_FreeGC(Tk_Display(tkwin), rectOvalPtr->outlineGC); } rectOvalPtr->outlineGC = newGC; @@ -358,13 +355,13 @@ ConfigureRectOval(canvasPtr, itemPtr, argc, argv, flags) } else { mask = GCForeground; } - newGC = Tk_GetGC(canvasPtr->tkwin, mask, &gcValues); + newGC = Tk_GetGC(tkwin, mask, &gcValues); } if (rectOvalPtr->fillGC != None) { - Tk_FreeGC(canvasPtr->display, rectOvalPtr->fillGC); + Tk_FreeGC(Tk_Display(tkwin), rectOvalPtr->fillGC); } rectOvalPtr->fillGC = newGC; - ComputeRectOvalBbox(canvasPtr, rectOvalPtr); + ComputeRectOvalBbox(canvas, rectOvalPtr); return TCL_OK; } @@ -387,11 +384,13 @@ ConfigureRectOval(canvasPtr, itemPtr, argc, argv, flags) */ static void -DeleteRectOval(canvasPtr, itemPtr) - Tk_Canvas *canvasPtr; /* Info about overall widget. */ +DeleteRectOval(canvas, itemPtr, display) + Tk_Canvas canvas; /* Info about overall widget. */ Tk_Item *itemPtr; /* Item that is being deleted. */ + Display *display; /* Display containing window for + * canvas. */ { - register RectOvalItem *rectOvalPtr = (RectOvalItem *) itemPtr; + RectOvalItem *rectOvalPtr = (RectOvalItem *) itemPtr; if (rectOvalPtr->outlineColor != NULL) { Tk_FreeColor(rectOvalPtr->outlineColor); @@ -400,13 +399,13 @@ DeleteRectOval(canvasPtr, itemPtr) Tk_FreeColor(rectOvalPtr->fillColor); } if (rectOvalPtr->fillStipple != None) { - Tk_FreeBitmap(canvasPtr->display, rectOvalPtr->fillStipple); + Tk_FreeBitmap(display, rectOvalPtr->fillStipple); } if (rectOvalPtr->outlineGC != None) { - Tk_FreeGC(canvasPtr->display, rectOvalPtr->outlineGC); + Tk_FreeGC(display, rectOvalPtr->outlineGC); } if (rectOvalPtr->fillGC != None) { - Tk_FreeGC(canvasPtr->display, rectOvalPtr->fillGC); + Tk_FreeGC(display, rectOvalPtr->fillGC); } } @@ -431,12 +430,13 @@ DeleteRectOval(canvasPtr, itemPtr) /* ARGSUSED */ static void -ComputeRectOvalBbox(canvasPtr, rectOvalPtr) - Tk_Canvas *canvasPtr; /* Canvas that contains item. */ - register RectOvalItem *rectOvalPtr; /* Item whose bbox is to be +ComputeRectOvalBbox(canvas, rectOvalPtr) + Tk_Canvas canvas; /* Canvas that contains item. */ + RectOvalItem *rectOvalPtr; /* Item whose bbox is to be * recomputed. */ { - int bloat; + int bloat, tmp; + double dtmp; /* * Make sure that the first coordinates are the lowest ones. @@ -455,11 +455,36 @@ ComputeRectOvalBbox(canvasPtr, rectOvalPtr) rectOvalPtr->bbox[0] = tmp; } - bloat = (rectOvalPtr->width+1)/2 + 1; - rectOvalPtr->header.x1 = rectOvalPtr->bbox[0] - bloat; - rectOvalPtr->header.y1 = rectOvalPtr->bbox[1] - bloat; - rectOvalPtr->header.x2 = rectOvalPtr->bbox[2] + bloat; - rectOvalPtr->header.y2 = rectOvalPtr->bbox[3] + bloat; + if (rectOvalPtr->outlineColor == NULL) { + bloat = 0; + } else { + bloat = (rectOvalPtr->width+1)/2; + } + + /* + * Special note: the rectangle is always drawn at least 1x1 in + * size, so round up the upper coordinates to be at least 1 unit + * greater than the lower ones. + */ + + tmp = (rectOvalPtr->bbox[0] >= 0) ? rectOvalPtr->bbox[0] + .5 + : rectOvalPtr->bbox[0] - .5; + rectOvalPtr->header.x1 = tmp - bloat; + tmp = (rectOvalPtr->bbox[1] >= 0) ? rectOvalPtr->bbox[1] + .5 + : rectOvalPtr->bbox[1] - .5; + rectOvalPtr->header.y1 = tmp - bloat; + dtmp = rectOvalPtr->bbox[2]; + if (dtmp < (rectOvalPtr->bbox[0] + 1)) { + dtmp = rectOvalPtr->bbox[0] + 1; + } + tmp = (dtmp >= 0) ? dtmp + .5 : dtmp - .5; + rectOvalPtr->header.x2 = tmp + bloat; + dtmp = rectOvalPtr->bbox[3]; + if (dtmp < (rectOvalPtr->bbox[1] + 1)) { + dtmp = rectOvalPtr->bbox[1] + 1; + } + tmp = (dtmp >= 0) ? dtmp + .5 : dtmp - .5; + rectOvalPtr->header.y2 = tmp + bloat; } /* @@ -475,21 +500,23 @@ ComputeRectOvalBbox(canvasPtr, rectOvalPtr) * * Side effects: * ItemPtr is drawn in drawable using the transformation - * information in canvasPtr. + * information in canvas. * *-------------------------------------------------------------- */ static void -DisplayRectOval(canvasPtr, itemPtr, drawable) - register Tk_Canvas *canvasPtr; /* Canvas that contains item. */ +DisplayRectOval(canvas, itemPtr, display, drawable, x, y, width, height) + Tk_Canvas canvas; /* Canvas that contains item. */ Tk_Item *itemPtr; /* Item to be displayed. */ + Display *display; /* Display on which to draw item. */ Drawable drawable; /* Pixmap or window in which to draw * item. */ + int x, y, width, height; /* Describes region of canvas that + * must be redisplayed (not used). */ { - register RectOvalItem *rectOvalPtr = (RectOvalItem *) itemPtr; - Display *display = Tk_Display(canvasPtr->tkwin); - int x1, y1, x2, y2; + RectOvalItem *rectOvalPtr = (RectOvalItem *) itemPtr; + short x1, y1, x2, y2; /* * Compute the screen coordinates of the bounding box for the item. @@ -497,10 +524,10 @@ DisplayRectOval(canvasPtr, itemPtr, drawable) * X servers will die if it isn't. */ - x1 = SCREEN_X(canvasPtr, rectOvalPtr->bbox[0]); - y1 = SCREEN_Y(canvasPtr, rectOvalPtr->bbox[1]); - x2 = SCREEN_X(canvasPtr, rectOvalPtr->bbox[2]); - y2 = SCREEN_Y(canvasPtr, rectOvalPtr->bbox[3]); + Tk_CanvasDrawableCoords(canvas, rectOvalPtr->bbox[0], rectOvalPtr->bbox[1], + &x1, &y1); + Tk_CanvasDrawableCoords(canvas, rectOvalPtr->bbox[2], rectOvalPtr->bbox[3], + &x2, &y2); if (x2 <= x1) { x2 = x1+1; } @@ -517,27 +544,27 @@ DisplayRectOval(canvasPtr, itemPtr, drawable) if (rectOvalPtr->fillGC != None) { if (rectOvalPtr->fillStipple != None) { - XSetTSOrigin(display, rectOvalPtr->fillGC, - -canvasPtr->drawableXOrigin, -canvasPtr->drawableYOrigin); + Tk_CanvasSetStippleOrigin(canvas, rectOvalPtr->fillGC); } - if (rectOvalPtr->header.typePtr == &TkRectangleType) { + if (rectOvalPtr->header.typePtr == &tkRectangleType) { XFillRectangle(display, drawable, rectOvalPtr->fillGC, x1, y1, (unsigned int) (x2-x1), (unsigned int) (y2-y1)); } else { XFillArc(display, drawable, rectOvalPtr->fillGC, - x1, y1, (x2-x1), (y2-y1), 0, 360*64); + x1, y1, (unsigned) (x2-x1), (unsigned) (y2-y1), + 0, 360*64); } if (rectOvalPtr->fillStipple != None) { XSetTSOrigin(display, rectOvalPtr->fillGC, 0, 0); } } if (rectOvalPtr->outlineGC != None) { - if (rectOvalPtr->header.typePtr == &TkRectangleType) { + if (rectOvalPtr->header.typePtr == &tkRectangleType) { XDrawRectangle(display, drawable, rectOvalPtr->outlineGC, - x1, y1, (x2-x1), (y2-y1)); + x1, y1, (unsigned) (x2-x1), (unsigned) (y2-y1)); } else { XDrawArc(display, drawable, rectOvalPtr->outlineGC, - x1, y1, (x2-x1), (y2-y1), 0, 360*64); + x1, y1, (unsigned) (x2-x1), (unsigned) (y2-y1), 0, 360*64); } } } @@ -567,12 +594,12 @@ DisplayRectOval(canvasPtr, itemPtr, drawable) /* ARGSUSED */ static double -RectToPoint(canvasPtr, itemPtr, pointPtr) - Tk_Canvas *canvasPtr; /* Canvas containing item. */ +RectToPoint(canvas, itemPtr, pointPtr) + Tk_Canvas canvas; /* Canvas containing item. */ Tk_Item *itemPtr; /* Item to check against point. */ double *pointPtr; /* Pointer to x and y coordinates. */ { - register RectOvalItem *rectPtr = (RectOvalItem *) itemPtr; + RectOvalItem *rectPtr = (RectOvalItem *) itemPtr; double xDiff, yDiff, x1, y1, x2, y2, inc, tmp; /* @@ -672,12 +699,12 @@ RectToPoint(canvasPtr, itemPtr, pointPtr) /* ARGSUSED */ static double -OvalToPoint(canvasPtr, itemPtr, pointPtr) - Tk_Canvas *canvasPtr; /* Canvas containing item. */ +OvalToPoint(canvas, itemPtr, pointPtr) + Tk_Canvas canvas; /* Canvas containing item. */ Tk_Item *itemPtr; /* Item to check against point. */ double *pointPtr; /* Pointer to x and y coordinates. */ { - register RectOvalItem *ovalPtr = (RectOvalItem *) itemPtr; + RectOvalItem *ovalPtr = (RectOvalItem *) itemPtr; double width; int filled; @@ -712,14 +739,14 @@ OvalToPoint(canvasPtr, itemPtr, pointPtr) /* ARGSUSED */ static int -RectToArea(canvasPtr, itemPtr, areaPtr) - Tk_Canvas *canvasPtr; /* Canvas containing item. */ +RectToArea(canvas, itemPtr, areaPtr) + Tk_Canvas canvas; /* Canvas containing item. */ Tk_Item *itemPtr; /* Item to check against rectangle. */ double *areaPtr; /* Pointer to array of four coordinates * (x1, y1, x2, y2) describing rectangular * area. */ { - register RectOvalItem *rectPtr = (RectOvalItem *) itemPtr; + RectOvalItem *rectPtr = (RectOvalItem *) itemPtr; double halfWidth; halfWidth = rectPtr->width/2.0; @@ -771,14 +798,14 @@ RectToArea(canvasPtr, itemPtr, areaPtr) /* ARGSUSED */ static int -OvalToArea(canvasPtr, itemPtr, areaPtr) - Tk_Canvas *canvasPtr; /* Canvas containing item. */ +OvalToArea(canvas, itemPtr, areaPtr) + Tk_Canvas canvas; /* Canvas containing item. */ Tk_Item *itemPtr; /* Item to check against oval. */ double *areaPtr; /* Pointer to array of four coordinates * (x1, y1, x2, y2) describing rectangular * area. */ { - register RectOvalItem *ovalPtr = (RectOvalItem *) itemPtr; + RectOvalItem *ovalPtr = (RectOvalItem *) itemPtr; double oval[4], halfWidth; int result; @@ -853,20 +880,20 @@ OvalToArea(canvasPtr, itemPtr, areaPtr) */ static void -ScaleRectOval(canvasPtr, itemPtr, originX, originY, scaleX, scaleY) - Tk_Canvas *canvasPtr; /* Canvas containing rectangle. */ +ScaleRectOval(canvas, itemPtr, originX, originY, scaleX, scaleY) + Tk_Canvas canvas; /* Canvas containing rectangle. */ Tk_Item *itemPtr; /* Rectangle to be scaled. */ double originX, originY; /* Origin about which to scale rect. */ double scaleX; /* Amount to scale in X direction. */ double scaleY; /* Amount to scale in Y direction. */ { - register RectOvalItem *rectOvalPtr = (RectOvalItem *) itemPtr; + RectOvalItem *rectOvalPtr = (RectOvalItem *) itemPtr; rectOvalPtr->bbox[0] = originX + scaleX*(rectOvalPtr->bbox[0] - originX); rectOvalPtr->bbox[1] = originY + scaleY*(rectOvalPtr->bbox[1] - originY); rectOvalPtr->bbox[2] = originX + scaleX*(rectOvalPtr->bbox[2] - originX); rectOvalPtr->bbox[3] = originY + scaleY*(rectOvalPtr->bbox[3] - originY); - ComputeRectOvalBbox(canvasPtr, rectOvalPtr); + ComputeRectOvalBbox(canvas, rectOvalPtr); } /* @@ -889,19 +916,19 @@ ScaleRectOval(canvasPtr, itemPtr, originX, originY, scaleX, scaleY) */ static void -TranslateRectOval(canvasPtr, itemPtr, deltaX, deltaY) - Tk_Canvas *canvasPtr; /* Canvas containing item. */ +TranslateRectOval(canvas, itemPtr, deltaX, deltaY) + Tk_Canvas canvas; /* Canvas containing item. */ Tk_Item *itemPtr; /* Item that is being moved. */ double deltaX, deltaY; /* Amount by which item is to be * moved. */ { - register RectOvalItem *rectOvalPtr = (RectOvalItem *) itemPtr; + RectOvalItem *rectOvalPtr = (RectOvalItem *) itemPtr; rectOvalPtr->bbox[0] += deltaX; rectOvalPtr->bbox[1] += deltaY; rectOvalPtr->bbox[2] += deltaX; rectOvalPtr->bbox[3] += deltaY; - ComputeRectOvalBbox(canvasPtr, rectOvalPtr); + ComputeRectOvalBbox(canvas, rectOvalPtr); } /* @@ -915,9 +942,9 @@ TranslateRectOval(canvasPtr, itemPtr, deltaX, deltaY) * Results: * The return value is a standard Tcl result. If an error * occurs in generating Postscript then an error message is - * left in canvasPtr->interp->result, replacing whatever used - * to be there. If no error occurs, then Postscript for the - * rectangle is appended to the result. + * left in interp->result, replacing whatever used to be there. + * If no error occurs, then Postscript for the rectangle is + * appended to the result. * * Side effects: * None. @@ -926,20 +953,21 @@ TranslateRectOval(canvasPtr, itemPtr, deltaX, deltaY) */ static int -RectOvalToPostscript(canvasPtr, itemPtr, psInfoPtr) - Tk_Canvas *canvasPtr; /* Information about overall canvas. */ +RectOvalToPostscript(interp, canvas, itemPtr, prepass) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + Tk_Canvas canvas; /* Information about overall canvas. */ Tk_Item *itemPtr; /* Item for which Postscript is * wanted. */ - Tk_PostscriptInfo *psInfoPtr; /* Information about the Postscript; - * must be passed back to Postscript - * utility procedures. */ + int prepass; /* 1 means this is a prepass to + * collect font information; 0 means + * final Postscript is being created. */ { char pathCmd[500], string[100]; - register RectOvalItem *rectOvalPtr = (RectOvalItem *) itemPtr; + RectOvalItem *rectOvalPtr = (RectOvalItem *) itemPtr; double y1, y2; - y1 = TkCanvPsY(psInfoPtr, rectOvalPtr->bbox[1]); - y2 = TkCanvPsY(psInfoPtr, rectOvalPtr->bbox[3]); + y1 = Tk_CanvasPsY(canvas, rectOvalPtr->bbox[1]); + y2 = Tk_CanvasPsY(canvas, rectOvalPtr->bbox[3]); /* * Generate a string that creates a path for the rectangle or oval. @@ -948,7 +976,7 @@ RectOvalToPostscript(canvasPtr, itemPtr, psInfoPtr) */ - if (rectOvalPtr->header.typePtr == &TkRectangleType) { + if (rectOvalPtr->header.typePtr == &tkRectangleType) { sprintf(pathCmd, "%.15g %.15g moveto %.15g 0 rlineto 0 %.15g rlineto %.15g 0 rlineto closepath\n", rectOvalPtr->bbox[0], y1, rectOvalPtr->bbox[2]-rectOvalPtr->bbox[0], y2-y1, @@ -964,18 +992,22 @@ RectOvalToPostscript(canvasPtr, itemPtr, psInfoPtr) */ if (rectOvalPtr->fillColor != NULL) { - Tcl_AppendResult(canvasPtr->interp, pathCmd, (char *) NULL); - if (TkCanvPsColor(canvasPtr, psInfoPtr, rectOvalPtr->fillColor) + Tcl_AppendResult(interp, pathCmd, (char *) NULL); + if (Tk_CanvasPsColor(interp, canvas, rectOvalPtr->fillColor) != TCL_OK) { return TCL_ERROR; } if (rectOvalPtr->fillStipple != None) { - if (TkCanvPsStipple(canvasPtr, psInfoPtr, - rectOvalPtr->fillStipple, 1) != TCL_OK) { + Tcl_AppendResult(interp, "clip ", (char *) NULL); + if (Tk_CanvasPsStipple(interp, canvas, rectOvalPtr->fillStipple) + != TCL_OK) { return TCL_ERROR; } + if (rectOvalPtr->outlineColor != NULL) { + Tcl_AppendResult(interp, "grestore gsave\n", (char *) NULL); + } } else { - Tcl_AppendResult(canvasPtr->interp, "fill\n", (char *) NULL); + Tcl_AppendResult(interp, "fill\n", (char *) NULL); } } @@ -984,15 +1016,15 @@ RectOvalToPostscript(canvasPtr, itemPtr, psInfoPtr) */ if (rectOvalPtr->outlineColor != NULL) { - Tcl_AppendResult(canvasPtr->interp, pathCmd, (char *) NULL); + Tcl_AppendResult(interp, pathCmd, (char *) NULL); sprintf(string, "%d setlinewidth", rectOvalPtr->width); - Tcl_AppendResult(canvasPtr->interp, string, + Tcl_AppendResult(interp, string, " 0 setlinejoin 2 setlinecap\n", (char *) NULL); - if (TkCanvPsColor(canvasPtr, psInfoPtr, rectOvalPtr->outlineColor) + if (Tk_CanvasPsColor(interp, canvas, rectOvalPtr->outlineColor) != TCL_OK) { return TCL_ERROR; } - Tcl_AppendResult(canvasPtr->interp, "stroke\n", (char *) NULL); + Tcl_AppendResult(interp, "stroke\n", (char *) NULL); } return TCL_OK; } diff --git a/tk4.2/generic/tkScale.c b/tk4.2/generic/tkScale.c new file mode 100644 index 0000000..5a5580f --- /dev/null +++ b/tk4.2/generic/tkScale.c @@ -0,0 +1,2054 @@ +/* + * tkScale.c -- + * + * This module implements a scale widgets for the Tk toolkit. + * A scale displays a slider that can be adjusted to change a + * value; it also displays numeric labels and a textual label, + * if desired. + * + * The modifications to use floating-point values are based on + * an implementation by Paul Mackerras. The -variable option + * is due to Henning Schulzrinne. All of these are used with + * permission. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkScale.c 1.80 96/03/21 13:11:55 + */ + +#include "tkPort.h" +#include "default.h" +#include "tkInt.h" +#include + +/* + * A data structure of the following type is kept for each scale + * widget managed by this file: + */ + +typedef struct { + Tk_Window tkwin; /* Window that embodies the scale. NULL + * means that the window has been destroyed + * but the data structures haven't yet been + * cleaned up.*/ + Display *display; /* Display containing widget. Used, among + * other things, so that resources can be + * freed even after tkwin has gone away. */ + Tcl_Interp *interp; /* Interpreter associated with scale. */ + Tcl_Command widgetCmd; /* Token for scale's widget command. */ + Tk_Uid orientUid; /* Orientation for window ("vertical" or + * "horizontal"). */ + int vertical; /* Non-zero means vertical orientation, + * zero means horizontal. */ + int width; /* Desired narrow dimension of scale, + * in pixels. */ + int length; /* Desired long dimension of scale, + * in pixels. */ + double value; /* Current value of scale. */ + char *varName; /* Name of variable (malloc'ed) or NULL. + * If non-NULL, scale's value tracks + * the contents of this variable and + * vice versa. */ + double fromValue; /* Value corresponding to left or top of + * scale. */ + double toValue; /* Value corresponding to right or bottom + * of scale. */ + double tickInterval; /* Distance between tick marks; 0 means + * don't display any tick marks. */ + double resolution; /* If > 0, all values are rounded to an + * even multiple of this value. */ + int digits; /* Number of significant digits to print + * in values. 0 means we get to choose the + * number based on resolution and/or the + * range of the scale. */ + char format[10]; /* Sprintf conversion specifier computed from + * digits and other information. */ + double bigIncrement; /* Amount to use for large increments to + * scale value. (0 means we pick a value). */ + char *command; /* Command prefix to use when invoking Tcl + * commands because the scale value changed. + * NULL means don't invoke commands. + * Malloc'ed. */ + int repeatDelay; /* How long to wait before auto-repeating + * on scrolling actions (in ms). */ + int repeatInterval; /* Interval between autorepeats (in ms). */ + char *label; /* Label to display above or to right of + * scale; NULL means don't display a + * label. Malloc'ed. */ + int labelLength; /* Number of non-NULL chars. in label. */ + Tk_Uid state; /* Normal or disabled. Value cannot be + * changed when scale is disabled. */ + + /* + * Information used when displaying widget: + */ + + int borderWidth; /* Width of 3-D border around window. */ + Tk_3DBorder bgBorder; /* Used for drawing slider and other + * background areas. */ + Tk_3DBorder activeBorder; /* For drawing the slider when active. */ + int sliderRelief; /* Is slider to be drawn raised, sunken, etc. */ + XColor *troughColorPtr; /* Color for drawing trough. */ + GC troughGC; /* For drawing trough. */ + GC copyGC; /* Used for copying from pixmap onto screen. */ + XFontStruct *fontPtr; /* Information about text font, or NULL. */ + XColor *textColorPtr; /* Color for drawing text. */ + GC textGC; /* GC for drawing text in normal mode. */ + int relief; /* Indicates whether window as a whole is + * raised, sunken, or flat. */ + int highlightWidth; /* Width in pixels of highlight to draw + * around widget when it has the focus. + * <= 0 means don't draw a highlight. */ + XColor *highlightBgColorPtr; + /* Color for drawing traversal highlight + * area when highlight is off. */ + XColor *highlightColorPtr; /* Color for drawing traversal highlight. */ + int inset; /* Total width of all borders, including + * traversal highlight and 3-D border. + * Indicates how much interior stuff must + * be offset from outside edges to leave + * room for borders. */ + int sliderLength; /* Length of slider, measured in pixels along + * long dimension of scale. */ + int showValue; /* Non-zero means to display the scale value + * below or to the left of the slider; zero + * means don't display the value. */ + + /* + * Layout information for horizontal scales, assuming that window + * gets the size it requested: + */ + + int horizLabelY; /* Y-coord at which to draw label. */ + int horizValueY; /* Y-coord at which to draw value text. */ + int horizTroughY; /* Y-coord of top of slider trough. */ + int horizTickY; /* Y-coord at which to draw tick text. */ + /* + * Layout information for vertical scales, assuming that window + * gets the size it requested: + */ + + int vertTickRightX; /* X-location of right side of tick-marks. */ + int vertValueRightX; /* X-location of right side of value string. */ + int vertTroughX; /* X-location of scale's slider trough. */ + int vertLabelX; /* X-location of origin of label. */ + + /* + * Miscellaneous information: + */ + + Tk_Cursor cursor; /* Current cursor for window, or None. */ + char *takeFocus; /* Value of -takefocus option; not used in + * the C code, but used by keyboard traversal + * scripts. Malloc'ed, but may be NULL. */ + int flags; /* Various flags; see below for + * definitions. */ +} Scale; + +/* + * Flag bits for scales: + * + * REDRAW_SLIDER - 1 means slider (and numerical readout) need + * to be redrawn. + * REDRAW_OTHER - 1 means other stuff besides slider and value + * need to be redrawn. + * REDRAW_ALL - 1 means the entire widget needs to be redrawn. + * ACTIVE - 1 means the widget is active (the mouse is + * in its window). + * INVOKE_COMMAND - 1 means the scale's command needs to be + * invoked during the next redisplay (the + * value of the scale has changed since the + * last time the command was invoked). + * SETTING_VAR - 1 means that the associated variable is + * being set by us, so there's no need for + * ScaleVarProc to do anything. + * NEVER_SET - 1 means that the scale's value has never + * been set before (so must invoke -command and + * set associated variable even if the value + * doesn't appear to have changed). + * GOT_FOCUS - 1 means that the focus is currently in + * this widget. + */ + +#define REDRAW_SLIDER 1 +#define REDRAW_OTHER 2 +#define REDRAW_ALL 3 +#define ACTIVE 4 +#define INVOKE_COMMAND 0x10 +#define SETTING_VAR 0x20 +#define NEVER_SET 0x40 +#define GOT_FOCUS 0x80 + +/* + * Symbolic values for the active parts of a slider. These are + * the values that may be returned by the ScaleElement procedure. + */ + +#define OTHER 0 +#define TROUGH1 1 +#define SLIDER 2 +#define TROUGH2 3 + +/* + * Space to leave between scale area and text, and between text and + * edge of window. + */ + +#define SPACING 2 + +/* + * How many characters of space to provide when formatting the + * scale's value: + */ + +#define PRINT_CHARS 150 + +/* + * Information used for argv parsing. + */ + +static Tk_ConfigSpec configSpecs[] = { + {TK_CONFIG_BORDER, "-activebackground", "activeBackground", "Foreground", + DEF_SCALE_ACTIVE_BG_COLOR, Tk_Offset(Scale, activeBorder), + TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_BORDER, "-activebackground", "activeBackground", "Foreground", + DEF_SCALE_ACTIVE_BG_MONO, Tk_Offset(Scale, activeBorder), + TK_CONFIG_MONO_ONLY}, + {TK_CONFIG_BORDER, "-background", "background", "Background", + DEF_SCALE_BG_COLOR, Tk_Offset(Scale, bgBorder), + TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_BORDER, "-background", "background", "Background", + DEF_SCALE_BG_MONO, Tk_Offset(Scale, bgBorder), + TK_CONFIG_MONO_ONLY}, + {TK_CONFIG_DOUBLE, "-bigincrement", "bigIncrement", "BigIncrement", + DEF_SCALE_BIG_INCREMENT, Tk_Offset(Scale, bigIncrement), 0}, + {TK_CONFIG_SYNONYM, "-bd", "borderWidth", (char *) NULL, + (char *) NULL, 0, 0}, + {TK_CONFIG_SYNONYM, "-bg", "background", (char *) NULL, + (char *) NULL, 0, 0}, + {TK_CONFIG_PIXELS, "-borderwidth", "borderWidth", "BorderWidth", + DEF_SCALE_BORDER_WIDTH, Tk_Offset(Scale, borderWidth), 0}, + {TK_CONFIG_STRING, "-command", "command", "Command", + DEF_SCALE_COMMAND, Tk_Offset(Scale, command), TK_CONFIG_NULL_OK}, + {TK_CONFIG_ACTIVE_CURSOR, "-cursor", "cursor", "Cursor", + DEF_SCALE_CURSOR, Tk_Offset(Scale, cursor), TK_CONFIG_NULL_OK}, + {TK_CONFIG_INT, "-digits", "digits", "Digits", + DEF_SCALE_DIGITS, Tk_Offset(Scale, digits), 0}, + {TK_CONFIG_SYNONYM, "-fg", "foreground", (char *) NULL, + (char *) NULL, 0, 0}, + {TK_CONFIG_FONT, "-font", "font", "Font", + DEF_SCALE_FONT, Tk_Offset(Scale, fontPtr), + 0}, + {TK_CONFIG_COLOR, "-foreground", "foreground", "Foreground", + DEF_SCALE_FG_COLOR, Tk_Offset(Scale, textColorPtr), + TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_COLOR, "-foreground", "foreground", "Foreground", + DEF_SCALE_FG_MONO, Tk_Offset(Scale, textColorPtr), + TK_CONFIG_MONO_ONLY}, + {TK_CONFIG_DOUBLE, "-from", "from", "From", + DEF_SCALE_FROM, Tk_Offset(Scale, fromValue), 0}, + {TK_CONFIG_COLOR, "-highlightbackground", "highlightBackground", + "HighlightBackground", DEF_SCALE_HIGHLIGHT_BG, + Tk_Offset(Scale, highlightBgColorPtr), 0}, + {TK_CONFIG_COLOR, "-highlightcolor", "highlightColor", "HighlightColor", + DEF_SCALE_HIGHLIGHT, Tk_Offset(Scale, highlightColorPtr), 0}, + {TK_CONFIG_PIXELS, "-highlightthickness", "highlightThickness", + "HighlightThickness", + DEF_SCALE_HIGHLIGHT_WIDTH, Tk_Offset(Scale, highlightWidth), 0}, + {TK_CONFIG_STRING, "-label", "label", "Label", + DEF_SCALE_LABEL, Tk_Offset(Scale, label), TK_CONFIG_NULL_OK}, + {TK_CONFIG_PIXELS, "-length", "length", "Length", + DEF_SCALE_LENGTH, Tk_Offset(Scale, length), 0}, + {TK_CONFIG_UID, "-orient", "orient", "Orient", + DEF_SCALE_ORIENT, Tk_Offset(Scale, orientUid), 0}, + {TK_CONFIG_RELIEF, "-relief", "relief", "Relief", + DEF_SCALE_RELIEF, Tk_Offset(Scale, relief), 0}, + {TK_CONFIG_INT, "-repeatdelay", "repeatDelay", "RepeatDelay", + DEF_SCALE_REPEAT_DELAY, Tk_Offset(Scale, repeatDelay), 0}, + {TK_CONFIG_INT, "-repeatinterval", "repeatInterval", "RepeatInterval", + DEF_SCALE_REPEAT_INTERVAL, Tk_Offset(Scale, repeatInterval), 0}, + {TK_CONFIG_DOUBLE, "-resolution", "resolution", "Resolution", + DEF_SCALE_RESOLUTION, Tk_Offset(Scale, resolution), 0}, + {TK_CONFIG_BOOLEAN, "-showvalue", "showValue", "ShowValue", + DEF_SCALE_SHOW_VALUE, Tk_Offset(Scale, showValue), 0}, + {TK_CONFIG_PIXELS, "-sliderlength", "sliderLength", "SliderLength", + DEF_SCALE_SLIDER_LENGTH, Tk_Offset(Scale, sliderLength), 0}, + {TK_CONFIG_RELIEF, "-sliderrelief", "sliderRelief", "SliderRelief", + DEF_SCALE_SLIDER_RELIEF, Tk_Offset(Scale, sliderRelief), + TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_UID, "-state", "state", "State", + DEF_SCALE_STATE, Tk_Offset(Scale, state), 0}, + {TK_CONFIG_STRING, "-takefocus", "takeFocus", "TakeFocus", + DEF_SCALE_TAKE_FOCUS, Tk_Offset(Scale, takeFocus), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_DOUBLE, "-tickinterval", "tickInterval", "TickInterval", + DEF_SCALE_TICK_INTERVAL, Tk_Offset(Scale, tickInterval), 0}, + {TK_CONFIG_DOUBLE, "-to", "to", "To", + DEF_SCALE_TO, Tk_Offset(Scale, toValue), 0}, + {TK_CONFIG_COLOR, "-troughcolor", "troughColor", "Background", + DEF_SCALE_TROUGH_COLOR, Tk_Offset(Scale, troughColorPtr), + TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_COLOR, "-troughcolor", "troughColor", "Background", + DEF_SCALE_TROUGH_MONO, Tk_Offset(Scale, troughColorPtr), + TK_CONFIG_MONO_ONLY}, + {TK_CONFIG_STRING, "-variable", "variable", "Variable", + DEF_SCALE_VARIABLE, Tk_Offset(Scale, varName), TK_CONFIG_NULL_OK}, + {TK_CONFIG_PIXELS, "-width", "width", "Width", + DEF_SCALE_WIDTH, Tk_Offset(Scale, width), 0}, + {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, 0} +}; + +/* + * Forward declarations for procedures defined later in this file: + */ + +static void ComputeFormat _ANSI_ARGS_((Scale *scalePtr)); +static void ComputeScaleGeometry _ANSI_ARGS_((Scale *scalePtr)); +static int ConfigureScale _ANSI_ARGS_((Tcl_Interp *interp, + Scale *scalePtr, int argc, char **argv, + int flags)); +static void DestroyScale _ANSI_ARGS_((char *memPtr)); +static void DisplayScale _ANSI_ARGS_((ClientData clientData)); +static void DisplayHorizontalScale _ANSI_ARGS_((Scale *scalePtr, + Drawable drawable, XRectangle *drawnAreaPtr)); +static void DisplayHorizontalValue _ANSI_ARGS_((Scale *scalePtr, + Drawable drawable, double value, int top)); +static void DisplayVerticalScale _ANSI_ARGS_((Scale *scalePtr, + Drawable drawable, XRectangle *drawnAreaPtr)); +static void DisplayVerticalValue _ANSI_ARGS_((Scale *scalePtr, + Drawable drawable, double value, int rightEdge)); +static void EventuallyRedrawScale _ANSI_ARGS_((Scale *scalePtr, + int what)); +static double PixelToValue _ANSI_ARGS_((Scale *scalePtr, int x, + int y)); +static double RoundToResolution _ANSI_ARGS_((Scale *scalePtr, + double value)); +static void ScaleCmdDeletedProc _ANSI_ARGS_(( + ClientData clientData)); +static int ScaleElement _ANSI_ARGS_((Scale *scalePtr, int x, + int y)); +static void ScaleEventProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +static char * ScaleVarProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *name1, char *name2, + int flags)); +static int ScaleWidgetCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static void SetScaleValue _ANSI_ARGS_((Scale *scalePtr, + double value, int setVar, int invokeCommand)); +static int ValueToPixel _ANSI_ARGS_((Scale *scalePtr, double value)); + +/* + *-------------------------------------------------------------- + * + * Tk_ScaleCmd -- + * + * This procedure is invoked to process the "scale" Tcl + * command. See the user documentation for details on what + * it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +int +Tk_ScaleCmd(clientData, interp, argc, argv) + ClientData clientData; /* Main window associated with + * interpreter. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tk_Window tkwin = (Tk_Window) clientData; + register Scale *scalePtr; + Tk_Window new; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " pathName ?options?\"", (char *) NULL); + return TCL_ERROR; + } + + new = Tk_CreateWindowFromPath(interp, tkwin, argv[1], (char *) NULL); + if (new == NULL) { + return TCL_ERROR; + } + + /* + * Initialize fields that won't be initialized by ConfigureScale, + * or which ConfigureScale expects to have reasonable values + * (e.g. resource pointers). + */ + + scalePtr = (Scale *) ckalloc(sizeof(Scale)); + scalePtr->tkwin = new; + scalePtr->display = Tk_Display(new); + scalePtr->interp = interp; + scalePtr->widgetCmd = Tcl_CreateCommand(interp, + Tk_PathName(scalePtr->tkwin), ScaleWidgetCmd, + (ClientData) scalePtr, ScaleCmdDeletedProc); + scalePtr->orientUid = NULL; + scalePtr->vertical = 0; + scalePtr->width = 0; + scalePtr->length = 0; + scalePtr->value = 0; + scalePtr->varName = NULL; + scalePtr->fromValue = 0; + scalePtr->toValue = 0; + scalePtr->tickInterval = 0; + scalePtr->resolution = 1; + scalePtr->bigIncrement = 0.0; + scalePtr->command = NULL; + scalePtr->repeatDelay = 0; + scalePtr->repeatInterval = 0; + scalePtr->label = NULL; + scalePtr->labelLength = 0; + scalePtr->state = tkNormalUid; + scalePtr->borderWidth = 0; + scalePtr->bgBorder = NULL; + scalePtr->activeBorder = NULL; + scalePtr->sliderRelief = TK_RELIEF_RAISED; + scalePtr->troughColorPtr = NULL; + scalePtr->troughGC = None; + scalePtr->copyGC = None; + scalePtr->fontPtr = NULL; + scalePtr->textColorPtr = NULL; + scalePtr->textGC = None; + scalePtr->relief = TK_RELIEF_FLAT; + scalePtr->highlightWidth = 0; + scalePtr->highlightBgColorPtr = NULL; + scalePtr->highlightColorPtr = NULL; + scalePtr->inset = 0; + scalePtr->sliderLength = 0; + scalePtr->showValue = 0; + scalePtr->horizLabelY = 0; + scalePtr->horizValueY = 0; + scalePtr->horizTroughY = 0; + scalePtr->horizTickY = 0; + scalePtr->vertTickRightX = 0; + scalePtr->vertValueRightX = 0; + scalePtr->vertTroughX = 0; + scalePtr->vertLabelX = 0; + scalePtr->cursor = None; + scalePtr->takeFocus = NULL; + scalePtr->flags = NEVER_SET; + + Tk_SetClass(scalePtr->tkwin, "Scale"); + Tk_CreateEventHandler(scalePtr->tkwin, + ExposureMask|StructureNotifyMask|FocusChangeMask, + ScaleEventProc, (ClientData) scalePtr); + if (ConfigureScale(interp, scalePtr, argc-2, argv+2, 0) != TCL_OK) { + goto error; + } + + interp->result = Tk_PathName(scalePtr->tkwin); + return TCL_OK; + + error: + Tk_DestroyWindow(scalePtr->tkwin); + return TCL_ERROR; +} + +/* + *-------------------------------------------------------------- + * + * ScaleWidgetCmd -- + * + * This procedure is invoked to process the Tcl command + * that corresponds to a widget managed by this module. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +static int +ScaleWidgetCmd(clientData, interp, argc, argv) + ClientData clientData; /* Information about scale + * widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register Scale *scalePtr = (Scale *) clientData; + int result = TCL_OK; + size_t length; + int c; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_Preserve((ClientData) scalePtr); + c = argv[1][0]; + length = strlen(argv[1]); + if ((c == 'c') && (strncmp(argv[1], "cget", length) == 0) + && (length >= 2)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " cget option\"", + (char *) NULL); + goto error; + } + result = Tk_ConfigureValue(interp, scalePtr->tkwin, configSpecs, + (char *) scalePtr, argv[2], 0); + } else if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0) + && (length >= 3)) { + if (argc == 2) { + result = Tk_ConfigureInfo(interp, scalePtr->tkwin, configSpecs, + (char *) scalePtr, (char *) NULL, 0); + } else if (argc == 3) { + result = Tk_ConfigureInfo(interp, scalePtr->tkwin, configSpecs, + (char *) scalePtr, argv[2], 0); + } else { + result = ConfigureScale(interp, scalePtr, argc-2, argv+2, + TK_CONFIG_ARGV_ONLY); + } + } else if ((c == 'c') && (strncmp(argv[1], "coords", length) == 0) + && (length >= 3)) { + int x, y ; + double value; + + if ((argc != 2) && (argc != 3)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " coords ?value?\"", (char *) NULL); + goto error; + } + if (argc == 3) { + if (Tcl_GetDouble(interp, argv[2], &value) != TCL_OK) { + goto error; + } + } else { + value = scalePtr->value; + } + if (scalePtr->vertical) { + x = scalePtr->vertTroughX + scalePtr->width/2 + + scalePtr->borderWidth; + y = ValueToPixel(scalePtr, value); + } else { + x = ValueToPixel(scalePtr, value); + y = scalePtr->horizTroughY + scalePtr->width/2 + + scalePtr->borderWidth; + } + sprintf(interp->result, "%d %d", x, y); + } else if ((c == 'g') && (strncmp(argv[1], "get", length) == 0)) { + double value; + int x, y; + + if ((argc != 2) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " get ?x y?\"", (char *) NULL); + goto error; + } + if (argc == 2) { + value = scalePtr->value; + } else { + if ((Tcl_GetInt(interp, argv[2], &x) != TCL_OK) + || (Tcl_GetInt(interp, argv[3], &y) != TCL_OK)) { + goto error; + } + value = PixelToValue(scalePtr, x, y); + } + sprintf(interp->result, scalePtr->format, value); + } else if ((c == 'i') && (strncmp(argv[1], "identify", length) == 0)) { + int x, y, thing; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " identify x y\"", (char *) NULL); + goto error; + } + if ((Tcl_GetInt(interp, argv[2], &x) != TCL_OK) + || (Tcl_GetInt(interp, argv[3], &y) != TCL_OK)) { + goto error; + } + thing = ScaleElement(scalePtr, x,y); + switch (thing) { + case TROUGH1: interp->result = "trough1"; break; + case SLIDER: interp->result = "slider"; break; + case TROUGH2: interp->result = "trough2"; break; + } + } else if ((c == 's') && (strncmp(argv[1], "set", length) == 0)) { + double value; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " set value\"", (char *) NULL); + goto error; + } + if (Tcl_GetDouble(interp, argv[2], &value) != TCL_OK) { + goto error; + } + if (scalePtr->state != tkDisabledUid) { + SetScaleValue(scalePtr, value, 1, 1); + } + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be cget, configure, coords, get, identify, or set", + (char *) NULL); + goto error; + } + Tcl_Release((ClientData) scalePtr); + return result; + + error: + Tcl_Release((ClientData) scalePtr); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * DestroyScale -- + * + * This procedure is invoked by Tcl_EventuallyFree or Tcl_Release + * to clean up the internal structure of a button at a safe time + * (when no-one is using it anymore). + * + * Results: + * None. + * + * Side effects: + * Everything associated with the scale is freed up. + * + *---------------------------------------------------------------------- + */ + +static void +DestroyScale(memPtr) + char *memPtr; /* Info about scale widget. */ +{ + register Scale *scalePtr = (Scale *) memPtr; + + /* + * Free up all the stuff that requires special handling, then + * let Tk_FreeOptions handle all the standard option-related + * stuff. + */ + + if (scalePtr->varName != NULL) { + Tcl_UntraceVar(scalePtr->interp, scalePtr->varName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + ScaleVarProc, (ClientData) scalePtr); + } + if (scalePtr->troughGC != None) { + Tk_FreeGC(scalePtr->display, scalePtr->troughGC); + } + if (scalePtr->copyGC != None) { + Tk_FreeGC(scalePtr->display, scalePtr->copyGC); + } + if (scalePtr->textGC != None) { + Tk_FreeGC(scalePtr->display, scalePtr->textGC); + } + Tk_FreeOptions(configSpecs, (char *) scalePtr, scalePtr->display, 0); + ckfree((char *) scalePtr); +} + +/* + *---------------------------------------------------------------------- + * + * ConfigureScale -- + * + * This procedure is called to process an argv/argc list, plus + * the Tk option database, in order to configure (or + * reconfigure) a scale widget. + * + * Results: + * The return value is a standard Tcl result. If TCL_ERROR is + * returned, then interp->result contains an error message. + * + * Side effects: + * Configuration information, such as colors, border width, + * etc. get set for scalePtr; old resources get freed, + * if there were any. + * + *---------------------------------------------------------------------- + */ + +static int +ConfigureScale(interp, scalePtr, argc, argv, flags) + Tcl_Interp *interp; /* Used for error reporting. */ + register Scale *scalePtr; /* Information about widget; may or may + * not already have values for some fields. */ + int argc; /* Number of valid entries in argv. */ + char **argv; /* Arguments. */ + int flags; /* Flags to pass to Tk_ConfigureWidget. */ +{ + XGCValues gcValues; + GC newGC; + size_t length; + + /* + * Eliminate any existing trace on a variable monitored by the scale. + */ + + if (scalePtr->varName != NULL) { + Tcl_UntraceVar(interp, scalePtr->varName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + ScaleVarProc, (ClientData) scalePtr); + } + + if (Tk_ConfigureWidget(interp, scalePtr->tkwin, configSpecs, + argc, argv, (char *) scalePtr, flags) != TCL_OK) { + return TCL_ERROR; + } + + /* + * If the scale is tied to the value of a variable, then set up + * a trace on the variable's value and set the scale's value from + * the value of the variable, if it exists. + */ + + if (scalePtr->varName != NULL) { + char *stringValue, *end; + double value; + + stringValue = Tcl_GetVar(interp, scalePtr->varName, TCL_GLOBAL_ONLY); + if (stringValue != NULL) { + value = strtod(stringValue, &end); + if ((end != stringValue) && (*end == 0)) { + scalePtr->value = RoundToResolution(scalePtr, value); + } + } + Tcl_TraceVar(interp, scalePtr->varName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + ScaleVarProc, (ClientData) scalePtr); + } + + /* + * Several options need special processing, such as parsing the + * orientation and creating GCs. + */ + + length = strlen(scalePtr->orientUid); + if (strncmp(scalePtr->orientUid, "vertical", length) == 0) { + scalePtr->vertical = 1; + } else if (strncmp(scalePtr->orientUid, "horizontal", length) == 0) { + scalePtr->vertical = 0; + } else { + Tcl_AppendResult(interp, "bad orientation \"", scalePtr->orientUid, + "\": must be vertical or horizontal", (char *) NULL); + return TCL_ERROR; + } + + scalePtr->fromValue = RoundToResolution(scalePtr, scalePtr->fromValue); + scalePtr->toValue = RoundToResolution(scalePtr, scalePtr->toValue); + scalePtr->tickInterval = RoundToResolution(scalePtr, + scalePtr->tickInterval); + + /* + * Make sure that the tick interval has the right sign so that + * addition moves from fromValue to toValue. + */ + + if ((scalePtr->tickInterval < 0) + ^ ((scalePtr->toValue - scalePtr->fromValue) < 0)) { + scalePtr->tickInterval = -scalePtr->tickInterval; + } + + /* + * Set the scale value to itself; all this does is to make sure + * that the scale's value is within the new acceptable range for + * the scale and reflect the value in the associated variable, + * if any. + */ + + ComputeFormat(scalePtr); + SetScaleValue(scalePtr, scalePtr->value, 1, 1); + + if (scalePtr->label != NULL) { + scalePtr->labelLength = strlen(scalePtr->label); + } else { + scalePtr->labelLength = 0; + } + + if ((scalePtr->state != tkNormalUid) + && (scalePtr->state != tkDisabledUid) + && (scalePtr->state != tkActiveUid)) { + Tcl_AppendResult(interp, "bad state value \"", scalePtr->state, + "\": must be normal, active, or disabled", (char *) NULL); + scalePtr->state = tkNormalUid; + return TCL_ERROR; + } + + Tk_SetBackgroundFromBorder(scalePtr->tkwin, scalePtr->bgBorder); + + gcValues.foreground = scalePtr->troughColorPtr->pixel; + newGC = Tk_GetGC(scalePtr->tkwin, GCForeground, &gcValues); + if (scalePtr->troughGC != None) { + Tk_FreeGC(scalePtr->display, scalePtr->troughGC); + } + scalePtr->troughGC = newGC; + if (scalePtr->copyGC == None) { + gcValues.graphics_exposures = False; + scalePtr->copyGC = Tk_GetGC(scalePtr->tkwin, GCGraphicsExposures, + &gcValues); + } + if (scalePtr->highlightWidth < 0) { + scalePtr->highlightWidth = 0; + } + gcValues.font = scalePtr->fontPtr->fid; + gcValues.foreground = scalePtr->textColorPtr->pixel; + newGC = Tk_GetGC(scalePtr->tkwin, GCForeground|GCFont, &gcValues); + if (scalePtr->textGC != None) { + Tk_FreeGC(scalePtr->display, scalePtr->textGC); + } + scalePtr->textGC = newGC; + + scalePtr->inset = scalePtr->highlightWidth + scalePtr->borderWidth; + + /* + * Recompute display-related information, and let the geometry + * manager know how much space is needed now. + */ + + ComputeScaleGeometry(scalePtr); + + EventuallyRedrawScale(scalePtr, REDRAW_ALL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ComputeFormat -- + * + * This procedure is invoked to recompute the "format" field + * of a scale's widget record, which determines how the value + * of the scale is converted to a string. + * + * Results: + * None. + * + * Side effects: + * The format field of scalePtr is modified. + * + *---------------------------------------------------------------------- + */ + +static void +ComputeFormat(scalePtr) + Scale *scalePtr; /* Information about scale widget. */ +{ + double maxValue, x; + int mostSigDigit, numDigits, leastSigDigit, afterDecimal; + int eDigits, fDigits; + + /* + * Compute the displacement from the decimal of the most significant + * digit required for any number in the scale's range. + */ + + maxValue = fabs(scalePtr->fromValue); + x = fabs(scalePtr->toValue); + if (x > maxValue) { + maxValue = x; + } + if (maxValue == 0) { + maxValue = 1; + } + mostSigDigit = floor(log10(maxValue)); + + /* + * If the number of significant digits wasn't specified explicitly, + * compute it. It's the difference between the most significant + * digit needed to represent any number on the scale and the + * most significant digit of the smallest difference between + * numbers on the scale. In other words, display enough digits so + * that at least one digit will be different between any two adjacent + * positions of the scale. + */ + + numDigits = scalePtr->digits; + if (numDigits <= 0) { + if (scalePtr->resolution > 0) { + /* + * A resolution was specified for the scale, so just use it. + */ + + leastSigDigit = floor(log10(scalePtr->resolution)); + } else { + /* + * No resolution was specified, so compute the difference + * in value between adjacent pixels and use it for the least + * significant digit. + */ + + x = fabs(scalePtr->fromValue - scalePtr->toValue); + if (scalePtr->length > 0) { + x /= scalePtr->length; + } + if (x > 0){ + leastSigDigit = floor(log10(x)); + } else { + leastSigDigit = 0; + } + } + numDigits = mostSigDigit - leastSigDigit + 1; + if (numDigits < 1) { + numDigits = 1; + } + } + + /* + * Compute the number of characters required using "e" format and + * "f" format, and then choose whichever one takes fewer characters. + */ + + eDigits = numDigits + 4; + if (numDigits > 1) { + eDigits++; /* Decimal point. */ + } + afterDecimal = numDigits - mostSigDigit - 1; + if (afterDecimal < 0) { + afterDecimal = 0; + } + fDigits = (mostSigDigit >= 0) ? mostSigDigit + afterDecimal : afterDecimal; + if (afterDecimal > 0) { + fDigits++; /* Decimal point. */ + } + if (mostSigDigit < 0) { + fDigits++; /* Zero to left of decimal point. */ + } + if (fDigits <= eDigits) { + sprintf(scalePtr->format, "%%.%df", afterDecimal); + } else { + sprintf(scalePtr->format, "%%.%de", numDigits-1); + } +} + +/* + *---------------------------------------------------------------------- + * + * ComputeScaleGeometry -- + * + * This procedure is called to compute various geometrical + * information for a scale, such as where various things get + * displayed. It's called when the window is reconfigured. + * + * Results: + * None. + * + * Side effects: + * Display-related numbers get changed in *scalePtr. The + * geometry manager gets told about the window's preferred size. + * + *---------------------------------------------------------------------- + */ + +static void +ComputeScaleGeometry(scalePtr) + register Scale *scalePtr; /* Information about widget. */ +{ + XCharStruct bbox; + char valueString[PRINT_CHARS]; + int dummy, lineHeight, valuePixels, x, y, extraSpace; + + /* + * Horizontal scales are simpler than vertical ones because + * all sizes are the same (the height of a line of text); + * handle them first and then quit. + */ + + if (!scalePtr->vertical) { + lineHeight = scalePtr->fontPtr->ascent + scalePtr->fontPtr->descent; + y = scalePtr->inset; + extraSpace = 0; + if (scalePtr->labelLength != 0) { + scalePtr->horizLabelY = y + SPACING; + y += lineHeight + SPACING; + extraSpace = SPACING; + } + if (scalePtr->showValue) { + scalePtr->horizValueY = y + SPACING; + y += lineHeight + SPACING; + extraSpace = SPACING; + } else { + scalePtr->horizValueY = y; + } + y += extraSpace; + scalePtr->horizTroughY = y; + y += scalePtr->width + 2*scalePtr->borderWidth; + if (scalePtr->tickInterval != 0) { + scalePtr->horizTickY = y + SPACING; + y += lineHeight + 2*SPACING; + } + Tk_GeometryRequest(scalePtr->tkwin, + scalePtr->length + 2*scalePtr->inset, y + scalePtr->inset); + Tk_SetInternalBorder(scalePtr->tkwin, scalePtr->inset); + return; + } + + /* + * Vertical scale: compute the amount of space needed to display + * the scales value by formatting strings for the two end points; + * use whichever length is longer. + */ + + sprintf(valueString, scalePtr->format, scalePtr->fromValue); + XTextExtents(scalePtr->fontPtr, valueString, (int) strlen(valueString), + &dummy, &dummy, &dummy, &bbox); + valuePixels = bbox.rbearing - bbox.lbearing; + sprintf(valueString, scalePtr->format, scalePtr->toValue); + XTextExtents(scalePtr->fontPtr, valueString, (int) strlen(valueString), + &dummy, &dummy, &dummy, &bbox); + if (valuePixels < bbox.rbearing - bbox.lbearing) { + valuePixels = bbox.rbearing - bbox.lbearing; + } + + /* + * Assign x-locations to the elements of the scale, working from + * left to right. + */ + + x = scalePtr->inset; + if ((scalePtr->tickInterval != 0) && (scalePtr->showValue)) { + scalePtr->vertTickRightX = x + SPACING + valuePixels; + scalePtr->vertValueRightX = scalePtr->vertTickRightX + valuePixels + + scalePtr->fontPtr->ascent/2; + x = scalePtr->vertValueRightX + SPACING; + } else if (scalePtr->tickInterval != 0) { + scalePtr->vertTickRightX = x + SPACING + valuePixels; + scalePtr->vertValueRightX = scalePtr->vertTickRightX; + x = scalePtr->vertTickRightX + SPACING; + } else if (scalePtr->showValue) { + scalePtr->vertTickRightX = x; + scalePtr->vertValueRightX = x + SPACING + valuePixels; + x = scalePtr->vertValueRightX + SPACING; + } else { + scalePtr->vertTickRightX = x; + scalePtr->vertValueRightX = x; + } + scalePtr->vertTroughX = x; + x += 2*scalePtr->borderWidth + scalePtr->width; + if (scalePtr->labelLength == 0) { + scalePtr->vertLabelX = 0; + } else { + XTextExtents(scalePtr->fontPtr, scalePtr->label, + scalePtr->labelLength, &dummy, &dummy, &dummy, &bbox); + scalePtr->vertLabelX = x + scalePtr->fontPtr->ascent/2 - bbox.lbearing; + x = scalePtr->vertLabelX + bbox.rbearing + + scalePtr->fontPtr->ascent/2; + } + Tk_GeometryRequest(scalePtr->tkwin, x + scalePtr->inset, + scalePtr->length + 2*scalePtr->inset); + Tk_SetInternalBorder(scalePtr->tkwin, scalePtr->inset); +} + +/* + *-------------------------------------------------------------- + * + * DisplayVerticalScale -- + * + * This procedure redraws the contents of a vertical scale + * window. It is invoked as a do-when-idle handler, so it only + * runs when there's nothing else for the application to do. + * + * Results: + * There is no return value. If only a part of the scale needs + * to be redrawn, then drawnAreaPtr is modified to reflect the + * area that was actually modified. + * + * Side effects: + * Information appears on the screen. + * + *-------------------------------------------------------------- + */ + +static void +DisplayVerticalScale(scalePtr, drawable, drawnAreaPtr) + Scale *scalePtr; /* Widget record for scale. */ + Drawable drawable; /* Where to display scale (window + * or pixmap). */ + XRectangle *drawnAreaPtr; /* Initally contains area of window; + * if only a part of the scale is + * redrawn, gets modified to reflect + * the part of the window that was + * redrawn. */ +{ + Tk_Window tkwin = scalePtr->tkwin; + int x, y, width, height, shadowWidth; + double tickValue; + Tk_3DBorder sliderBorder; + + /* + * Display the information from left to right across the window. + */ + + if (!(scalePtr->flags & REDRAW_OTHER)) { + drawnAreaPtr->x = scalePtr->vertTickRightX; + drawnAreaPtr->y = scalePtr->inset; + drawnAreaPtr->width = scalePtr->vertTroughX + scalePtr->width + + 2*scalePtr->borderWidth - scalePtr->vertTickRightX; + drawnAreaPtr->height -= 2*scalePtr->inset; + } + Tk_Fill3DRectangle(tkwin, drawable, scalePtr->bgBorder, + drawnAreaPtr->x, drawnAreaPtr->y, drawnAreaPtr->width, + drawnAreaPtr->height, 0, TK_RELIEF_FLAT); + if (scalePtr->flags & REDRAW_OTHER) { + /* + * Display the tick marks. + */ + + if (scalePtr->tickInterval != 0) { + for (tickValue = scalePtr->fromValue; ; + tickValue += scalePtr->tickInterval) { + /* + * The RoundToResolution call gets rid of accumulated + * round-off errors, if any. + */ + + tickValue = RoundToResolution(scalePtr, tickValue); + if (scalePtr->toValue >= scalePtr->fromValue) { + if (tickValue > scalePtr->toValue) { + break; + } + } else { + if (tickValue < scalePtr->toValue) { + break; + } + } + DisplayVerticalValue(scalePtr, drawable, tickValue, + scalePtr->vertTickRightX); + } + } + } + + /* + * Display the value, if it is desired. + */ + + if (scalePtr->showValue) { + DisplayVerticalValue(scalePtr, drawable, scalePtr->value, + scalePtr->vertValueRightX); + } + + /* + * Display the trough and the slider. + */ + + Tk_Draw3DRectangle(tkwin, drawable, + scalePtr->bgBorder, scalePtr->vertTroughX, scalePtr->inset, + scalePtr->width + 2*scalePtr->borderWidth, + Tk_Height(tkwin) - 2*scalePtr->inset, scalePtr->borderWidth, + TK_RELIEF_SUNKEN); + XFillRectangle(scalePtr->display, drawable, scalePtr->troughGC, + scalePtr->vertTroughX + scalePtr->borderWidth, + scalePtr->inset + scalePtr->borderWidth, + (unsigned) scalePtr->width, + (unsigned) (Tk_Height(tkwin) - 2*scalePtr->inset + - 2*scalePtr->borderWidth)); + if (scalePtr->state == tkActiveUid) { + sliderBorder = scalePtr->activeBorder; + } else { + sliderBorder = scalePtr->bgBorder; + } + width = scalePtr->width; + height = scalePtr->sliderLength/2; + x = scalePtr->vertTroughX + scalePtr->borderWidth; + y = ValueToPixel(scalePtr, scalePtr->value) - height; + shadowWidth = scalePtr->borderWidth/2; + if (shadowWidth == 0) { + shadowWidth = 1; + } + Tk_Draw3DRectangle(tkwin, drawable, sliderBorder, x, y, width, + 2*height, shadowWidth, scalePtr->sliderRelief); + x += shadowWidth; + y += shadowWidth; + width -= 2*shadowWidth; + height -= shadowWidth; + Tk_Fill3DRectangle(tkwin, drawable, sliderBorder, x, y, width, + height, shadowWidth, scalePtr->sliderRelief); + Tk_Fill3DRectangle(tkwin, drawable, sliderBorder, x, y+height, + width, height, shadowWidth, scalePtr->sliderRelief); + + /* + * Draw the label to the right of the scale. + */ + + if ((scalePtr->flags & REDRAW_OTHER) && (scalePtr->labelLength != 0)) { + XDrawString(scalePtr->display, drawable, + scalePtr->textGC, scalePtr->vertLabelX, + scalePtr->inset + (3*scalePtr->fontPtr->ascent)/2, + scalePtr->label, scalePtr->labelLength); + } +} + +/* + *---------------------------------------------------------------------- + * + * DisplayVerticalValue -- + * + * This procedure is called to display values (scale readings) + * for vertically-oriented scales. + * + * Results: + * None. + * + * Side effects: + * The numerical value corresponding to value is displayed with + * its right edge at "rightEdge", and at a vertical position in + * the scale that corresponds to "value". + * + *---------------------------------------------------------------------- + */ + +static void +DisplayVerticalValue(scalePtr, drawable, value, rightEdge) + register Scale *scalePtr; /* Information about widget in which to + * display value. */ + Drawable drawable; /* Pixmap or window in which to draw + * the value. */ + double value; /* Y-coordinate of number to display, + * specified in application coords, not + * in pixels (we'll compute pixels). */ + int rightEdge; /* X-coordinate of right edge of text, + * specified in pixels. */ +{ + register Tk_Window tkwin = scalePtr->tkwin; + int y, dummy, length; + char valueString[PRINT_CHARS]; + XCharStruct bbox; + + y = ValueToPixel(scalePtr, value) + scalePtr->fontPtr->ascent/2; + sprintf(valueString, scalePtr->format, value); + length = strlen(valueString); + XTextExtents(scalePtr->fontPtr, valueString, length, + &dummy, &dummy, &dummy, &bbox); + + /* + * Adjust the y-coordinate if necessary to keep the text entirely + * inside the window. + */ + + if ((y - bbox.ascent) < (scalePtr->inset + SPACING)) { + y = scalePtr->inset + SPACING + bbox.ascent; + } + if ((y + bbox.descent) > (Tk_Height(tkwin) - scalePtr->inset - SPACING)) { + y = Tk_Height(tkwin) - scalePtr->inset - SPACING - bbox.descent; + } + XDrawString(scalePtr->display, drawable, scalePtr->textGC, + rightEdge - bbox.rbearing, y, valueString, length); +} + +/* + *-------------------------------------------------------------- + * + * DisplayHorizontalScale -- + * + * This procedure redraws the contents of a horizontal scale + * window. It is invoked as a do-when-idle handler, so it only + * runs when there's nothing else for the application to do. + * + * Results: + * There is no return value. If only a part of the scale needs + * to be redrawn, then drawnAreaPtr is modified to reflect the + * area that was actually modified. + * + * Side effects: + * Information appears on the screen. + * + *-------------------------------------------------------------- + */ + +static void +DisplayHorizontalScale(scalePtr, drawable, drawnAreaPtr) + Scale *scalePtr; /* Widget record for scale. */ + Drawable drawable; /* Where to display scale (window + * or pixmap). */ + XRectangle *drawnAreaPtr; /* Initally contains area of window; + * if only a part of the scale is + * redrawn, gets modified to reflect + * the part of the window that was + * redrawn. */ +{ + register Tk_Window tkwin = scalePtr->tkwin; + int x, y, width, height, shadowWidth; + double tickValue; + Tk_3DBorder sliderBorder; + + /* + * Display the information from bottom to top across the window. + */ + + if (!(scalePtr->flags & REDRAW_OTHER)) { + drawnAreaPtr->x = scalePtr->inset; + drawnAreaPtr->y = scalePtr->horizValueY; + drawnAreaPtr->width -= 2*scalePtr->inset; + drawnAreaPtr->height = scalePtr->horizTroughY + scalePtr->width + + 2*scalePtr->borderWidth - scalePtr->horizValueY; + } + Tk_Fill3DRectangle(tkwin, drawable, scalePtr->bgBorder, + drawnAreaPtr->x, drawnAreaPtr->y, drawnAreaPtr->width, + drawnAreaPtr->height, 0, TK_RELIEF_FLAT); + if (scalePtr->flags & REDRAW_OTHER) { + /* + * Display the tick marks. + */ + + if (scalePtr->tickInterval != 0) { + for (tickValue = scalePtr->fromValue; ; + tickValue += scalePtr->tickInterval) { + /* + * The RoundToResolution call gets rid of accumulated + * round-off errors, if any. + */ + + tickValue = RoundToResolution(scalePtr, tickValue); + if (scalePtr->toValue >= scalePtr->fromValue) { + if (tickValue > scalePtr->toValue) { + break; + } + } else { + if (tickValue < scalePtr->toValue) { + break; + } + } + DisplayHorizontalValue(scalePtr, drawable, tickValue, + scalePtr->horizTickY); + } + } + } + + /* + * Display the value, if it is desired. + */ + + if (scalePtr->showValue) { + DisplayHorizontalValue(scalePtr, drawable, scalePtr->value, + scalePtr->horizValueY); + } + + /* + * Display the trough and the slider. + */ + + y = scalePtr->horizTroughY; + Tk_Draw3DRectangle(tkwin, drawable, + scalePtr->bgBorder, scalePtr->inset, y, + Tk_Width(tkwin) - 2*scalePtr->inset, + scalePtr->width + 2*scalePtr->borderWidth, + scalePtr->borderWidth, TK_RELIEF_SUNKEN); + XFillRectangle(scalePtr->display, drawable, scalePtr->troughGC, + scalePtr->inset + scalePtr->borderWidth, + y + scalePtr->borderWidth, + (unsigned) (Tk_Width(tkwin) - 2*scalePtr->inset + - 2*scalePtr->borderWidth), + (unsigned) scalePtr->width); + if (scalePtr->state == tkActiveUid) { + sliderBorder = scalePtr->activeBorder; + } else { + sliderBorder = scalePtr->bgBorder; + } + width = scalePtr->sliderLength/2; + height = scalePtr->width; + x = ValueToPixel(scalePtr, scalePtr->value) - width; + y += scalePtr->borderWidth; + shadowWidth = scalePtr->borderWidth/2; + if (shadowWidth == 0) { + shadowWidth = 1; + } + Tk_Draw3DRectangle(tkwin, drawable, sliderBorder, + x, y, 2*width, height, shadowWidth, scalePtr->sliderRelief); + x += shadowWidth; + y += shadowWidth; + width -= shadowWidth; + height -= 2*shadowWidth; + Tk_Fill3DRectangle(tkwin, drawable, sliderBorder, x, y, width, height, + shadowWidth, scalePtr->sliderRelief); + Tk_Fill3DRectangle(tkwin, drawable, sliderBorder, x+width, y, + width, height, shadowWidth, scalePtr->sliderRelief); + + /* + * Draw the label at the top of the scale. + */ + + if ((scalePtr->flags & REDRAW_OTHER) && (scalePtr->labelLength != 0)) { + XDrawString(scalePtr->display, drawable, + scalePtr->textGC, scalePtr->inset + scalePtr->fontPtr->ascent/2, + scalePtr->horizLabelY + scalePtr->fontPtr->ascent, + scalePtr->label, scalePtr->labelLength); + } +} + +/* + *---------------------------------------------------------------------- + * + * DisplayHorizontalValue -- + * + * This procedure is called to display values (scale readings) + * for horizontally-oriented scales. + * + * Results: + * None. + * + * Side effects: + * The numerical value corresponding to value is displayed with + * its bottom edge at "bottom", and at a horizontal position in + * the scale that corresponds to "value". + * + *---------------------------------------------------------------------- + */ + +static void +DisplayHorizontalValue(scalePtr, drawable, value, top) + register Scale *scalePtr; /* Information about widget in which to + * display value. */ + Drawable drawable; /* Pixmap or window in which to draw + * the value. */ + double value; /* X-coordinate of number to display, + * specified in application coords, not + * in pixels (we'll compute pixels). */ + int top; /* Y-coordinate of top edge of text, + * specified in pixels. */ +{ + register Tk_Window tkwin = scalePtr->tkwin; + int x, y, dummy, length; + char valueString[PRINT_CHARS]; + XCharStruct bbox; + + x = ValueToPixel(scalePtr, value); + y = top + scalePtr->fontPtr->ascent; + sprintf(valueString, scalePtr->format, value); + length = strlen(valueString); + XTextExtents(scalePtr->fontPtr, valueString, length, + &dummy, &dummy, &dummy, &bbox); + + /* + * Adjust the x-coordinate if necessary to keep the text entirely + * inside the window. + */ + + x -= (bbox.rbearing - bbox.lbearing)/2; + if ((x + bbox.lbearing) < (scalePtr->inset + SPACING)) { + x = scalePtr->inset + SPACING - bbox.lbearing; + } + if ((x + bbox.rbearing) > (Tk_Width(tkwin) - scalePtr->inset)) { + x = Tk_Width(tkwin) - scalePtr->inset - SPACING - bbox.rbearing; + } + XDrawString(scalePtr->display, drawable, scalePtr->textGC, x, y, + valueString, length); +} + +/* + *---------------------------------------------------------------------- + * + * DisplayScale -- + * + * This procedure is invoked as an idle handler to redisplay + * the contents of a scale widget. + * + * Results: + * None. + * + * Side effects: + * The scale gets redisplayed. + * + *---------------------------------------------------------------------- + */ + +static void +DisplayScale(clientData) + ClientData clientData; /* Widget record for scale. */ +{ + Scale *scalePtr = (Scale *) clientData; + Tk_Window tkwin = scalePtr->tkwin; + Tcl_Interp *interp = scalePtr->interp; + Pixmap pixmap; + int result; + char string[PRINT_CHARS]; + XRectangle drawnArea; + + if ((scalePtr->tkwin == NULL) || !Tk_IsMapped(scalePtr->tkwin)) { + goto done; + } + + /* + * Invoke the scale's command if needed. + */ + + Tcl_Preserve((ClientData) scalePtr); + Tcl_Preserve((ClientData) interp); + if ((scalePtr->flags & INVOKE_COMMAND) && (scalePtr->command != NULL)) { + sprintf(string, scalePtr->format, scalePtr->value); + result = Tcl_VarEval(interp, scalePtr->command, " ", string, + (char *) NULL); + if (result != TCL_OK) { + Tcl_AddErrorInfo(interp, "\n (command executed by scale)"); + Tcl_BackgroundError(interp); + } + } + Tcl_Release((ClientData) interp); + scalePtr->flags &= ~INVOKE_COMMAND; + if (scalePtr->tkwin == NULL) { + Tcl_Release((ClientData) scalePtr); + return; + } + Tcl_Release((ClientData) scalePtr); + + /* + * In order to avoid screen flashes, this procedure redraws + * the scale in a pixmap, then copies the pixmap to the + * screen in a single operation. This means that there's no + * point in time where the on-sreen image has been cleared. + */ + + pixmap = Tk_GetPixmap(scalePtr->display, Tk_WindowId(tkwin), + Tk_Width(tkwin), Tk_Height(tkwin), Tk_Depth(tkwin)); + drawnArea.x = 0; + drawnArea.y = 0; + drawnArea.width = Tk_Width(tkwin); + drawnArea.height = Tk_Height(tkwin); + + /* + * Much of the redisplay is done totally differently for + * horizontal and vertical scales. Handle the part that's + * different. + */ + + if (scalePtr->vertical) { + DisplayVerticalScale(scalePtr, pixmap, &drawnArea); + } else { + DisplayHorizontalScale(scalePtr, pixmap, &drawnArea); + } + + /* + * Now handle the part of redisplay that is the same for + * horizontal and vertical scales: border and traversal + * highlight. + */ + + if (scalePtr->flags & REDRAW_OTHER) { + if (scalePtr->relief != TK_RELIEF_FLAT) { + Tk_Draw3DRectangle(tkwin, pixmap, scalePtr->bgBorder, + scalePtr->highlightWidth, scalePtr->highlightWidth, + Tk_Width(tkwin) - 2*scalePtr->highlightWidth, + Tk_Height(tkwin) - 2*scalePtr->highlightWidth, + scalePtr->borderWidth, scalePtr->relief); + } + if (scalePtr->highlightWidth != 0) { + GC gc; + + if (scalePtr->flags & GOT_FOCUS) { + gc = Tk_GCForColor(scalePtr->highlightColorPtr, pixmap); + } else { + gc = Tk_GCForColor(scalePtr->highlightBgColorPtr, pixmap); + } + Tk_DrawFocusHighlight(tkwin, gc, scalePtr->highlightWidth, pixmap); + } + } + + /* + * Copy the information from the off-screen pixmap onto the screen, + * then delete the pixmap. + */ + + XCopyArea(scalePtr->display, pixmap, Tk_WindowId(tkwin), + scalePtr->copyGC, drawnArea.x, drawnArea.y, drawnArea.width, + drawnArea.height, drawnArea.x, drawnArea.y); + Tk_FreePixmap(scalePtr->display, pixmap); + + done: + scalePtr->flags &= ~REDRAW_ALL; +} + +/* + *---------------------------------------------------------------------- + * + * ScaleElement -- + * + * Determine which part of a scale widget lies under a given + * point. + * + * Results: + * The return value is either TROUGH1, SLIDER, TROUGH2, or + * OTHER, depending on which of the scale's active elements + * (if any) is under the point at (x,y). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ScaleElement(scalePtr, x, y) + Scale *scalePtr; /* Widget record for scale. */ + int x, y; /* Coordinates within scalePtr's window. */ +{ + int sliderFirst; + + if (scalePtr->vertical) { + if ((x < scalePtr->vertTroughX) + || (x >= (scalePtr->vertTroughX + 2*scalePtr->borderWidth + + scalePtr->width))) { + return OTHER; + } + if ((y < scalePtr->inset) + || (y >= (Tk_Height(scalePtr->tkwin) - scalePtr->inset))) { + return OTHER; + } + sliderFirst = ValueToPixel(scalePtr, scalePtr->value) + - scalePtr->sliderLength/2; + if (y < sliderFirst) { + return TROUGH1; + } + if (y < (sliderFirst+scalePtr->sliderLength)) { + return SLIDER; + } + return TROUGH2; + } + + if ((y < scalePtr->horizTroughY) + || (y >= (scalePtr->horizTroughY + 2*scalePtr->borderWidth + + scalePtr->width))) { + return OTHER; + } + if ((x < scalePtr->inset) + || (x >= (Tk_Width(scalePtr->tkwin) - scalePtr->inset))) { + return OTHER; + } + sliderFirst = ValueToPixel(scalePtr, scalePtr->value) + - scalePtr->sliderLength/2; + if (x < sliderFirst) { + return TROUGH1; + } + if (x < (sliderFirst+scalePtr->sliderLength)) { + return SLIDER; + } + return TROUGH2; +} + +/* + *---------------------------------------------------------------------- + * + * PixelToValue -- + * + * Given a pixel within a scale window, return the scale + * reading corresponding to that pixel. + * + * Results: + * A double-precision scale reading. If the value is outside + * the legal range for the scale then it's rounded to the nearest + * end of the scale. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static double +PixelToValue(scalePtr, x, y) + register Scale *scalePtr; /* Information about widget. */ + int x, y; /* Coordinates of point within + * window. */ +{ + double value, pixelRange; + + if (scalePtr->vertical) { + pixelRange = Tk_Height(scalePtr->tkwin) - scalePtr->sliderLength + - 2*scalePtr->inset - 2*scalePtr->borderWidth; + value = y; + } else { + pixelRange = Tk_Width(scalePtr->tkwin) - scalePtr->sliderLength + - 2*scalePtr->inset - 2*scalePtr->borderWidth; + value = x; + } + + if (pixelRange <= 0) { + /* + * Not enough room for the slider to actually slide: just return + * the scale's current value. + */ + + return scalePtr->value; + } + value -= scalePtr->sliderLength/2 + scalePtr->inset + + scalePtr->borderWidth; + value /= pixelRange; + if (value < 0) { + value = 0; + } + if (value > 1) { + value = 1; + } + value = scalePtr->fromValue + + value * (scalePtr->toValue - scalePtr->fromValue); + return RoundToResolution(scalePtr, value); +} + +/* + *---------------------------------------------------------------------- + * + * ValueToPixel -- + * + * Given a reading of the scale, return the x-coordinate or + * y-coordinate corresponding to that reading, depending on + * whether the scale is vertical or horizontal, respectively. + * + * Results: + * An integer value giving the pixel location corresponding + * to reading. The value is restricted to lie within the + * defined range for the scale. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ValueToPixel(scalePtr, value) + register Scale *scalePtr; /* Information about widget. */ + double value; /* Reading of the widget. */ +{ + int y, pixelRange; + double valueRange; + + valueRange = scalePtr->toValue - scalePtr->fromValue; + pixelRange = (scalePtr->vertical ? Tk_Height(scalePtr->tkwin) + : Tk_Width(scalePtr->tkwin)) - scalePtr->sliderLength + - 2*scalePtr->inset - 2*scalePtr->borderWidth; + if (valueRange == 0) { + y = 0; + } else { + y = (int) ((value - scalePtr->fromValue) * pixelRange + / valueRange + 0.5); + if (y < 0) { + y = 0; + } else if (y > pixelRange) { + y = pixelRange; + } + } + y += scalePtr->sliderLength/2 + scalePtr->inset + scalePtr->borderWidth; + return y; +} + +/* + *-------------------------------------------------------------- + * + * ScaleEventProc -- + * + * This procedure is invoked by the Tk dispatcher for various + * events on scales. + * + * Results: + * None. + * + * Side effects: + * When the window gets deleted, internal structures get + * cleaned up. When it gets exposed, it is redisplayed. + * + *-------------------------------------------------------------- + */ + +static void +ScaleEventProc(clientData, eventPtr) + ClientData clientData; /* Information about window. */ + XEvent *eventPtr; /* Information about event. */ +{ + Scale *scalePtr = (Scale *) clientData; + + if ((eventPtr->type == Expose) && (eventPtr->xexpose.count == 0)) { + EventuallyRedrawScale(scalePtr, REDRAW_ALL); + } else if (eventPtr->type == DestroyNotify) { + if (scalePtr->tkwin != NULL) { + scalePtr->tkwin = NULL; + Tcl_DeleteCommand(scalePtr->interp, + Tcl_GetCommandName(scalePtr->interp, scalePtr->widgetCmd)); + } + if (scalePtr->flags & REDRAW_ALL) { + Tcl_CancelIdleCall(DisplayScale, (ClientData) scalePtr); + } + Tcl_EventuallyFree((ClientData) scalePtr, DestroyScale); + } else if (eventPtr->type == ConfigureNotify) { + ComputeScaleGeometry(scalePtr); + EventuallyRedrawScale(scalePtr, REDRAW_ALL); + } else if (eventPtr->type == FocusIn) { + if (eventPtr->xfocus.detail != NotifyInferior) { + scalePtr->flags |= GOT_FOCUS; + if (scalePtr->highlightWidth > 0) { + EventuallyRedrawScale(scalePtr, REDRAW_ALL); + } + } + } else if (eventPtr->type == FocusOut) { + if (eventPtr->xfocus.detail != NotifyInferior) { + scalePtr->flags &= ~GOT_FOCUS; + if (scalePtr->highlightWidth > 0) { + EventuallyRedrawScale(scalePtr, REDRAW_ALL); + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * ScaleCmdDeletedProc -- + * + * This procedure is invoked when a widget command is deleted. If + * the widget isn't already in the process of being destroyed, + * this command destroys it. + * + * Results: + * None. + * + * Side effects: + * The widget is destroyed. + * + *---------------------------------------------------------------------- + */ + +static void +ScaleCmdDeletedProc(clientData) + ClientData clientData; /* Pointer to widget record for widget. */ +{ + Scale *scalePtr = (Scale *) clientData; + Tk_Window tkwin = scalePtr->tkwin; + + /* + * This procedure could be invoked either because the window was + * destroyed and the command was then deleted (in which case tkwin + * is NULL) or because the command was deleted, and then this procedure + * destroys the widget. + */ + + if (tkwin != NULL) { + scalePtr->tkwin = NULL; + Tk_DestroyWindow(tkwin); + } +} + +/* + *-------------------------------------------------------------- + * + * SetScaleValue -- + * + * This procedure changes the value of a scale and invokes + * a Tcl command to reflect the current position of a scale + * + * Results: + * None. + * + * Side effects: + * A Tcl command is invoked, and an additional error-processing + * command may also be invoked. The scale's slider is redrawn. + * + *-------------------------------------------------------------- + */ + +static void +SetScaleValue(scalePtr, value, setVar, invokeCommand) + register Scale *scalePtr; /* Info about widget. */ + double value; /* New value for scale. Gets adjusted + * if it's off the scale. */ + int setVar; /* Non-zero means reflect new value through + * to associated variable, if any. */ + int invokeCommand; /* Non-zero means invoked -command option + * to notify of new value, 0 means don't. */ +{ + char string[PRINT_CHARS]; + + value = RoundToResolution(scalePtr, value); + if ((value < scalePtr->fromValue) + ^ (scalePtr->toValue < scalePtr->fromValue)) { + value = scalePtr->fromValue; + } + if ((value > scalePtr->toValue) + ^ (scalePtr->toValue < scalePtr->fromValue)) { + value = scalePtr->toValue; + } + if (scalePtr->flags & NEVER_SET) { + scalePtr->flags &= ~NEVER_SET; + } else if (scalePtr->value == value) { + return; + } + scalePtr->value = value; + if (invokeCommand) { + scalePtr->flags |= INVOKE_COMMAND; + } + EventuallyRedrawScale(scalePtr, REDRAW_SLIDER); + + if (setVar && (scalePtr->varName != NULL)) { + sprintf(string, scalePtr->format, scalePtr->value); + scalePtr->flags |= SETTING_VAR; + Tcl_SetVar(scalePtr->interp, scalePtr->varName, string, + TCL_GLOBAL_ONLY); + scalePtr->flags &= ~SETTING_VAR; + } +} + +/* + *-------------------------------------------------------------- + * + * EventuallyRedrawScale -- + * + * Arrange for part or all of a scale widget to redrawn at + * the next convenient time in the future. + * + * Results: + * None. + * + * Side effects: + * If "what" is REDRAW_SLIDER then just the slider and the + * value readout will be redrawn; if "what" is REDRAW_ALL + * then the entire widget will be redrawn. + * + *-------------------------------------------------------------- + */ + +static void +EventuallyRedrawScale(scalePtr, what) + register Scale *scalePtr; /* Information about widget. */ + int what; /* What to redraw: REDRAW_SLIDER + * or REDRAW_ALL. */ +{ + if ((what == 0) || (scalePtr->tkwin == NULL) + || !Tk_IsMapped(scalePtr->tkwin)) { + return; + } + if ((scalePtr->flags & REDRAW_ALL) == 0) { + Tcl_DoWhenIdle(DisplayScale, (ClientData) scalePtr); + } + scalePtr->flags |= what; +} + +/* + *-------------------------------------------------------------- + * + * RoundToResolution -- + * + * Round a given floating-point value to the nearest multiple + * of the scale's resolution. + * + * Results: + * The return value is the rounded result. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static double +RoundToResolution(scalePtr, value) + Scale *scalePtr; /* Information about scale widget. */ + double value; /* Value to round. */ +{ + double rem, new; + + if (scalePtr->resolution <= 0) { + return value; + } + new = scalePtr->resolution * floor(value/scalePtr->resolution); + rem = value - new; + if (rem < 0) { + if (rem <= -scalePtr->resolution/2) { + new -= scalePtr->resolution; + } + } else { + if (rem >= scalePtr->resolution/2) { + new += scalePtr->resolution; + } + } + return new; +} + +/* + *---------------------------------------------------------------------- + * + * ScaleVarProc -- + * + * This procedure is invoked by Tcl whenever someone modifies a + * variable associated with a scale widget. + * + * Results: + * NULL is always returned. + * + * Side effects: + * The value displayed in the scale will change to match the + * variable's new value. If the variable has a bogus value then + * it is reset to the value of the scale. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static char * +ScaleVarProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Information about button. */ + 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 Scale *scalePtr = (Scale *) clientData; + char *stringValue, *end, *result; + double value; + + /* + * If the variable is unset, then immediately recreate it unless + * the whole interpreter is going away. + */ + + if (flags & TCL_TRACE_UNSETS) { + if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) { + Tcl_TraceVar(interp, scalePtr->varName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + ScaleVarProc, clientData); + scalePtr->flags |= NEVER_SET; + SetScaleValue(scalePtr, scalePtr->value, 1, 0); + } + return (char *) NULL; + } + + /* + * If we came here because we updated the variable (in SetScaleValue), + * then ignore the trace. Otherwise update the scale with the value + * of the variable. + */ + + if (scalePtr->flags & SETTING_VAR) { + return (char *) NULL; + } + result = NULL; + stringValue = Tcl_GetVar(interp, scalePtr->varName, TCL_GLOBAL_ONLY); + if (stringValue != NULL) { + value = strtod(stringValue, &end); + if ((end == stringValue) || (*end != 0)) { + result = "can't assign non-numeric value to scale variable"; + } else { + scalePtr->value = RoundToResolution(scalePtr, value); + } + + /* + * This code is a bit tricky because it sets the scale's value before + * calling SetScaleValue. This way, SetScaleValue won't bother to + * set the variable again or to invoke the -command. However, it + * also won't redisplay the scale, so we have to ask for that + * explicitly. + */ + + SetScaleValue(scalePtr, scalePtr->value, 1, 0); + EventuallyRedrawScale(scalePtr, REDRAW_SLIDER); + } + + return result; +} diff --git a/tk3.6/tkScrollbar.c b/tk4.2/generic/tkScrollbar.c similarity index 52% rename from tk3.6/tkScrollbar.c rename to tk4.2/generic/tkScrollbar.c index f58a9af..0b04a62 100644 --- a/tk3.6/tkScrollbar.c +++ b/tk4.2/generic/tkScrollbar.c @@ -6,32 +6,16 @@ * mouse clicks on features within the scrollbar cause * scrolling commands to be invoked. * - * Copyright (c) 1990-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tkScrollbar.c 1.79 96/02/15 18:52:40 */ -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkScrollbar.c,v 1.45 93/10/27 17:13:08 ouster Exp $ SPRITE (Berkeley)"; -#endif - -#include "tkConfig.h" +#include "tkPort.h" #include "default.h" #include "tkInt.h" @@ -49,6 +33,7 @@ typedef struct { * other things, so that resources can be * freed even after tkwin has gone away. */ Tcl_Interp *interp; /* Interpreter associated with scrollbar. */ + Tcl_Command widgetCmd; /* Token for scrollbar's widget command. */ Tk_Uid orientUid; /* Orientation for window ("vertical" or * "horizontal"). */ int vertical; /* Non-zero means vertical orientation @@ -62,81 +47,106 @@ typedef struct { int repeatDelay; /* How long to wait before auto-repeating * on scrolling actions (in ms). */ int repeatInterval; /* Interval between autorepeats (in ms). */ + int jump; /* Value of -jump option. */ /* * Information used when displaying widget: */ int borderWidth; /* Width of 3-D borders. */ - Tk_3DBorder bgBorder; /* Used for drawing background. */ - Tk_3DBorder fgBorder; /* For drawing foreground shapes. */ - Tk_3DBorder activeBorder; /* For drawing foreground shapes when - * active (i.e. when mouse is positioned - * over element). NULL means use fgBorder. */ + Tk_3DBorder bgBorder; /* Used for drawing background (all flat + * surfaces except for trough). */ + Tk_3DBorder activeBorder; /* For drawing backgrounds when active (i.e. + * when mouse is positioned over element). */ + XColor *troughColorPtr; /* Color for drawing trough. */ + GC troughGC; /* For drawing trough. */ GC copyGC; /* Used for copying from pixmap onto screen. */ int relief; /* Indicates whether window as a whole is * raised, sunken, or flat. */ - int offset; /* Zero if relief is TK_RELIEF_FLAT, - * borderWidth otherwise. Indicates how - * much interior stuff must be offset from - * outside edges to leave room for border. */ + int highlightWidth; /* Width in pixels of highlight to draw + * around widget when it has the focus. + * <= 0 means don't draw a highlight. */ + XColor *highlightBgColorPtr; + /* Color for drawing traversal highlight + * area when highlight is off. */ + XColor *highlightColorPtr; /* Color for drawing traversal highlight. */ + int inset; /* Total width of all borders, including + * traversal highlight and 3-D border. + * Indicates how much interior stuff must + * be offset from outside edges to leave + * room for borders. */ + int elementBorderWidth; /* Width of border to draw around elements + * inside scrollbar (arrows and slider). + * -1 means use borderWidth. */ int arrowLength; /* Length of arrows along long dimension of - * scrollbar. Recomputed on window size - * changes. */ + * scrollbar, including space for a small gap + * between the arrow and the slider. + * Recomputed on window size changes. */ int sliderFirst; /* Pixel coordinate of top or left edge * of slider area, including border. */ int sliderLast; /* Coordinate of pixel just after bottom * or right edge of slider area, including * border. */ - int mouseField; /* Indicates which scrollbar element is - * under mouse (e.g. TOP_ARROW; see below - * for possible values). */ - int pressField; /* Field in which button was pressed, or -1 - * if no button is down. */ - int pressPos; /* Position of mouse when button was - * pressed (y for vertical scrollbar, x - * for horizontal). */ - int pressFirstUnit; /* Value of "firstUnit" when mouse button - * was pressed. */ + int activeField; /* Names field to be displayed in active + * colors, such as TOP_ARROW, or 0 for + * no field. */ + int activeRelief; /* Value of -activeRelief option: relief + * to use for active element. */ /* * Information describing the application related to the scrollbar. * This information is provided by the application by invoking the - * "set" widget command. + * "set" widget command. This information can now be provided in + * two ways: the "old" form (totalUnits, windowUnits, firstUnit, + * and lastUnit), or the "new" form (firstFraction and lastFraction). + * FirstFraction and lastFraction will always be valid, but + * the old-style information is only valid if the NEW_STYLE_COMMANDS + * flag is 0. */ int totalUnits; /* Total dimension of application, in - * units. */ - int windowUnits; /* Maximum number of units that can - * be displayed in the window at - * once. */ + * units. Valid only if the NEW_STYLE_COMMANDS + * flag isn't set. */ + int windowUnits; /* Maximum number of units that can be + * displayed in the window at once. Valid + * only if the NEW_STYLE_COMMANDS flag isn't + * set. */ int firstUnit; /* Number of last unit visible in - * application's window. */ - int lastUnit; /* Index of last unit visible in window. */ + * application's window. Valid only if the + * NEW_STYLE_COMMANDS flag isn't set. */ + int lastUnit; /* Index of last unit visible in window. + * Valid only if the NEW_STYLE_COMMANDS + * flag isn't set. */ + double firstFraction; /* Position of first visible thing in window, + * specified as a fraction between 0 and + * 1.0. */ + double lastFraction; /* Position of last visible thing in window, + * specified as a fraction between 0 and + * 1.0. */ /* * Miscellaneous information: */ - Cursor cursor; /* Current cursor for window, or None. */ - Tk_TimerToken autoRepeat; /* Token for auto-repeat that's - * currently in progress. NULL means no - * auto-repeat in progress. */ + Tk_Cursor cursor; /* Current cursor for window, or None. */ + char *takeFocus; /* Value of -takefocus option; not used in + * the C code, but used by keyboard traversal + * scripts. Malloc'ed, but may be NULL. */ int flags; /* Various flags; see below for * definitions. */ } Scrollbar; /* - * Legal values for "mouseField" field of Scrollbar structures. These + * Legal values for "activeField" field of Scrollbar structures. These * are also the return values from the ScrollbarPosition procedure. */ +#define OUTSIDE 0 #define TOP_ARROW 1 #define TOP_GAP 2 #define SLIDER 3 #define BOTTOM_GAP 4 #define BOTTOM_ARROW 5 -#define OUTSIDE 6 /* * Flag bits for scrollbars: @@ -144,9 +154,17 @@ typedef struct { * REDRAW_PENDING: Non-zero means a DoWhenIdle handler * has already been queued to redraw * this window. + * NEW_STYLE_COMMANDS: Non-zero means the new style of commands + * should be used to communicate with the + * widget: ".t yview scroll 2 lines", instead + * of ".t yview 40", for example. + * GOT_FOCUS: Non-zero means this window has the input + * focus. */ #define REDRAW_PENDING 1 +#define NEW_STYLE_COMMANDS 2 +#define GOT_FOCUS 4 /* * Minimum slider length, in pixels (designed to make sure that the slider @@ -160,12 +178,14 @@ typedef struct { */ static Tk_ConfigSpec configSpecs[] = { - {TK_CONFIG_BORDER, "-activeforeground", "activeForeground", "Background", - DEF_SCROLLBAR_ACTIVE_FG_COLOR, Tk_Offset(Scrollbar, activeBorder), + {TK_CONFIG_BORDER, "-activebackground", "activeBackground", "Foreground", + DEF_SCROLLBAR_ACTIVE_BG_COLOR, Tk_Offset(Scrollbar, activeBorder), TK_CONFIG_COLOR_ONLY}, - {TK_CONFIG_BORDER, "-activeforeground", "activeForeground", "Background", - DEF_SCROLLBAR_ACTIVE_FG_MONO, Tk_Offset(Scrollbar, activeBorder), + {TK_CONFIG_BORDER, "-activebackground", "activeBackground", "Foreground", + DEF_SCROLLBAR_ACTIVE_BG_MONO, Tk_Offset(Scrollbar, activeBorder), TK_CONFIG_MONO_ONLY}, + {TK_CONFIG_RELIEF, "-activerelief", "activeRelief", "Relief", + DEF_SCROLLBAR_ACTIVE_RELIEF, Tk_Offset(Scrollbar, activeRelief), 0}, {TK_CONFIG_BORDER, "-background", "background", "Background", DEF_SCROLLBAR_BG_COLOR, Tk_Offset(Scrollbar, bgBorder), TK_CONFIG_COLOR_ONLY}, @@ -183,14 +203,20 @@ static Tk_ConfigSpec configSpecs[] = { TK_CONFIG_NULL_OK}, {TK_CONFIG_ACTIVE_CURSOR, "-cursor", "cursor", "Cursor", DEF_SCROLLBAR_CURSOR, Tk_Offset(Scrollbar, cursor), TK_CONFIG_NULL_OK}, - {TK_CONFIG_SYNONYM, "-fg", "foreground", (char *) NULL, - (char *) NULL, 0, 0}, - {TK_CONFIG_BORDER, "-foreground", "foreground", "Foreground", - DEF_SCROLLBAR_FG_COLOR, Tk_Offset(Scrollbar, fgBorder), - TK_CONFIG_COLOR_ONLY}, - {TK_CONFIG_BORDER, "-foreground", "foreground", "Foreground", - DEF_SCROLLBAR_FG_MONO, Tk_Offset(Scrollbar, fgBorder), - TK_CONFIG_MONO_ONLY}, + {TK_CONFIG_PIXELS, "-elementborderwidth", "elementBorderWidth", + "BorderWidth", DEF_SCROLLBAR_EL_BORDER_WIDTH, + Tk_Offset(Scrollbar, elementBorderWidth), 0}, + {TK_CONFIG_COLOR, "-highlightbackground", "highlightBackground", + "HighlightBackground", DEF_SCROLLBAR_HIGHLIGHT_BG, + Tk_Offset(Scrollbar, highlightBgColorPtr), 0}, + {TK_CONFIG_COLOR, "-highlightcolor", "highlightColor", "HighlightColor", + DEF_SCROLLBAR_HIGHLIGHT, + Tk_Offset(Scrollbar, highlightColorPtr), 0}, + {TK_CONFIG_PIXELS, "-highlightthickness", "highlightThickness", + "HighlightThickness", + DEF_SCROLLBAR_HIGHLIGHT_WIDTH, Tk_Offset(Scrollbar, highlightWidth), 0}, + {TK_CONFIG_BOOLEAN, "-jump", "jump", "Jump", + DEF_SCROLLBAR_JUMP, Tk_Offset(Scrollbar, jump), 0}, {TK_CONFIG_UID, "-orient", "orient", "Orient", DEF_SCROLLBAR_ORIENT, Tk_Offset(Scrollbar, orientUid), 0}, {TK_CONFIG_RELIEF, "-relief", "relief", "Relief", @@ -199,6 +225,15 @@ static Tk_ConfigSpec configSpecs[] = { DEF_SCROLLBAR_REPEAT_DELAY, Tk_Offset(Scrollbar, repeatDelay), 0}, {TK_CONFIG_INT, "-repeatinterval", "repeatInterval", "RepeatInterval", DEF_SCROLLBAR_REPEAT_INTERVAL, Tk_Offset(Scrollbar, repeatInterval), 0}, + {TK_CONFIG_STRING, "-takefocus", "takeFocus", "TakeFocus", + DEF_SCROLLBAR_TAKE_FOCUS, Tk_Offset(Scrollbar, takeFocus), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_COLOR, "-troughcolor", "troughColor", "Background", + DEF_SCROLLBAR_TROUGH_COLOR, Tk_Offset(Scrollbar, troughColorPtr), + TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_COLOR, "-troughcolor", "troughColor", "Background", + DEF_SCROLLBAR_TROUGH_MONO, Tk_Offset(Scrollbar, troughColorPtr), + TK_CONFIG_MONO_ONLY}, {TK_CONFIG_PIXELS, "-width", "width", "Width", DEF_SCROLLBAR_WIDTH, Tk_Offset(Scrollbar, width), 0}, {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, @@ -214,23 +249,17 @@ static void ComputeScrollbarGeometry _ANSI_ARGS_(( static int ConfigureScrollbar _ANSI_ARGS_((Tcl_Interp *interp, Scrollbar *scrollPtr, int argc, char **argv, int flags)); -static void DestroyScrollbar _ANSI_ARGS_((ClientData clientData)); +static void DestroyScrollbar _ANSI_ARGS_((char *memPtr)); static void DisplayScrollbar _ANSI_ARGS_((ClientData clientData)); static void EventuallyRedraw _ANSI_ARGS_((Scrollbar *scrollPtr)); +static void ScrollbarCmdDeletedProc _ANSI_ARGS_(( + ClientData clientData)); static void ScrollbarEventProc _ANSI_ARGS_((ClientData clientData, XEvent *eventPtr)); -static void ScrollbarMouseProc _ANSI_ARGS_((ClientData clientData, - XEvent *eventPtr)); -static void ScrollbarNewField _ANSI_ARGS_((Scrollbar *scrollPtr, - int field)); static int ScrollbarPosition _ANSI_ARGS_((Scrollbar *scrollPtr, int x, int y)); -static void ScrollbarTimerProc _ANSI_ARGS_(( - ClientData clientData)); static int ScrollbarWidgetCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *, int argc, char **argv)); -static void ScrollCmd _ANSI_ARGS_((Scrollbar *scrollPtr, - int unit)); /* *-------------------------------------------------------------- @@ -263,7 +292,7 @@ Tk_ScrollbarCmd(clientData, interp, argc, argv) Tk_Window new; if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " pathName ?options?\"", (char *) NULL); return TCL_ERROR; } @@ -283,6 +312,9 @@ Tk_ScrollbarCmd(clientData, interp, argc, argv) scrollPtr->tkwin = new; scrollPtr->display = Tk_Display(new); scrollPtr->interp = interp; + scrollPtr->widgetCmd = Tcl_CreateCommand(interp, + Tk_PathName(scrollPtr->tkwin), ScrollbarWidgetCmd, + (ClientData) scrollPtr, ScrollbarCmdDeletedProc); scrollPtr->orientUid = NULL; scrollPtr->vertical = 0; scrollPtr->width = 0; @@ -292,34 +324,35 @@ Tk_ScrollbarCmd(clientData, interp, argc, argv) scrollPtr->repeatInterval = 0; scrollPtr->borderWidth = 0; scrollPtr->bgBorder = NULL; - scrollPtr->fgBorder = NULL; scrollPtr->activeBorder = NULL; + scrollPtr->troughColorPtr = NULL; + scrollPtr->troughGC = None; scrollPtr->copyGC = None; scrollPtr->relief = TK_RELIEF_FLAT; - scrollPtr->offset = 0; + scrollPtr->highlightWidth = 0; + scrollPtr->highlightBgColorPtr = NULL; + scrollPtr->highlightColorPtr = NULL; + scrollPtr->inset = 0; + scrollPtr->elementBorderWidth = -1; scrollPtr->arrowLength = 0; scrollPtr->sliderFirst = 0; scrollPtr->sliderLast = 0; - scrollPtr->mouseField = OUTSIDE; - scrollPtr->pressField = -1; - scrollPtr->pressPos = 0; - scrollPtr->pressFirstUnit = 0; + scrollPtr->activeField = 0; + scrollPtr->activeRelief = TK_RELIEF_RAISED; scrollPtr->totalUnits = 0; scrollPtr->windowUnits = 0; scrollPtr->firstUnit = 0; scrollPtr->lastUnit = 0; + scrollPtr->firstFraction = 0.0; + scrollPtr->lastFraction = 0.0; scrollPtr->cursor = None; - scrollPtr->autoRepeat = NULL; + scrollPtr->takeFocus = NULL; scrollPtr->flags = 0; Tk_SetClass(scrollPtr->tkwin, "Scrollbar"); - Tk_CreateEventHandler(scrollPtr->tkwin, ExposureMask|StructureNotifyMask, + Tk_CreateEventHandler(scrollPtr->tkwin, + ExposureMask|StructureNotifyMask|FocusChangeMask, ScrollbarEventProc, (ClientData) scrollPtr); - Tk_CreateEventHandler(scrollPtr->tkwin, EnterWindowMask|LeaveWindowMask - |PointerMotionMask|ButtonPressMask|ButtonReleaseMask, - ScrollbarMouseProc, (ClientData) scrollPtr); - Tcl_CreateCommand(interp, Tk_PathName(scrollPtr->tkwin), ScrollbarWidgetCmd, - (ClientData) scrollPtr, (void (*)()) NULL); if (ConfigureScrollbar(interp, scrollPtr, argc-2, argv+2, 0) != TCL_OK) { goto error; } @@ -360,18 +393,55 @@ ScrollbarWidgetCmd(clientData, interp, argc, argv) { register Scrollbar *scrollPtr = (Scrollbar *) clientData; int result = TCL_OK; - int length; - char c; + size_t length; + int c; if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " option ?arg arg ...?\"", (char *) NULL); return TCL_ERROR; } - Tk_Preserve((ClientData) scrollPtr); + Tcl_Preserve((ClientData) scrollPtr); c = argv[1][0]; length = strlen(argv[1]); - if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0)) { + if ((c == 'a') && (strncmp(argv[1], "activate", length) == 0)) { + if (argc == 2) { + switch (scrollPtr->activeField) { + case TOP_ARROW: interp->result = "arrow1"; break; + case SLIDER: interp->result = "slider"; break; + case BOTTOM_ARROW: interp->result = "arrow2"; break; + } + goto done; + } + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " activate element\"", (char *) NULL); + goto error; + } + c = argv[2][0]; + length = strlen(argv[2]); + if ((c == 'a') && (strcmp(argv[2], "arrow1") == 0)) { + scrollPtr->activeField = TOP_ARROW; + } else if ((c == 'a') && (strcmp(argv[2], "arrow2") == 0)) { + scrollPtr->activeField = BOTTOM_ARROW; + } else if ((c == 's') && (strncmp(argv[2], "slider", length) == 0)) { + scrollPtr->activeField = SLIDER; + } else { + scrollPtr->activeField = OUTSIDE; + } + EventuallyRedraw(scrollPtr); + } else if ((c == 'c') && (strncmp(argv[1], "cget", length) == 0) + && (length >= 2)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " cget option\"", + (char *) NULL); + goto error; + } + result = Tk_ConfigureValue(interp, scrollPtr->tkwin, configSpecs, + (char *) scrollPtr, argv[2], 0); + } else if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0) + && (length >= 2)) { if (argc == 2) { result = Tk_ConfigureInfo(interp, scrollPtr->tkwin, configSpecs, (char *) scrollPtr, (char *) NULL, 0); @@ -382,69 +452,191 @@ ScrollbarWidgetCmd(clientData, interp, argc, argv) result = ConfigureScrollbar(interp, scrollPtr, argc-2, argv+2, TK_CONFIG_ARGV_ONLY); } + } else if ((c == 'd') && (strncmp(argv[1], "delta", length) == 0)) { + int xDelta, yDelta, pixels, length; + double fraction; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " delta xDelta yDelta\"", (char *) NULL); + goto error; + } + if ((Tcl_GetInt(interp, argv[2], &xDelta) != TCL_OK) + || (Tcl_GetInt(interp, argv[3], &yDelta) != TCL_OK)) { + goto error; + } + if (scrollPtr->vertical) { + pixels = yDelta; + length = Tk_Height(scrollPtr->tkwin) - 1 + - 2*(scrollPtr->arrowLength + scrollPtr->inset); + } else { + pixels = xDelta; + length = Tk_Width(scrollPtr->tkwin) - 1 + - 2*(scrollPtr->arrowLength + scrollPtr->inset); + } + if (length == 0) { + fraction = 0.0; + } else { + fraction = ((double) pixels / (double) length); + } + sprintf(interp->result, "%g", fraction); + } else if ((c == 'f') && (strncmp(argv[1], "fraction", length) == 0)) { + int x, y, pos, length; + double fraction; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " fraction x y\"", (char *) NULL); + goto error; + } + if ((Tcl_GetInt(interp, argv[2], &x) != TCL_OK) + || (Tcl_GetInt(interp, argv[3], &y) != TCL_OK)) { + goto error; + } + if (scrollPtr->vertical) { + pos = y - (scrollPtr->arrowLength + scrollPtr->inset); + length = Tk_Height(scrollPtr->tkwin) - 1 + - 2*(scrollPtr->arrowLength + scrollPtr->inset); + } else { + pos = x - (scrollPtr->arrowLength + scrollPtr->inset); + length = Tk_Width(scrollPtr->tkwin) - 1 + - 2*(scrollPtr->arrowLength + scrollPtr->inset); + } + if (length == 0) { + fraction = 0.0; + } else { + fraction = ((double) pos / (double) length); + } + if (fraction < 0) { + fraction = 0; + } else if (fraction > 1.0) { + fraction = 1.0; + } + sprintf(interp->result, "%g", fraction); } else if ((c == 'g') && (strncmp(argv[1], "get", length) == 0)) { if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " get\"", (char *) NULL); goto error; } - sprintf(interp->result, "%d %d %d %d", scrollPtr->totalUnits, - scrollPtr->windowUnits, scrollPtr->firstUnit, - scrollPtr->lastUnit); + if (scrollPtr->flags & NEW_STYLE_COMMANDS) { + char first[TCL_DOUBLE_SPACE], last[TCL_DOUBLE_SPACE]; + + Tcl_PrintDouble(interp, scrollPtr->firstFraction, first); + Tcl_PrintDouble(interp, scrollPtr->lastFraction, last); + Tcl_AppendResult(interp, first, " ", last, (char *) NULL); + } else { + sprintf(interp->result, "%d %d %d %d", scrollPtr->totalUnits, + scrollPtr->windowUnits, scrollPtr->firstUnit, + scrollPtr->lastUnit); + } + } else if ((c == 'i') && (strncmp(argv[1], "identify", length) == 0)) { + int x, y, thing; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " identify x y\"", (char *) NULL); + goto error; + } + if ((Tcl_GetInt(interp, argv[2], &x) != TCL_OK) + || (Tcl_GetInt(interp, argv[3], &y) != TCL_OK)) { + goto error; + } + thing = ScrollbarPosition(scrollPtr, x,y); + switch (thing) { + case TOP_ARROW: interp->result = "arrow1"; break; + case TOP_GAP: interp->result = "trough1"; break; + case SLIDER: interp->result = "slider"; break; + case BOTTOM_GAP: interp->result = "trough2"; break; + case BOTTOM_ARROW: interp->result = "arrow2"; break; + } } else if ((c == 's') && (strncmp(argv[1], "set", length) == 0)) { int totalUnits, windowUnits, firstUnit, lastUnit; - if (argc != 6) { + if (argc == 4) { + double first, last; + + if (Tcl_GetDouble(interp, argv[2], &first) != TCL_OK) { + goto error; + } + if (Tcl_GetDouble(interp, argv[3], &last) != TCL_OK) { + goto error; + } + if (first < 0) { + scrollPtr->firstFraction = 0; + } else if (first > 1.0) { + scrollPtr->firstFraction = 1.0; + } else { + scrollPtr->firstFraction = first; + } + if (last < scrollPtr->firstFraction) { + scrollPtr->lastFraction = scrollPtr->firstFraction; + } else if (last > 1.0) { + scrollPtr->lastFraction = 1.0; + } else { + scrollPtr->lastFraction = last; + } + scrollPtr->flags |= NEW_STYLE_COMMANDS; + } else if (argc == 6) { + if (Tcl_GetInt(interp, argv[2], &totalUnits) != TCL_OK) { + goto error; + } + if (totalUnits < 0) { + totalUnits = 0; + } + if (Tcl_GetInt(interp, argv[3], &windowUnits) != TCL_OK) { + goto error; + } + if (windowUnits < 0) { + windowUnits = 0; + } + if (Tcl_GetInt(interp, argv[4], &firstUnit) != TCL_OK) { + goto error; + } + if (Tcl_GetInt(interp, argv[5], &lastUnit) != TCL_OK) { + goto error; + } + if (totalUnits > 0) { + if (lastUnit < firstUnit) { + lastUnit = firstUnit; + } + } else { + firstUnit = lastUnit = 0; + } + scrollPtr->totalUnits = totalUnits; + scrollPtr->windowUnits = windowUnits; + scrollPtr->firstUnit = firstUnit; + scrollPtr->lastUnit = lastUnit; + if (scrollPtr->totalUnits == 0) { + scrollPtr->firstFraction = 0.0; + scrollPtr->lastFraction = 1.0; + } else { + scrollPtr->firstFraction = ((double) firstUnit)/totalUnits; + scrollPtr->lastFraction = ((double) (lastUnit+1))/totalUnits; + } + scrollPtr->flags &= ~NEW_STYLE_COMMANDS; + } else { Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " set firstFraction lastFraction\" or \"", argv[0], " set totalUnits windowUnits firstUnit lastUnit\"", (char *) NULL); goto error; } - if (Tcl_GetInt(interp, argv[2], &totalUnits) != TCL_OK) { - goto error; - } - if (totalUnits < 0) { - sprintf(interp->result, "illegal totalUnits %d", totalUnits); - goto error; - } - if (Tcl_GetInt(interp, argv[3], &windowUnits) != TCL_OK) { - goto error; - } - if (windowUnits < 0) { - sprintf(interp->result, "illegal windowUnits %d", windowUnits); - goto error; - } - if (Tcl_GetInt(interp, argv[4], &firstUnit) != TCL_OK) { - goto error; - } - if (Tcl_GetInt(interp, argv[5], &lastUnit) != TCL_OK) { - goto error; - } - if (totalUnits > 0) { - if (lastUnit < firstUnit) { - sprintf(interp->result, "illegal lastUnit %d", lastUnit); - goto error; - } - } else { - firstUnit = lastUnit = 0; - } - scrollPtr->totalUnits = totalUnits; - scrollPtr->windowUnits = windowUnits; - scrollPtr->firstUnit = firstUnit; - scrollPtr->lastUnit = lastUnit; ComputeScrollbarGeometry(scrollPtr); EventuallyRedraw(scrollPtr); } else { Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be configure, get, or set", (char *) NULL); + "\": must be activate, cget, configure, delta, fraction, ", + "get, identify, or set", (char *) NULL); goto error; } - Tk_Release((ClientData) scrollPtr); + done: + Tcl_Release((ClientData) scrollPtr); return result; error: - Tk_Release((ClientData) scrollPtr); + Tcl_Release((ClientData) scrollPtr); return TCL_ERROR; } @@ -453,7 +645,7 @@ ScrollbarWidgetCmd(clientData, interp, argc, argv) * * DestroyScrollbar -- * - * This procedure is invoked by Tk_EventuallyFree or Tk_Release + * This procedure is invoked by Tcl_EventuallyFree or Tcl_Release * to clean up the internal structure of a scrollbar at a safe time * (when no-one is using it anymore). * @@ -467,10 +659,10 @@ ScrollbarWidgetCmd(clientData, interp, argc, argv) */ static void -DestroyScrollbar(clientData) - ClientData clientData; /* Info about scrollbar widget. */ +DestroyScrollbar(memPtr) + char *memPtr; /* Info about scrollbar widget. */ { - register Scrollbar *scrollPtr = (Scrollbar *) clientData; + register Scrollbar *scrollPtr = (Scrollbar *) memPtr; /* * Free up all the stuff that requires special handling, then @@ -478,6 +670,9 @@ DestroyScrollbar(clientData) * stuff. */ + if (scrollPtr->troughGC != None) { + Tk_FreeGC(scrollPtr->display, scrollPtr->troughGC); + } if (scrollPtr->copyGC != None) { Tk_FreeGC(scrollPtr->display, scrollPtr->copyGC); } @@ -517,8 +712,9 @@ ConfigureScrollbar(interp, scrollPtr, argc, argv, flags) int flags; /* Flags to pass to * Tk_ConfigureWidget. */ { - int length; + size_t length; XGCValues gcValues; + GC new; if (Tk_ConfigureWidget(interp, scrollPtr->tkwin, configSpecs, argc, argv, (char *) scrollPtr, flags) != TCL_OK) { @@ -549,6 +745,12 @@ ConfigureScrollbar(interp, scrollPtr, argc, argv, flags) Tk_SetBackgroundFromBorder(scrollPtr->tkwin, scrollPtr->bgBorder); + gcValues.foreground = scrollPtr->troughColorPtr->pixel; + new = Tk_GetGC(scrollPtr->tkwin, GCForeground, &gcValues); + if (scrollPtr->troughGC != None) { + Tk_FreeGC(scrollPtr->display, scrollPtr->troughGC); + } + scrollPtr->troughGC = new; if (scrollPtr->copyGC == None) { gcValues.graphics_exposures = False; scrollPtr->copyGC = Tk_GetGC(scrollPtr->tkwin, GCGraphicsExposures, @@ -593,7 +795,7 @@ DisplayScrollbar(clientData) register Tk_Window tkwin = scrollPtr->tkwin; XPoint points[7]; Tk_3DBorder border; - int relief, width; + int relief, width, elementBorderWidth; Pixmap pixmap; if ((scrollPtr->tkwin == NULL) || !Tk_IsMapped(tkwin)) { @@ -601,9 +803,13 @@ DisplayScrollbar(clientData) } if (scrollPtr->vertical) { - width = Tk_Width(tkwin) - 2*scrollPtr->offset; + width = Tk_Width(tkwin) - 2*scrollPtr->inset; } else { - width = Tk_Height(tkwin) - 2*scrollPtr->offset; + width = Tk_Height(tkwin) - 2*scrollPtr->inset; + } + elementBorderWidth = scrollPtr->elementBorderWidth; + if (elementBorderWidth < 0) { + elementBorderWidth = scrollPtr->borderWidth; } /* @@ -613,12 +819,28 @@ DisplayScrollbar(clientData) * point in time where the on-sreen image has been cleared. */ - pixmap = XCreatePixmap(scrollPtr->display, Tk_WindowId(tkwin), + pixmap = Tk_GetPixmap(scrollPtr->display, Tk_WindowId(tkwin), Tk_Width(tkwin), Tk_Height(tkwin), Tk_Depth(tkwin)); - - Tk_Fill3DRectangle(scrollPtr->display, pixmap, scrollPtr->bgBorder, - 0, 0, Tk_Width(tkwin), Tk_Height(tkwin), + + if (scrollPtr->highlightWidth != 0) { + GC gc; + + if (scrollPtr->flags & GOT_FOCUS) { + gc = Tk_GCForColor(scrollPtr->highlightColorPtr, pixmap); + } else { + gc = Tk_GCForColor(scrollPtr->highlightBgColorPtr, pixmap); + } + Tk_DrawFocusHighlight(tkwin, gc, scrollPtr->highlightWidth, pixmap); + } + Tk_Draw3DRectangle(tkwin, pixmap, scrollPtr->bgBorder, + scrollPtr->highlightWidth, scrollPtr->highlightWidth, + Tk_Width(tkwin) - 2*scrollPtr->highlightWidth, + Tk_Height(tkwin) - 2*scrollPtr->highlightWidth, scrollPtr->borderWidth, scrollPtr->relief); + XFillRectangle(scrollPtr->display, pixmap, scrollPtr->troughGC, + scrollPtr->inset, scrollPtr->inset, + (unsigned) (Tk_Width(tkwin) - 2*scrollPtr->inset), + (unsigned) (Tk_Height(tkwin) - 2*scrollPtr->inset)); /* * Draw the top or left arrow. The coordinates of the polygon @@ -628,90 +850,90 @@ DisplayScrollbar(clientData) * scrollbar and be properly centered. */ - if (scrollPtr->mouseField == TOP_ARROW) { + if (scrollPtr->activeField == TOP_ARROW) { border = scrollPtr->activeBorder; - relief = scrollPtr->pressField == TOP_ARROW ? TK_RELIEF_SUNKEN + relief = scrollPtr->activeField == TOP_ARROW ? scrollPtr->activeRelief : TK_RELIEF_RAISED; } else { - border = scrollPtr->fgBorder; + border = scrollPtr->bgBorder; relief = TK_RELIEF_RAISED; } if (scrollPtr->vertical) { - points[0].x = scrollPtr->offset - 1; - points[0].y = scrollPtr->arrowLength + scrollPtr->offset; - points[1].x = width + scrollPtr->offset; + points[0].x = scrollPtr->inset - 1; + points[0].y = scrollPtr->arrowLength + scrollPtr->inset - 1; + points[1].x = width + scrollPtr->inset; points[1].y = points[0].y; - points[2].x = width/2 + scrollPtr->offset; - points[2].y = scrollPtr->offset - 1; - Tk_Fill3DPolygon(scrollPtr->display, pixmap, border, - points, 3, scrollPtr->borderWidth, relief); + points[2].x = width/2 + scrollPtr->inset; + points[2].y = scrollPtr->inset - 1; + Tk_Fill3DPolygon(tkwin, pixmap, border, points, 3, + elementBorderWidth, relief); } else { - points[0].x = scrollPtr->arrowLength + scrollPtr->offset; - points[0].y = scrollPtr->offset - 1; - points[1].x = scrollPtr->offset; - points[1].y = width/2 + scrollPtr->offset; + points[0].x = scrollPtr->arrowLength + scrollPtr->inset - 1; + points[0].y = scrollPtr->inset - 1; + points[1].x = scrollPtr->inset; + points[1].y = width/2 + scrollPtr->inset; points[2].x = points[0].x; - points[2].y = width + scrollPtr->offset; - Tk_Fill3DPolygon(scrollPtr->display, pixmap, border, - points, 3, scrollPtr->borderWidth, relief); + points[2].y = width + scrollPtr->inset; + Tk_Fill3DPolygon(tkwin, pixmap, border, points, 3, + elementBorderWidth, relief); } /* * Display the bottom or right arrow. */ - if (scrollPtr->mouseField == BOTTOM_ARROW) { + if (scrollPtr->activeField == BOTTOM_ARROW) { border = scrollPtr->activeBorder; - relief = scrollPtr->pressField == BOTTOM_ARROW ? TK_RELIEF_SUNKEN - : TK_RELIEF_RAISED; + relief = scrollPtr->activeField == BOTTOM_ARROW + ? scrollPtr->activeRelief : TK_RELIEF_RAISED; } else { - border = scrollPtr->fgBorder; + border = scrollPtr->bgBorder; relief = TK_RELIEF_RAISED; } if (scrollPtr->vertical) { - points[0].x = scrollPtr->offset; + points[0].x = scrollPtr->inset; points[0].y = Tk_Height(tkwin) - scrollPtr->arrowLength - - scrollPtr->offset; - points[1].x = width/2 + scrollPtr->offset; - points[1].y = Tk_Height(tkwin) - scrollPtr->offset; - points[2].x = width + scrollPtr->offset; + - scrollPtr->inset + 1; + points[1].x = width/2 + scrollPtr->inset; + points[1].y = Tk_Height(tkwin) - scrollPtr->inset; + points[2].x = width + scrollPtr->inset; points[2].y = points[0].y; - Tk_Fill3DPolygon(scrollPtr->display, pixmap, border, - points, 3, scrollPtr->borderWidth, relief); + Tk_Fill3DPolygon(tkwin, pixmap, border, + points, 3, elementBorderWidth, relief); } else { points[0].x = Tk_Width(tkwin) - scrollPtr->arrowLength - - scrollPtr->offset; - points[0].y = scrollPtr->offset - 1; + - scrollPtr->inset + 1; + points[0].y = scrollPtr->inset - 1; points[1].x = points[0].x; - points[1].y = width + scrollPtr->offset; - points[2].x = Tk_Width(tkwin) - scrollPtr->offset; - points[2].y = width/2 + scrollPtr->offset; - Tk_Fill3DPolygon(scrollPtr->display, pixmap, border, - points, 3, scrollPtr->borderWidth, relief); + points[1].y = width + scrollPtr->inset; + points[2].x = Tk_Width(tkwin) - scrollPtr->inset; + points[2].y = width/2 + scrollPtr->inset; + Tk_Fill3DPolygon(tkwin, pixmap, border, + points, 3, elementBorderWidth, relief); } /* * Display the slider. */ - if (scrollPtr->mouseField == SLIDER) { + if (scrollPtr->activeField == SLIDER) { border = scrollPtr->activeBorder; - relief = scrollPtr->pressField == SLIDER ? TK_RELIEF_SUNKEN + relief = scrollPtr->activeField == SLIDER ? scrollPtr->activeRelief : TK_RELIEF_RAISED; } else { - border = scrollPtr->fgBorder; + border = scrollPtr->bgBorder; relief = TK_RELIEF_RAISED; } if (scrollPtr->vertical) { - Tk_Fill3DRectangle(scrollPtr->display, pixmap, border, - 1 + scrollPtr->offset, scrollPtr->sliderFirst, - width-2, scrollPtr->sliderLast - scrollPtr->sliderFirst, - scrollPtr->borderWidth, relief); + Tk_Fill3DRectangle(tkwin, pixmap, border, + scrollPtr->inset, scrollPtr->sliderFirst, + width, scrollPtr->sliderLast - scrollPtr->sliderFirst, + elementBorderWidth, relief); } else { - Tk_Fill3DRectangle(scrollPtr->display, pixmap, border, - scrollPtr->sliderFirst, 1 + scrollPtr->offset, - scrollPtr->sliderLast - scrollPtr->sliderFirst, width-2, - scrollPtr->borderWidth, relief); + Tk_Fill3DRectangle(tkwin, pixmap, border, + scrollPtr->sliderFirst, scrollPtr->inset, + scrollPtr->sliderLast - scrollPtr->sliderFirst, width, + elementBorderWidth, relief); } /* @@ -720,8 +942,9 @@ DisplayScrollbar(clientData) */ XCopyArea(scrollPtr->display, pixmap, Tk_WindowId(tkwin), - scrollPtr->copyGC, 0, 0, Tk_Width(tkwin), Tk_Height(tkwin), 0, 0); - XFreePixmap(scrollPtr->display, pixmap); + scrollPtr->copyGC, 0, 0, (unsigned) Tk_Width(tkwin), + (unsigned) Tk_Height(tkwin), 0, 0); + Tk_FreePixmap(scrollPtr->display, pixmap); done: scrollPtr->flags &= ~REDRAW_PENDING; @@ -755,14 +978,71 @@ ScrollbarEventProc(clientData, eventPtr) if ((eventPtr->type == Expose) && (eventPtr->xexpose.count == 0)) { EventuallyRedraw(scrollPtr); } else if (eventPtr->type == DestroyNotify) { - Tcl_DeleteCommand(scrollPtr->interp, Tk_PathName(scrollPtr->tkwin)); - scrollPtr->tkwin = NULL; - if (scrollPtr->flags & REDRAW_PENDING) { - Tk_CancelIdleCall(DisplayScrollbar, (ClientData) scrollPtr); + if (scrollPtr->tkwin != NULL) { + scrollPtr->tkwin = NULL; + Tcl_DeleteCommand(scrollPtr->interp, + Tcl_GetCommandName(scrollPtr->interp, + scrollPtr->widgetCmd)); } - Tk_EventuallyFree((ClientData) scrollPtr, DestroyScrollbar); + if (scrollPtr->flags & REDRAW_PENDING) { + Tcl_CancelIdleCall(DisplayScrollbar, (ClientData) scrollPtr); + } + Tcl_EventuallyFree((ClientData) scrollPtr, DestroyScrollbar); } else if (eventPtr->type == ConfigureNotify) { ComputeScrollbarGeometry(scrollPtr); + EventuallyRedraw(scrollPtr); + } else if (eventPtr->type == FocusIn) { + if (eventPtr->xfocus.detail != NotifyInferior) { + scrollPtr->flags |= GOT_FOCUS; + if (scrollPtr->highlightWidth > 0) { + EventuallyRedraw(scrollPtr); + } + } + } else if (eventPtr->type == FocusOut) { + if (eventPtr->xfocus.detail != NotifyInferior) { + scrollPtr->flags &= ~GOT_FOCUS; + if (scrollPtr->highlightWidth > 0) { + EventuallyRedraw(scrollPtr); + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * ScrollbarCmdDeletedProc -- + * + * This procedure is invoked when a widget command is deleted. If + * the widget isn't already in the process of being destroyed, + * this command destroys it. + * + * Results: + * None. + * + * Side effects: + * The widget is destroyed. + * + *---------------------------------------------------------------------- + */ + +static void +ScrollbarCmdDeletedProc(clientData) + ClientData clientData; /* Pointer to widget record for widget. */ +{ + Scrollbar *scrollPtr = (Scrollbar *) clientData; + Tk_Window tkwin = scrollPtr->tkwin; + + /* + * This procedure could be invoked either because the window was + * destroyed and the command was then deleted (in which case tkwin + * is NULL) or because the command was deleted, and then this procedure + * destroys the widget. + */ + + if (tkwin != NULL) { + scrollPtr->tkwin = NULL; + Tk_DestroyWindow(tkwin); } } @@ -791,52 +1071,43 @@ ComputeScrollbarGeometry(scrollPtr) { int width, fieldLength; - if (scrollPtr->relief == TK_RELIEF_FLAT) { - scrollPtr->offset = 0; - } else { - scrollPtr->offset = scrollPtr->borderWidth; + if (scrollPtr->highlightWidth < 0) { + scrollPtr->highlightWidth = 0; } + scrollPtr->inset = scrollPtr->highlightWidth + scrollPtr->borderWidth; width = (scrollPtr->vertical) ? Tk_Width(scrollPtr->tkwin) : Tk_Height(scrollPtr->tkwin); - scrollPtr->arrowLength = - (((width - 2*scrollPtr->offset)*173) + 100) / 200; + scrollPtr->arrowLength = width - 2*scrollPtr->inset + 1; fieldLength = (scrollPtr->vertical ? Tk_Height(scrollPtr->tkwin) : Tk_Width(scrollPtr->tkwin)) - - 2*(scrollPtr->arrowLength + scrollPtr->offset); + - 2*(scrollPtr->arrowLength + scrollPtr->inset); if (fieldLength < 0) { fieldLength = 0; } - if (scrollPtr->totalUnits <= 0) { - scrollPtr->sliderFirst = 0; - scrollPtr->sliderLast = fieldLength; - } else { - scrollPtr->sliderFirst = (fieldLength*scrollPtr->firstUnit - + scrollPtr->totalUnits/2)/scrollPtr->totalUnits; - scrollPtr->sliderLast = (fieldLength*(scrollPtr->lastUnit+1) - + scrollPtr->totalUnits/2)/scrollPtr->totalUnits; + scrollPtr->sliderFirst = fieldLength*scrollPtr->firstFraction; + scrollPtr->sliderLast = fieldLength*scrollPtr->lastFraction; - /* - * Adjust the slider so that some piece of it is always - * displayed in the scrollbar and so that it has at least - * a minimal width (so it can be grabbed with the mouse). - */ + /* + * Adjust the slider so that some piece of it is always + * displayed in the scrollbar and so that it has at least + * a minimal width (so it can be grabbed with the mouse). + */ - if (scrollPtr->sliderFirst > (fieldLength - 2*scrollPtr->borderWidth)) { - scrollPtr->sliderFirst = fieldLength - 2*scrollPtr->borderWidth; - } - if (scrollPtr->sliderFirst < 0) { - scrollPtr->sliderFirst = 0; - } - if (scrollPtr->sliderLast < (scrollPtr->sliderFirst - + MIN_SLIDER_LENGTH)) { - scrollPtr->sliderLast = scrollPtr->sliderFirst + MIN_SLIDER_LENGTH; - } - if (scrollPtr->sliderLast > fieldLength) { - scrollPtr->sliderLast = fieldLength; - } + if (scrollPtr->sliderFirst > (fieldLength - 2*scrollPtr->borderWidth)) { + scrollPtr->sliderFirst = fieldLength - 2*scrollPtr->borderWidth; } - scrollPtr->sliderFirst += scrollPtr->arrowLength + scrollPtr->offset; - scrollPtr->sliderLast += scrollPtr->arrowLength + scrollPtr->offset; + if (scrollPtr->sliderFirst < 0) { + scrollPtr->sliderFirst = 0; + } + if (scrollPtr->sliderLast < (scrollPtr->sliderFirst + + MIN_SLIDER_LENGTH)) { + scrollPtr->sliderLast = scrollPtr->sliderFirst + MIN_SLIDER_LENGTH; + } + if (scrollPtr->sliderLast > fieldLength) { + scrollPtr->sliderLast = fieldLength; + } + scrollPtr->sliderFirst += scrollPtr->arrowLength + scrollPtr->inset; + scrollPtr->sliderLast += scrollPtr->arrowLength + scrollPtr->inset; /* * Register the desired geometry for the window (leave enough space @@ -847,16 +1118,15 @@ ComputeScrollbarGeometry(scrollPtr) if (scrollPtr->vertical) { Tk_GeometryRequest(scrollPtr->tkwin, - scrollPtr->width + 2*scrollPtr->offset, + scrollPtr->width + 2*scrollPtr->inset, 2*(scrollPtr->arrowLength + scrollPtr->borderWidth - + scrollPtr->offset)); + + scrollPtr->inset)); } else { Tk_GeometryRequest(scrollPtr->tkwin, 2*(scrollPtr->arrowLength + scrollPtr->borderWidth - + scrollPtr->offset), scrollPtr->width + 2*scrollPtr->offset); + + scrollPtr->inset), scrollPtr->width + 2*scrollPtr->inset); } - Tk_SetInternalBorder(scrollPtr->tkwin, scrollPtr->borderWidth); - + Tk_SetInternalBorder(scrollPtr->tkwin, scrollPtr->inset); } /* @@ -898,7 +1168,8 @@ ScrollbarPosition(scrollPtr, x, y) width = Tk_Height(scrollPtr->tkwin); } - if ((x < 0) || (x > width) || (y < 0)) { + if ((x < scrollPtr->inset) || (x >= (width - scrollPtr->inset)) + || (y < scrollPtr->inset) || (y >= (length - scrollPtr->inset))) { return OUTSIDE; } @@ -907,7 +1178,7 @@ ScrollbarPosition(scrollPtr, x, y) * DisplayScrollbar. Be sure to keep the two consistent. */ - if (y < (scrollPtr->offset + scrollPtr->arrowLength)) { + if (y < (scrollPtr->inset + scrollPtr->arrowLength)) { return TOP_ARROW; } if (y < scrollPtr->sliderFirst) { @@ -916,198 +1187,12 @@ ScrollbarPosition(scrollPtr, x, y) if (y < scrollPtr->sliderLast) { return SLIDER; } - if (y >= (length - (scrollPtr->arrowLength + scrollPtr->offset))) { + if (y >= (length - (scrollPtr->arrowLength + scrollPtr->inset))) { return BOTTOM_ARROW; } return BOTTOM_GAP; } -/* - *-------------------------------------------------------------- - * - * ScrollbarMouseProc -- - * - * This procedure is called back by Tk in response to - * mouse events such as window entry, window exit, mouse - * motion, and button presses. - * - * Results: - * None. - * - * Side effects: - * This procedure implements the "feel" of the scrollbar - * by issuing scrolling commands in response to button presses - * and mouse motion. - * - *-------------------------------------------------------------- - */ - -static void -ScrollbarMouseProc(clientData, eventPtr) - ClientData clientData; /* Information about window. */ - register XEvent *eventPtr; /* Information about event. */ -{ - register Scrollbar *scrollPtr = (Scrollbar *) clientData; - - Tk_Preserve((ClientData) scrollPtr); - if (eventPtr->type == EnterNotify) { - if (scrollPtr->pressField == -1) { - ScrollbarNewField(scrollPtr, - ScrollbarPosition(scrollPtr, eventPtr->xcrossing.x, - eventPtr->xcrossing.y)); - } - } else if (eventPtr->type == LeaveNotify) { - if (scrollPtr->pressField == -1) { - ScrollbarNewField(scrollPtr, OUTSIDE); - } - } else if (eventPtr->type == MotionNotify) { - if (scrollPtr->pressField == SLIDER) { - int delta, length, newFirst; - - if (scrollPtr->vertical) { - delta = eventPtr->xmotion.y - scrollPtr->pressPos; - length = Tk_Height(scrollPtr->tkwin) - - 2*(scrollPtr->arrowLength + scrollPtr->offset); - } else { - delta = eventPtr->xmotion.x - scrollPtr->pressPos; - length = Tk_Width(scrollPtr->tkwin) - - 2*(scrollPtr->arrowLength + scrollPtr->offset); - } - - /* - * Do the division with positive numbers to avoid - * differences in negative-number truncation on different - * machines. - */ - - if (delta >= 0) { - newFirst = scrollPtr->pressFirstUnit - + ((delta * scrollPtr->totalUnits) + (length/2)) - / length; - } else { - newFirst = scrollPtr->pressFirstUnit - - (((-delta) * scrollPtr->totalUnits) + (length/2)) - / length; - } - ScrollCmd(scrollPtr, newFirst); - } else if (scrollPtr->pressField == -1) { - ScrollbarNewField(scrollPtr, - ScrollbarPosition(scrollPtr, eventPtr->xmotion.x, - eventPtr->xmotion.y)); - } - } else if ((eventPtr->type == ButtonPress) - && (eventPtr->xbutton.state == 0)) { - /* - * The following procedure call is only necessary for OpenWindows 2.0 - * because it seems to send ButtonPress events to scrollbars - * without an EnterNotify or MotionNotify event first (9/23/92). - */ - - ScrollbarNewField(scrollPtr, - ScrollbarPosition(scrollPtr, eventPtr->xbutton.x, - eventPtr->xbutton.y)); - scrollPtr->pressField = scrollPtr->mouseField; - if (scrollPtr->pressField != SLIDER) { - scrollPtr->autoRepeat = Tk_CreateTimerHandler( - scrollPtr->repeatDelay, - ScrollbarTimerProc, (ClientData) scrollPtr); - } - if (scrollPtr->vertical) { - scrollPtr->pressPos = eventPtr->xbutton.y; - } else { - scrollPtr->pressPos = eventPtr->xbutton.x; - } - scrollPtr->pressFirstUnit = scrollPtr->firstUnit; - if (scrollPtr->pressFirstUnit <= -scrollPtr->windowUnits) { - scrollPtr->pressFirstUnit = 1-scrollPtr->windowUnits; - } - if (scrollPtr->pressFirstUnit >= scrollPtr->totalUnits) { - scrollPtr->pressFirstUnit = scrollPtr->totalUnits-1; - } - EventuallyRedraw(scrollPtr); - } else if (eventPtr->type == ButtonRelease) { - if (scrollPtr->pressField == scrollPtr->mouseField) { - switch (scrollPtr->pressField) { - case TOP_ARROW: - ScrollCmd(scrollPtr, scrollPtr->firstUnit-1); - break; - case TOP_GAP: - if (scrollPtr->windowUnits <= 1) { - ScrollCmd(scrollPtr, scrollPtr->firstUnit - 1); - } else { - ScrollCmd(scrollPtr, scrollPtr->firstUnit - - (scrollPtr->windowUnits-1)); - } - break; - case BOTTOM_GAP: { - if (scrollPtr->windowUnits <= 1) { - ScrollCmd(scrollPtr, scrollPtr->firstUnit + 1); - } else { - ScrollCmd(scrollPtr, scrollPtr->firstUnit - + (scrollPtr->windowUnits-1)); - } - break; - } - case BOTTOM_ARROW: - ScrollCmd(scrollPtr, scrollPtr->firstUnit+1); - break; - } - } - if (scrollPtr->autoRepeat != NULL) { - Tk_DeleteTimerHandler(scrollPtr->autoRepeat); - scrollPtr->autoRepeat = NULL; - } - EventuallyRedraw(scrollPtr); - scrollPtr->pressField = -1; - ScrollbarNewField(scrollPtr, - ScrollbarPosition(scrollPtr, eventPtr->xbutton.x, - eventPtr->xbutton.y)); - } - Tk_Release((ClientData) scrollPtr); -} - -/* - *-------------------------------------------------------------- - * - * ScrollCmd -- - * - * This procedure takes care of invoking a scrolling Tcl - * command and reporting any error that occurs in it. - * - * Results: - * None. - * - * Side effects: - * A Tcl command is invoked, and an additional error-processing - * command may also be invoked. - * - *-------------------------------------------------------------- - */ - -static void -ScrollCmd(scrollPtr, unit) - register Scrollbar *scrollPtr; /* Scrollbar from which to issue - * command. */ - int unit; /* Unit position within thing being - * being displayed that should appear - * at top or right of screen. */ -{ - char string[20]; - int result; - - if ((unit == scrollPtr->firstUnit) || (scrollPtr->command == NULL)) { - return; - } - sprintf(string, " %d", unit); - result = Tcl_VarEval(scrollPtr->interp, scrollPtr->command, string, - (char *) NULL); - if (result != TCL_OK) { - Tcl_AddErrorInfo(scrollPtr->interp, - "\n (scrolling command executed by scrollbar)"); - Tk_BackgroundError(scrollPtr->interp); - } -} - /* *-------------------------------------------------------------- * @@ -1133,91 +1218,7 @@ EventuallyRedraw(scrollPtr) return; } if ((scrollPtr->flags & REDRAW_PENDING) == 0) { - Tk_DoWhenIdle(DisplayScrollbar, (ClientData) scrollPtr); + Tcl_DoWhenIdle(DisplayScrollbar, (ClientData) scrollPtr); scrollPtr->flags |= REDRAW_PENDING; } } - -/* - *-------------------------------------------------------------- - * - * ScrollbarNewField -- - * - * This procedure is called to declare that the mouse is in - * a particular field of the scrollbar (e.g. top arrow), so - * that the field can be highlighed and the previous field - * can be returned to normal display. - * - * Results: - * None. - * - * Side effects: - * Fields may be redisplayed. - * - *-------------------------------------------------------------- - */ - -static void -ScrollbarNewField(scrollPtr, field) - register Scrollbar *scrollPtr; /* Information about widget. */ - int field; /* Identifies field under mouse, - * e.g. TOP_ARROW. */ -{ - if (field == scrollPtr->mouseField) { - return; - } - EventuallyRedraw(scrollPtr); - scrollPtr->mouseField = field; -} - -/* - *-------------------------------------------------------------- - * - * ScrollbarTimerProc -- - * - * This procedure is invoked as a Tk timer handler for actions - * that auto-repeat (mouse presses in an arrow or gap). It - * performs the auto-repeat action. - * - * Results: - * None. - * - * Side effects: - * Whatever action corresponds to the current mouse button - * is repeated, and this procedure is rescheduled to execute - * again later. - * - *-------------------------------------------------------------- - */ - -static void -ScrollbarTimerProc(clientData) - ClientData clientData; /* Information about widget. */ -{ - register Scrollbar *scrollPtr = (Scrollbar *) clientData; - - Tk_Preserve((ClientData) scrollPtr); - switch(scrollPtr->pressField) { - case TOP_ARROW: - ScrollCmd(scrollPtr, scrollPtr->firstUnit-1); - break; - case TOP_GAP: - ScrollCmd(scrollPtr, scrollPtr->firstUnit - - (scrollPtr->windowUnits-1)); - break; - case BOTTOM_GAP: { - ScrollCmd(scrollPtr, scrollPtr->firstUnit - + (scrollPtr->windowUnits-1)); - break; - } - case BOTTOM_ARROW: - ScrollCmd(scrollPtr, scrollPtr->firstUnit+1); - break; - } - if (scrollPtr->tkwin != NULL) { - scrollPtr->autoRepeat = Tk_CreateTimerHandler( - scrollPtr->repeatInterval, ScrollbarTimerProc, - (ClientData) scrollPtr); - } - Tk_Release((ClientData) scrollPtr); -} diff --git a/tk4.2/generic/tkSelect.c b/tk4.2/generic/tkSelect.c new file mode 100644 index 0000000..9e9f6c7 --- /dev/null +++ b/tk4.2/generic/tkSelect.c @@ -0,0 +1,1341 @@ +/* + * tkSelect.c -- + * + * This file manages the selection for the Tk toolkit, + * translating between the standard X ICCCM conventions + * and Tcl commands. + * + * Copyright (c) 1990-1993 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkSelect.c 1.56 96/03/21 13:16:29 + */ + +#include "tkInt.h" +#include "tkSelect.h" + +/* + * When a selection handler is set up by invoking "selection handle", + * one of the following data structures is set up to hold information + * about the command to invoke and its interpreter. + */ + +typedef struct { + Tcl_Interp *interp; /* Interpreter in which to invoke command. */ + int cmdLength; /* # of non-NULL bytes in command. */ + char command[4]; /* Command to invoke. Actual space is + * allocated as large as necessary. This + * must be the last entry in the structure. */ +} CommandInfo; + +/* + * When selection ownership is claimed with the "selection own" Tcl command, + * one of the following structures is created to record the Tcl command + * to be executed when the selection is lost again. + */ + +typedef struct LostCommand { + Tcl_Interp *interp; /* Interpreter in which to invoke command. */ + char command[4]; /* Command to invoke. Actual space is + * allocated as large as necessary. This + * must be the last entry in the structure. */ +} LostCommand; + +/* + * Shared variables: + */ + +TkSelInProgress *pendingPtr = NULL; + /* Topmost search in progress, or + * NULL if none. */ + +/* + * Forward declarations for procedures defined in this file: + */ + +static int HandleTclCommand _ANSI_ARGS_((ClientData clientData, + int offset, char *buffer, int maxBytes)); +static void LostSelection _ANSI_ARGS_((ClientData clientData)); +static int SelGetProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *portion)); + +/* + *-------------------------------------------------------------- + * + * Tk_CreateSelHandler -- + * + * This procedure is called to register a procedure + * as the handler for selection requests of a particular + * target type on a particular window for a particular + * selection. + * + * Results: + * None. + * + * Side effects: + * In the future, whenever the selection is in tkwin's + * window and someone requests the selection in the + * form given by target, proc will be invoked to provide + * part or all of the selection in the given form. If + * there was already a handler declared for the given + * window, target and selection type, then it is replaced. + * Proc should have the following form: + * + * int + * proc(clientData, offset, buffer, maxBytes) + * ClientData clientData; + * int offset; + * char *buffer; + * int maxBytes; + * { + * } + * + * The clientData argument to proc will be the same as + * the clientData argument to this procedure. The offset + * argument indicates which portion of the selection to + * return: skip the first offset bytes. Buffer is a + * pointer to an area in which to place the converted + * selection, and maxBytes gives the number of bytes + * available at buffer. Proc should place the selection + * in buffer as a string, and return a count of the number + * of bytes of selection actually placed in buffer (not + * including the terminating NULL character). If the + * return value equals maxBytes, this is a sign that there + * is probably still more selection information available. + * + *-------------------------------------------------------------- + */ + +void +Tk_CreateSelHandler(tkwin, selection, target, proc, clientData, format) + Tk_Window tkwin; /* Token for window. */ + Atom selection; /* Selection to be handled. */ + Atom target; /* The kind of selection conversions + * that can be handled by proc, + * e.g. TARGETS or STRING. */ + Tk_SelectionProc *proc; /* Procedure to invoke to convert + * selection to type "target". */ + ClientData clientData; /* Value to pass to proc. */ + Atom format; /* Format in which the selection + * information should be returned to + * the requestor. XA_STRING is best by + * far, but anything listed in the ICCCM + * will be tolerated (blech). */ +{ + register TkSelHandler *selPtr; + TkWindow *winPtr = (TkWindow *) tkwin; + + if (winPtr->dispPtr->multipleAtom == None) { + TkSelInit(tkwin); + } + + /* + * See if there's already a handler for this target and selection on + * this window. If so, re-use it. If not, create a new one. + */ + + for (selPtr = winPtr->selHandlerList; ; selPtr = selPtr->nextPtr) { + if (selPtr == NULL) { + selPtr = (TkSelHandler *) ckalloc(sizeof(TkSelHandler)); + selPtr->nextPtr = winPtr->selHandlerList; + winPtr->selHandlerList = selPtr; + break; + } + if ((selPtr->selection == selection) && (selPtr->target == target)) { + + /* + * Special case: when replacing handler created by + * "selection handle", free up memory. Should there be a + * callback to allow other clients to do this too? + */ + + if (selPtr->proc == HandleTclCommand) { + ckfree((char *) selPtr->clientData); + } + break; + } + } + selPtr->selection = selection; + selPtr->target = target; + selPtr->format = format; + selPtr->proc = proc; + selPtr->clientData = clientData; + if (format == XA_STRING) { + selPtr->size = 8; + } else { + selPtr->size = 32; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tk_DeleteSelHandler -- + * + * Remove the selection handler for a given window, target, and + * selection, if it exists. + * + * Results: + * None. + * + * Side effects: + * The selection handler for tkwin and target is removed. If there + * is no such handler then nothing happens. + * + *---------------------------------------------------------------------- + */ + +void +Tk_DeleteSelHandler(tkwin, selection, target) + Tk_Window tkwin; /* Token for window. */ + Atom selection; /* The selection whose handler + * is to be removed. */ + Atom target; /* The target whose selection + * handler is to be removed. */ +{ + TkWindow *winPtr = (TkWindow *) tkwin; + register TkSelHandler *selPtr, *prevPtr; + register TkSelInProgress *ipPtr; + + /* + * Find the selection handler to be deleted, or return if it doesn't + * exist. + */ + + for (selPtr = winPtr->selHandlerList, prevPtr = NULL; ; + prevPtr = selPtr, selPtr = selPtr->nextPtr) { + if (selPtr == NULL) { + return; + } + if ((selPtr->selection == selection) && (selPtr->target == target)) { + break; + } + } + + /* + * If ConvertSelection is processing this handler, tell it that the + * handler is dead. + */ + + for (ipPtr = pendingPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { + if (ipPtr->selPtr == selPtr) { + ipPtr->selPtr = NULL; + } + } + + /* + * Free resources associated with the handler. + */ + + if (prevPtr == NULL) { + winPtr->selHandlerList = selPtr->nextPtr; + } else { + prevPtr->nextPtr = selPtr->nextPtr; + } + if (selPtr->proc == HandleTclCommand) { + ckfree((char *) selPtr->clientData); + } + ckfree((char *) selPtr); +} + +/* + *-------------------------------------------------------------- + * + * Tk_OwnSelection -- + * + * Arrange for tkwin to become the owner of a selection. + * + * Results: + * None. + * + * Side effects: + * From now on, requests for the selection will be directed + * to procedures associated with tkwin (they must have been + * declared with calls to Tk_CreateSelHandler). When the + * selection is lost by this window, proc will be invoked + * (see the manual entry for details). This procedure may + * invoke callbacks, including Tcl scripts, so any calling + * function should be reentrant at the point where + * Tk_OwnSelection is invoked. + * + *-------------------------------------------------------------- + */ + +void +Tk_OwnSelection(tkwin, selection, proc, clientData) + Tk_Window tkwin; /* Window to become new selection + * owner. */ + Atom selection; /* Selection that window should own. */ + Tk_LostSelProc *proc; /* Procedure to call when selection + * is taken away from tkwin. */ + ClientData clientData; /* Arbitrary one-word argument to + * pass to proc. */ +{ + register TkWindow *winPtr = (TkWindow *) tkwin; + TkDisplay *dispPtr = winPtr->dispPtr; + TkSelectionInfo *infoPtr; + Tk_LostSelProc *clearProc = NULL; + ClientData clearData = NULL; /* Initialization needed only to + * prevent compiler warning. */ + + + if (dispPtr->multipleAtom == None) { + TkSelInit(tkwin); + } + Tk_MakeWindowExist(tkwin); + + /* + * This code is somewhat tricky. First, we find the specified selection + * on the selection list. If the previous owner is in this process, and + * is a different window, then we need to invoke the clearProc. However, + * it's dangerous to call the clearProc right now, because it could + * invoke a Tcl script that wrecks the current state (e.g. it could + * delete the window). To be safe, defer the call until the end of the + * procedure when we no longer care about the state. + */ + + for (infoPtr = dispPtr->selectionInfoPtr; infoPtr != NULL; + infoPtr = infoPtr->nextPtr) { + if (infoPtr->selection == selection) { + break; + } + } + if (infoPtr == NULL) { + infoPtr = (TkSelectionInfo*) ckalloc(sizeof(TkSelectionInfo)); + infoPtr->selection = selection; + infoPtr->nextPtr = dispPtr->selectionInfoPtr; + dispPtr->selectionInfoPtr = infoPtr; + } else if (infoPtr->clearProc != NULL) { + if (infoPtr->owner != tkwin) { + clearProc = infoPtr->clearProc; + clearData = infoPtr->clearData; + } else if (infoPtr->clearProc == LostSelection) { + /* + * If the selection handler is one created by "selection own", + * be sure to free the record for it; otherwise there will be + * a memory leak. + */ + + ckfree((char *) infoPtr->clearData); + } + } + + infoPtr->owner = tkwin; + infoPtr->serial = NextRequest(winPtr->display); + infoPtr->clearProc = proc; + infoPtr->clearData = clientData; + + /* + * Note that we are using CurrentTime, even though ICCCM recommends against + * this practice (the problem is that we don't necessarily have a valid + * time to use). We will not be able to retrieve a useful timestamp for + * the TIMESTAMP target later. + */ + + infoPtr->time = CurrentTime; + + /* + * Note that we are not checking to see if the selection claim succeeded. + * If the ownership does not change, then the clearProc may never be + * invoked, and we will return incorrect information when queried for the + * current selection owner. + */ + + XSetSelectionOwner(winPtr->display, infoPtr->selection, winPtr->window, + infoPtr->time); + + /* + * Now that we are done, we can invoke clearProc without running into + * reentrancy problems. + */ + + if (clearProc != NULL) { + (*clearProc)(clearData); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tk_ClearSelection -- + * + * Eliminate the specified selection on tkwin's display, if there is one. + * + * Results: + * None. + * + * Side effects: + * The specified selection is cleared, so that future requests to retrieve + * it will fail until some application owns it again. This procedure + * invokes callbacks, possibly including Tcl scripts, so any calling + * function should be reentrant at the point Tk_ClearSelection is invoked. + * + *---------------------------------------------------------------------- + */ + +void +Tk_ClearSelection(tkwin, selection) + Tk_Window tkwin; /* Window that selects a display. */ + Atom selection; /* Selection to be cancelled. */ +{ + register TkWindow *winPtr = (TkWindow *) tkwin; + TkDisplay *dispPtr = winPtr->dispPtr; + TkSelectionInfo *infoPtr; + TkSelectionInfo *prevPtr; + TkSelectionInfo *nextPtr; + Tk_LostSelProc *clearProc = NULL; + ClientData clearData = NULL; /* Initialization needed only to + * prevent compiler warning. */ + + if (dispPtr->multipleAtom == None) { + TkSelInit(tkwin); + } + + for (infoPtr = dispPtr->selectionInfoPtr, prevPtr = NULL; + infoPtr != NULL; infoPtr = nextPtr) { + nextPtr = infoPtr->nextPtr; + if (infoPtr->selection == selection) { + if (prevPtr == NULL) { + dispPtr->selectionInfoPtr = nextPtr; + } else { + prevPtr->nextPtr = nextPtr; + } + break; + } + prevPtr = infoPtr; + } + + if (infoPtr != NULL) { + clearProc = infoPtr->clearProc; + clearData = infoPtr->clearData; + ckfree((char *) infoPtr); + } + XSetSelectionOwner(winPtr->display, selection, None, CurrentTime); + + if (clearProc != NULL) { + (*clearProc)(clearData); + } +} + +/* + *-------------------------------------------------------------- + * + * Tk_GetSelection -- + * + * Retrieve the value of a selection and pass it off (in + * pieces, possibly) to a given procedure. + * + * Results: + * The return value is a standard Tcl return value. + * If an error occurs (such as no selection exists) + * then an error message is left in interp->result. + * + * Side effects: + * The standard X11 protocols are used to retrieve the + * selection. When it arrives, it is passed to proc. If + * the selection is very large, it will be passed to proc + * in several pieces. Proc should have the following + * structure: + * + * int + * proc(clientData, interp, portion) + * ClientData clientData; + * Tcl_Interp *interp; + * char *portion; + * { + * } + * + * The interp and clientData arguments to proc will be the + * same as the corresponding arguments to Tk_GetSelection. + * The portion argument points to a character string + * containing part of the selection, and numBytes indicates + * the length of the portion, not including the terminating + * NULL character. If the selection arrives in several pieces, + * the "portion" arguments in separate calls will contain + * successive parts of the selection. Proc should normally + * return TCL_OK. If it detects an error then it should return + * TCL_ERROR and leave an error message in interp->result; the + * remainder of the selection retrieval will be aborted. + * + *-------------------------------------------------------------- + */ + +int +Tk_GetSelection(interp, tkwin, selection, target, proc, clientData) + Tcl_Interp *interp; /* Interpreter to use for reporting + * errors. */ + Tk_Window tkwin; /* Window on whose behalf to retrieve + * the selection (determines display + * from which to retrieve). */ + Atom selection; /* Selection to retrieve. */ + Atom target; /* Desired form in which selection + * is to be returned. */ + Tk_GetSelProc *proc; /* Procedure to call to process the + * selection, once it has been retrieved. */ + ClientData clientData; /* Arbitrary value to pass to proc. */ +{ + TkWindow *winPtr = (TkWindow *) tkwin; + TkDisplay *dispPtr = winPtr->dispPtr; + TkSelectionInfo *infoPtr; + + if (dispPtr->multipleAtom == None) { + TkSelInit(tkwin); + } + + /* + * If the selection is owned by a window managed by this + * process, then call the retrieval procedure directly, + * rather than going through the X server (it's dangerous + * to go through the X server in this case because it could + * result in deadlock if an INCR-style selection results). + */ + + for (infoPtr = dispPtr->selectionInfoPtr; infoPtr != NULL; + infoPtr = infoPtr->nextPtr) { + if (infoPtr->selection == selection) + break; + } + if (infoPtr != NULL) { + register TkSelHandler *selPtr; + int offset, result, count; + char buffer[TK_SEL_BYTES_AT_ONCE+1]; + TkSelInProgress ip; + + for (selPtr = ((TkWindow *) infoPtr->owner)->selHandlerList; + selPtr != NULL; selPtr = selPtr->nextPtr) { + if ((selPtr->target == target) + && (selPtr->selection == selection)) { + break; + } + } + if (selPtr == NULL) { + Atom type; + + count = TkSelDefaultSelection(infoPtr, target, buffer, + TK_SEL_BYTES_AT_ONCE, &type); + if (count > TK_SEL_BYTES_AT_ONCE) { + panic("selection handler returned too many bytes"); + } + if (count < 0) { + goto cantget; + } + buffer[count] = 0; + result = (*proc)(clientData, interp, buffer); + } else { + offset = 0; + result = TCL_OK; + ip.selPtr = selPtr; + ip.nextPtr = pendingPtr; + pendingPtr = &ip; + while (1) { + count = (selPtr->proc)(selPtr->clientData, offset, buffer, + TK_SEL_BYTES_AT_ONCE); + if ((count < 0) || (ip.selPtr == NULL)) { + pendingPtr = ip.nextPtr; + goto cantget; + } + if (count > TK_SEL_BYTES_AT_ONCE) { + panic("selection handler returned too many bytes"); + } + buffer[count] = '\0'; + result = (*proc)(clientData, interp, buffer); + if ((result != TCL_OK) || (count < TK_SEL_BYTES_AT_ONCE) + || (ip.selPtr == NULL)) { + break; + } + offset += count; + } + pendingPtr = ip.nextPtr; + } + return result; + } + + /* + * The selection is owned by some other process. + */ + + return TkSelGetSelection(interp, tkwin, selection, target, proc, + clientData); + + cantget: + Tcl_AppendResult(interp, Tk_GetAtomName(tkwin, selection), + " selection doesn't exist or form \"", Tk_GetAtomName(tkwin, target), + "\" not defined", (char *) NULL); + return TCL_ERROR; +} + +/* + *-------------------------------------------------------------- + * + * Tk_SelectionCmd -- + * + * This procedure is invoked to process the "selection" Tcl + * command. See the user documentation for details on what + * it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +int +Tk_SelectionCmd(clientData, interp, argc, argv) + ClientData clientData; /* Main window associated with + * interpreter. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tk_Window tkwin = (Tk_Window) clientData; + char *path = NULL; + Atom selection; + char *selName = NULL; + int c, count; + size_t length; + char **args; + + if (argc < 2) { + sprintf(interp->result, + "wrong # args: should be \"%.50s option ?arg arg ...?\"", + argv[0]); + return TCL_ERROR; + } + c = argv[1][0]; + length = strlen(argv[1]); + if ((c == 'c') && (strncmp(argv[1], "clear", length) == 0)) { + for (count = argc-2, args = argv+2; count > 0; count -= 2, args += 2) { + if (args[0][0] != '-') { + break; + } + if (count < 2) { + Tcl_AppendResult(interp, "value for \"", *args, + "\" missing", (char *) NULL); + return TCL_ERROR; + } + c = args[0][1]; + length = strlen(args[0]); + if ((c == 'd') && (strncmp(args[0], "-displayof", length) == 0)) { + path = args[1]; + } else if ((c == 's') + && (strncmp(args[0], "-selection", length) == 0)) { + selName = args[1]; + } else { + Tcl_AppendResult(interp, "unknown option \"", args[0], + "\"", (char *) NULL); + return TCL_ERROR; + } + } + if (count == 1) { + path = args[0]; + } else if (count > 1) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " clear ?options?\"", (char *) NULL); + return TCL_ERROR; + } + if (path != NULL) { + tkwin = Tk_NameToWindow(interp, path, tkwin); + } + if (tkwin == NULL) { + return TCL_ERROR; + } + if (selName != NULL) { + selection = Tk_InternAtom(tkwin, selName); + } else { + selection = XA_PRIMARY; + } + + Tk_ClearSelection(tkwin, selection); + return TCL_OK; + } else if ((c == 'g') && (strncmp(argv[1], "get", length) == 0)) { + Atom target; + char *targetName = NULL; + Tcl_DString selBytes; + int result; + + for (count = argc-2, args = argv+2; count > 0; count -= 2, args += 2) { + if (args[0][0] != '-') { + break; + } + if (count < 2) { + Tcl_AppendResult(interp, "value for \"", *args, + "\" missing", (char *) NULL); + return TCL_ERROR; + } + c = args[0][1]; + length = strlen(args[0]); + if ((c == 'd') && (strncmp(args[0], "-displayof", length) == 0)) { + path = args[1]; + } else if ((c == 's') + && (strncmp(args[0], "-selection", length) == 0)) { + selName = args[1]; + } else if ((c == 't') + && (strncmp(args[0], "-type", length) == 0)) { + targetName = args[1]; + } else { + Tcl_AppendResult(interp, "unknown option \"", args[0], + "\"", (char *) NULL); + return TCL_ERROR; + } + } + if (path != NULL) { + tkwin = Tk_NameToWindow(interp, path, tkwin); + } + if (tkwin == NULL) { + return TCL_ERROR; + } + if (selName != NULL) { + selection = Tk_InternAtom(tkwin, selName); + } else { + selection = XA_PRIMARY; + } + if (count > 1) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " get ?options?\"", (char *) NULL); + return TCL_ERROR; + } else if (count == 1) { + target = Tk_InternAtom(tkwin, args[0]); + } else if (targetName != NULL) { + target = Tk_InternAtom(tkwin, targetName); + } else { + target = XA_STRING; + } + + Tcl_DStringInit(&selBytes); + result = Tk_GetSelection(interp, tkwin, selection, target, SelGetProc, + (ClientData) &selBytes); + if (result == TCL_OK) { + Tcl_DStringResult(interp, &selBytes); + } else { + Tcl_DStringFree(&selBytes); + } + return result; + } else if ((c == 'h') && (strncmp(argv[1], "handle", length) == 0)) { + Atom target, format; + char *targetName = NULL; + char *formatName = NULL; + register CommandInfo *cmdInfoPtr; + int cmdLength; + + for (count = argc-2, args = argv+2; count > 0; count -= 2, args += 2) { + if (args[0][0] != '-') { + break; + } + if (count < 2) { + Tcl_AppendResult(interp, "value for \"", *args, + "\" missing", (char *) NULL); + return TCL_ERROR; + } + c = args[0][1]; + length = strlen(args[0]); + if ((c == 'f') && (strncmp(args[0], "-format", length) == 0)) { + formatName = args[1]; + } else if ((c == 's') + && (strncmp(args[0], "-selection", length) == 0)) { + selName = args[1]; + } else if ((c == 't') + && (strncmp(args[0], "-type", length) == 0)) { + targetName = args[1]; + } else { + Tcl_AppendResult(interp, "unknown option \"", args[0], + "\"", (char *) NULL); + return TCL_ERROR; + } + } + + if ((count < 2) || (count > 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " handle ?options? window command\"", (char *) NULL); + return TCL_ERROR; + } + tkwin = Tk_NameToWindow(interp, args[0], tkwin); + if (tkwin == NULL) { + return TCL_ERROR; + } + if (selName != NULL) { + selection = Tk_InternAtom(tkwin, selName); + } else { + selection = XA_PRIMARY; + } + + if (count > 2) { + target = Tk_InternAtom(tkwin, args[2]); + } else if (targetName != NULL) { + target = Tk_InternAtom(tkwin, targetName); + } else { + target = XA_STRING; + } + if (count > 3) { + format = Tk_InternAtom(tkwin, args[3]); + } else if (formatName != NULL) { + format = Tk_InternAtom(tkwin, formatName); + } else { + format = XA_STRING; + } + cmdLength = strlen(args[1]); + if (cmdLength == 0) { + Tk_DeleteSelHandler(tkwin, selection, target); + } else { + cmdInfoPtr = (CommandInfo *) ckalloc((unsigned) ( + sizeof(CommandInfo) - 3 + cmdLength)); + cmdInfoPtr->interp = interp; + cmdInfoPtr->cmdLength = cmdLength; + strcpy(cmdInfoPtr->command, args[1]); + Tk_CreateSelHandler(tkwin, selection, target, HandleTclCommand, + (ClientData) cmdInfoPtr, format); + } + return TCL_OK; + } else if ((c == 'o') && (strncmp(argv[1], "own", length) == 0)) { + register LostCommand *lostPtr; + char *script = NULL; + int cmdLength; + + for (count = argc-2, args = argv+2; count > 0; count -= 2, args += 2) { + if (args[0][0] != '-') { + break; + } + if (count < 2) { + Tcl_AppendResult(interp, "value for \"", *args, + "\" missing", (char *) NULL); + return TCL_ERROR; + } + c = args[0][1]; + length = strlen(args[0]); + if ((c == 'c') && (strncmp(args[0], "-command", length) == 0)) { + script = args[1]; + } else if ((c == 'd') + && (strncmp(args[0], "-displayof", length) == 0)) { + path = args[1]; + } else if ((c == 's') + && (strncmp(args[0], "-selection", length) == 0)) { + selName = args[1]; + } else { + Tcl_AppendResult(interp, "unknown option \"", args[0], + "\"", (char *) NULL); + return TCL_ERROR; + } + } + + if (count > 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " own ?options? ?window?\"", (char *) NULL); + return TCL_ERROR; + } + if (selName != NULL) { + selection = Tk_InternAtom(tkwin, selName); + } else { + selection = XA_PRIMARY; + } + if (count == 0) { + TkSelectionInfo *infoPtr; + TkWindow *winPtr; + if (path != NULL) { + tkwin = Tk_NameToWindow(interp, path, tkwin); + } + if (tkwin == NULL) { + return TCL_ERROR; + } + winPtr = (TkWindow *)tkwin; + for (infoPtr = winPtr->dispPtr->selectionInfoPtr; infoPtr != NULL; + infoPtr = infoPtr->nextPtr) { + if (infoPtr->selection == selection) + break; + } + + /* + * Ignore the internal clipboard window. + */ + + if ((infoPtr != NULL) + && (infoPtr->owner != winPtr->dispPtr->clipWindow)) { + interp->result = Tk_PathName(infoPtr->owner); + } + return TCL_OK; + } + tkwin = Tk_NameToWindow(interp, args[0], tkwin); + if (tkwin == NULL) { + return TCL_ERROR; + } + if (count == 2) { + script = args[1]; + } + if (script == NULL) { + Tk_OwnSelection(tkwin, selection, (Tk_LostSelProc *) NULL, + (ClientData) NULL); + return TCL_OK; + } + cmdLength = strlen(script); + lostPtr = (LostCommand *) ckalloc((unsigned) (sizeof(LostCommand) + -3 + cmdLength)); + lostPtr->interp = interp; + strcpy(lostPtr->command, script); + Tk_OwnSelection(tkwin, selection, LostSelection, (ClientData) lostPtr); + return TCL_OK; + } else { + sprintf(interp->result, + "bad option \"%.50s\": must be clear, get, handle, or own", + argv[1]); + return TCL_ERROR; + } +} + +/* + *---------------------------------------------------------------------- + * + * TkSelDeadWindow -- + * + * This procedure is invoked just before a TkWindow is deleted. + * It performs selection-related cleanup. + * + * Results: + * None. + * + * Side effects: + * Frees up memory associated with the selection. + * + *---------------------------------------------------------------------- + */ + +void +TkSelDeadWindow(winPtr) + register TkWindow *winPtr; /* Window that's being deleted. */ +{ + register TkSelHandler *selPtr; + register TkSelInProgress *ipPtr; + TkSelectionInfo *infoPtr, *prevPtr, *nextPtr; + + /* + * While deleting all the handlers, be careful to check whether + * ConvertSelection or TkSelPropProc are about to process one of the + * deleted handlers. + */ + + while (winPtr->selHandlerList != NULL) { + selPtr = winPtr->selHandlerList; + winPtr->selHandlerList = selPtr->nextPtr; + for (ipPtr = pendingPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { + if (ipPtr->selPtr == selPtr) { + ipPtr->selPtr = NULL; + } + } + if (selPtr->proc == HandleTclCommand) { + ckfree((char *) selPtr->clientData); + } + ckfree((char *) selPtr); + } + + /* + * Remove selections owned by window being deleted. + */ + + for (infoPtr = winPtr->dispPtr->selectionInfoPtr, prevPtr = NULL; + infoPtr != NULL; infoPtr = nextPtr) { + nextPtr = infoPtr->nextPtr; + if (infoPtr->owner == (Tk_Window) winPtr) { + if (infoPtr->clearProc == LostSelection) { + ckfree((char *) infoPtr->clearData); + } + ckfree((char *) infoPtr); + infoPtr = prevPtr; + if (prevPtr == NULL) { + winPtr->dispPtr->selectionInfoPtr = nextPtr; + } else { + prevPtr->nextPtr = nextPtr; + } + } + prevPtr = infoPtr; + } +} + +/* + *---------------------------------------------------------------------- + * + * TkSelInit -- + * + * Initialize selection-related information for a display. + * + * Results: + * None. + * + * Side effects: + * Selection-related information is initialized. + * + *---------------------------------------------------------------------- + */ + +void +TkSelInit(tkwin) + Tk_Window tkwin; /* Window token (used to find + * display to initialize). */ +{ + register TkDisplay *dispPtr = ((TkWindow *) tkwin)->dispPtr; + + /* + * Fetch commonly-used atoms. + */ + + dispPtr->multipleAtom = Tk_InternAtom(tkwin, "MULTIPLE"); + dispPtr->incrAtom = Tk_InternAtom(tkwin, "INCR"); + dispPtr->targetsAtom = Tk_InternAtom(tkwin, "TARGETS"); + dispPtr->timestampAtom = Tk_InternAtom(tkwin, "TIMESTAMP"); + dispPtr->textAtom = Tk_InternAtom(tkwin, "TEXT"); + dispPtr->compoundTextAtom = Tk_InternAtom(tkwin, "COMPOUND_TEXT"); + dispPtr->applicationAtom = Tk_InternAtom(tkwin, "TK_APPLICATION"); + dispPtr->windowAtom = Tk_InternAtom(tkwin, "TK_WINDOW"); + dispPtr->clipboardAtom = Tk_InternAtom(tkwin, "CLIPBOARD"); +} + +/* + *---------------------------------------------------------------------- + * + * TkSelClearSelection -- + * + * This procedure is invoked to process a SelectionClear event. + * + * Results: + * None. + * + * Side effects: + * Invokes the clear procedure for the window which lost the + * selection. + * + *---------------------------------------------------------------------- + */ + +void +TkSelClearSelection(tkwin, eventPtr) + Tk_Window tkwin; /* Window for which event was targeted. */ + register XEvent *eventPtr; /* X SelectionClear event. */ +{ + register TkWindow *winPtr = (TkWindow *) tkwin; + TkDisplay *dispPtr = winPtr->dispPtr; + TkSelectionInfo *infoPtr; + TkSelectionInfo *prevPtr; + + /* + * Invoke clear procedure for window that just lost the selection. This + * code is a bit tricky, because any callbacks due to selection changes + * between windows managed by the process have already been made. Thus, + * ignore the event unless it refers to the window that's currently the + * selection owner and the event was generated after the server saw the + * SetSelectionOwner request. + */ + + for (infoPtr = dispPtr->selectionInfoPtr, prevPtr = NULL; + infoPtr != NULL; infoPtr = infoPtr->nextPtr) { + if (infoPtr->selection == eventPtr->xselectionclear.selection) { + break; + } + prevPtr = infoPtr; + } + + if (infoPtr != NULL && (infoPtr->owner == tkwin) + && (eventPtr->xselectionclear.serial >= infoPtr->serial)) { + if (prevPtr == NULL) { + dispPtr->selectionInfoPtr = infoPtr->nextPtr; + } else { + prevPtr->nextPtr = infoPtr->nextPtr; + } + + /* + * Because of reentrancy problems, calling clearProc must be done + * after the infoPtr has been removed from the selectionInfoPtr + * list (clearProc could modify the list, e.g. by creating + * a new selection). + */ + + if (infoPtr->clearProc != NULL) { + (*infoPtr->clearProc)(infoPtr->clearData); + } + ckfree((char *) infoPtr); + } +} + +/* + *-------------------------------------------------------------- + * + * SelGetProc -- + * + * This procedure is invoked to process pieces of the selection + * as they arrive during "selection get" commands. + * + * Results: + * Always returns TCL_OK. + * + * Side effects: + * Bytes get appended to the dynamic string pointed to by the + * clientData argument. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +SelGetProc(clientData, interp, portion) + ClientData clientData; /* Dynamic string holding partially + * assembled selection. */ + Tcl_Interp *interp; /* Interpreter used for error + * reporting (not used). */ + char *portion; /* New information to be appended. */ +{ + Tcl_DStringAppend((Tcl_DString *) clientData, portion, -1); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * HandleTclCommand -- + * + * This procedure acts as selection handler for handlers created + * by the "selection handle" command. It invokes a Tcl command to + * retrieve the selection. + * + * Results: + * The return value is a count of the number of bytes actually + * stored at buffer, or -1 if an error occurs while executing + * the Tcl command to retrieve the selection. + * + * Side effects: + * None except for things done by the Tcl command. + * + *---------------------------------------------------------------------- + */ + +static int +HandleTclCommand(clientData, offset, buffer, maxBytes) + ClientData clientData; /* Information about command to execute. */ + int offset; /* Return selection bytes starting at this + * offset. */ + char *buffer; /* Place to store converted selection. */ + int maxBytes; /* Maximum # of bytes to store at buffer. */ +{ + CommandInfo *cmdInfoPtr = (CommandInfo *) clientData; + int spaceNeeded, length; +#define MAX_STATIC_SIZE 100 + char staticSpace[MAX_STATIC_SIZE]; + char *command; + Tcl_Interp *interp; + Tcl_DString oldResult; + + /* + * We must copy the interpreter pointer from CommandInfo because the + * command could delete the handler, freeing the CommandInfo data before we + * are done using it. We must also protect the interpreter from being + * deleted too soo. + */ + + interp = cmdInfoPtr->interp; + Tcl_Preserve((ClientData) interp); + + /* + * First, generate a command by taking the command string + * and appending the offset and maximum # of bytes. + */ + + spaceNeeded = cmdInfoPtr->cmdLength + 30; + if (spaceNeeded < MAX_STATIC_SIZE) { + command = staticSpace; + } else { + command = (char *) ckalloc((unsigned) spaceNeeded); + } + sprintf(command, "%s %d %d", cmdInfoPtr->command, offset, maxBytes); + + /* + * Execute the command. Be sure to restore the state of the + * interpreter after executing the command. + */ + + Tcl_DStringInit(&oldResult); + Tcl_DStringGetResult(interp, &oldResult); + if (TkCopyAndGlobalEval(interp, command) == TCL_OK) { + length = strlen(interp->result); + if (length > maxBytes) { + length = maxBytes; + } + memcpy((VOID *) buffer, (VOID *) interp->result, (size_t) length); + buffer[length] = '\0'; + } else { + length = -1; + } + Tcl_DStringResult(interp, &oldResult); + + if (command != staticSpace) { + ckfree(command); + } + + Tcl_Release((ClientData) interp); + return length; +} + +/* + *---------------------------------------------------------------------- + * + * TkSelDefaultSelection -- + * + * This procedure is called to generate selection information + * for a few standard targets such as TIMESTAMP and TARGETS. + * It is invoked only if no handler has been declared by the + * application. + * + * Results: + * If "target" is a standard target understood by this procedure, + * the selection is converted to that form and stored as a + * character string in buffer. The type of the selection (e.g. + * STRING or ATOM) is stored in *typePtr, and the return value is + * a count of the # of non-NULL bytes at buffer. If the target + * wasn't understood, or if there isn't enough space at buffer + * to hold the entire selection (no INCR-mode transfers for this + * stuff!), then -1 is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TkSelDefaultSelection(infoPtr, target, buffer, maxBytes, typePtr) + TkSelectionInfo *infoPtr; /* Info about selection being retrieved. */ + Atom target; /* Desired form of selection. */ + char *buffer; /* Place to put selection characters. */ + int maxBytes; /* Maximum # of bytes to store at buffer. */ + Atom *typePtr; /* Store here the type of the selection, + * for use in converting to proper X format. */ +{ + register TkWindow *winPtr = (TkWindow *) infoPtr->owner; + TkDisplay *dispPtr = winPtr->dispPtr; + + if (target == dispPtr->timestampAtom) { + if (maxBytes < 20) { + return -1; + } + sprintf(buffer, "0x%x", (unsigned int) infoPtr->time); + *typePtr = XA_INTEGER; + return strlen(buffer); + } + + if (target == dispPtr->targetsAtom) { + register TkSelHandler *selPtr; + char *atomString; + int length, atomLength; + + if (maxBytes < 50) { + return -1; + } + strcpy(buffer, "MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW"); + length = strlen(buffer); + for (selPtr = winPtr->selHandlerList; selPtr != NULL; + selPtr = selPtr->nextPtr) { + if ((selPtr->selection == infoPtr->selection) + && (selPtr->target != dispPtr->applicationAtom) + && (selPtr->target != dispPtr->windowAtom)) { + atomString = Tk_GetAtomName((Tk_Window) winPtr, + selPtr->target); + atomLength = strlen(atomString) + 1; + if ((length + atomLength) >= maxBytes) { + return -1; + } + sprintf(buffer+length, " %s", atomString); + length += atomLength; + } + } + *typePtr = XA_ATOM; + return length; + } + + if (target == dispPtr->applicationAtom) { + int length; + char *name = winPtr->mainPtr->winPtr->nameUid; + + length = strlen(name); + if (maxBytes <= length) { + return -1; + } + strcpy(buffer, name); + *typePtr = XA_STRING; + return length; + } + + if (target == dispPtr->windowAtom) { + int length; + char *name = winPtr->pathName; + + length = strlen(name); + if (maxBytes <= length) { + return -1; + } + strcpy(buffer, name); + *typePtr = XA_STRING; + return length; + } + + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * LostSelection -- + * + * This procedure is invoked when a window has lost ownership of + * the selection and the ownership was claimed with the command + * "selection own". + * + * Results: + * None. + * + * Side effects: + * A Tcl script is executed; it can do almost anything. + * + *---------------------------------------------------------------------- + */ + +static void +LostSelection(clientData) + ClientData clientData; /* Pointer to CommandInfo structure. */ +{ + LostCommand *lostPtr = (LostCommand *) clientData; + char *oldResultString; + Tcl_FreeProc *oldFreeProc; + Tcl_Interp *interp; + + interp = lostPtr->interp; + Tcl_Preserve((ClientData) interp); + + /* + * Execute the command. Save the interpreter's result, if any, and + * restore it after executing the command. + */ + + oldFreeProc = interp->freeProc; + if (oldFreeProc != TCL_STATIC) { + oldResultString = interp->result; + } else { + oldResultString = (char *) ckalloc((unsigned) + (strlen(interp->result) + 1)); + strcpy(oldResultString, interp->result); + oldFreeProc = TCL_DYNAMIC; + } + interp->freeProc = TCL_STATIC; + if (TkCopyAndGlobalEval(interp, lostPtr->command) != TCL_OK) { + Tcl_BackgroundError(interp); + } + Tcl_FreeResult(interp); + interp->result = oldResultString; + interp->freeProc = oldFreeProc; + + Tcl_Release((ClientData) interp); + + /* + * Free the storage for the command, since we're done with it now. + */ + + ckfree((char *) lostPtr); +} diff --git a/tk4.2/generic/tkSelect.h b/tk4.2/generic/tkSelect.h new file mode 100644 index 0000000..8595599 --- /dev/null +++ b/tk4.2/generic/tkSelect.h @@ -0,0 +1,184 @@ +/* + * tkSelect.h -- + * + * Declarations of types shared among the files that implement + * selection support. + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkSelect.h 1.4 95/11/03 13:22:41 + */ + +#ifndef _TKSELECT +#define _TKSELECT + +/* + * When a selection is owned by a window on a given display, one of the + * following structures is present on a list of current selections in the + * display structure. The structure is used to record the current owner of + * a selection for use in later retrieval requests. There is a list of + * such structures because a display can have multiple different selections + * active at the same time. + */ + +typedef struct TkSelectionInfo { + Atom selection; /* Selection name, e.g. XA_PRIMARY. */ + Tk_Window owner; /* Current owner of this selection. */ + int serial; /* Serial number of last XSelectionSetOwner + * request made to server for this + * selection (used to filter out redundant + * SelectionClear events). */ + Time time; /* Timestamp used to acquire selection. */ + Tk_LostSelProc *clearProc; /* Procedure to call when owner loses + * selection. */ + ClientData clearData; /* Info to pass to clearProc. */ + struct TkSelectionInfo *nextPtr; + /* Next in list of current selections on + * this display. NULL means end of list */ +} TkSelectionInfo; + +/* + * One of the following structures exists for each selection handler + * created for a window by calling Tk_CreateSelHandler. The handlers + * are linked in a list rooted in the TkWindow structure. + */ + +typedef struct TkSelHandler { + Atom selection; /* Selection name, e.g. XA_PRIMARY */ + Atom target; /* Target type for selection + * conversion, such as TARGETS or + * STRING. */ + Atom format; /* Format in which selection + * info will be returned, such + * as STRING or ATOM. */ + Tk_SelectionProc *proc; /* Procedure to generate selection + * in this format. */ + ClientData clientData; /* Argument to pass to proc. */ + int size; /* Size of units returned by proc + * (8 for STRING, 32 for almost + * anything else). */ + struct TkSelHandler *nextPtr; + /* Next selection handler associated + * with same window (NULL for end of + * list). */ +} TkSelHandler; + +/* + * When the selection is being retrieved, one of the following + * structures is present on a list of pending selection retrievals. + * The structure is used to communicate between the background + * procedure that requests the selection and the foreground + * event handler that processes the events in which the selection + * is returned. There is a list of such structures so that there + * can be multiple simultaneous selection retrievals (e.g. on + * different displays). + */ + +typedef struct TkSelRetrievalInfo { + Tcl_Interp *interp; /* Interpreter for error reporting. */ + TkWindow *winPtr; /* Window used as requestor for + * selection. */ + Atom selection; /* Selection being requested. */ + Atom property; /* Property where selection will appear. */ + Atom target; /* Desired form for selection. */ + int (*proc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, + char *portion)); /* Procedure to call to handle pieces + * of selection. */ + ClientData clientData; /* Argument for proc. */ + int result; /* Initially -1. Set to a Tcl + * return value once the selection + * has been retrieved. */ + Tcl_TimerToken timeout; /* Token for current timeout procedure. */ + int idleTime; /* Number of seconds that have gone by + * without hearing anything from the + * selection owner. */ + struct TkSelRetrievalInfo *nextPtr; + /* Next in list of all pending + * selection retrievals. NULL means + * end of list. */ +} TkSelRetrievalInfo; + +/* + * The clipboard contains a list of buffers of various types and formats. + * All of the buffers of a given type will be returned in sequence when the + * CLIPBOARD selection is retrieved. All buffers of a given type on the + * same clipboard must have the same format. The TkClipboardTarget structure + * is used to record the information about a chain of buffers of the same + * type. + */ + +typedef struct TkClipboardBuffer { + char *buffer; /* Null terminated data buffer. */ + long length; /* Length of string in buffer. */ + struct TkClipboardBuffer *nextPtr; /* Next in list of buffers. NULL + * means end of list . */ +} TkClipboardBuffer; + +typedef struct TkClipboardTarget { + Atom type; /* Type conversion supported. */ + Atom format; /* Representation used for data. */ + TkClipboardBuffer *firstBufferPtr; /* First in list of data buffers. */ + TkClipboardBuffer *lastBufferPtr; /* Last in list of clipboard buffers. + * Used to speed up appends. */ + struct TkClipboardTarget *nextPtr; /* Next in list of targets on + * clipboard. NULL means end of + * list. */ +} TkClipboardTarget; + +/* + * It is possible for a Tk_SelectionProc to delete the handler that it + * represents. If this happens, the code that is retrieving the selection + * needs to know about it so it doesn't use the now-defunct handler + * structure. One structure of the following form is created for each + * retrieval in progress, so that the retriever can find out if its + * handler is deleted. All of the pending retrievals (if there are more + * than one) are linked into a list. + */ + +typedef struct TkSelInProgress { + TkSelHandler *selPtr; /* Handler being executed. If this handler + * is deleted, the field is set to NULL. */ + struct TkSelInProgress *nextPtr; + /* Next higher nested search. */ +} TkSelInProgress; + +/* + * Declarations for variables shared among the selection-related files: + */ + +extern TkSelInProgress *pendingPtr; + /* Topmost search in progress, or + * NULL if none. */ + +/* + * Chunk size for retrieving selection. It's defined both in + * words and in bytes; the word size is used to allocate + * buffer space that's guaranteed to be word-aligned and that + * has an extra character for the terminating NULL. + */ + +#define TK_SEL_BYTES_AT_ONCE 4000 +#define TK_SEL_WORDS_AT_ONCE 1001 + +/* + * Declarations for procedures that are used by the selection-related files + * but shouldn't be used anywhere else in Tk (or by Tk clients): + */ + +extern void TkSelClearSelection _ANSI_ARGS_((Tk_Window tkwin, + XEvent *eventPtr)); +extern int TkSelDefaultSelection _ANSI_ARGS_(( + TkSelectionInfo *infoPtr, Atom target, + char *buffer, int maxBytes, Atom *typePtr)); +extern int TkSelGetSelection _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, Atom selection, Atom target, + Tk_GetSelProc *proc, ClientData clientData)); +#ifndef TkSelUpdateClipboard +extern void TkSelUpdateClipboard _ANSI_ARGS_((TkWindow *winPtr, + TkClipboardTarget *targetPtr)); +#endif + +#endif /* _TKSELECT */ diff --git a/tk4.2/generic/tkSend.c b/tk4.2/generic/tkSend.c new file mode 100644 index 0000000..074ce5a --- /dev/null +++ b/tk4.2/generic/tkSend.c @@ -0,0 +1,1867 @@ +/* + * tkSend.c -- + * + * This file provides procedures that implement the "send" + * command, allowing commands to be passed from interpreter + * to interpreter. + * + * Copyright (c) 1989-1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkSend.c 1.64 96/07/20 17:38:32 + */ + +#include "tkPort.h" +#include "tkInt.h" + +/* + * The following structure is used to keep track of the interpreters + * registered by this process. + */ + +typedef struct RegisteredInterp { + char *name; /* Interpreter's name (malloc-ed). */ + Tcl_Interp *interp; /* Interpreter associated with name. NULL + * means that the application was unregistered + * or deleted while a send was in progress + * to it. */ + TkDisplay *dispPtr; /* Display for the application. Needed + * because we may need to unregister the + * interpreter after its main window has + * been deleted. */ + struct RegisteredInterp *nextPtr; + /* Next in list of names associated + * with interps in this process. + * NULL means end of list. */ +} RegisteredInterp; + +static RegisteredInterp *registry = NULL; + /* List of all interpreters + * registered by this process. */ + +/* + * A registry of all interpreters for a display is kept in a + * property "InterpRegistry" on the root window of the display. + * It is organized as a series of zero or more concatenated strings + * (in no particular order), each of the form + * window space name '\0' + * where "window" is the hex id of the comm. window to use to talk + * to an interpreter named "name". + * + * When the registry is being manipulated by an application (e.g. to + * add or remove an entry), it is loaded into memory using a structure + * of the following type: + */ + +typedef struct NameRegistry { + TkDisplay *dispPtr; /* Display from which the registry was + * read. */ + int locked; /* Non-zero means that the display was + * locked when the property was read in. */ + int modified; /* Non-zero means that the property has + * been modified, so it needs to be written + * out when the NameRegistry is closed. */ + unsigned long propLength; /* Length of the property, in bytes. */ + char *property; /* The contents of the property, or NULL + * if none. See format description above; + * this is *not* terminated by the first + * null character. Dynamically allocated. */ + int allocedByX; /* Non-zero means must free property with + * XFree; zero means use ckfree. */ +} NameRegistry; + +/* + * When a result is being awaited from a sent command, one of + * the following structures is present on a list of all outstanding + * sent commands. The information in the structure is used to + * process the result when it arrives. You're probably wondering + * how there could ever be multiple outstanding sent commands. + * This could happen if interpreters invoke each other recursively. + * It's unlikely, but possible. + */ + +typedef struct PendingCommand { + int serial; /* Serial number expected in + * result. */ + TkDisplay *dispPtr; /* Display being used for communication. */ + char *target; /* Name of interpreter command is + * being sent to. */ + Window commWindow; /* Target's communication window. */ + Tcl_Interp *interp; /* Interpreter from which the send + * was invoked. */ + int code; /* Tcl return code for command + * will be stored here. */ + char *result; /* String result for command (malloc'ed), + * or NULL. */ + char *errorInfo; /* Information for "errorInfo" variable, + * or NULL (malloc'ed). */ + char *errorCode; /* Information for "errorCode" variable, + * or NULL (malloc'ed). */ + int gotResponse; /* 1 means a response has been received, + * 0 means the command is still outstanding. */ + struct PendingCommand *nextPtr; + /* Next in list of all outstanding + * commands. NULL means end of + * list. */ +} PendingCommand; + +static PendingCommand *pendingCommands = NULL; + /* List of all commands currently + * being waited for. */ + +/* + * The information below is used for communication between processes + * during "send" commands. Each process keeps a private window, never + * even mapped, with one property, "Comm". When a command is sent to + * an interpreter, the command is appended to the comm property of the + * communication window associated with the interp's process. Similarly, + * when a result is returned from a sent command, it is also appended + * to the comm property. + * + * Each command and each result takes the form of ASCII text. For a + * command, the text consists of a zero character followed by several + * null-terminated ASCII strings. The first string consists of the + * single letter "c". Subsequent strings have the form "option value" + * where the following options are supported: + * + * -r commWindow serial + * + * This option means that a response should be sent to the window + * whose X identifier is "commWindow" (in hex), and the response should + * be identified with the serial number given by "serial" (in decimal). + * If this option isn't specified then the send is asynchronous and + * no response is sent. + * + * -n name + * "Name" gives the name of the application for which the command is + * intended. This option must be present. + * + * -s script + * + * "Script" is the script to be executed. This option must be present. + * + * The options may appear in any order. The -n and -s options must be + * present, but -r may be omitted for asynchronous RPCs. For compatibility + * with future releases that may add new features, there may be additional + * options present; as long as they start with a "-" character, they will + * be ignored. + * + * A result also consists of a zero character followed by several null- + * terminated ASCII strings. The first string consists of the single + * letter "r". Subsequent strings have the form "option value" where + * the following options are supported: + * + * -s serial + * + * Identifies the command for which this is the result. It is the + * same as the "serial" field from the -s option in the command. This + * option must be present. + * + * -c code + * + * "Code" is the completion code for the script, in decimal. If the + * code is omitted it defaults to TCL_OK. + * + * -r result + * + * "Result" is the result string for the script, which may be either + * a result or an error message. If this field is omitted then it + * defaults to an empty string. + * + * -i errorInfo + * + * "ErrorInfo" gives a string with which to initialize the errorInfo + * variable. This option may be omitted; it is ignored unless the + * completion code is TCL_ERROR. + * + * -e errorCode + * + * "ErrorCode" gives a string with with to initialize the errorCode + * variable. This option may be omitted; it is ignored unless the + * completion code is TCL_ERROR. + * + * Options may appear in any order, and only the -s option must be + * present. As with commands, there may be additional options besides + * these; unknown options are ignored. + */ + +/* + * The following variable is the serial number that was used in the + * last "send" command. It is exported only for testing purposes. + */ + +int tkSendSerial = 0; + +/* + * Maximum size property that can be read at one time by + * this module: + */ + +#define MAX_PROP_WORDS 100000 + +/* + * The following variable can be set while debugging to do things like + * skip locking the server. + */ + +static int sendDebug = 0; + +/* + * Forward declarations for procedures defined later in this file: + */ + +static int AppendErrorProc _ANSI_ARGS_((ClientData clientData, + XErrorEvent *errorPtr)); +static void AppendPropCarefully _ANSI_ARGS_((Display *display, + Window window, Atom property, char *value, + int length, PendingCommand *pendingPtr)); +static void DeleteProc _ANSI_ARGS_((ClientData clientData)); +static void RegAddName _ANSI_ARGS_((NameRegistry *regPtr, + char *name, Window commWindow)); +static void RegClose _ANSI_ARGS_((NameRegistry *regPtr)); +static void RegDeleteName _ANSI_ARGS_((NameRegistry *regPtr, + char *name)); +static Window RegFindName _ANSI_ARGS_((NameRegistry *regPtr, + char *name)); +static NameRegistry * RegOpen _ANSI_ARGS_((Tcl_Interp *interp, + TkDisplay *dispPtr, int lock)); +static void SendEventProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +static int SendInit _ANSI_ARGS_((Tcl_Interp *interp, + TkDisplay *dispPtr)); +static Tk_RestrictAction SendRestrictProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +static int ServerSecure _ANSI_ARGS_((TkDisplay *dispPtr)); +static void TimeoutProc _ANSI_ARGS_((ClientData clientData)); +static void UpdateCommWindow _ANSI_ARGS_((TkDisplay *dispPtr)); +static int ValidateName _ANSI_ARGS_((TkDisplay *dispPtr, + char *name, Window commWindow, int oldOK)); + +/* + *---------------------------------------------------------------------- + * + * RegOpen -- + * + * This procedure loads the name registry for a display into + * memory so that it can be manipulated. + * + * Results: + * The return value is a pointer to the loaded registry. + * + * Side effects: + * If "lock" is set then the server will be locked. It is the + * caller's responsibility to call RegClose when finished with + * the registry, so that we can write back the registry if + * neeeded, unlock the server if needed, and free memory. + * + *---------------------------------------------------------------------- + */ + +static NameRegistry * +RegOpen(interp, dispPtr, lock) + Tcl_Interp *interp; /* Interpreter to use for error reporting + * (errors cause a panic so in fact no + * error is ever returned, but the interpreter + * is needed anyway). */ + TkDisplay *dispPtr; /* Display whose name registry is to be + * opened. */ + int lock; /* Non-zero means lock the window server + * when opening the registry, so no-one + * else can use the registry until we + * close it. */ +{ + NameRegistry *regPtr; + int result, actualFormat; + unsigned long bytesAfter; + Atom actualType; + + if (dispPtr->commTkwin == NULL) { + SendInit(interp, dispPtr); + } + + regPtr = (NameRegistry *) ckalloc(sizeof(NameRegistry)); + regPtr->dispPtr = dispPtr; + regPtr->locked = 0; + regPtr->modified = 0; + regPtr->allocedByX = 1; + + if (lock && !sendDebug) { + XGrabServer(dispPtr->display); + regPtr->locked = 1; + } + + /* + * Read the registry property. + */ + + result = XGetWindowProperty(dispPtr->display, + RootWindow(dispPtr->display, 0), + dispPtr->registryProperty, 0, MAX_PROP_WORDS, + False, XA_STRING, &actualType, &actualFormat, + ®Ptr->propLength, &bytesAfter, + (unsigned char **) ®Ptr->property); + + if (actualType == None) { + regPtr->propLength = 0; + regPtr->property = NULL; + } else if ((result != Success) || (actualFormat != 8) + || (actualType != XA_STRING)) { + /* + * The property is improperly formed; delete it. + */ + + if (regPtr->property != NULL) { + XFree(regPtr->property); + regPtr->propLength = 0; + regPtr->property = NULL; + } + XDeleteProperty(dispPtr->display, + RootWindow(dispPtr->display, 0), + dispPtr->registryProperty); + } + + /* + * Xlib placed an extra null byte after the end of the property, just + * to make sure that it is always NULL-terminated. Be sure to include + * this byte in our count if it's needed to ensure null termination + * (note: as of 8/95 I'm no longer sure why this code is needed; seems + * like it shouldn't be). + */ + + if ((regPtr->propLength > 0) + && (regPtr->property[regPtr->propLength-1] != 0)) { + regPtr->propLength++; + } + return regPtr; +} + +/* + *---------------------------------------------------------------------- + * + * RegFindName -- + * + * Given an open name registry, this procedure finds an entry + * with a given name, if there is one, and returns information + * about that entry. + * + * Results: + * The return value is the X identifier for the comm window for + * the application named "name", or None if there is no such + * entry in the registry. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Window +RegFindName(regPtr, name) + NameRegistry *regPtr; /* Pointer to a registry opened with a + * previous call to RegOpen. */ + char *name; /* Name of an application. */ +{ + char *p, *entry; + Window commWindow; + + commWindow = None; + for (p = regPtr->property; (p-regPtr->property) < regPtr->propLength; ) { + entry = p; + while ((*p != 0) && (!isspace(UCHAR(*p)))) { + p++; + } + if ((*p != 0) && (strcmp(name, p+1) == 0)) { + if (sscanf(entry, "%x", (unsigned int *) &commWindow) == 1) { + return commWindow; + } + } + while (*p != 0) { + p++; + } + p++; + } + return None; +} + +/* + *---------------------------------------------------------------------- + * + * RegDeleteName -- + * + * This procedure deletes the entry for a given name from + * an open registry. + * + * Results: + * None. + * + * Side effects: + * If there used to be an entry named "name" in the registry, + * then it is deleted and the registry is marked as modified + * so it will be written back when closed. + * + *---------------------------------------------------------------------- + */ + +static void +RegDeleteName(regPtr, name) + NameRegistry *regPtr; /* Pointer to a registry opened with a + * previous call to RegOpen. */ + char *name; /* Name of an application. */ +{ + char *p, *entry, *entryName; + int count; + + for (p = regPtr->property; (p-regPtr->property) < regPtr->propLength; ) { + entry = p; + while ((*p != 0) && (!isspace(UCHAR(*p)))) { + p++; + } + if (*p != 0) { + p++; + } + entryName = p; + while (*p != 0) { + p++; + } + p++; + if ((strcmp(name, entryName) == 0)) { + /* + * Found the matching entry. Copy everything after it + * down on top of it. + */ + + count = regPtr->propLength - (p - regPtr->property); + if (count > 0) { + memmove((VOID *) entry, (VOID *) p, (size_t) count); + } + regPtr->propLength -= p - entry; + regPtr->modified = 1; + return; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * RegAddName -- + * + * Add a new entry to an open registry. + * + * Results: + * None. + * + * Side effects: + * The open registry is expanded; it is marked as modified so that + * it will be written back when closed. + * + *---------------------------------------------------------------------- + */ + +static void +RegAddName(regPtr, name, commWindow) + NameRegistry *regPtr; /* Pointer to a registry opened with a + * previous call to RegOpen. */ + char *name; /* Name of an application. The caller + * must ensure that this name isn't + * already registered. */ + Window commWindow; /* X identifier for comm. window of + * application. */ +{ + char id[30]; + char *newProp; + int idLength, newBytes; + + sprintf(id, "%x ", (unsigned int) commWindow); + idLength = strlen(id); + newBytes = idLength + strlen(name) + 1; + newProp = (char *) ckalloc((unsigned) (regPtr->propLength + newBytes)); + strcpy(newProp, id); + strcpy(newProp+idLength, name); + if (regPtr->property != NULL) { + memcpy((VOID *) (newProp + newBytes), (VOID *) regPtr->property, + regPtr->propLength); + if (regPtr->allocedByX) { + XFree(regPtr->property); + } else { + ckfree(regPtr->property); + } + } + regPtr->modified = 1; + regPtr->propLength += newBytes; + regPtr->property = newProp; + regPtr->allocedByX = 0; +} + +/* + *---------------------------------------------------------------------- + * + * RegClose -- + * + * This procedure is called to end a series of operations on + * a name registry. + * + * Results: + * None. + * + * Side effects: + * The registry is written back if it has been modified, and the + * X server is unlocked if it was locked. Memory for the + * registry is freed, so the caller should never use regPtr + * again. + * + *---------------------------------------------------------------------- + */ + +static void +RegClose(regPtr) + NameRegistry *regPtr; /* Pointer to a registry opened with a + * previous call to RegOpen. */ +{ + if (regPtr->modified) { + if (!regPtr->locked && !sendDebug) { + panic("The name registry was modified without being locked!"); + } + XChangeProperty(regPtr->dispPtr->display, + RootWindow(regPtr->dispPtr->display, 0), + regPtr->dispPtr->registryProperty, XA_STRING, 8, + PropModeReplace, (unsigned char *) regPtr->property, + (int) regPtr->propLength); + } + + if (regPtr->locked) { + XUngrabServer(regPtr->dispPtr->display); + } + XFlush(regPtr->dispPtr->display); + + if (regPtr->property != NULL) { + if (regPtr->allocedByX) { + XFree(regPtr->property); + } else { + ckfree(regPtr->property); + } + } + ckfree((char *) regPtr); +} + +/* + *---------------------------------------------------------------------- + * + * ValidateName -- + * + * This procedure checks to see if an entry in the registry + * is still valid. + * + * Results: + * The return value is 1 if the given commWindow exists and its + * name is "name". Otherwise 0 is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ValidateName(dispPtr, name, commWindow, oldOK) + TkDisplay *dispPtr; /* Display for which to perform the + * validation. */ + char *name; /* The name of an application. */ + Window commWindow; /* X identifier for the application's + * comm. window. */ + int oldOK; /* Non-zero means that we should consider + * an application to be valid even if it + * looks like an old-style (pre-4.0) one; + * 0 means consider these invalid. */ +{ + int result, actualFormat, argc, i; + unsigned long length, bytesAfter; + Atom actualType; + char *property; + Tk_ErrorHandler handler; + char **argv; + + property = NULL; + + /* + * Ignore X errors when reading the property (e.g., the window + * might not exist). If an error occurs, result will be some + * value other than Success. + */ + + handler = Tk_CreateErrorHandler(dispPtr->display, -1, -1, -1, + (Tk_ErrorProc *) NULL, (ClientData) NULL); + result = XGetWindowProperty(dispPtr->display, commWindow, + dispPtr->appNameProperty, 0, MAX_PROP_WORDS, + False, XA_STRING, &actualType, &actualFormat, + &length, &bytesAfter, (unsigned char **) &property); + + if ((result == Success) && (actualType == None)) { + XWindowAttributes atts; + + /* + * The comm. window exists but the property we're looking for + * doesn't exist. This probably means that the application + * comes from an older version of Tk (< 4.0) that didn't set the + * property; if this is the case, then assume for compatibility's + * sake that everything's OK. However, it's also possible that + * some random application has re-used the window id for something + * totally unrelated. Check a few characteristics of the window, + * such as its dimensions and mapped state, to be sure that it + * still "smells" like a commWindow. + */ + + if (!oldOK + || !XGetWindowAttributes(dispPtr->display, commWindow, &atts) + || (atts.width != 1) || (atts.height != 1) + || (atts.map_state != IsUnmapped)) { + result = 0; + } else { + result = 1; + } + } else if ((result == Success) && (actualFormat == 8) + && (actualType == XA_STRING)) { + result = 0; + if (Tcl_SplitList((Tcl_Interp *) NULL, property, &argc, &argv) + == TCL_OK) { + for (i = 0; i < argc; i++) { + if (strcmp(argv[i], name) == 0) { + result = 1; + break; + } + } + ckfree((char *) argv); + } + } else { + result = 0; + } + Tk_DeleteErrorHandler(handler); + if (property != NULL) { + XFree(property); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * ServerSecure -- + * + * Check whether a server is secure enough for us to trust + * Tcl scripts arriving via that server. + * + * Results: + * The return value is 1 if the server is secure, which means + * that host-style authentication is turned on but there are + * no hosts in the enabled list. This means that some other + * form of authorization (presumably more secure, such as xauth) + * is in use. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ServerSecure(dispPtr) + TkDisplay *dispPtr; /* Display to check. */ +{ +#ifdef TK_NO_SECURITY + return 1; +#else + XHostAddress *addrPtr; + int numHosts, secure; + Bool enabled; + + secure = 0; + addrPtr = XListHosts(dispPtr->display, &numHosts, &enabled); + if (enabled && (numHosts == 0)) { + secure = 1; + } + if (addrPtr != NULL) { + XFree((char *) addrPtr); + } + return secure; +#endif /* TK_NO_SECURITY */ +} + +/* + *-------------------------------------------------------------- + * + * Tk_SetAppName -- + * + * This procedure is called to associate an ASCII name with a Tk + * application. If the application has already been named, the + * name replaces the old one. + * + * Results: + * The return value is the name actually given to the application. + * This will normally be the same as name, but if name was already + * in use for an application then a name of the form "name #2" will + * be chosen, with a high enough number to make the name unique. + * + * Side effects: + * Registration info is saved, thereby allowing the "send" command + * to be used later to invoke commands in the application. In + * addition, the "send" command is created in the application's + * interpreter. The registration will be removed automatically + * if the interpreter is deleted or the "send" command is removed. + * + *-------------------------------------------------------------- + */ + +char * +Tk_SetAppName(tkwin, name) + Tk_Window tkwin; /* Token for any window in the application + * to be named: it is just used to identify + * the application and the display. */ + char *name; /* The name that will be used to + * refer to the interpreter in later + * "send" commands. Must be globally + * unique. */ +{ + RegisteredInterp *riPtr, *riPtr2; + Window w; + TkWindow *winPtr = (TkWindow *) tkwin; + TkDisplay *dispPtr; + NameRegistry *regPtr; + Tcl_Interp *interp; + char *actualName; + Tcl_DString dString; + int offset, i; + +#ifdef __WIN32__ + return name; +#endif /* __WIN32__ */ + + dispPtr = winPtr->dispPtr; + interp = winPtr->mainPtr->interp; + if (dispPtr->commTkwin == NULL) { + SendInit(interp, winPtr->dispPtr); + } + + /* + * See if the application is already registered; if so, remove its + * current name from the registry. + */ + + regPtr = RegOpen(interp, winPtr->dispPtr, 1); + for (riPtr = registry; ; riPtr = riPtr->nextPtr) { + if (riPtr == NULL) { + /* + * This interpreter isn't currently registered; create + * the data structure that will be used to register it locally, + * plus add the "send" command to the interpreter. + */ + + riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp)); + riPtr->interp = interp; + riPtr->dispPtr = winPtr->dispPtr; + riPtr->nextPtr = registry; + registry = riPtr; + Tcl_CreateCommand(interp, "send", Tk_SendCmd, (ClientData) riPtr, + DeleteProc); + break; + } + if (riPtr->interp == interp) { + /* + * The interpreter is currently registered; remove it from + * the name registry. + */ + + RegDeleteName(regPtr, riPtr->name); + ckfree(riPtr->name); + break; + } + } + + /* + * Pick a name to use for the application. Use "name" if it's not + * already in use. Otherwise add a suffix such as " #2", trying + * larger and larger numbers until we eventually find one that is + * unique. + */ + + actualName = name; + offset = 0; /* Needed only to avoid "used before + * set" compiler warnings. */ + for (i = 1; ; i++) { + if (i > 1) { + if (i == 2) { + Tcl_DStringInit(&dString); + Tcl_DStringAppend(&dString, name, -1); + Tcl_DStringAppend(&dString, " #", 2); + offset = Tcl_DStringLength(&dString); + Tcl_DStringSetLength(&dString, offset+10); + actualName = Tcl_DStringValue(&dString); + } + sprintf(actualName + offset, "%d", i); + } + w = RegFindName(regPtr, actualName); + if (w == None) { + break; + } + + /* + * The name appears to be in use already, but double-check to + * be sure (perhaps the application died without removing its + * name from the registry?). + */ + + if (w == Tk_WindowId(dispPtr->commTkwin)) { + for (riPtr2 = registry; riPtr2 != NULL; riPtr2 = riPtr2->nextPtr) { + if ((riPtr2->interp != interp) && + (strcmp(riPtr2->name, actualName) == 0)) { + goto nextSuffix; + } + } + RegDeleteName(regPtr, actualName); + break; + } else if (!ValidateName(winPtr->dispPtr, actualName, w, 1)) { + RegDeleteName(regPtr, actualName); + break; + } + nextSuffix: + continue; + } + + /* + * We've now got a name to use. Store it in the name registry and + * in the local entry for this application, plus put it in a property + * on the commWindow. + */ + + RegAddName(regPtr, actualName, Tk_WindowId(dispPtr->commTkwin)); + RegClose(regPtr); + riPtr->name = (char *) ckalloc((unsigned) (strlen(actualName) + 1)); + strcpy(riPtr->name, actualName); + if (actualName != name) { + Tcl_DStringFree(&dString); + } + UpdateCommWindow(dispPtr); + + return riPtr->name; +} + +/* + *-------------------------------------------------------------- + * + * Tk_SendCmd -- + * + * This procedure is invoked to process the "send" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +int +Tk_SendCmd(clientData, interp, argc, argv) + ClientData clientData; /* Information about sender (only + * dispPtr field is used). */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + TkWindow *winPtr; + Window commWindow; + PendingCommand pending; + register RegisteredInterp *riPtr; + char *destName, buffer[30]; + int result, c, async, i, firstArg; + size_t length; + Tk_RestrictProc *prevRestrictProc; + ClientData prevArg; + TkDisplay *dispPtr; + NameRegistry *regPtr; + Tcl_DString request; + Tcl_Interp *localInterp; /* Used when the interpreter to + * send the command to is within + * the same process. */ + + /* + * Process options, if any. + */ + + async = 0; + winPtr = (TkWindow *) Tk_MainWindow(interp); + if (winPtr == NULL) { + return TCL_ERROR; + } + for (i = 1; i < (argc-1); ) { + if (argv[i][0] != '-') { + break; + } + c = argv[i][1]; + length = strlen(argv[i]); + if ((c == 'a') && (strncmp(argv[i], "-async", length) == 0)) { + async = 1; + i++; + } else if ((c == 'd') && (strncmp(argv[i], "-displayof", + length) == 0)) { + winPtr = (TkWindow *) Tk_NameToWindow(interp, argv[i+1], + (Tk_Window) winPtr); + if (winPtr == NULL) { + return TCL_ERROR; + } + i += 2; + } else if (strcmp(argv[i], "--") == 0) { + i++; + break; + } else { + Tcl_AppendResult(interp, "bad option \"", argv[i], + "\": must be -async, -displayof, or --", (char *) NULL); + return TCL_ERROR; + } + } + + if (argc < (i+2)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?options? interpName arg ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + destName = argv[i]; + firstArg = i+1; + + dispPtr = winPtr->dispPtr; + if (dispPtr->commTkwin == NULL) { + SendInit(interp, winPtr->dispPtr); + } + + /* + * See if the target interpreter is local. If so, execute + * the command directly without going through the X server. + * The only tricky thing is passing the result from the target + * interpreter to the invoking interpreter. Watch out: they + * could be the same! + */ + + for (riPtr = registry; riPtr != NULL; riPtr = riPtr->nextPtr) { + if ((riPtr->dispPtr != dispPtr) + || (strcmp(riPtr->name, destName) != 0)) { + continue; + } + Tcl_Preserve((ClientData) riPtr); + localInterp = riPtr->interp; + Tcl_Preserve((ClientData) localInterp); + if (firstArg == (argc-1)) { + result = Tcl_GlobalEval(localInterp, argv[firstArg]); + } else { + Tcl_DStringInit(&request); + Tcl_DStringAppend(&request, argv[firstArg], -1); + for (i = firstArg+1; i < argc; i++) { + Tcl_DStringAppend(&request, " ", 1); + Tcl_DStringAppend(&request, argv[i], -1); + } + result = Tcl_GlobalEval(localInterp, Tcl_DStringValue(&request)); + Tcl_DStringFree(&request); + } + if (interp != localInterp) { + if (result == TCL_ERROR) { + + /* + * An error occurred, so transfer error information from the + * destination interpreter back to our interpreter. Must clear + * interp's result before calling Tcl_AddErrorInfo, since + * Tcl_AddErrorInfo will store the interp's result in errorInfo + * before appending riPtr's $errorInfo; we've already got + * everything we need in riPtr's $errorInfo. + */ + + Tcl_ResetResult(interp); + Tcl_AddErrorInfo(interp, Tcl_GetVar2(localInterp, + "errorInfo", (char *) NULL, TCL_GLOBAL_ONLY)); + Tcl_SetVar2(interp, "errorCode", (char *) NULL, + Tcl_GetVar2(localInterp, "errorCode", (char *) NULL, + TCL_GLOBAL_ONLY), TCL_GLOBAL_ONLY); + } + if (localInterp->freeProc != TCL_STATIC) { + interp->result = localInterp->result; + interp->freeProc = localInterp->freeProc; + localInterp->freeProc = TCL_STATIC; + } else { + Tcl_SetResult(interp, localInterp->result, TCL_VOLATILE); + } + Tcl_ResetResult(localInterp); + } + Tcl_Release((ClientData) riPtr); + Tcl_Release((ClientData) localInterp); + return result; + } + + /* + * Bind the interpreter name to a communication window. + */ + + regPtr = RegOpen(interp, winPtr->dispPtr, 0); + commWindow = RegFindName(regPtr, destName); + RegClose(regPtr); + if (commWindow == None) { + Tcl_AppendResult(interp, "no application named \"", + destName, "\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * Send the command to the target interpreter by appending it to the + * comm window in the communication window. + */ + + tkSendSerial++; + Tcl_DStringInit(&request); + Tcl_DStringAppend(&request, "\0c\0-n ", 6); + Tcl_DStringAppend(&request, destName, -1); + if (!async) { + sprintf(buffer, "%x %d", + (unsigned int) Tk_WindowId(dispPtr->commTkwin), + tkSendSerial); + Tcl_DStringAppend(&request, "\0-r ", 4); + Tcl_DStringAppend(&request, buffer, -1); + } + Tcl_DStringAppend(&request, "\0-s ", 4); + Tcl_DStringAppend(&request, argv[firstArg], -1); + for (i = firstArg+1; i < argc; i++) { + Tcl_DStringAppend(&request, " ", 1); + Tcl_DStringAppend(&request, argv[i], -1); + } + (void) AppendPropCarefully(dispPtr->display, commWindow, + dispPtr->commProperty, Tcl_DStringValue(&request), + Tcl_DStringLength(&request) + 1, + (async) ? (PendingCommand *) NULL : &pending); + Tcl_DStringFree(&request); + if (async) { + /* + * This is an asynchronous send: return immediately without + * waiting for a response. + */ + + return TCL_OK; + } + + /* + * Register the fact that we're waiting for a command to complete + * (this is needed by SendEventProc and by AppendErrorProc to pass + * back the command's results). Set up a timeout handler so that + * we can check during long sends to make sure that the destination + * application is still alive. + */ + + pending.serial = tkSendSerial; + pending.dispPtr = dispPtr; + pending.target = destName; + pending.commWindow = commWindow; + pending.interp = interp; + pending.result = NULL; + pending.errorInfo = NULL; + pending.errorCode = NULL; + pending.gotResponse = 0; + pending.nextPtr = pendingCommands; + pendingCommands = &pending; + + /* + * Enter a loop processing X events until the result comes + * in or the target is declared to be dead. While waiting + * for a result, look only at send-related events so that + * the send is synchronous with respect to other events in + * the application. + */ + + prevRestrictProc = Tk_RestrictEvents(SendRestrictProc, + (ClientData) NULL, &prevArg); + Tcl_CreateModalTimeout(1000, TimeoutProc, (ClientData) &pending); + while (!pending.gotResponse) { + Tcl_DoOneEvent(TCL_WINDOW_EVENTS); + } + Tcl_DeleteModalTimeout(TimeoutProc, (ClientData) &pending); + (void) Tk_RestrictEvents(prevRestrictProc, prevArg, &prevArg); + + /* + * Unregister the information about the pending command + * and return the result. + */ + + if (pendingCommands == &pending) { + pendingCommands = pending.nextPtr; + } else { + PendingCommand *pcPtr; + + for (pcPtr = pendingCommands; pcPtr != NULL; + pcPtr = pcPtr->nextPtr) { + if (pcPtr->nextPtr == &pending) { + pcPtr->nextPtr = pending.nextPtr; + break; + } + } + } + if (pending.errorInfo != NULL) { + /* + * Special trick: must clear the interp's result before calling + * Tcl_AddErrorInfo, since Tcl_AddErrorInfo will store the interp's + * result in errorInfo before appending pending.errorInfo; we've + * already got everything we need in pending.errorInfo. + */ + + Tcl_ResetResult(interp); + Tcl_AddErrorInfo(interp, pending.errorInfo); + ckfree(pending.errorInfo); + } + if (pending.errorCode != NULL) { + Tcl_SetVar2(interp, "errorCode", (char *) NULL, pending.errorCode, + TCL_GLOBAL_ONLY); + ckfree(pending.errorCode); + } + Tcl_SetResult(interp, pending.result, TCL_DYNAMIC); + return pending.code; +} + +/* + *---------------------------------------------------------------------- + * + * TkGetInterpNames -- + * + * This procedure is invoked to fetch a list of all the + * interpreter names currently registered for the display + * of a particular window. + * + * Results: + * A standard Tcl return value. Interp->result will be set + * to hold a list of all the interpreter names defined for + * tkwin's display. If an error occurs, then TCL_ERROR + * is returned and interp->result will hold an error message. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TkGetInterpNames(interp, tkwin) + Tcl_Interp *interp; /* Interpreter for returning a result. */ + Tk_Window tkwin; /* Window whose display is to be used + * for the lookup. */ +{ + TkWindow *winPtr = (TkWindow *) tkwin; + char *p, *entry, *entryName; + NameRegistry *regPtr; + Window commWindow; + int count; + + /* + * Read the registry property, then scan through all of its entries. + * Validate each entry to be sure that its application still exists. + */ + + regPtr = RegOpen(interp, winPtr->dispPtr, 1); + for (p = regPtr->property; (p-regPtr->property) < regPtr->propLength; ) { + entry = p; + if (sscanf(p, "%x",(unsigned int *) &commWindow) != 1) { + commWindow = None; + } + while ((*p != 0) && (!isspace(UCHAR(*p)))) { + p++; + } + if (*p != 0) { + p++; + } + entryName = p; + while (*p != 0) { + p++; + } + p++; + if (ValidateName(winPtr->dispPtr, entryName, commWindow, 1)) { + /* + * The application still exists; add its name to the result. + */ + + Tcl_AppendElement(interp, entryName); + } else { + /* + * This name is bogus (perhaps the application died without + * cleaning up its entry in the registry?). Delete the name. + */ + + count = regPtr->propLength - (p - regPtr->property); + if (count > 0) { + memmove((VOID *) entry, (VOID *) p, (size_t) count); + } + regPtr->propLength -= p - entry; + regPtr->modified = 1; + p = entry; + } + } + RegClose(regPtr); + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * SendInit -- + * + * This procedure is called to initialize the + * communication channels for sending commands and + * receiving results. + * + * Results: + * None. + * + * Side effects: + * Sets up various data structures and windows. + * + *-------------------------------------------------------------- + */ + +static int +SendInit(interp, dispPtr) + Tcl_Interp *interp; /* Interpreter to use for error reporting + * (no errors are ever returned, but the + * interpreter is needed anyway). */ + TkDisplay *dispPtr; /* Display to initialize. */ +{ + XSetWindowAttributes atts; + + /* + * Create the window used for communication, and set up an + * event handler for it. + */ + + dispPtr->commTkwin = Tk_CreateWindow(interp, (Tk_Window) NULL, + "_comm", DisplayString(dispPtr->display)); + if (dispPtr->commTkwin == NULL) { + panic("Tk_CreateWindow failed in SendInit!"); + } + atts.override_redirect = True; + Tk_ChangeWindowAttributes(dispPtr->commTkwin, + CWOverrideRedirect, &atts); + Tk_CreateEventHandler(dispPtr->commTkwin, PropertyChangeMask, + SendEventProc, (ClientData) dispPtr); + Tk_MakeWindowExist(dispPtr->commTkwin); + + /* + * Get atoms used as property names. + */ + + dispPtr->commProperty = Tk_InternAtom(dispPtr->commTkwin, "Comm"); + dispPtr->registryProperty = Tk_InternAtom(dispPtr->commTkwin, + "InterpRegistry"); + dispPtr->appNameProperty = Tk_InternAtom(dispPtr->commTkwin, + "TK_APPLICATION"); + + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * SendEventProc -- + * + * This procedure is invoked automatically by the toolkit + * event manager when a property changes on the communication + * window. This procedure reads the property and handles + * command requests and responses. + * + * Results: + * None. + * + * Side effects: + * If there are command requests in the property, they + * are executed. If there are responses in the property, + * their information is saved for the (ostensibly waiting) + * "send" commands. The property is deleted. + * + *-------------------------------------------------------------- + */ + +static void +SendEventProc(clientData, eventPtr) + ClientData clientData; /* Display information. */ + XEvent *eventPtr; /* Information about event. */ +{ + TkDisplay *dispPtr = (TkDisplay *) clientData; + char *propInfo; + register char *p; + int result, actualFormat; + unsigned long numItems, bytesAfter; + Atom actualType; + Tcl_Interp *remoteInterp; /* Interp in which to execute the command. */ + + if ((eventPtr->xproperty.atom != dispPtr->commProperty) + || (eventPtr->xproperty.state != PropertyNewValue)) { + return; + } + + /* + * Read the comm property and delete it. + */ + + propInfo = NULL; + result = XGetWindowProperty(dispPtr->display, + Tk_WindowId(dispPtr->commTkwin), + dispPtr->commProperty, 0, MAX_PROP_WORDS, True, + XA_STRING, &actualType, &actualFormat, + &numItems, &bytesAfter, (unsigned char **) &propInfo); + + /* + * If the property doesn't exist or is improperly formed + * then ignore it. + */ + + if ((result != Success) || (actualType != XA_STRING) + || (actualFormat != 8)) { + if (propInfo != NULL) { + XFree(propInfo); + } + return; + } + + /* + * Several commands and results could arrive in the property at + * one time; each iteration through the outer loop handles a + * single command or result. + */ + + for (p = propInfo; (p-propInfo) < numItems; ) { + /* + * Ignore leading NULLs; each command or result starts with a + * NULL so that no matter how badly formed a preceding command + * is, we'll be able to tell that a new command/result is + * starting. + */ + + if (*p == 0) { + p++; + continue; + } + + if ((*p == 'c') && (p[1] == 0)) { + Window commWindow; + char *interpName, *script, *serial, *end; + Tcl_DString reply; + RegisteredInterp *riPtr; + + /* + *---------------------------------------------------------- + * This is an incoming command from some other application. + * Iterate over all of its options. Stop when we reach + * the end of the property or something that doesn't look + * like an option. + *---------------------------------------------------------- + */ + + p += 2; + interpName = NULL; + commWindow = None; + serial = ""; + script = NULL; + while (((p-propInfo) < numItems) && (*p == '-')) { + switch (p[1]) { + case 'r': + commWindow = (Window) strtoul(p+2, &end, 16); + if ((end == p+2) || (*end != ' ')) { + commWindow = None; + } else { + p = serial = end+1; + } + break; + case 'n': + if (p[2] == ' ') { + interpName = p+3; + } + break; + case 's': + if (p[2] == ' ') { + script = p+3; + } + break; + } + while (*p != 0) { + p++; + } + p++; + } + + if ((script == NULL) || (interpName == NULL)) { + continue; + } + + /* + * Initialize the result property, so that we're ready at any + * time if we need to return an error. + */ + + if (commWindow != None) { + Tcl_DStringInit(&reply); + Tcl_DStringAppend(&reply, "\0r\0-s ", 6); + Tcl_DStringAppend(&reply, serial, -1); + Tcl_DStringAppend(&reply, "\0-r ", 4); + } + + if (!ServerSecure(dispPtr)) { + if (commWindow != None) { + Tcl_DStringAppend(&reply, "X server insecure (must use xauth-style authorization); command ignored", -1); + } + result = TCL_ERROR; + goto returnResult; + } + + /* + * Locate the application, then execute the script. + */ + + for (riPtr = registry; ; riPtr = riPtr->nextPtr) { + if (riPtr == NULL) { + if (commWindow != None) { + Tcl_DStringAppend(&reply, + "receiver never heard of interpreter \"", -1); + Tcl_DStringAppend(&reply, interpName, -1); + Tcl_DStringAppend(&reply, "\"", 1); + } + result = TCL_ERROR; + goto returnResult; + } + if (strcmp(riPtr->name, interpName) == 0) { + break; + } + } + Tcl_Preserve((ClientData) riPtr); + + /* + * We must protect the interpreter because the script may + * enter another event loop, which might call Tcl_DeleteInterp. + */ + + remoteInterp = riPtr->interp; + Tcl_Preserve((ClientData) remoteInterp); + + result = Tcl_GlobalEval(remoteInterp, script); + + /* + * The call to Tcl_Release may have released the interpreter + * which will cause the "send" command for that interpreter + * to be deleted. The command deletion callback will set the + * riPtr->interp field to NULL, hence the check below for NULL. + */ + + if (commWindow != None) { + Tcl_DStringAppend(&reply, remoteInterp->result, -1); + if (result == TCL_ERROR) { + char *varValue; + + varValue = Tcl_GetVar2(remoteInterp, "errorInfo", + (char *) NULL, TCL_GLOBAL_ONLY); + if (varValue != NULL) { + Tcl_DStringAppend(&reply, "\0-i ", 4); + Tcl_DStringAppend(&reply, varValue, -1); + } + varValue = Tcl_GetVar2(remoteInterp, "errorCode", + (char *) NULL, TCL_GLOBAL_ONLY); + if (varValue != NULL) { + Tcl_DStringAppend(&reply, "\0-e ", 4); + Tcl_DStringAppend(&reply, varValue, -1); + } + } + } + Tcl_Release((ClientData) remoteInterp); + Tcl_Release((ClientData) riPtr); + + /* + * Return the result to the sender if a commWindow was + * specified (if none was specified then this is an asynchronous + * call). Right now reply has everything but the completion + * code, but it needs the NULL to terminate the current option. + */ + + returnResult: + if (commWindow != None) { + if (result != TCL_OK) { + char buffer[20]; + + sprintf(buffer, "%d", result); + Tcl_DStringAppend(&reply, "\0-c ", 4); + Tcl_DStringAppend(&reply, buffer, -1); + } + (void) AppendPropCarefully(dispPtr->display, commWindow, + dispPtr->commProperty, Tcl_DStringValue(&reply), + Tcl_DStringLength(&reply) + 1, + (PendingCommand *) NULL); + XFlush(dispPtr->display); + Tcl_DStringFree(&reply); + } + } else if ((*p == 'r') && (p[1] == 0)) { + int serial, code, gotSerial; + char *errorInfo, *errorCode, *resultString; + PendingCommand *pcPtr; + + /* + *---------------------------------------------------------- + * This is a reply to some command that we sent out. Iterate + * over all of its options. Stop when we reach the end of the + * property or something that doesn't look like an option. + *---------------------------------------------------------- + */ + + p += 2; + code = TCL_OK; + gotSerial = 0; + errorInfo = NULL; + errorCode = NULL; + resultString = ""; + while (((p-propInfo) < numItems) && (*p == '-')) { + switch (p[1]) { + case 'c': + if (sscanf(p+2, " %d", &code) != 1) { + code = TCL_OK; + } + break; + case 'e': + if (p[2] == ' ') { + errorCode = p+3; + } + break; + case 'i': + if (p[2] == ' ') { + errorInfo = p+3; + } + break; + case 'r': + if (p[2] == ' ') { + resultString = p+3; + } + break; + case 's': + if (sscanf(p+2, " %d", &serial) == 1) { + gotSerial = 1; + } + break; + } + while (*p != 0) { + p++; + } + p++; + } + + if (!gotSerial) { + continue; + } + + /* + * Give the result information to anyone who's + * waiting for it. + */ + + for (pcPtr = pendingCommands; pcPtr != NULL; + pcPtr = pcPtr->nextPtr) { + if ((serial != pcPtr->serial) || (pcPtr->result != NULL)) { + continue; + } + pcPtr->code = code; + if (resultString != NULL) { + pcPtr->result = (char *) ckalloc((unsigned) + (strlen(resultString) + 1)); + strcpy(pcPtr->result, resultString); + } + if (code == TCL_ERROR) { + if (errorInfo != NULL) { + pcPtr->errorInfo = (char *) ckalloc((unsigned) + (strlen(errorInfo) + 1)); + strcpy(pcPtr->errorInfo, errorInfo); + } + if (errorCode != NULL) { + pcPtr->errorCode = (char *) ckalloc((unsigned) + (strlen(errorCode) + 1)); + strcpy(pcPtr->errorCode, errorCode); + } + } + pcPtr->gotResponse = 1; + break; + } + } else { + /* + * Didn't recognize this thing. Just skip through the next + * null character and try again. + */ + + while (*p != 0) { + p++; + } + p++; + } + } + XFree(propInfo); +} + +/* + *-------------------------------------------------------------- + * + * AppendPropCarefully -- + * + * Append a given property to a given window, but set up + * an X error handler so that if the append fails this + * procedure can return an error code rather than having + * Xlib panic. + * + * Results: + * None. + * + * Side effects: + * The given property on the given window is appended to. + * If this operation fails and if pendingPtr is non-NULL, + * then the pending operation is marked as complete with + * an error. + * + *-------------------------------------------------------------- + */ + +static void +AppendPropCarefully(display, window, property, value, length, pendingPtr) + Display *display; /* Display on which to operate. */ + Window window; /* Window whose property is to + * be modified. */ + Atom property; /* Name of property. */ + char *value; /* Characters to append to property. */ + int length; /* Number of bytes to append. */ + PendingCommand *pendingPtr; /* Pending command to mark complete + * if an error occurs during the + * property op. NULL means just + * ignore the error. */ +{ + Tk_ErrorHandler handler; + + handler = Tk_CreateErrorHandler(display, -1, -1, -1, AppendErrorProc, + (ClientData) pendingPtr); + XChangeProperty(display, window, property, XA_STRING, 8, + PropModeAppend, (unsigned char *) value, length); + Tk_DeleteErrorHandler(handler); +} + +/* + * The procedure below is invoked if an error occurs during + * the XChangeProperty operation above. + */ + + /* ARGSUSED */ +static int +AppendErrorProc(clientData, errorPtr) + ClientData clientData; /* Command to mark complete, or NULL. */ + XErrorEvent *errorPtr; /* Information about error. */ +{ + PendingCommand *pendingPtr = (PendingCommand *) clientData; + register PendingCommand *pcPtr; + + if (pendingPtr == NULL) { + return 0; + } + + /* + * Make sure this command is still pending. + */ + + for (pcPtr = pendingCommands; pcPtr != NULL; + pcPtr = pcPtr->nextPtr) { + if ((pcPtr == pendingPtr) && (pcPtr->result == NULL)) { + pcPtr->result = (char *) ckalloc((unsigned) + (strlen(pcPtr->target) + 50)); + sprintf(pcPtr->result, "no application named \"%s\"", + pcPtr->target); + pcPtr->code = TCL_ERROR; + pcPtr->gotResponse = 1; + break; + } + } + return 0; +} + +/* + *-------------------------------------------------------------- + * + * TimeoutProc -- + * + * This procedure is invoked when an unusually long amout of + * time has elapsed during the processing of a sent command. + * It checks to make sure that the target application still + * exists, and reschedules itself to check again later. + * + * Results: + * None. + * + * Side effects: + * If the target application has gone away abort the send + * operation with an error. + * + *-------------------------------------------------------------- + */ + +static void +TimeoutProc(clientData) + ClientData clientData; /* Information about command that + * has been sent but not yet + * responded to. */ +{ + PendingCommand *pcPtr = (PendingCommand *) clientData; + register PendingCommand *pcPtr2; + + /* + * Make sure that the command is still in the pending list + * and that it hasn't already completed. Then validate the + * existence of the target application. + */ + + for (pcPtr2 = pendingCommands; pcPtr2 != NULL; + pcPtr2 = pcPtr2->nextPtr) { + char *msg; + if ((pcPtr2 != pcPtr) || (pcPtr2->result != NULL)) { + continue; + } + if (!ValidateName(pcPtr2->dispPtr, pcPtr2->target, + pcPtr2->commWindow, 0)) { + if (ValidateName(pcPtr2->dispPtr, pcPtr2->target, + pcPtr2->commWindow, 1)) { + msg = + "target application died or uses a Tk version before 4.0"; + } else { + msg = "target application died"; + } + pcPtr2->code = TCL_ERROR; + pcPtr2->result = (char *) ckalloc((unsigned) (strlen(msg) + 1)); + strcpy(pcPtr2->result, msg); + pcPtr2->gotResponse = 1; + } else { + Tcl_DeleteModalTimeout(TimeoutProc, clientData); + Tcl_CreateModalTimeout(2000, TimeoutProc, clientData); + } + } +} + +/* + *-------------------------------------------------------------- + * + * DeleteProc -- + * + * This procedure is invoked by Tcl when the "send" command + * is deleted in an interpreter. It unregisters the interpreter. + * + * Results: + * None. + * + * Side effects: + * The interpreter given by riPtr is unregistered. + * + *-------------------------------------------------------------- + */ + +static void +DeleteProc(clientData) + ClientData clientData; /* Info about registration, passed + * as ClientData. */ +{ + RegisteredInterp *riPtr = (RegisteredInterp *) clientData; + register RegisteredInterp *riPtr2; + NameRegistry *regPtr; + + regPtr = RegOpen(riPtr->interp, riPtr->dispPtr, 1); + RegDeleteName(regPtr, riPtr->name); + RegClose(regPtr); + + if (registry == riPtr) { + registry = riPtr->nextPtr; + } else { + for (riPtr2 = registry; riPtr2 != NULL; + riPtr2 = riPtr2->nextPtr) { + if (riPtr2->nextPtr == riPtr) { + riPtr2->nextPtr = riPtr->nextPtr; + break; + } + } + } + ckfree((char *) riPtr->name); + riPtr->interp = NULL; + UpdateCommWindow(riPtr->dispPtr); + Tcl_EventuallyFree((ClientData) riPtr, TCL_DYNAMIC); +} + +/* + *---------------------------------------------------------------------- + * + * SendRestrictProc -- + * + * This procedure filters incoming events when a "send" command + * is outstanding. It defers all events except those containing + * send commands and results. + * + * Results: + * False is returned except for property-change events on a + * commWindow. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static Tk_RestrictAction +SendRestrictProc(clientData, eventPtr) + ClientData clientData; /* Not used. */ + register XEvent *eventPtr; /* Event that just arrived. */ +{ + TkDisplay *dispPtr; + + if (eventPtr->type != PropertyNotify) { + return TK_DEFER_EVENT; + } + for (dispPtr = tkDisplayList; dispPtr != NULL; dispPtr = dispPtr->nextPtr) { + if ((eventPtr->xany.display == dispPtr->display) + && (eventPtr->xproperty.window + == Tk_WindowId(dispPtr->commTkwin))) { + return TK_PROCESS_EVENT; + } + } + return TK_DEFER_EVENT; +} + +/* + *---------------------------------------------------------------------- + * + * UpdateCommWindow -- + * + * This procedure updates the list of application names stored + * on our commWindow. It is typically called when interpreters + * are registered and unregistered. + * + * Results: + * None. + * + * Side effects: + * The TK_APPLICATION property on the comm window is updated. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateCommWindow(dispPtr) + TkDisplay *dispPtr; /* Display whose commWindow is to be + * updated. */ +{ + Tcl_DString names; + RegisteredInterp *riPtr; + + Tcl_DStringInit(&names); + for (riPtr = registry; riPtr != NULL; riPtr = riPtr->nextPtr) { + Tcl_DStringAppendElement(&names, riPtr->name); + } + XChangeProperty(dispPtr->display, Tk_WindowId(dispPtr->commTkwin), + dispPtr->appNameProperty, XA_STRING, 8, PropModeReplace, + (unsigned char *) Tcl_DStringValue(&names), + Tcl_DStringLength(&names)); + Tcl_DStringFree(&names); +} diff --git a/tk3.6/library/demos/tkSquare.c b/tk4.2/generic/tkSquare.c similarity index 79% rename from tk3.6/library/demos/tkSquare.c rename to tk4.2/generic/tkSquare.c index dde270e..669cdb9 100644 --- a/tk3.6/library/demos/tkSquare.c +++ b/tk4.2/generic/tkSquare.c @@ -4,34 +4,19 @@ * This module implements "square" widgets. A "square" is * a widget that displays a single square that can be moved * around and resized. This file is intended as an example - * of how to build a widget. + * of how to build a widget; it isn't included in the + * normal wish, but it is included in "tktest". * - * Copyright (c) 1991-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tkSquare.c 1.17 96/07/23 16:54:29 */ -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/library/demos/RCS/tkSquare.c,v 1.8 93/10/18 15:08:37 ouster Exp $ SPRITE (Berkeley)"; -#endif - -#include "tkConfig.h" +#include "tkPort.h" #include "tk.h" /* @@ -45,6 +30,7 @@ typedef struct { * widget record hasn't been cleaned up yet. */ Display *display; /* X's token for the window's display. */ Tcl_Interp *interp; /* Interpreter associated with widget. */ + Tcl_Command widgetCmd; /* Token for square's widget command. */ int x, y; /* Position of square's upper-left corner * within widget. */ int size; /* Width and height of square. */ @@ -100,10 +86,14 @@ static Tk_ConfigSpec configSpecs[] = { * Forward declarations for procedures defined later in this file: */ +int SquareCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static void SquareCmdDeletedProc _ANSI_ARGS_(( + ClientData clientData)); static int SquareConfigure _ANSI_ARGS_((Tcl_Interp *interp, Square *squarePtr, int argc, char **argv, int flags)); -static void SquareDestroy _ANSI_ARGS_((ClientData clientData)); +static void SquareDestroy _ANSI_ARGS_((char *memPtr)); static void SquareDisplay _ANSI_ARGS_((ClientData clientData)); static void KeepInWindow _ANSI_ARGS_((Square *squarePtr)); static void SquareEventProc _ANSI_ARGS_((ClientData clientData, @@ -141,7 +131,7 @@ SquareCmd(clientData, interp, argc, argv) Tk_Window tkwin; if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " pathName ?options?\"", (char *) NULL); return TCL_ERROR; } @@ -160,6 +150,9 @@ SquareCmd(clientData, interp, argc, argv) squarePtr->tkwin = tkwin; squarePtr->display = Tk_Display(tkwin); squarePtr->interp = interp; + squarePtr->widgetCmd = Tcl_CreateCommand(interp, + Tk_PathName(squarePtr->tkwin), SquareWidgetCmd, + (ClientData) squarePtr, SquareCmdDeletedProc); squarePtr->x = 0; squarePtr->y = 0; squarePtr->size = 20; @@ -173,8 +166,6 @@ SquareCmd(clientData, interp, argc, argv) Tk_CreateEventHandler(squarePtr->tkwin, ExposureMask|StructureNotifyMask, SquareEventProc, (ClientData) squarePtr); - Tcl_CreateCommand(interp, Tk_PathName(squarePtr->tkwin), SquareWidgetCmd, - (ClientData) squarePtr, (void (*)()) NULL); if (SquareConfigure(interp, squarePtr, argc-2, argv+2, 0) != TCL_OK) { Tk_DestroyWindow(squarePtr->tkwin); return TCL_ERROR; @@ -211,7 +202,7 @@ SquareWidgetCmd(clientData, interp, argc, argv) { Square *squarePtr = (Square *) clientData; int result = TCL_OK; - int length; + size_t length; char c; if (argc < 2) { @@ -219,10 +210,21 @@ SquareWidgetCmd(clientData, interp, argc, argv) argv[0], " option ?arg arg ...?\"", (char *) NULL); return TCL_ERROR; } - Tk_Preserve((ClientData) squarePtr); + Tcl_Preserve((ClientData) squarePtr); c = argv[1][0]; length = strlen(argv[1]); - if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0)) { + if ((c == 'c') && (strncmp(argv[1], "cget", length) == 0) + && (length >= 2)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " cget option\"", + (char *) NULL); + goto error; + } + result = Tk_ConfigureValue(interp, squarePtr->tkwin, configSpecs, + (char *) squarePtr, argv[2], 0); + } else if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0) + && (length >= 2)) { if (argc == 2) { result = Tk_ConfigureInfo(interp, squarePtr->tkwin, configSpecs, (char *) squarePtr, (char *) NULL, 0); @@ -271,18 +273,19 @@ SquareWidgetCmd(clientData, interp, argc, argv) sprintf(interp->result, "%d", squarePtr->size); } else { Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be configure, position, or size", (char *) NULL); + "\": must be cget, configure, position, or size", + (char *) NULL); goto error; } if (!squarePtr->updatePending) { - Tk_DoWhenIdle(SquareDisplay, (ClientData) squarePtr); + Tcl_DoWhenIdle(SquareDisplay, (ClientData) squarePtr); squarePtr->updatePending = 1; } - Tk_Release((ClientData) squarePtr); + Tcl_Release((ClientData) squarePtr); return result; error: - Tk_Release((ClientData) squarePtr); + Tcl_Release((ClientData) squarePtr); return TCL_ERROR; } @@ -344,7 +347,7 @@ SquareConfigure(interp, squarePtr, argc, argv, flags) Tk_GeometryRequest(squarePtr->tkwin, 200, 150); Tk_SetInternalBorder(squarePtr->tkwin, squarePtr->borderWidth); if (!squarePtr->updatePending) { - Tk_DoWhenIdle(SquareDisplay, (ClientData) squarePtr); + Tcl_DoWhenIdle(SquareDisplay, (ClientData) squarePtr); squarePtr->updatePending = 1; } return TCL_OK; @@ -377,22 +380,64 @@ SquareEventProc(clientData, eventPtr) if (eventPtr->type == Expose) { if (!squarePtr->updatePending) { - Tk_DoWhenIdle(SquareDisplay, (ClientData) squarePtr); + Tcl_DoWhenIdle(SquareDisplay, (ClientData) squarePtr); squarePtr->updatePending = 1; } } else if (eventPtr->type == ConfigureNotify) { KeepInWindow(squarePtr); if (!squarePtr->updatePending) { - Tk_DoWhenIdle(SquareDisplay, (ClientData) squarePtr); + Tcl_DoWhenIdle(SquareDisplay, (ClientData) squarePtr); squarePtr->updatePending = 1; } } else if (eventPtr->type == DestroyNotify) { - Tcl_DeleteCommand(squarePtr->interp, Tk_PathName(squarePtr->tkwin)); - squarePtr->tkwin = NULL; - if (squarePtr->updatePending) { - Tk_CancelIdleCall(SquareDisplay, (ClientData) squarePtr); + if (squarePtr->tkwin != NULL) { + squarePtr->tkwin = NULL; + Tcl_DeleteCommand(squarePtr->interp, + Tcl_GetCommandName(squarePtr->interp, + squarePtr->widgetCmd)); } - Tk_EventuallyFree((ClientData) squarePtr, SquareDestroy); + if (squarePtr->updatePending) { + Tcl_CancelIdleCall(SquareDisplay, (ClientData) squarePtr); + } + Tcl_EventuallyFree((ClientData) squarePtr, SquareDestroy); + } +} + +/* + *---------------------------------------------------------------------- + * + * SquareCmdDeletedProc -- + * + * This procedure is invoked when a widget command is deleted. If + * the widget isn't already in the process of being destroyed, + * this command destroys it. + * + * Results: + * None. + * + * Side effects: + * The widget is destroyed. + * + *---------------------------------------------------------------------- + */ + +static void +SquareCmdDeletedProc(clientData) + ClientData clientData; /* Pointer to widget record for widget. */ +{ + Square *squarePtr = (Square *) clientData; + Tk_Window tkwin = squarePtr->tkwin; + + /* + * This procedure could be invoked either because the window was + * destroyed and the command was then deleted (in which case tkwin + * is NULL) or because the command was deleted, and then this procedure + * destroys the widget. + */ + + if (tkwin != NULL) { + squarePtr->tkwin = NULL; + Tk_DestroyWindow(tkwin); } } @@ -433,7 +478,7 @@ SquareDisplay(clientData) */ if (squarePtr->doubleBuffer) { - pm = XCreatePixmap(Tk_Display(tkwin), Tk_WindowId(tkwin), + pm = Tk_GetPixmap(Tk_Display(tkwin), Tk_WindowId(tkwin), Tk_Width(tkwin), Tk_Height(tkwin), DefaultDepthOfScreen(Tk_Screen(tkwin))); d = pm; @@ -445,16 +490,15 @@ SquareDisplay(clientData) * Redraw the widget's background and border. */ - Tk_Fill3DRectangle(Tk_Display(tkwin), d, squarePtr->bgBorder, - 0, 0, Tk_Width(tkwin), Tk_Height(tkwin), - squarePtr->borderWidth, squarePtr->relief); + Tk_Fill3DRectangle(tkwin, d, squarePtr->bgBorder, 0, 0, Tk_Width(tkwin), + Tk_Height(tkwin), squarePtr->borderWidth, squarePtr->relief); /* * Display the square. */ - Tk_Fill3DRectangle(Tk_Display(tkwin), d, squarePtr->fgBorder, - squarePtr->x, squarePtr->y, squarePtr->size, squarePtr->size, + Tk_Fill3DRectangle(tkwin, d, squarePtr->fgBorder, squarePtr->x, + squarePtr->y, squarePtr->size, squarePtr->size, squarePtr->borderWidth, TK_RELIEF_RAISED); /* @@ -463,8 +507,9 @@ SquareDisplay(clientData) if (squarePtr->doubleBuffer) { XCopyArea(Tk_Display(tkwin), pm, Tk_WindowId(tkwin), squarePtr->gc, - 0, 0, Tk_Width(tkwin), Tk_Height(tkwin), 0, 0); - XFreePixmap(Tk_Display(tkwin), pm); + 0, 0, (unsigned) Tk_Width(tkwin), (unsigned) Tk_Height(tkwin), + 0, 0); + Tk_FreePixmap(Tk_Display(tkwin), pm); } } @@ -473,7 +518,7 @@ SquareDisplay(clientData) * * SquareDestroy -- * - * This procedure is invoked by Tk_EventuallyFree or Tk_Release + * This procedure is invoked by Tcl_EventuallyFree or Tcl_Release * to clean up the internal structure of a square at a safe time * (when no-one is using it anymore). * @@ -487,10 +532,10 @@ SquareDisplay(clientData) */ static void -SquareDestroy(clientData) - ClientData clientData; /* Info about square widget. */ +SquareDestroy(memPtr) + char *memPtr; /* Info about square widget. */ { - Square *squarePtr = (Square *) clientData; + Square *squarePtr = (Square *) memPtr; Tk_FreeOptions(configSpecs, (char *) squarePtr, squarePtr->display, 0); if (squarePtr->gc != None) { diff --git a/tk4.2/generic/tkTest.c b/tk4.2/generic/tkTest.c new file mode 100644 index 0000000..36e1540 --- /dev/null +++ b/tk4.2/generic/tkTest.c @@ -0,0 +1,1162 @@ +/* + * tkTest.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-1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkTest.c 1.35 96/10/03 11:22:26 + */ + +#include "tkInt.h" +#include "tkPort.h" + +#ifdef __WIN32__ +#include "tkWinInt.h" +#endif + +/* + * The table below describes events and is used by the "testevent" + * command. + */ + +typedef struct { + char *name; /* Name of event. */ + int type; /* Event type for X, such as + * ButtonPress. */ +} EventInfo; + +static EventInfo eventArray[] = { + {"Motion", MotionNotify}, + {"Button", ButtonPress}, + {"ButtonPress", ButtonPress}, + {"ButtonRelease", ButtonRelease}, + {"Colormap", ColormapNotify}, + {"Enter", EnterNotify}, + {"Leave", LeaveNotify}, + {"Expose", Expose}, + {"FocusIn", FocusIn}, + {"FocusOut", FocusOut}, + {"Keymap", KeymapNotify}, + {"Key", KeyPress}, + {"KeyPress", KeyPress}, + {"KeyRelease", KeyRelease}, + {"Property", PropertyNotify}, + {"ResizeRequest", ResizeRequest}, + {"Circulate", CirculateNotify}, + {"Configure", ConfigureNotify}, + {"Destroy", DestroyNotify}, + {"Gravity", GravityNotify}, + {"Map", MapNotify}, + {"Reparent", ReparentNotify}, + {"Unmap", UnmapNotify}, + {"Visibility", VisibilityNotify}, + {"CirculateRequest",CirculateRequest}, + {"ConfigureRequest",ConfigureRequest}, + {"MapRequest", MapRequest}, + {(char *) NULL, 0} +}; + +/* + * The defines and table below are used to classify events into + * various groups. The reason for this is that logically identical + * fields (e.g. "state") appear at different places in different + * types of events. The classification masks can be used to figure + * out quickly where to extract information from events. + */ + +#define KEY_BUTTON_MOTION 0x1 +#define CROSSING 0x2 +#define FOCUS 0x4 +#define EXPOSE 0x8 +#define VISIBILITY 0x10 +#define CREATE 0x20 +#define MAP 0x40 +#define REPARENT 0x80 +#define CONFIG 0x100 +#define CONFIG_REQ 0x200 +#define RESIZE_REQ 0x400 +#define GRAVITY 0x800 +#define PROP 0x1000 +#define SEL_CLEAR 0x2000 +#define SEL_REQ 0x4000 +#define SEL_NOTIFY 0x8000 +#define COLORMAP 0x10000 +#define MAPPING 0x20000 + +static int flagArray[LASTEvent] = { + /* Not used */ 0, + /* Not used */ 0, + /* KeyPress */ KEY_BUTTON_MOTION, + /* KeyRelease */ KEY_BUTTON_MOTION, + /* ButtonPress */ KEY_BUTTON_MOTION, + /* ButtonRelease */ KEY_BUTTON_MOTION, + /* MotionNotify */ KEY_BUTTON_MOTION, + /* EnterNotify */ CROSSING, + /* LeaveNotify */ CROSSING, + /* FocusIn */ FOCUS, + /* FocusOut */ FOCUS, + /* KeymapNotify */ 0, + /* Expose */ EXPOSE, + /* GraphicsExpose */ EXPOSE, + /* NoExpose */ 0, + /* VisibilityNotify */ VISIBILITY, + /* CreateNotify */ CREATE, + /* DestroyNotify */ 0, + /* UnmapNotify */ 0, + /* MapNotify */ MAP, + /* MapRequest */ 0, + /* ReparentNotify */ REPARENT, + /* ConfigureNotify */ CONFIG, + /* ConfigureRequest */ CONFIG_REQ, + /* GravityNotify */ 0, + /* ResizeRequest */ RESIZE_REQ, + /* CirculateNotify */ 0, + /* CirculateRequest */ 0, + /* PropertyNotify */ PROP, + /* SelectionClear */ SEL_CLEAR, + /* SelectionRequest */ SEL_REQ, + /* SelectionNotify */ SEL_NOTIFY, + /* ColormapNotify */ COLORMAP, + /* ClientMessage */ 0, + /* MappingNotify */ MAPPING +}; + +/* + * The following data structure represents the master for a test + * image: + */ + +typedef struct TImageMaster { + Tk_ImageMaster master; /* Tk's token for image master. */ + Tcl_Interp *interp; /* Interpreter for application. */ + int width, height; /* Dimensions of image. */ + char *imageName; /* Name of image (malloc-ed). */ + char *varName; /* Name of variable in which to log + * events for image (malloc-ed). */ +} TImageMaster; + +/* + * The following data structure represents a particular use of a + * particular test image. + */ + +typedef struct TImageInstance { + TImageMaster *masterPtr; /* Pointer to master for image. */ + XColor *fg; /* Foreground color for drawing in image. */ + GC gc; /* Graphics context for drawing in image. */ +} TImageInstance; + +/* + * The type record for test images: + */ + +static int ImageCreate _ANSI_ARGS_((Tcl_Interp *interp, + char *name, int argc, char **argv, + Tk_ImageType *typePtr, Tk_ImageMaster master, + ClientData *clientDataPtr)); +static ClientData ImageGet _ANSI_ARGS_((Tk_Window tkwin, + ClientData clientData)); +static void ImageDisplay _ANSI_ARGS_((ClientData clientData, + Display *display, Drawable drawable, + int imageX, int imageY, int width, + int height, int drawableX, + int drawableY)); +static void ImageFree _ANSI_ARGS_((ClientData clientData, + Display *display)); +static void ImageDelete _ANSI_ARGS_((ClientData clientData)); + +static Tk_ImageType imageType = { + "test", /* name */ + ImageCreate, /* createProc */ + ImageGet, /* getProc */ + ImageDisplay, /* displayProc */ + ImageFree, /* freeProc */ + ImageDelete, /* deleteProc */ + (Tk_ImageType *) NULL /* nextPtr */ +}; + +/* + * One of the following structures describes each of the interpreters + * created by the "testnewapp" command. This information is used by + * the "testdeleteinterps" command to destroy all of those interpreters. + */ + +typedef struct NewApp { + Tcl_Interp *interp; /* Token for interpreter. */ + struct NewApp *nextPtr; /* Next in list of new interpreters. */ +} NewApp; + +static NewApp *newAppPtr = NULL; + /* First in list of all new interpreters. */ + +/* + * Declaration for the square widget's class command procedure: + */ + +extern int SquareCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char *argv[])); + +/* + * Forward declarations for procedures defined later in this file: + */ + +int Tktest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +static int ImageCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +#ifdef __WIN32__ +static int TestclipboardCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +#endif +static int TestdeleteappsCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TesteventCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestmakeexistCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestsendCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); + +/* + *---------------------------------------------------------------------- + * + * Tktest_Init -- + * + * This procedure performs intialization for the Tk test + * suite exensions. + * + * Results: + * Returns a standard Tcl completion code, and leaves an error + * message in interp->result if an error occurs. + * + * Side effects: + * Creates several test commands. + * + *---------------------------------------------------------------------- + */ + +int +Tktest_Init(interp) + Tcl_Interp *interp; /* Interpreter for application. */ +{ + static int initialized = 0; + + /* + * Create additional commands for testing Tk. + */ + + if (Tcl_PkgProvide(interp, "Tktest", TK_VERSION) == TCL_ERROR) { + return TCL_ERROR; + } + + Tcl_CreateCommand(interp, "square", SquareCmd, + (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL); +#ifdef __WIN32__ + Tcl_CreateCommand(interp, "testclipboard", TestclipboardCmd, + (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL); +#endif + Tcl_CreateCommand(interp, "testdeleteapps", TestdeleteappsCmd, + (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testevent", TesteventCmd, + (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testmakeexist", TestmakeexistCmd, + (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testsend", TestsendCmd, + (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL); + + /* + * Create test image type. + */ + + if (!initialized) { + initialized = 1; + Tk_CreateImageType(&imageType); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestclipboardCmd -- + * + * This procedure implements the testclipboard command. It provides + * a way to determine the actual contents of the Windows clipboard. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#ifdef __WIN32__ +static int +TestclipboardCmd(clientData, interp, argc, argv) + ClientData clientData; /* Main window for application. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + TkWindow *winPtr = (TkWindow *) clientData; + HGLOBAL handle; + char *data; + + if (OpenClipboard(NULL)) { + handle = GetClipboardData(CF_TEXT); + if (handle != NULL) { + data = GlobalLock(handle); + Tcl_AppendResult(interp, data, (char *) NULL); + GlobalUnlock(handle); + } + CloseClipboard(); + } + return TCL_OK; +} +#endif + +/* + *---------------------------------------------------------------------- + * + * TestdeleteappsCmd -- + * + * This procedure implements the "testdeleteapps" command. It cleans + * up all the interpreters left behind by the "testnewapp" command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * All the intepreters created by previous calls to "testnewapp" + * get deleted. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestdeleteappsCmd(clientData, interp, argc, argv) + ClientData clientData; /* Main window for application. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + NewApp *nextPtr; + + while (newAppPtr != NULL) { + nextPtr = newAppPtr->nextPtr; + Tcl_DeleteInterp(newAppPtr->interp); + ckfree((char *) newAppPtr); + newAppPtr = nextPtr; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TesteventCmd -- + * + * This procedure implements the "testevent" command. It allows + * events to be generated on the fly, for testing event-handling. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates and handles events. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TesteventCmd(clientData, interp, argc, argv) + ClientData clientData; /* Main window for application. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tk_Window main = (Tk_Window) clientData; + Tk_Window tkwin, tkwin2; + XEvent event; + EventInfo *eiPtr; + char *field, *value; + int i, number, flags; + KeySym keysym; + + if ((argc < 3) || !(argc & 1)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " window type ?field value field value ...?\"", + (char *) NULL); + return TCL_ERROR; + } + tkwin = Tk_NameToWindow(interp, argv[1], main); + if (tkwin == NULL) { + return TCL_ERROR; + } + + /* + * Get the type of the event. + */ + + memset((VOID *) &event, 0, sizeof(event)); + for (eiPtr = eventArray; ; eiPtr++) { + if (eiPtr->name == NULL) { + Tcl_AppendResult(interp, "bad event type \"", argv[2], + "\"", (char *) NULL); + return TCL_ERROR; + } + if (strcmp(eiPtr->name, argv[2]) == 0) { + event.xany.type = eiPtr->type; + break; + } + } + + /* + * Fill in fields that are common to all events. + */ + + event.xany.serial = NextRequest(Tk_Display(tkwin)); + event.xany.send_event = False; + event.xany.window = Tk_WindowId(tkwin); + event.xany.display = Tk_Display(tkwin); + + /* + * Process the remaining arguments to fill in additional fields + * of the event. + */ + + flags = flagArray[event.xany.type]; + for (i = 3; i < argc; i += 2) { + field = argv[i]; + value = argv[i+1]; + if (strcmp(field, "-above") == 0) { + tkwin2 = Tk_NameToWindow(interp, value, main); + if (tkwin2 == NULL) { + return TCL_ERROR; + } + event.xconfigure.above = Tk_WindowId(tkwin2); + } else if (strcmp(field, "-borderwidth") == 0) { + if (Tcl_GetInt(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + event.xcreatewindow.border_width = number; + } else if (strcmp(field, "-button") == 0) { + if (Tcl_GetInt(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + event.xbutton.button = number; + } else if (strcmp(field, "-count") == 0) { + if (Tcl_GetInt(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + if (flags & EXPOSE) { + event.xexpose.count = number; + } else if (flags & MAPPING) { + event.xmapping.count = number; + } + } else if (strcmp(field, "-detail") == 0) { + if (flags & (CROSSING|FOCUS)) { + if (strcmp(value, "NotifyAncestor") == 0) { + number = NotifyAncestor; + } else if (strcmp(value, "NotifyVirtual") == 0) { + number = NotifyVirtual; + } else if (strcmp(value, "NotifyInferior") == 0) { + number = NotifyInferior; + } else if (strcmp(value, "NotifyNonlinear") == 0) { + number = NotifyNonlinear; + } else if (strcmp(value, "NotifyNonlinearVirtual") == 0) { + number = NotifyNonlinearVirtual; + } else if (strcmp(value, "NotifyPointer") == 0) { + number = NotifyPointer; + } else if (strcmp(value, "NotifyPointerRoot") == 0) { + number = NotifyPointerRoot; + } else if (strcmp(value, "NotifyDetailNone") == 0) { + number = NotifyDetailNone; + } else { + Tcl_AppendResult(interp, "bad detail \"", value, "\"", + (char *) NULL); + return TCL_ERROR; + } + if (flags & FOCUS) { + event.xfocus.detail = number; + } else { + event.xcrossing.detail = number; + } + } else if (flags & CONFIG_REQ) { + if (strcmp(value, "Above") == 0) { + number = Above; + } else if (strcmp(value, "Below") == 0) { + number = Below; + } else if (strcmp(value, "TopIf") == 0) { + number = TopIf; + } else if (strcmp(value, "BottomIf") == 0) { + number = BottomIf; + } else if (strcmp(value, "Opposite") == 0) { + number = Opposite; + } else { + Tcl_AppendResult(interp, "bad detail \"", value, "\"", + (char *) NULL); + return TCL_ERROR; + } + event.xconfigurerequest.detail = number; + } + } else if (strcmp(field, "-focus") == 0) { + if (Tcl_GetInt(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + event.xcrossing.focus = number; + } else if (strcmp(field, "-height") == 0) { + if (Tcl_GetInt(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + if (flags & EXPOSE) { + event.xexpose.height = number; + } else if (flags & (CONFIG|CONFIG_REQ)) { + event.xconfigure.height = number; + } else if (flags & RESIZE_REQ) { + event.xresizerequest.height = number; + } + } else if (strcmp(field, "-keycode") == 0) { + if (Tcl_GetInt(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + event.xkey.keycode = number; + } else if (strcmp(field, "-keysym") == 0) { + keysym = TkStringToKeysym(value); + if (keysym == NoSymbol) { + Tcl_AppendResult(interp, "unknown keysym \"", value, + "\"", (char *) NULL); + return TCL_ERROR; + } + number = XKeysymToKeycode(event.xany.display, keysym); + if (number == 0) { + Tcl_AppendResult(interp, "no keycode for keysym \"", value, + "\"", (char *) NULL); + return TCL_ERROR; + } + event.xkey.keycode = number; + } else if (strcmp(field, "-mode") == 0) { + if (strcmp(value, "NotifyNormal") == 0) { + number = NotifyNormal; + } else if (strcmp(value, "NotifyGrab") == 0) { + number = NotifyGrab; + } else if (strcmp(value, "NotifyUngrab") == 0) { + number = NotifyUngrab; + } else if (strcmp(value, "NotifyWhileGrabbed") == 0) { + number = NotifyWhileGrabbed; + } else { + Tcl_AppendResult(interp, "bad mode \"", value, "\"", + (char *) NULL); + return TCL_ERROR; + } + if (flags & CROSSING) { + event.xcrossing.mode = number; + } else if (flags & FOCUS) { + event.xfocus.mode = number; + } + } else if (strcmp(field, "-override") == 0) { + if (Tcl_GetInt(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + if (flags & CREATE) { + event.xcreatewindow.override_redirect = number; + } else if (flags & MAP) { + event.xmap.override_redirect = number; + } else if (flags & REPARENT) { + event.xreparent.override_redirect = number; + } else if (flags & CONFIG) { + event.xconfigure.override_redirect = number; + } + } else if (strcmp(field, "-place") == 0) { + if (strcmp(value, "PlaceOnTop") == 0) { + event.xcirculate.place = PlaceOnTop; + } else if (strcmp(value, "PlaceOnBottom") == 0) { + event.xcirculate.place = PlaceOnBottom; + } else if (strcmp(value, "bogus") == 0) { + event.xcirculate.place = 147; + } else { + Tcl_AppendResult(interp, "bad place \"", value, "\"", + (char *) NULL); + return TCL_ERROR; + } + } else if (strcmp(field, "-root") == 0) { + if (Tcl_GetInt(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + event.xkey.root = number; + } else if (strcmp(field, "-rootx") == 0) { + if (Tcl_GetInt(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + event.xkey.x_root = number; + } else if (strcmp(field, "-rooty") == 0) { + if (Tcl_GetInt(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + event.xkey.y_root = number; + } else if (strcmp(field, "-sendevent") == 0) { + if (Tcl_GetInt(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + event.xany.send_event = number; + } else if (strcmp(field, "-serial") == 0) { + if (Tcl_GetInt(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + event.xany.serial = number; + } else if (strcmp(field, "-state") == 0) { + if (flags & KEY_BUTTON_MOTION) { + if (Tcl_GetInt(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + event.xkey.state = number; + } else if (flags & CROSSING) { + if (Tcl_GetInt(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + event.xcrossing.state = number; + } else if (flags & VISIBILITY) { + if (strcmp(value, "VisibilityUnobscured") == 0) { + number = VisibilityUnobscured; + } else if (strcmp(value, "VisibilityPartiallyObscured") == 0) { + number = VisibilityPartiallyObscured; + } else if (strcmp(value, "VisibilityFullyObscured") == 0) { + number = VisibilityFullyObscured; + } else { + Tcl_AppendResult(interp, "bad state \"", value, "\"", + (char *) NULL); + return TCL_ERROR; + } + event.xvisibility.state = number; + } + } else if (strcmp(field, "-subwindow") == 0) { + tkwin2 = Tk_NameToWindow(interp, value, main); + if (tkwin2 == NULL) { + return TCL_ERROR; + } + event.xkey.subwindow = Tk_WindowId(tkwin2); + } else if (strcmp(field, "-time") == 0) { + if (Tcl_GetInt(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + if (flags & (KEY_BUTTON_MOTION|PROP|SEL_CLEAR)) { + event.xkey.time = (Time) number; + } else if (flags & SEL_REQ) { + event.xselectionrequest.time = (Time) number; + } else if (flags & SEL_NOTIFY) { + event.xselection.time = (Time) number; + } + } else if (strcmp(field, "-valueMask") == 0) { + if (Tcl_GetInt(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + event.xconfigurerequest.value_mask = number; + } else if (strcmp(field, "-width") == 0) { + if (Tcl_GetInt(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + if (flags & EXPOSE) { + event.xexpose.width = number; + } else if (flags & (CONFIG|CONFIG_REQ)) { + event.xconfigure.width = number; + } else if (flags & RESIZE_REQ) { + event.xresizerequest.width = number; + } + } else if (strcmp(field, "-window") == 0) { + tkwin2 = Tk_NameToWindow(interp, value, main); + if (tkwin2 == NULL) { + return TCL_ERROR; + } + event.xmap.window = Tk_WindowId(tkwin2); + } else if (strcmp(field, "-x") == 0) { + int rootX, rootY; + if (Tcl_GetInt(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + Tk_GetRootCoords(tkwin, &rootX, &rootY); + rootX += number; + if (flags & KEY_BUTTON_MOTION) { + event.xkey.x = number; + event.xkey.x_root = rootX; + } else if (flags & EXPOSE) { + event.xexpose.x = number; + } else if (flags & (CREATE|CONFIG|GRAVITY|CONFIG_REQ)) { + event.xcreatewindow.x = number; + } else if (flags & REPARENT) { + event.xreparent.x = number; + } else if (flags & CROSSING) { + event.xcrossing.x = number; + event.xcrossing.x_root = rootY; + } + } else if (strcmp(field, "-y") == 0) { + int rootX, rootY; + if (Tcl_GetInt(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + Tk_GetRootCoords(tkwin, &rootX, &rootY); + rootY += number; + if (flags & KEY_BUTTON_MOTION) { + event.xkey.y = number; + event.xkey.y_root = rootY; + } else if (flags & EXPOSE) { + event.xexpose.y = number; + } else if (flags & (CREATE|CONFIG|GRAVITY|CONFIG_REQ)) { + event.xcreatewindow.y = number; + } else if (flags & REPARENT) { + event.xreparent.y = number; + } else if (flags & CROSSING) { + event.xcrossing.y = number; + event.xcrossing.y_root = rootY; + } + } else { + Tcl_AppendResult(interp, "bad option \"", field, "\"", + (char *) NULL); + return TCL_ERROR; + } + } + Tk_HandleEvent(&event); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestmakeexistCmd -- + * + * This procedure implements the "testmakeexist" command. It calls + * Tk_MakeWindowExist on each of its arguments to force the windows + * to be created. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Forces windows to be created. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestmakeexistCmd(clientData, interp, argc, argv) + ClientData clientData; /* Main window for application. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tk_Window main = (Tk_Window) clientData; + int i; + Tk_Window tkwin; + + for (i = 1; i < argc; i++) { + tkwin = Tk_NameToWindow(interp, argv[i], main); + if (tkwin == NULL) { + return TCL_ERROR; + } + Tk_MakeWindowExist(tkwin); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ImageCreate -- + * + * This procedure is called by the Tk image code to create "test" + * images. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * The data structure for a new image is allocated. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +ImageCreate(interp, name, argc, argv, typePtr, master, clientDataPtr) + Tcl_Interp *interp; /* Interpreter for application containing + * image. */ + char *name; /* Name to use for image. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings for options (doesn't + * include image name or type). */ + Tk_ImageType *typePtr; /* Pointer to our type record (not used). */ + Tk_ImageMaster master; /* Token for image, to be used by us in + * later callbacks. */ + ClientData *clientDataPtr; /* Store manager's token for image here; + * it will be returned in later callbacks. */ +{ + TImageMaster *timPtr; + char *varName; + int i; + + varName = "log"; + for (i = 0; i < argc; i += 2) { + if (strcmp(argv[i], "-variable") != 0) { + Tcl_AppendResult(interp, "bad option name \"", argv[i], + "\"", (char *) NULL); + return TCL_ERROR; + } + if ((i+1) == argc) { + Tcl_AppendResult(interp, "no value given for \"", argv[i], + "\" option", (char *) NULL); + return TCL_ERROR; + } + varName = argv[i+1]; + } + timPtr = (TImageMaster *) ckalloc(sizeof(TImageMaster)); + timPtr->master = master; + timPtr->interp = interp; + timPtr->width = 30; + timPtr->height = 15; + timPtr->imageName = (char *) ckalloc((unsigned) (strlen(name) + 1)); + strcpy(timPtr->imageName, name); + timPtr->varName = (char *) ckalloc((unsigned) (strlen(varName) + 1)); + strcpy(timPtr->varName, varName); + Tcl_CreateCommand(interp, name, ImageCmd, (ClientData) timPtr, + (Tcl_CmdDeleteProc *) NULL); + *clientDataPtr = (ClientData) timPtr; + Tk_ImageChanged(master, 0, 0, 30, 15, 30, 15); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ImageCmd -- + * + * This procedure implements the commands corresponding to individual + * images. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Forces windows to be created. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +ImageCmd(clientData, interp, argc, argv) + ClientData clientData; /* Main window for application. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + TImageMaster *timPtr = (TImageMaster *) clientData; + int x, y, width, height; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], "option ?arg arg ...?", (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[1], "changed") == 0) { + if (argc != 8) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " changed x y width height imageWidth imageHeight", + (char *) NULL); + return TCL_ERROR; + } + if ((Tcl_GetInt(interp, argv[2], &x) != TCL_OK) + || (Tcl_GetInt(interp, argv[3], &y) != TCL_OK) + || (Tcl_GetInt(interp, argv[4], &width) != TCL_OK) + || (Tcl_GetInt(interp, argv[5], &height) != TCL_OK) + || (Tcl_GetInt(interp, argv[6], &timPtr->width) != TCL_OK) + || (Tcl_GetInt(interp, argv[7], &timPtr->height) != TCL_OK)) { + return TCL_ERROR; + } + Tk_ImageChanged(timPtr->master, x, y, width, height, timPtr->width, + timPtr->height); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be changed", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ImageGet -- + * + * This procedure is called by Tk to set things up for using a + * test image in a particular widget. + * + * Results: + * The return value is a token for the image instance, which is + * used in future callbacks to ImageDisplay and ImageFree. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static ClientData +ImageGet(tkwin, clientData) + Tk_Window tkwin; /* Token for window in which image will + * be used. */ + ClientData clientData; /* Pointer to TImageMaster for image. */ +{ + TImageMaster *timPtr = (TImageMaster *) clientData; + TImageInstance *instPtr; + char buffer[100]; + XGCValues gcValues; + + sprintf(buffer, "%s get", timPtr->imageName); + Tcl_SetVar(timPtr->interp, timPtr->varName, buffer, + TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT); + + instPtr = (TImageInstance *) ckalloc(sizeof(TImageInstance)); + instPtr->masterPtr = timPtr; + instPtr->fg = Tk_GetColor(timPtr->interp, tkwin, "#ff0000"); + gcValues.foreground = instPtr->fg->pixel; + instPtr->gc = Tk_GetGC(tkwin, GCForeground, &gcValues); + return (ClientData) instPtr; +} + +/* + *---------------------------------------------------------------------- + * + * ImageDisplay -- + * + * This procedure is invoked to redisplay part or all of an + * image in a given drawable. + * + * Results: + * None. + * + * Side effects: + * The image gets partially redrawn, as an "X" that shows the + * exact redraw area. + * + *---------------------------------------------------------------------- + */ + +static void +ImageDisplay(clientData, display, drawable, imageX, imageY, width, height, + drawableX, drawableY) + ClientData clientData; /* Pointer to TImageInstance for image. */ + Display *display; /* Display to use for drawing. */ + Drawable drawable; /* Where to redraw image. */ + int imageX, imageY; /* Origin of area to redraw, relative to + * origin of image. */ + int width, height; /* Dimensions of area to redraw. */ + int drawableX, drawableY; /* Coordinates in drawable corresponding to + * imageX and imageY. */ +{ + TImageInstance *instPtr = (TImageInstance *) clientData; + char buffer[200]; + + sprintf(buffer, "%s display %d %d %d %d %d %d", + instPtr->masterPtr->imageName, imageX, imageY, width, height, + drawableX, drawableY); + Tcl_SetVar(instPtr->masterPtr->interp, instPtr->masterPtr->varName, buffer, + TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT); + if (width > (instPtr->masterPtr->width - imageX)) { + width = instPtr->masterPtr->width - imageX; + } + if (height > (instPtr->masterPtr->height - imageY)) { + height = instPtr->masterPtr->height - imageY; + } + XDrawRectangle(display, drawable, instPtr->gc, drawableX, drawableY, + (unsigned) (width-1), (unsigned) (height-1)); + XDrawLine(display, drawable, instPtr->gc, drawableX, drawableY, + (int) (drawableX + width - 1), (int) (drawableY + height - 1)); + XDrawLine(display, drawable, instPtr->gc, drawableX, + (int) (drawableY + height - 1), + (int) (drawableX + width - 1), drawableY); +} + +/* + *---------------------------------------------------------------------- + * + * ImageFree -- + * + * This procedure is called when an instance of an image is + * no longer used. + * + * Results: + * None. + * + * Side effects: + * Information related to the instance is freed. + * + *---------------------------------------------------------------------- + */ + +static void +ImageFree(clientData, display) + ClientData clientData; /* Pointer to TImageInstance for instance. */ + Display *display; /* Display where image was to be drawn. */ +{ + TImageInstance *instPtr = (TImageInstance *) clientData; + char buffer[200]; + + sprintf(buffer, "%s free", instPtr->masterPtr->imageName); + Tcl_SetVar(instPtr->masterPtr->interp, instPtr->masterPtr->varName, buffer, + TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT); + Tk_FreeColor(instPtr->fg); + Tk_FreeGC(display, instPtr->gc); + ckfree((char *) instPtr); +} + +/* + *---------------------------------------------------------------------- + * + * ImageDelete -- + * + * This procedure is called to clean up a test image when + * an application goes away. + * + * Results: + * None. + * + * Side effects: + * Information about the image is deleted. + * + *---------------------------------------------------------------------- + */ + +static void +ImageDelete(clientData) + ClientData clientData; /* Pointer to TImageMaster for image. When + * this procedure is called, no more + * instances exist. */ +{ + TImageMaster *timPtr = (TImageMaster *) clientData; + char buffer[100]; + + sprintf(buffer, "%s delete", timPtr->imageName); + Tcl_SetVar(timPtr->interp, timPtr->varName, buffer, + TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT); + + Tcl_DeleteCommand(timPtr->interp, timPtr->imageName); + ckfree(timPtr->imageName); + ckfree(timPtr->varName); + ckfree((char *) timPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TestsendCmd -- + * + * This procedure implements the "testsend" command. It provides + * a set of functions for testing the "send" command and support + * procedure in tkSend.c. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Depends on option; see below. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestsendCmd(clientData, interp, argc, argv) + ClientData clientData; /* Main window for application. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + TkWindow *winPtr = (TkWindow *) clientData; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args; must be \"", argv[0], + " option ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + +#ifndef __WIN32__ + if (strcmp(argv[1], "bogus") == 0) { + XChangeProperty(winPtr->dispPtr->display, + RootWindow(winPtr->dispPtr->display, 0), + winPtr->dispPtr->registryProperty, XA_INTEGER, 32, + PropModeReplace, + (unsigned char *) "This is bogus information", 6); + } else if (strcmp(argv[1], "prop") == 0) { + int result, actualFormat, length; + unsigned long bytesAfter; + Atom actualType, propName; + char *property, *p, *end; + Window w; + + if ((argc != 4) && (argc != 5)) { + Tcl_AppendResult(interp, "wrong # args; must be \"", argv[0], + " prop window name ?value ?\"", (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[2], "root") == 0) { + w = RootWindow(winPtr->dispPtr->display, 0); + } else if (strcmp(argv[2], "comm") == 0) { + w = Tk_WindowId(winPtr->dispPtr->commTkwin); + } else { + w = strtoul(argv[2], &end, 0); + } + propName = Tk_InternAtom((Tk_Window) winPtr, argv[3]); + if (argc == 4) { + property = NULL; + result = XGetWindowProperty(winPtr->dispPtr->display, + w, propName, 0, 100000, False, XA_STRING, + &actualType, &actualFormat, (unsigned long *) &length, + &bytesAfter, (unsigned char **) &property); + if ((result == Success) && (actualType != None) + && (actualFormat == 8) && (actualType == XA_STRING)) { + for (p = property; (p-property) < length; p++) { + if (*p == 0) { + *p = '\n'; + } + } + Tcl_SetResult(interp, property, TCL_VOLATILE); + } + if (property != NULL) { + XFree(property); + } + } else { + if (argv[4][0] == 0) { + XDeleteProperty(winPtr->dispPtr->display, w, propName); + } else { + for (p = argv[4]; *p != 0; p++) { + if (*p == '\n') { + *p = 0; + } + } + XChangeProperty(winPtr->dispPtr->display, + w, propName, XA_STRING, 8, PropModeReplace, + (unsigned char *) argv[4], p-argv[4]); + } + } + } else if (strcmp(argv[1], "serial") == 0) { + sprintf(interp->result, "%d", tkSendSerial+1); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be bogus, prop, or serial", (char *) NULL); + return TCL_ERROR; + } +#endif + return TCL_OK; +} diff --git a/tk4.2/generic/tkText.c b/tk4.2/generic/tkText.c new file mode 100644 index 0000000..76d16ae --- /dev/null +++ b/tk4.2/generic/tkText.c @@ -0,0 +1,2194 @@ +/* + * tkText.c -- + * + * This module provides a big chunk of the implementation of + * multi-line editable text widgets for Tk. Among other things, + * it provides the Tcl command interfaces to text widgets and + * the display code. The B-tree representation of text is + * implemented elsewhere. + * + * Copyright (c) 1992-1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkText.c 1.91 96/05/16 13:19:58 + */ + +#include "default.h" +#include "tkPort.h" +#include "tkInt.h" + +#ifdef MAC_TCL +#define Style TkStyle +#define DInfo TkDInfo +#endif + +#include "tkText.h" + +/* + * Information used to parse text configuration options: + */ + +static Tk_ConfigSpec configSpecs[] = { + {TK_CONFIG_BORDER, "-background", "background", "Background", + DEF_TEXT_BG_COLOR, Tk_Offset(TkText, border), TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_BORDER, "-background", "background", "Background", + DEF_TEXT_BG_MONO, Tk_Offset(TkText, border), TK_CONFIG_MONO_ONLY}, + {TK_CONFIG_SYNONYM, "-bd", "borderWidth", (char *) NULL, + (char *) NULL, 0, 0}, + {TK_CONFIG_SYNONYM, "-bg", "background", (char *) NULL, + (char *) NULL, 0, 0}, + {TK_CONFIG_PIXELS, "-borderwidth", "borderWidth", "BorderWidth", + DEF_TEXT_BORDER_WIDTH, Tk_Offset(TkText, borderWidth), 0}, + {TK_CONFIG_ACTIVE_CURSOR, "-cursor", "cursor", "Cursor", + DEF_TEXT_CURSOR, Tk_Offset(TkText, cursor), TK_CONFIG_NULL_OK}, + {TK_CONFIG_BOOLEAN, "-exportselection", "exportSelection", + "ExportSelection", DEF_TEXT_EXPORT_SELECTION, + Tk_Offset(TkText, exportSelection), 0}, + {TK_CONFIG_SYNONYM, "-fg", "foreground", (char *) NULL, + (char *) NULL, 0, 0}, + {TK_CONFIG_FONT, "-font", "font", "Font", + DEF_TEXT_FONT, Tk_Offset(TkText, fontPtr), 0}, + {TK_CONFIG_COLOR, "-foreground", "foreground", "Foreground", + DEF_TEXT_FG, Tk_Offset(TkText, fgColor), 0}, + {TK_CONFIG_PIXELS, "-height", "height", "Height", + DEF_TEXT_HEIGHT, Tk_Offset(TkText, height), 0}, + {TK_CONFIG_COLOR, "-highlightbackground", "highlightBackground", + "HighlightBackground", DEF_TEXT_HIGHLIGHT_BG, + Tk_Offset(TkText, highlightBgColorPtr), 0}, + {TK_CONFIG_COLOR, "-highlightcolor", "highlightColor", "HighlightColor", + DEF_TEXT_HIGHLIGHT, Tk_Offset(TkText, highlightColorPtr), 0}, + {TK_CONFIG_PIXELS, "-highlightthickness", "highlightThickness", + "HighlightThickness", + DEF_TEXT_HIGHLIGHT_WIDTH, Tk_Offset(TkText, highlightWidth), 0}, + {TK_CONFIG_BORDER, "-insertbackground", "insertBackground", "Foreground", + DEF_TEXT_INSERT_BG, Tk_Offset(TkText, insertBorder), 0}, + {TK_CONFIG_PIXELS, "-insertborderwidth", "insertBorderWidth", "BorderWidth", + DEF_TEXT_INSERT_BD_COLOR, Tk_Offset(TkText, insertBorderWidth), + TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_PIXELS, "-insertborderwidth", "insertBorderWidth", "BorderWidth", + DEF_TEXT_INSERT_BD_MONO, Tk_Offset(TkText, insertBorderWidth), + TK_CONFIG_MONO_ONLY}, + {TK_CONFIG_INT, "-insertofftime", "insertOffTime", "OffTime", + DEF_TEXT_INSERT_OFF_TIME, Tk_Offset(TkText, insertOffTime), 0}, + {TK_CONFIG_INT, "-insertontime", "insertOnTime", "OnTime", + DEF_TEXT_INSERT_ON_TIME, Tk_Offset(TkText, insertOnTime), 0}, + {TK_CONFIG_PIXELS, "-insertwidth", "insertWidth", "InsertWidth", + DEF_TEXT_INSERT_WIDTH, Tk_Offset(TkText, insertWidth), 0}, + {TK_CONFIG_PIXELS, "-padx", "padX", "Pad", + DEF_TEXT_PADX, Tk_Offset(TkText, padX), 0}, + {TK_CONFIG_PIXELS, "-pady", "padY", "Pad", + DEF_TEXT_PADY, Tk_Offset(TkText, padY), 0}, + {TK_CONFIG_RELIEF, "-relief", "relief", "Relief", + DEF_TEXT_RELIEF, Tk_Offset(TkText, relief), 0}, + {TK_CONFIG_BORDER, "-selectbackground", "selectBackground", "Foreground", + DEF_TEXT_SELECT_COLOR, Tk_Offset(TkText, selBorder), + TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_BORDER, "-selectbackground", "selectBackground", "Foreground", + DEF_TEXT_SELECT_MONO, Tk_Offset(TkText, selBorder), + TK_CONFIG_MONO_ONLY}, + {TK_CONFIG_STRING, "-selectborderwidth", "selectBorderWidth", "BorderWidth", + DEF_TEXT_SELECT_BD_COLOR, Tk_Offset(TkText, selBdString), + TK_CONFIG_COLOR_ONLY|TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-selectborderwidth", "selectBorderWidth", "BorderWidth", + DEF_TEXT_SELECT_BD_MONO, Tk_Offset(TkText, selBdString), + TK_CONFIG_MONO_ONLY|TK_CONFIG_NULL_OK}, + {TK_CONFIG_COLOR, "-selectforeground", "selectForeground", "Background", + DEF_TEXT_SELECT_FG_COLOR, Tk_Offset(TkText, selFgColorPtr), + TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_COLOR, "-selectforeground", "selectForeground", "Background", + DEF_TEXT_SELECT_FG_MONO, Tk_Offset(TkText, selFgColorPtr), + TK_CONFIG_MONO_ONLY}, + {TK_CONFIG_BOOLEAN, "-setgrid", "setGrid", "SetGrid", + DEF_TEXT_SET_GRID, Tk_Offset(TkText, setGrid), 0}, + {TK_CONFIG_PIXELS, "-spacing1", "spacing1", "Spacing", + DEF_TEXT_SPACING1, Tk_Offset(TkText, spacing1), + TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_PIXELS, "-spacing2", "spacing2", "Spacing", + DEF_TEXT_SPACING2, Tk_Offset(TkText, spacing2), + TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_PIXELS, "-spacing3", "spacing3", "Spacing", + DEF_TEXT_SPACING3, Tk_Offset(TkText, spacing3), + TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_UID, "-state", "state", "State", + DEF_TEXT_STATE, Tk_Offset(TkText, state), 0}, + {TK_CONFIG_STRING, "-tabs", "tabs", "Tabs", + DEF_TEXT_TABS, Tk_Offset(TkText, tabOptionString), TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-takefocus", "takeFocus", "TakeFocus", + DEF_TEXT_TAKE_FOCUS, Tk_Offset(TkText, takeFocus), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_INT, "-width", "width", "Width", + DEF_TEXT_WIDTH, Tk_Offset(TkText, width), 0}, + {TK_CONFIG_UID, "-wrap", "wrap", "Wrap", + DEF_TEXT_WRAP, Tk_Offset(TkText, wrapMode), 0}, + {TK_CONFIG_STRING, "-xscrollcommand", "xScrollCommand", "ScrollCommand", + DEF_TEXT_XSCROLL_COMMAND, Tk_Offset(TkText, xScrollCmd), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-yscrollcommand", "yScrollCommand", "ScrollCommand", + DEF_TEXT_YSCROLL_COMMAND, Tk_Offset(TkText, yScrollCmd), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, 0} +}; + +/* + * Tk_Uid's used to represent text states: + */ + +Tk_Uid tkTextCharUid = NULL; +Tk_Uid tkTextDisabledUid = NULL; +Tk_Uid tkTextNoneUid = NULL; +Tk_Uid tkTextNormalUid = NULL; +Tk_Uid tkTextWordUid = NULL; + +/* + * Boolean variable indicating whether or not special debugging code + * should be executed. + */ + +int tkTextDebug = 0; + +/* + * Forward declarations for procedures defined later in this file: + */ + +static int ConfigureText _ANSI_ARGS_((Tcl_Interp *interp, + TkText *textPtr, int argc, char **argv, int flags)); +static int DeleteChars _ANSI_ARGS_((TkText *textPtr, + char *index1String, char *index2String)); +static void DestroyText _ANSI_ARGS_((char *memPtr)); +static void InsertChars _ANSI_ARGS_((TkText *textPtr, + TkTextIndex *indexPtr, char *string)); +static void TextBlinkProc _ANSI_ARGS_((ClientData clientData)); +static void TextCmdDeletedProc _ANSI_ARGS_(( + ClientData clientData)); +static void TextEventProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +static int TextFetchSelection _ANSI_ARGS_((ClientData clientData, + int offset, char *buffer, int maxBytes)); +static int TextSearchCmd _ANSI_ARGS_((TkText *textPtr, + Tcl_Interp *interp, int argc, char **argv)); +static int TextWidgetCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static int TextDumpCmd _ANSI_ARGS_((TkText *textPtr, + Tcl_Interp *interp, int argc, char **argv)); +static void DumpLine _ANSI_ARGS_((Tcl_Interp *interp, + TkText *textPtr, int what, TkTextLine *linePtr, + int start, int end, int lineno, char *command)); +static int DumpSegment _ANSI_ARGS_((Tcl_Interp *interp, char *key, + char *value, char * command, int lineno, int offset, + int what)); + + +/* + *-------------------------------------------------------------- + * + * Tk_TextCmd -- + * + * This procedure is invoked to process the "text" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +int +Tk_TextCmd(clientData, interp, argc, argv) + ClientData clientData; /* Main window associated with + * interpreter. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tk_Window tkwin = (Tk_Window) clientData; + Tk_Window new; + register TkText *textPtr; + TkTextIndex startIndex; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " pathName ?options?\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * Perform once-only initialization: + */ + + if (tkTextNormalUid == NULL) { + tkTextCharUid = Tk_GetUid("char"); + tkTextDisabledUid = Tk_GetUid("disabled"); + tkTextNoneUid = Tk_GetUid("none"); + tkTextNormalUid = Tk_GetUid("normal"); + tkTextWordUid = Tk_GetUid("word"); + } + + /* + * Create the window. + */ + + new = Tk_CreateWindowFromPath(interp, tkwin, argv[1], (char *) NULL); + if (new == NULL) { + return TCL_ERROR; + } + + textPtr = (TkText *) ckalloc(sizeof(TkText)); + textPtr->tkwin = new; + textPtr->display = Tk_Display(new); + textPtr->interp = interp; + textPtr->widgetCmd = Tcl_CreateCommand(interp, + Tk_PathName(textPtr->tkwin), TextWidgetCmd, + (ClientData) textPtr, TextCmdDeletedProc); + textPtr->tree = TkBTreeCreate(textPtr); + Tcl_InitHashTable(&textPtr->tagTable, TCL_STRING_KEYS); + textPtr->numTags = 0; + Tcl_InitHashTable(&textPtr->markTable, TCL_STRING_KEYS); + Tcl_InitHashTable(&textPtr->windowTable, TCL_STRING_KEYS); + textPtr->state = tkTextNormalUid; + textPtr->border = NULL; + textPtr->borderWidth = 0; + textPtr->padX = 0; + textPtr->padY = 0; + textPtr->relief = TK_RELIEF_FLAT; + textPtr->highlightWidth = 0; + textPtr->highlightBgColorPtr = NULL; + textPtr->highlightColorPtr = NULL; + textPtr->cursor = None; + textPtr->fgColor = NULL; + textPtr->fontPtr = NULL; + textPtr->charWidth = 1; + textPtr->spacing1 = 0; + textPtr->spacing2 = 0; + textPtr->spacing3 = 0; + textPtr->tabOptionString = NULL; + textPtr->tabArrayPtr = NULL; + textPtr->wrapMode = tkTextCharUid; + textPtr->width = 0; + textPtr->height = 0; + textPtr->setGrid = 0; + textPtr->prevWidth = Tk_Width(new); + textPtr->prevHeight = Tk_Height(new); + TkTextCreateDInfo(textPtr); + TkTextMakeIndex(textPtr->tree, 0, 0, &startIndex); + TkTextSetYView(textPtr, &startIndex, 0); + textPtr->selTagPtr = NULL; + textPtr->selBorder = NULL; + textPtr->selBdString = NULL; + textPtr->selFgColorPtr = NULL; + textPtr->exportSelection = 1; + textPtr->abortSelections = 0; + textPtr->insertMarkPtr = NULL; + textPtr->insertBorder = NULL; + textPtr->insertWidth = 0; + textPtr->insertBorderWidth = 0; + textPtr->insertOnTime = 0; + textPtr->insertOffTime = 0; + textPtr->insertBlinkHandler = (Tcl_TimerToken) NULL; + textPtr->bindingTable = NULL; + textPtr->currentMarkPtr = NULL; + textPtr->pickEvent.type = LeaveNotify; + textPtr->pickEvent.xcrossing.x = 0; + textPtr->pickEvent.xcrossing.y = 0; + textPtr->numCurTags = 0; + textPtr->curTagArrayPtr = NULL; + textPtr->takeFocus = NULL; + textPtr->xScrollCmd = NULL; + textPtr->yScrollCmd = NULL; + textPtr->flags = 0; + + /* + * Create the "sel" tag and the "current" and "insert" marks. + */ + + textPtr->selTagPtr = TkTextCreateTag(textPtr, "sel"); + textPtr->selTagPtr->reliefString = (char *) ckalloc(7); + strcpy(textPtr->selTagPtr->reliefString, "raised"); + textPtr->selTagPtr->relief = TK_RELIEF_RAISED; + textPtr->currentMarkPtr = TkTextSetMark(textPtr, "current", &startIndex); + textPtr->insertMarkPtr = TkTextSetMark(textPtr, "insert", &startIndex); + + Tk_SetClass(new, "Text"); + Tk_CreateEventHandler(textPtr->tkwin, + ExposureMask|StructureNotifyMask|FocusChangeMask, + TextEventProc, (ClientData) textPtr); + Tk_CreateEventHandler(textPtr->tkwin, KeyPressMask|KeyReleaseMask + |ButtonPressMask|ButtonReleaseMask|EnterWindowMask + |LeaveWindowMask|PointerMotionMask, TkTextBindProc, + (ClientData) textPtr); + Tk_CreateSelHandler(textPtr->tkwin, XA_PRIMARY, XA_STRING, + TextFetchSelection, (ClientData) textPtr, XA_STRING); + if (ConfigureText(interp, textPtr, argc-2, argv+2, 0) != TCL_OK) { + Tk_DestroyWindow(textPtr->tkwin); + return TCL_ERROR; + } + interp->result = Tk_PathName(textPtr->tkwin); + + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * TextWidgetCmd -- + * + * This procedure is invoked to process the Tcl command + * that corresponds to a text widget. See the user + * documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +static int +TextWidgetCmd(clientData, interp, argc, argv) + ClientData clientData; /* Information about text widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register TkText *textPtr = (TkText *) clientData; + int result = TCL_OK; + size_t length; + int c; + TkTextIndex index1, index2; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_Preserve((ClientData) textPtr); + c = argv[1][0]; + length = strlen(argv[1]); + if ((c == 'b') && (strncmp(argv[1], "bbox", length) == 0)) { + int x, y, width, height; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " bbox index\"", (char *) NULL); + result = TCL_ERROR; + goto done; + } + if (TkTextGetIndex(interp, textPtr, argv[2], &index1) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + if (TkTextCharBbox(textPtr, &index1, &x, &y, &width, &height) == 0) { + sprintf(interp->result, "%d %d %d %d", x, y, width, height); + } + } else if ((c == 'c') && (strncmp(argv[1], "cget", length) == 0) + && (length >= 2)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " cget option\"", + (char *) NULL); + result = TCL_ERROR; + goto done; + } + result = Tk_ConfigureValue(interp, textPtr->tkwin, configSpecs, + (char *) textPtr, argv[2], 0); + } else if ((c == 'c') && (strncmp(argv[1], "compare", length) == 0) + && (length >= 3)) { + int relation, value; + char *p; + + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " compare index1 op index2\"", (char *) NULL); + result = TCL_ERROR; + goto done; + } + if ((TkTextGetIndex(interp, textPtr, argv[2], &index1) != TCL_OK) + || (TkTextGetIndex(interp, textPtr, argv[4], &index2) + != TCL_OK)) { + result = TCL_ERROR; + goto done; + } + relation = TkTextIndexCmp(&index1, &index2); + p = argv[3]; + if (p[0] == '<') { + value = (relation < 0); + if ((p[1] == '=') && (p[2] == 0)) { + value = (relation <= 0); + } else if (p[1] != 0) { + compareError: + Tcl_AppendResult(interp, "bad comparison operator \"", + argv[3], "\": must be <, <=, ==, >=, >, or !=", + (char *) NULL); + result = TCL_ERROR; + goto done; + } + } else if (p[0] == '>') { + value = (relation > 0); + if ((p[1] == '=') && (p[2] == 0)) { + value = (relation >= 0); + } else if (p[1] != 0) { + goto compareError; + } + } else if ((p[0] == '=') && (p[1] == '=') && (p[2] == 0)) { + value = (relation == 0); + } else if ((p[0] == '!') && (p[1] == '=') && (p[2] == 0)) { + value = (relation != 0); + } else { + goto compareError; + } + interp->result = (value) ? "1" : "0"; + } else if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0) + && (length >= 3)) { + if (argc == 2) { + result = Tk_ConfigureInfo(interp, textPtr->tkwin, configSpecs, + (char *) textPtr, (char *) NULL, 0); + } else if (argc == 3) { + result = Tk_ConfigureInfo(interp, textPtr->tkwin, configSpecs, + (char *) textPtr, argv[2], 0); + } else { + result = ConfigureText(interp, textPtr, argc-2, argv+2, + TK_CONFIG_ARGV_ONLY); + } + } else if ((c == 'd') && (strncmp(argv[1], "debug", length) == 0) + && (length >= 3)) { + if (argc > 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " debug boolean\"", (char *) NULL); + result = TCL_ERROR; + goto done; + } + if (argc == 2) { + interp->result = (tkBTreeDebug) ? "1" : "0"; + } else { + if (Tcl_GetBoolean(interp, argv[2], &tkBTreeDebug) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + tkTextDebug = tkBTreeDebug; + } + } else if ((c == 'd') && (strncmp(argv[1], "delete", length) == 0) + && (length >= 3)) { + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " delete index1 ?index2?\"", (char *) NULL); + result = TCL_ERROR; + goto done; + } + if (textPtr->state == tkTextNormalUid) { + result = DeleteChars(textPtr, argv[2], + (argc == 4) ? argv[3] : (char *) NULL); + } + } else if ((c == 'd') && (strncmp(argv[1], "dlineinfo", length) == 0) + && (length >= 2)) { + int x, y, width, height, base; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " dlineinfo index\"", (char *) NULL); + result = TCL_ERROR; + goto done; + } + if (TkTextGetIndex(interp, textPtr, argv[2], &index1) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + if (TkTextDLineInfo(textPtr, &index1, &x, &y, &width, &height, &base) + == 0) { + sprintf(interp->result, "%d %d %d %d %d", x, y, width, + height, base); + } + } else if ((c == 'g') && (strncmp(argv[1], "get", length) == 0)) { + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " get index1 ?index2?\"", (char *) NULL); + result = TCL_ERROR; + goto done; + } + if (TkTextGetIndex(interp, textPtr, argv[2], &index1) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + if (argc == 3) { + index2 = index1; + TkTextIndexForwChars(&index2, 1, &index2); + } else if (TkTextGetIndex(interp, textPtr, argv[3], &index2) + != TCL_OK) { + result = TCL_ERROR; + goto done; + } + if (TkTextIndexCmp(&index1, &index2) >= 0) { + goto done; + } + while (1) { + int offset, last, savedChar; + TkTextSegment *segPtr; + + segPtr = TkTextIndexToSeg(&index1, &offset); + last = segPtr->size; + if (index1.linePtr == index2.linePtr) { + int last2; + + if (index2.charIndex == index1.charIndex) { + break; + } + last2 = index2.charIndex - index1.charIndex + offset; + if (last2 < last) { + last = last2; + } + } + if (segPtr->typePtr == &tkTextCharType) { + savedChar = segPtr->body.chars[last]; + segPtr->body.chars[last] = 0; + Tcl_AppendResult(interp, segPtr->body.chars + offset, + (char *) NULL); + segPtr->body.chars[last] = savedChar; + } + TkTextIndexForwChars(&index1, last-offset, &index1); + } + } else if ((c == 'i') && (strncmp(argv[1], "index", length) == 0) + && (length >= 3)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " index index\"", + (char *) NULL); + result = TCL_ERROR; + goto done; + } + if (TkTextGetIndex(interp, textPtr, argv[2], &index1) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + TkTextPrintIndex(&index1, interp->result); + } else if ((c == 'i') && (strncmp(argv[1], "insert", length) == 0) + && (length >= 3)) { + int i, j, numTags; + char **tagNames; + TkTextTag **oldTagArrayPtr; + + if (argc < 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], + " insert index chars ?tagList chars tagList ...?\"", + (char *) NULL); + result = TCL_ERROR; + goto done; + } + if (TkTextGetIndex(interp, textPtr, argv[2], &index1) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + if (textPtr->state == tkTextNormalUid) { + for (j = 3; j < argc; j += 2) { + InsertChars(textPtr, &index1, argv[j]); + if (argc > (j+1)) { + TkTextIndexForwChars(&index1, (int) strlen(argv[j]), + &index2); + oldTagArrayPtr = TkBTreeGetTags(&index1, &numTags); + if (oldTagArrayPtr != NULL) { + for (i = 0; i < numTags; i++) { + TkBTreeTag(&index1, &index2, oldTagArrayPtr[i], 0); + } + ckfree((char *) oldTagArrayPtr); + } + if (Tcl_SplitList(interp, argv[j+1], &numTags, &tagNames) + != TCL_OK) { + result = TCL_ERROR; + goto done; + } + for (i = 0; i < numTags; i++) { + TkBTreeTag(&index1, &index2, + TkTextCreateTag(textPtr, tagNames[i]), 1); + } + ckfree((char *) tagNames); + index1 = index2; + } + } + } + } else if ((c == 'd') && (strncmp(argv[1], "dump", length) == 0)) { + result = TextDumpCmd(textPtr, interp, argc, argv); + } else if ((c == 'm') && (strncmp(argv[1], "mark", length) == 0)) { + result = TkTextMarkCmd(textPtr, interp, argc, argv); + } else if ((c == 's') && (strcmp(argv[1], "scan") == 0) && (length >= 2)) { + result = TkTextScanCmd(textPtr, interp, argc, argv); + } else if ((c == 's') && (strcmp(argv[1], "search") == 0) + && (length >= 3)) { + result = TextSearchCmd(textPtr, interp, argc, argv); + } else if ((c == 's') && (strcmp(argv[1], "see") == 0) && (length >= 3)) { + result = TkTextSeeCmd(textPtr, interp, argc, argv); + } else if ((c == 't') && (strcmp(argv[1], "tag") == 0)) { + result = TkTextTagCmd(textPtr, interp, argc, argv); + } else if ((c == 'w') && (strncmp(argv[1], "window", length) == 0)) { + result = TkTextWindowCmd(textPtr, interp, argc, argv); + } else if ((c == 'x') && (strncmp(argv[1], "xview", length) == 0)) { + result = TkTextXviewCmd(textPtr, interp, argc, argv); + } else if ((c == 'y') && (strncmp(argv[1], "yview", length) == 0) + && (length >= 2)) { + result = TkTextYviewCmd(textPtr, interp, argc, argv); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be bbox, cget, compare, configure, debug, delete, ", + "dlineinfo, get, index, insert, mark, scan, search, see, ", + "tag, window, xview, or yview", + (char *) NULL); + result = TCL_ERROR; + } + + done: + Tcl_Release((ClientData) textPtr); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * DestroyText -- + * + * This procedure is invoked by Tcl_EventuallyFree or Tcl_Release + * to clean up the internal structure of a text at a safe time + * (when no-one is using it anymore). + * + * Results: + * None. + * + * Side effects: + * Everything associated with the text is freed up. + * + *---------------------------------------------------------------------- + */ + +static void +DestroyText(memPtr) + char *memPtr; /* Info about text widget. */ +{ + register TkText *textPtr = (TkText *) memPtr; + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + TkTextTag *tagPtr; + + /* + * Free up all the stuff that requires special handling, then + * let Tk_FreeOptions handle all the standard option-related + * stuff. Special note: free up display-related information + * before deleting the B-tree, since display-related stuff + * may refer to stuff in the B-tree. + */ + + TkTextFreeDInfo(textPtr); + TkBTreeDestroy(textPtr->tree); + for (hPtr = Tcl_FirstHashEntry(&textPtr->tagTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + tagPtr = (TkTextTag *) Tcl_GetHashValue(hPtr); + TkTextFreeTag(textPtr, tagPtr); + } + Tcl_DeleteHashTable(&textPtr->tagTable); + for (hPtr = Tcl_FirstHashEntry(&textPtr->markTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + ckfree((char *) Tcl_GetHashValue(hPtr)); + } + Tcl_DeleteHashTable(&textPtr->markTable); + if (textPtr->tabArrayPtr != NULL) { + ckfree((char *) textPtr->tabArrayPtr); + } + if (textPtr->insertBlinkHandler != NULL) { + Tcl_DeleteTimerHandler(textPtr->insertBlinkHandler); + } + if (textPtr->bindingTable != NULL) { + Tk_DeleteBindingTable(textPtr->bindingTable); + } + + /* + * NOTE: do NOT free up selBorder, selBdString, or selFgColorPtr: + * they are duplicates of information in the "sel" tag, which was + * freed up as part of deleting the tags above. + */ + + textPtr->selBorder = NULL; + textPtr->selBdString = NULL; + textPtr->selFgColorPtr = NULL; + Tk_FreeOptions(configSpecs, (char *) textPtr, textPtr->display, 0); + ckfree((char *) textPtr); +} + +/* + *---------------------------------------------------------------------- + * + * ConfigureText -- + * + * This procedure is called to process an argv/argc list, plus + * the Tk option database, in order to configure (or + * reconfigure) a text widget. + * + * Results: + * The return value is a standard Tcl result. If TCL_ERROR is + * returned, then interp->result contains an error message. + * + * Side effects: + * Configuration information, such as text string, colors, font, + * etc. get set for textPtr; old resources get freed, if there + * were any. + * + *---------------------------------------------------------------------- + */ + +static int +ConfigureText(interp, textPtr, argc, argv, flags) + Tcl_Interp *interp; /* Used for error reporting. */ + register TkText *textPtr; /* Information about widget; may or may + * not already have values for some fields. */ + int argc; /* Number of valid entries in argv. */ + char **argv; /* Arguments. */ + int flags; /* Flags to pass to Tk_ConfigureWidget. */ +{ + int oldExport = textPtr->exportSelection; + int charHeight; + + if (Tk_ConfigureWidget(interp, textPtr->tkwin, configSpecs, + argc, argv, (char *) textPtr, flags) != TCL_OK) { + return TCL_ERROR; + } + + /* + * A few other options also need special processing, such as parsing + * the geometry and setting the background from a 3-D border. + */ + + if ((textPtr->state != tkTextNormalUid) + && (textPtr->state != tkTextDisabledUid)) { + Tcl_AppendResult(interp, "bad state value \"", textPtr->state, + "\": must be normal or disabled", (char *) NULL); + textPtr->state = tkTextNormalUid; + return TCL_ERROR; + } + + if ((textPtr->wrapMode != tkTextCharUid) + && (textPtr->wrapMode != tkTextNoneUid) + && (textPtr->wrapMode != tkTextWordUid)) { + Tcl_AppendResult(interp, "bad wrap mode \"", textPtr->wrapMode, + "\": must be char, none, or word", (char *) NULL); + textPtr->wrapMode = tkTextCharUid; + return TCL_ERROR; + } + + Tk_SetBackgroundFromBorder(textPtr->tkwin, textPtr->border); + + /* + * Don't allow negative spacings. + */ + + if (textPtr->spacing1 < 0) { + textPtr->spacing1 = 0; + } + if (textPtr->spacing2 < 0) { + textPtr->spacing2 = 0; + } + if (textPtr->spacing3 < 0) { + textPtr->spacing3 = 0; + } + + /* + * Parse tab stops. + */ + + if (textPtr->tabArrayPtr != NULL) { + ckfree((char *) textPtr->tabArrayPtr); + textPtr->tabArrayPtr = NULL; + } + if (textPtr->tabOptionString != NULL) { + textPtr->tabArrayPtr = TkTextGetTabs(interp, textPtr->tkwin, + textPtr->tabOptionString); + if (textPtr->tabArrayPtr == NULL) { + Tcl_AddErrorInfo(interp,"\n (while processing -tabs option)"); + return TCL_ERROR; + } + } + + /* + * Make sure that configuration options are properly mirrored + * between the widget record and the "sel" tags. NOTE: we don't + * have to free up information during the mirroring; old + * information was freed when it was replaced in the widget + * record. + */ + + textPtr->selTagPtr->border = textPtr->selBorder; + if (textPtr->selTagPtr->bdString != textPtr->selBdString) { + textPtr->selTagPtr->bdString = textPtr->selBdString; + if (textPtr->selBdString != NULL) { + if (Tk_GetPixels(interp, textPtr->tkwin, textPtr->selBdString, + &textPtr->selTagPtr->borderWidth) != TCL_OK) { + return TCL_ERROR; + } + if (textPtr->selTagPtr->borderWidth < 0) { + textPtr->selTagPtr->borderWidth = 0; + } + } + } + textPtr->selTagPtr->fgColor = textPtr->selFgColorPtr; + textPtr->selTagPtr->affectsDisplay = 0; + if ((textPtr->selTagPtr->border != NULL) + || (textPtr->selTagPtr->bdString != NULL) + || (textPtr->selTagPtr->reliefString != NULL) + || (textPtr->selTagPtr->bgStipple != None) + || (textPtr->selTagPtr->fgColor != NULL) + || (textPtr->selTagPtr->fontPtr != None) + || (textPtr->selTagPtr->fgStipple != None) + || (textPtr->selTagPtr->justifyString != NULL) + || (textPtr->selTagPtr->lMargin1String != NULL) + || (textPtr->selTagPtr->lMargin2String != NULL) + || (textPtr->selTagPtr->offsetString != NULL) + || (textPtr->selTagPtr->overstrikeString != NULL) + || (textPtr->selTagPtr->rMarginString != NULL) + || (textPtr->selTagPtr->spacing1String != NULL) + || (textPtr->selTagPtr->spacing2String != NULL) + || (textPtr->selTagPtr->spacing3String != NULL) + || (textPtr->selTagPtr->tabString != NULL) + || (textPtr->selTagPtr->underlineString != NULL) + || (textPtr->selTagPtr->wrapMode != NULL)) { + textPtr->selTagPtr->affectsDisplay = 1; + } + TkTextRedrawTag(textPtr, (TkTextIndex *) NULL, (TkTextIndex *) NULL, + textPtr->selTagPtr, 1); + + /* + * Claim the selection if we've suddenly started exporting it and there + * are tagged characters. + */ + + if (textPtr->exportSelection && (!oldExport)) { + TkTextSearch search; + TkTextIndex first, last; + + TkTextMakeIndex(textPtr->tree, 0, 0, &first); + TkTextMakeIndex(textPtr->tree, + TkBTreeNumLines(textPtr->tree), 0, &last); + TkBTreeStartSearch(&first, &last, textPtr->selTagPtr, &search); + if (TkBTreeCharTagged(&first, textPtr->selTagPtr) + || TkBTreeNextTag(&search)) { + Tk_OwnSelection(textPtr->tkwin, XA_PRIMARY, TkTextLostSelection, + (ClientData) textPtr); + textPtr->flags |= GOT_SELECTION; + } + } + + /* + * Register the desired geometry for the window, and arrange for + * the window to be redisplayed. + */ + + if (textPtr->width <= 0) { + textPtr->width = 1; + } + if (textPtr->height <= 0) { + textPtr->height = 1; + } + textPtr->charWidth = XTextWidth(textPtr->fontPtr, "0", 1); + if (textPtr->charWidth <= 0) { + textPtr->charWidth = 1; + } + charHeight = (textPtr->fontPtr->ascent + textPtr->fontPtr->descent); + Tk_GeometryRequest(textPtr->tkwin, + textPtr->width * textPtr->charWidth + 2*textPtr->borderWidth + + 2*textPtr->padX + 2*textPtr->highlightWidth, + textPtr->height * charHeight + 2*textPtr->borderWidth + + 2*textPtr->padY + 2*textPtr->highlightWidth); + Tk_SetInternalBorder(textPtr->tkwin, + textPtr->borderWidth + textPtr->highlightWidth); + if (textPtr->setGrid) { + Tk_SetGrid(textPtr->tkwin, textPtr->width, textPtr->height, + textPtr->charWidth, charHeight); + } else { + Tk_UnsetGrid(textPtr->tkwin); + } + + TkTextRelayoutWindow(textPtr); + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * TextEventProc -- + * + * This procedure is invoked by the Tk dispatcher on + * structure changes to a text. For texts with 3D + * borders, this procedure is also invoked for exposures. + * + * Results: + * None. + * + * Side effects: + * When the window gets deleted, internal structures get + * cleaned up. When it gets exposed, it is redisplayed. + * + *-------------------------------------------------------------- + */ + +static void +TextEventProc(clientData, eventPtr) + ClientData clientData; /* Information about window. */ + register XEvent *eventPtr; /* Information about event. */ +{ + register TkText *textPtr = (TkText *) clientData; + TkTextIndex index, index2; + + if (eventPtr->type == Expose) { + TkTextRedrawRegion(textPtr, eventPtr->xexpose.x, + eventPtr->xexpose.y, eventPtr->xexpose.width, + eventPtr->xexpose.height); + } else if (eventPtr->type == ConfigureNotify) { + if ((textPtr->prevWidth != Tk_Width(textPtr->tkwin)) + || (textPtr->prevHeight != Tk_Height(textPtr->tkwin))) { + TkTextRelayoutWindow(textPtr); + textPtr->prevWidth = Tk_Width(textPtr->tkwin); + textPtr->prevHeight = Tk_Height(textPtr->tkwin); + } + } else if (eventPtr->type == DestroyNotify) { + if (textPtr->tkwin != NULL) { + if (textPtr->setGrid) { + Tk_UnsetGrid(textPtr->tkwin); + } + textPtr->tkwin = NULL; + Tcl_DeleteCommand(textPtr->interp, + Tcl_GetCommandName(textPtr->interp, + textPtr->widgetCmd)); + } + Tcl_EventuallyFree((ClientData) textPtr, DestroyText); + } else if ((eventPtr->type == FocusIn) || (eventPtr->type == FocusOut)) { + if (eventPtr->xfocus.detail != NotifyInferior) { + Tcl_DeleteTimerHandler(textPtr->insertBlinkHandler); + if (eventPtr->type == FocusIn) { + textPtr->flags |= GOT_FOCUS | INSERT_ON; + if (textPtr->insertOffTime != 0) { + textPtr->insertBlinkHandler = Tcl_CreateTimerHandler( + textPtr->insertOnTime, TextBlinkProc, + (ClientData) textPtr); + } + } else { + textPtr->flags &= ~(GOT_FOCUS | INSERT_ON); + textPtr->insertBlinkHandler = (Tcl_TimerToken) NULL; + } + TkTextMarkSegToIndex(textPtr, textPtr->insertMarkPtr, &index); + TkTextIndexForwChars(&index, 1, &index2); + TkTextChanged(textPtr, &index, &index2); + if (textPtr->highlightWidth > 0) { + TkTextRedrawRegion(textPtr, 0, 0, textPtr->highlightWidth, + textPtr->highlightWidth); + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TextCmdDeletedProc -- + * + * This procedure is invoked when a widget command is deleted. If + * the widget isn't already in the process of being destroyed, + * this command destroys it. + * + * Results: + * None. + * + * Side effects: + * The widget is destroyed. + * + *---------------------------------------------------------------------- + */ + +static void +TextCmdDeletedProc(clientData) + ClientData clientData; /* Pointer to widget record for widget. */ +{ + TkText *textPtr = (TkText *) clientData; + Tk_Window tkwin = textPtr->tkwin; + + /* + * This procedure could be invoked either because the window was + * destroyed and the command was then deleted (in which case tkwin + * is NULL) or because the command was deleted, and then this procedure + * destroys the widget. + */ + + if (tkwin != NULL) { + if (textPtr->setGrid) { + Tk_UnsetGrid(textPtr->tkwin); + } + textPtr->tkwin = NULL; + Tk_DestroyWindow(tkwin); + } +} + +/* + *---------------------------------------------------------------------- + * + * InsertChars -- + * + * This procedure implements most of the functionality of the + * "insert" widget command. + * + * Results: + * None. + * + * Side effects: + * The characters in "string" get added to the text just before + * the character indicated by "indexPtr". + * + *---------------------------------------------------------------------- + */ + +static void +InsertChars(textPtr, indexPtr, string) + TkText *textPtr; /* Overall information about text widget. */ + TkTextIndex *indexPtr; /* Where to insert new characters. May be + * modified and/or invalidated. */ + char *string; /* Null-terminated string containing new + * information to add to text. */ +{ + int lineIndex, resetView, offset; + TkTextIndex newTop; + + /* + * Don't allow insertions on the last (dummy) line of the text. + */ + + lineIndex = TkBTreeLineIndex(indexPtr->linePtr); + if (lineIndex == TkBTreeNumLines(textPtr->tree)) { + lineIndex--; + TkTextMakeIndex(textPtr->tree, lineIndex, 1000000, indexPtr); + } + + /* + * Notify the display module that lines are about to change, then do + * the insertion. If the insertion occurs on the top line of the + * widget (textPtr->topIndex), then we have to recompute topIndex + * after the insertion, since the insertion could invalidate it. + */ + + resetView = offset = 0; + if (indexPtr->linePtr == textPtr->topIndex.linePtr) { + resetView = 1; + offset = textPtr->topIndex.charIndex; + if (offset > indexPtr->charIndex) { + offset += strlen(string); + } + } + TkTextChanged(textPtr, indexPtr, indexPtr); + TkBTreeInsertChars(indexPtr, string); + if (resetView) { + TkTextMakeIndex(textPtr->tree, lineIndex, 0, &newTop); + TkTextIndexForwChars(&newTop, offset, &newTop); + TkTextSetYView(textPtr, &newTop, 0); + } + + /* + * Invalidate any selection retrievals in progress. + */ + + textPtr->abortSelections = 1; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteChars -- + * + * This procedure implements most of the functionality of the + * "delete" widget command. + * + * Results: + * Returns a standard Tcl result, and leaves an error message + * in textPtr->interp if there is an error. + * + * Side effects: + * Characters get deleted from the text. + * + *---------------------------------------------------------------------- + */ + +static int +DeleteChars(textPtr, index1String, index2String) + TkText *textPtr; /* Overall information about text widget. */ + char *index1String; /* String describing location of first + * character to delete. */ + char *index2String; /* String describing location of last + * character to delete. NULL means just + * delete the one character given by + * index1String. */ +{ + int line1, line2, line, charIndex, resetView; + TkTextIndex index1, index2; + + /* + * Parse the starting and stopping indices. + */ + + if (TkTextGetIndex(textPtr->interp, textPtr, index1String, &index1) + != TCL_OK) { + return TCL_ERROR; + } + if (index2String != NULL) { + if (TkTextGetIndex(textPtr->interp, textPtr, index2String, &index2) + != TCL_OK) { + return TCL_ERROR; + } + } else { + index2 = index1; + TkTextIndexForwChars(&index2, 1, &index2); + } + + /* + * Make sure there's really something to delete. + */ + + if (TkTextIndexCmp(&index1, &index2) >= 0) { + return TCL_OK; + } + + /* + * The code below is ugly, but it's needed to make sure there + * is always a dummy empty line at the end of the text. If the + * final newline of the file (just before the dummy line) is being + * deleted, then back up index to just before the newline. If + * there is a newline just before the first character being deleted, + * then back up the first index too, so that an even number of lines + * gets deleted. Furthermore, remove any tags that are present on + * the newline that isn't going to be deleted after all (this simulates + * deleting the newline and then adding a "clean" one back again). + */ + + line1 = TkBTreeLineIndex(index1.linePtr); + line2 = TkBTreeLineIndex(index2.linePtr); + if (line2 == TkBTreeNumLines(textPtr->tree)) { + TkTextTag **arrayPtr; + int arraySize, i; + TkTextIndex oldIndex2; + + oldIndex2 = index2; + TkTextIndexBackChars(&oldIndex2, 1, &index2); + line2--; + if ((index1.charIndex == 0) && (line1 != 0)) { + TkTextIndexBackChars(&index1, 1, &index1); + line1--; + } + arrayPtr = TkBTreeGetTags(&index2, &arraySize); + if (arrayPtr != NULL) { + for (i = 0; i < arraySize; i++) { + TkBTreeTag(&index2, &oldIndex2, arrayPtr[i], 0); + } + ckfree((char *) arrayPtr); + } + } + + /* + * Tell the display what's about to happen so it can discard + * obsolete display information, then do the deletion. Also, + * if the deletion involves the top line on the screen, then + * we have to reset the view (the deletion will invalidate + * textPtr->topIndex). Compute what the new first character + * will be, then do the deletion, then reset the view. + */ + + TkTextChanged(textPtr, &index1, &index2); + resetView = line = charIndex = 0; + if (TkTextIndexCmp(&index2, &textPtr->topIndex) >= 0) { + if (TkTextIndexCmp(&index1, &textPtr->topIndex) <= 0) { + /* + * Deletion range straddles topIndex: use the beginning + * of the range as the new topIndex. + */ + + resetView = 1; + line = line1; + charIndex = index1.charIndex; + } else if (index1.linePtr == textPtr->topIndex.linePtr) { + /* + * Deletion range starts on top line but after topIndex. + * Use the current topIndex as the new one. + */ + + resetView = 1; + line = line1; + charIndex = textPtr->topIndex.charIndex; + } + } else if (index2.linePtr == textPtr->topIndex.linePtr) { + /* + * Deletion range ends on top line but before topIndex. + * Figure out what will be the new character index for + * the character currently pointed to by topIndex. + */ + + resetView = 1; + line = line2; + charIndex = textPtr->topIndex.charIndex; + if (index1.linePtr != index2.linePtr) { + charIndex -= index2.charIndex; + } else { + charIndex -= (index2.charIndex - index1.charIndex); + } + } + TkBTreeDeleteChars(&index1, &index2); + if (resetView) { + TkTextMakeIndex(textPtr->tree, line, charIndex, &index1); + TkTextSetYView(textPtr, &index1, 0); + } + + /* + * Invalidate any selection retrievals in progress. + */ + + textPtr->abortSelections = 1; + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TextFetchSelection -- + * + * This procedure is called back by Tk when the selection is + * requested by someone. It returns part or all of the selection + * in a buffer provided by the caller. + * + * Results: + * The return value is the number of non-NULL bytes stored + * at buffer. Buffer is filled (or partially filled) with a + * NULL-terminated string containing part or all of the selection, + * as given by offset and maxBytes. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TextFetchSelection(clientData, offset, buffer, maxBytes) + ClientData clientData; /* Information about text widget. */ + int offset; /* Offset within selection of first + * character to be returned. */ + char *buffer; /* Location in which to place + * selection. */ + int maxBytes; /* Maximum number of bytes to place + * at buffer, not including terminating + * NULL character. */ +{ + register TkText *textPtr = (TkText *) clientData; + TkTextIndex eof; + int count, chunkSize, offsetInSeg; + TkTextSearch search; + TkTextSegment *segPtr; + + if (!textPtr->exportSelection) { + return -1; + } + + /* + * Find the beginning of the next range of selected text. Note: if + * the selection is being retrieved in multiple pieces (offset != 0) + * and some modification has been made to the text that affects the + * selection then reject the selection request (make 'em start over + * again). + */ + + if (offset == 0) { + TkTextMakeIndex(textPtr->tree, 0, 0, &textPtr->selIndex); + textPtr->abortSelections = 0; + } else if (textPtr->abortSelections) { + return 0; + } + TkTextMakeIndex(textPtr->tree, TkBTreeNumLines(textPtr->tree), 0, &eof); + TkBTreeStartSearch(&textPtr->selIndex, &eof, textPtr->selTagPtr, &search); + if (!TkBTreeCharTagged(&textPtr->selIndex, textPtr->selTagPtr)) { + if (!TkBTreeNextTag(&search)) { + if (offset == 0) { + return -1; + } else { + return 0; + } + } + textPtr->selIndex = search.curIndex; + } + + /* + * Each iteration through the outer loop below scans one selected range. + * Each iteration through the inner loop scans one segment in the + * selected range. + */ + + count = 0; + while (1) { + /* + * Find the end of the current range of selected text. + */ + + if (!TkBTreeNextTag(&search)) { + panic("TextFetchSelection couldn't find end of range"); + } + + /* + * Copy information from character segments into the buffer + * until either we run out of space in the buffer or we get + * to the end of this range of text. + */ + + while (1) { + if (maxBytes == 0) { + goto done; + } + segPtr = TkTextIndexToSeg(&textPtr->selIndex, &offsetInSeg); + chunkSize = segPtr->size - offsetInSeg; + if (chunkSize > maxBytes) { + chunkSize = maxBytes; + } + if (textPtr->selIndex.linePtr == search.curIndex.linePtr) { + int leftInRange; + + leftInRange = search.curIndex.charIndex + - textPtr->selIndex.charIndex; + if (leftInRange < chunkSize) { + chunkSize = leftInRange; + if (chunkSize <= 0) { + break; + } + } + } + if (segPtr->typePtr == &tkTextCharType) { + memcpy((VOID *) buffer, (VOID *) (segPtr->body.chars + + offsetInSeg), (size_t) chunkSize); + buffer += chunkSize; + maxBytes -= chunkSize; + count += chunkSize; + } + TkTextIndexForwChars(&textPtr->selIndex, chunkSize, + &textPtr->selIndex); + } + + /* + * Find the beginning of the next range of selected text. + */ + + if (!TkBTreeNextTag(&search)) { + break; + } + textPtr->selIndex = search.curIndex; + } + + done: + *buffer = 0; + return count; +} + +/* + *---------------------------------------------------------------------- + * + * TkTextLostSelection -- + * + * This procedure is called back by Tk when the selection is + * grabbed away from a text widget. + * + * Results: + * None. + * + * Side effects: + * The "sel" tag is cleared from the window. + * + *---------------------------------------------------------------------- + */ + +void +TkTextLostSelection(clientData) + ClientData clientData; /* Information about text widget. */ +{ + register TkText *textPtr = (TkText *) clientData; + TkTextIndex start, end; + + if (!textPtr->exportSelection) { + return; + } + + /* + * Just remove the "sel" tag from everything in the widget. + */ + + TkTextMakeIndex(textPtr->tree, 0, 0, &start); + TkTextMakeIndex(textPtr->tree, TkBTreeNumLines(textPtr->tree), 0, &end); + TkTextRedrawTag(textPtr, &start, &end, textPtr->selTagPtr, 1); + TkBTreeTag(&start, &end, textPtr->selTagPtr, 0); + textPtr->flags &= ~GOT_SELECTION; +} + +/* + *---------------------------------------------------------------------- + * + * TextBlinkProc -- + * + * This procedure is called as a timer handler to blink the + * insertion cursor off and on. + * + * Results: + * None. + * + * Side effects: + * The cursor gets turned on or off, redisplay gets invoked, + * and this procedure reschedules itself. + * + *---------------------------------------------------------------------- + */ + +static void +TextBlinkProc(clientData) + ClientData clientData; /* Pointer to record describing text. */ +{ + register TkText *textPtr = (TkText *) clientData; + TkTextIndex index, index2; + + if (!(textPtr->flags & GOT_FOCUS) || (textPtr->insertOffTime == 0)) { + return; + } + if (textPtr->flags & INSERT_ON) { + textPtr->flags &= ~INSERT_ON; + textPtr->insertBlinkHandler = Tcl_CreateTimerHandler( + textPtr->insertOffTime, TextBlinkProc, (ClientData) textPtr); + } else { + textPtr->flags |= INSERT_ON; + textPtr->insertBlinkHandler = Tcl_CreateTimerHandler( + textPtr->insertOnTime, TextBlinkProc, (ClientData) textPtr); + } + TkTextMarkSegToIndex(textPtr, textPtr->insertMarkPtr, &index); + TkTextIndexForwChars(&index, 1, &index2); + TkTextChanged(textPtr, &index, &index2); +} + +/* + *---------------------------------------------------------------------- + * + * TextSearchCmd -- + * + * This procedure is invoked to process the "search" widget command + * for text widgets. See the user documentation for details on what + * it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +TextSearchCmd(textPtr, interp, argc, argv) + TkText *textPtr; /* Information about text widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int backwards, exact, c, i, argsLeft, noCase, leftToScan; + size_t length; + int numLines, startingLine, startingChar, lineNum, firstChar, lastChar; + int code, matchLength, matchChar, passes, stopLine, searchWholeText; + int patLength; + char *arg, *pattern, *varName, *p, *startOfLine; + char buffer[20]; + TkTextIndex index, stopIndex; + Tcl_DString line, patDString; + TkTextSegment *segPtr; + TkTextLine *linePtr; + Tcl_RegExp regexp = NULL; /* Initialization needed only to + * prevent compiler warning. */ + + /* + * Parse switches and other arguments. + */ + + exact = 1; + backwards = 0; + noCase = 0; + varName = NULL; + for (i = 2; i < argc; i++) { + arg = argv[i]; + if (arg[0] != '-') { + break; + } + length = strlen(arg); + if (length < 2) { + badSwitch: + Tcl_AppendResult(interp, "bad switch \"", arg, + "\": must be -forward, -backward, -exact, -regexp, ", + "-nocase, -count, or --", (char *) NULL); + return TCL_ERROR; + } + c = arg[1]; + if ((c == 'b') && (strncmp(argv[i], "-backwards", length) == 0)) { + backwards = 1; + } else if ((c == 'c') && (strncmp(argv[i], "-count", length) == 0)) { + if (i >= (argc-1)) { + interp->result = "no value given for \"-count\" option"; + return TCL_ERROR; + } + i++; + varName = argv[i]; + } else if ((c == 'e') && (strncmp(argv[i], "-exact", length) == 0)) { + exact = 1; + } else if ((c == 'f') && (strncmp(argv[i], "-forwards", length) == 0)) { + backwards = 0; + } else if ((c == 'n') && (strncmp(argv[i], "-nocase", length) == 0)) { + noCase = 1; + } else if ((c == 'r') && (strncmp(argv[i], "-regexp", length) == 0)) { + exact = 0; + } else if ((c == '-') && (strncmp(argv[i], "--", length) == 0)) { + i++; + break; + } else { + goto badSwitch; + } + } + argsLeft = argc - (i+2); + if ((argsLeft != 0) && (argsLeft != 1)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " search ?switches? pattern index ?stopIndex?", + (char *) NULL); + return TCL_ERROR; + } + pattern = argv[i]; + + /* + * Convert the pattern to lower-case if we're supposed to ignore case. + */ + + if (noCase) { + Tcl_DStringInit(&patDString); + Tcl_DStringAppend(&patDString, pattern, -1); + pattern = Tcl_DStringValue(&patDString); + for (p = pattern; *p != 0; p++) { + if (isupper(UCHAR(*p))) { + *p = tolower(UCHAR(*p)); + } + } + } + + if (TkTextGetIndex(interp, textPtr, argv[i+1], &index) != TCL_OK) { + return TCL_ERROR; + } + numLines = TkBTreeNumLines(textPtr->tree); + startingLine = TkBTreeLineIndex(index.linePtr); + startingChar = index.charIndex; + if (startingLine >= numLines) { + if (backwards) { + startingLine = TkBTreeNumLines(textPtr->tree) - 1; + startingChar = TkBTreeCharsInLine(TkBTreeFindLine(textPtr->tree, + startingLine)); + } else { + startingLine = 0; + startingChar = 0; + } + } + if (argsLeft == 1) { + if (TkTextGetIndex(interp, textPtr, argv[i+2], &stopIndex) != TCL_OK) { + return TCL_ERROR; + } + stopLine = TkBTreeLineIndex(stopIndex.linePtr); + if (!backwards && (stopLine == numLines)) { + stopLine = numLines-1; + } + searchWholeText = 0; + } else { + stopLine = 0; + searchWholeText = 1; + } + + /* + * Scan through all of the lines of the text circularly, starting + * at the given index. + */ + + matchLength = patLength = 0; /* Only needed to prevent compiler + * warnings. */ + if (exact) { + patLength = strlen(pattern); + } else { + regexp = Tcl_RegExpCompile(interp, pattern); + if (regexp == NULL) { + return TCL_ERROR; + } + } + lineNum = startingLine; + code = TCL_OK; + Tcl_DStringInit(&line); + for (passes = 0; passes < 2; ) { + if (lineNum >= numLines) { + /* + * Don't search the dummy last line of the text. + */ + + goto nextLine; + } + + /* + * Extract the text from the line. If we're doing regular + * expression matching, drop the newline from the line, so + * that "$" can be used to match the end of the line. + */ + + linePtr = TkBTreeFindLine(textPtr->tree, lineNum); + for (segPtr = linePtr->segPtr; segPtr != NULL; + segPtr = segPtr->nextPtr) { + if (segPtr->typePtr != &tkTextCharType) { + continue; + } + Tcl_DStringAppend(&line, segPtr->body.chars, segPtr->size); + } + if (!exact) { + Tcl_DStringSetLength(&line, Tcl_DStringLength(&line)-1); + } + startOfLine = Tcl_DStringValue(&line); + + /* + * If we're ignoring case, convert the line to lower case. + */ + + if (noCase) { + for (p = Tcl_DStringValue(&line); *p != 0; p++) { + if (isupper(UCHAR(*p))) { + *p = tolower(UCHAR(*p)); + } + } + } + + /* + * Check for matches within the current line. If so, and if we're + * searching backwards, repeat the search to find the last match + * in the line. + */ + + matchChar = -1; + firstChar = 0; + lastChar = INT_MAX; + if (lineNum == startingLine) { + int indexInDString; + + /* + * The starting line is tricky: the first time we see it + * we check one part of the line, and the second pass through + * we check the other part of the line. We have to be very + * careful here because there could be embedded windows or + * other things that are not in the extracted line. Rescan + * the original line to compute the index in it of the first + * character. + */ + + indexInDString = startingChar; + for (segPtr = linePtr->segPtr, leftToScan = startingChar; + leftToScan > 0; segPtr = segPtr->nextPtr) { + if (segPtr->typePtr != &tkTextCharType) { + indexInDString -= segPtr->size; + } + leftToScan -= segPtr->size; + } + + passes++; + if ((passes == 1) ^ backwards) { + /* + * Only use the last part of the line. + */ + + firstChar = indexInDString; + if (firstChar >= Tcl_DStringLength(&line)) { + goto nextLine; + } + } else { + /* + * Use only the first part of the line. + */ + + lastChar = indexInDString; + } + } + do { + int thisLength; + if (exact) { + p = strstr(startOfLine + firstChar, pattern); + if (p == NULL) { + break; + } + i = p - startOfLine; + thisLength = patLength; + } else { + char *start, *end; + int match; + + match = Tcl_RegExpExec(interp, regexp, + startOfLine + firstChar, startOfLine); + if (match < 0) { + code = TCL_ERROR; + goto done; + } + if (!match) { + break; + } + Tcl_RegExpRange(regexp, 0, &start, &end); + i = start - startOfLine; + thisLength = end - start; + } + if (i >= lastChar) { + break; + } + matchChar = i; + matchLength = thisLength; + firstChar = matchChar+1; + } while (backwards); + + /* + * If we found a match then we're done. Make sure that + * the match occurred before the stopping index, if one was + * specified. + */ + + if (matchChar >= 0) { + /* + * The index information returned by the regular expression + * parser only considers textual information: it doesn't + * account for embedded windows or any other non-textual info. + * Scan through the line's segments again to adjust both + * matchChar and matchCount. + */ + + for (segPtr = linePtr->segPtr, leftToScan = matchChar; + leftToScan >= 0; segPtr = segPtr->nextPtr) { + if (segPtr->typePtr != &tkTextCharType) { + matchChar += segPtr->size; + continue; + } + leftToScan -= segPtr->size; + } + for (leftToScan += matchLength; leftToScan > 0; + segPtr = segPtr->nextPtr) { + if (segPtr->typePtr != &tkTextCharType) { + matchLength += segPtr->size; + continue; + } + leftToScan -= segPtr->size; + } + TkTextMakeIndex(textPtr->tree, lineNum, matchChar, &index); + if (!searchWholeText) { + if (!backwards && (TkTextIndexCmp(&index, &stopIndex) >= 0)) { + goto done; + } + if (backwards && (TkTextIndexCmp(&index, &stopIndex) < 0)) { + goto done; + } + } + if (varName != NULL) { + sprintf(buffer, "%d", matchLength); + if (Tcl_SetVar(interp, varName, buffer, TCL_LEAVE_ERR_MSG) + == NULL) { + code = TCL_ERROR; + goto done; + } + } + TkTextPrintIndex(&index, interp->result); + goto done; + } + + /* + * Go to the next (or previous) line; + */ + + nextLine: + if (backwards) { + lineNum--; + if (!searchWholeText) { + if (lineNum < stopLine) { + break; + } + } else if (lineNum < 0) { + lineNum = numLines-1; + } + } else { + lineNum++; + if (!searchWholeText) { + if (lineNum > stopLine) { + break; + } + } else if (lineNum >= numLines) { + lineNum = 0; + } + } + Tcl_DStringSetLength(&line, 0); + } + done: + Tcl_DStringFree(&line); + if (noCase) { + Tcl_DStringFree(&patDString); + } + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TkTextGetTabs -- + * + * Parses a string description of a set of tab stops. + * + * Results: + * The return value is a pointer to a malloc'ed structure holding + * parsed information about the tab stops. If an error occurred + * then the return value is NULL and an error message is left in + * interp->result. + * + * Side effects: + * Memory is allocated for the structure that is returned. It is + * up to the caller to free this structure when it is no longer + * needed. + * + *---------------------------------------------------------------------- + */ + +TkTextTabArray * +TkTextGetTabs(interp, tkwin, string) + Tcl_Interp *interp; /* Used for error reporting. */ + Tk_Window tkwin; /* Window in which the tabs will be + * used. */ + char *string; /* Description of the tab stops. See + * the text manual entry for details. */ +{ + int argc, i, count, c; + char **argv; + TkTextTabArray *tabArrayPtr; + TkTextTab *tabPtr; + + if (Tcl_SplitList(interp, string, &argc, &argv) != TCL_OK) { + return NULL; + } + + /* + * First find out how many entries we need to allocate in the + * tab array. + */ + + count = 0; + for (i = 0; i < argc; i++) { + c = argv[i][0]; + if ((c != 'l') && (c != 'r') && (c != 'c') && (c != 'n')) { + count++; + } + } + + /* + * Parse the elements of the list one at a time to fill in the + * array. + */ + + tabArrayPtr = (TkTextTabArray *) ckalloc((unsigned) + (sizeof(TkTextTabArray) + (count-1)*sizeof(TkTextTab))); + tabArrayPtr->numTabs = 0; + for (i = 0, tabPtr = &tabArrayPtr->tabs[0]; i < argc; i++, tabPtr++) { + if (Tk_GetPixels(interp, tkwin, argv[i], &tabPtr->location) + != TCL_OK) { + goto error; + } + tabArrayPtr->numTabs++; + + /* + * See if there is an explicit alignment in the next list + * element. Otherwise just use "left". + */ + + tabPtr->alignment = LEFT; + if ((i+1) == argc) { + continue; + } + c = UCHAR(argv[i+1][0]); + if (!isalpha(c)) { + continue; + } + i += 1; + if ((c == 'l') && (strncmp(argv[i], "left", + strlen(argv[i])) == 0)) { + tabPtr->alignment = LEFT; + } else if ((c == 'r') && (strncmp(argv[i], "right", + strlen(argv[i])) == 0)) { + tabPtr->alignment = RIGHT; + } else if ((c == 'c') && (strncmp(argv[i], "center", + strlen(argv[i])) == 0)) { + tabPtr->alignment = CENTER; + } else if ((c == 'n') && (strncmp(argv[i], + "numeric", strlen(argv[i])) == 0)) { + tabPtr->alignment = NUMERIC; + } else { + Tcl_AppendResult(interp, "bad tab alignment \"", + argv[i], "\": must be left, right, center, or numeric", + (char *) NULL); + goto error; + } + } + ckfree((char *) argv); + return tabArrayPtr; + + error: + ckfree((char *) tabArrayPtr); + ckfree((char *) argv); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TextDumpCmd -- + * + * Return information about the text, tags, marks, and embedded windows + * in a text widget. See the man page for the description of the + * text dump operation for all the details. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Memory is allocated for the result, if needed (standard Tcl result + * side effects). + * + *---------------------------------------------------------------------- + */ + +static int +TextDumpCmd(textPtr, interp, argc, argv) + register TkText *textPtr; /* Information about text widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. Someone else has already + * parsed this command enough to know that + * argv[1] is "dump". */ +{ + TkTextIndex index1, index2; + int arg; + int lineno; /* Current line number */ + int what = 0; /* bitfield to select segment types */ + int atEnd; /* True if dumping up to logical end */ + TkTextLine *linePtr; + char *command = NULL; /* Script callback to apply to segments */ +#define TK_DUMP_TEXT 0x1 +#define TK_DUMP_MARK 0x2 +#define TK_DUMP_TAG 0x4 +#define TK_DUMP_WIN 0x8 +#define TK_DUMP_ALL (TK_DUMP_TEXT|TK_DUMP_MARK|TK_DUMP_TAG|TK_DUMP_WIN) + + for (arg=2 ; argv[arg] != (char *) NULL ; arg++) { + size_t len; + if (argv[arg][0] != '-') { + break; + } + len = strlen(argv[arg]); + if (strncmp("-all", argv[arg], len) == 0) { + what = TK_DUMP_ALL; + } else if (strncmp("-text", argv[arg], len) == 0) { + what |= TK_DUMP_TEXT; + } else if (strncmp("-tag", argv[arg], len) == 0) { + what |= TK_DUMP_TAG; + } else if (strncmp("-mark", argv[arg], len) == 0) { + what |= TK_DUMP_MARK; + } else if (strncmp("-window", argv[arg], len) == 0) { + what |= TK_DUMP_WIN; + } else if (strncmp("-command", argv[arg], len) == 0) { + arg++; + if (arg >= argc) { + Tcl_AppendResult(interp, "Usage: ", argv[0], " dump ?-all -text -mark -tag -window? ?-command script? index ?index2?", NULL); + return TCL_ERROR; + } + command = argv[arg]; + } else { + Tcl_AppendResult(interp, "Usage: ", argv[0], " dump ?-all -text -mark -tag -window? ?-command script? index ?index2?", NULL); + return TCL_ERROR; + } + } + if (arg >= argc) { + Tcl_AppendResult(interp, "Usage: ", argv[0], " dump ?-all -text -mark -tag -window? ?-command script? index ?index2?", NULL); + return TCL_ERROR; + } + if (what == 0) { + what = TK_DUMP_ALL; + } + if (TkTextGetIndex(interp, textPtr, argv[arg], &index1) != TCL_OK) { + return TCL_ERROR; + } + lineno = TkBTreeLineIndex(index1.linePtr) + 1; + arg++; + atEnd = 0; + if (argc == arg) { + TkTextIndexForwChars(&index1, 1, &index2); + } else { + if (TkTextGetIndex(interp, textPtr, argv[arg], &index2) != TCL_OK) { + return TCL_ERROR; + } + if (strncmp(argv[arg], "end", strlen(argv[arg])) == 0) { + atEnd = 1; + } + } + if (TkTextIndexCmp(&index1, &index2) >= 0) { + return TCL_OK; + } + if (index1.linePtr == index2.linePtr) { + DumpLine(interp, textPtr, what, index1.linePtr, + index1.charIndex, index2.charIndex, lineno, command); + } else { + DumpLine(interp, textPtr, what, index1.linePtr, + index1.charIndex, 32000000, lineno, command); + linePtr = index1.linePtr; + while ((linePtr = TkBTreeNextLine(linePtr)) != (TkTextLine *)NULL) { + lineno++; + if (linePtr == index2.linePtr) { + break; + } + DumpLine(interp, textPtr, what, linePtr, 0, 32000000, + lineno, command); + } + DumpLine(interp, textPtr, what, index2.linePtr, 0, + index2.charIndex, lineno, command); + } + /* + * Special case to get the leftovers hiding at the end mark. + */ + if (atEnd) { + DumpLine(interp, textPtr, what & ~TK_DUMP_TEXT, index2.linePtr, + 0, 1, lineno, command); + + } + return TCL_OK; +} + +/* + * DumpLine + * Return information about a given text line from character + * position "start" up to, but not including, "end". + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None, but see DumpSegment. + */ +static void +DumpLine(interp, textPtr, what, linePtr, start, end, lineno, command) + Tcl_Interp *interp; + TkText *textPtr; + int what; /* bit flags to select segment types */ + TkTextLine *linePtr; /* The current line */ + int start, end; /* Character range to dump */ + int lineno; /* Line number for indices dump */ + char *command; /* Script to apply to the segment */ +{ + int offset; + TkTextSegment *segPtr; + /* + * Must loop through line looking at its segments. + * character + * toggleOn, toggleOff + * mark + * window + */ + for (offset = 0, segPtr = linePtr->segPtr ; + (offset < end) && (segPtr != (TkTextSegment *)NULL) ; + offset += segPtr->size, segPtr = segPtr->nextPtr) { + int result = TCL_OK; + if ((what & TK_DUMP_TEXT) && (segPtr->typePtr == &tkTextCharType) && + (offset + segPtr->size > start)) { + char savedChar; /* Last char used in the seg */ + int last = segPtr->size; /* Index of savedChar */ + int first = 0; /* Index of first char in seg */ + if (offset + segPtr->size > end) { + last = end - offset; + } + if (start > offset) { + first = start - offset; + } + savedChar = segPtr->body.chars[last]; + segPtr->body.chars[last] = '\0'; + result = DumpSegment(interp, "text", segPtr->body.chars + first, + command, lineno, offset + first, what); + segPtr->body.chars[last] = savedChar; + } else if ((offset >= start)) { + if ((what & TK_DUMP_MARK) && (segPtr->typePtr->name[0] == 'm')) { + TkTextMark *markPtr = (TkTextMark *)&segPtr->body; + char *name = Tcl_GetHashKey(&textPtr->markTable, markPtr->hPtr); + result = DumpSegment(interp, "mark", name, + command, lineno, offset, what); + } else if ((what & TK_DUMP_TAG) && + (segPtr->typePtr == &tkTextToggleOnType)) { + result = DumpSegment(interp, "tagon", + segPtr->body.toggle.tagPtr->name, + command, lineno, offset, what); + } else if ((what & TK_DUMP_TAG) && + (segPtr->typePtr == &tkTextToggleOffType)) { + result = DumpSegment(interp, "tagoff", + segPtr->body.toggle.tagPtr->name, + command, lineno, offset, what); + } else if ((what & TK_DUMP_WIN) && + (segPtr->typePtr->name[0] == 'w')) { + TkTextEmbWindow *ewPtr = (TkTextEmbWindow *)&segPtr->body; + char *pathname; + if (ewPtr->tkwin == (Tk_Window) NULL) { + pathname = ""; + } else { + pathname = Tk_PathName(ewPtr->tkwin); + } + result = DumpSegment(interp, "window", pathname, + command, lineno, offset, what); + } + } + } +} + +/* + * DumpSegment + * Either append information about the current segment to the result, + * or make a script callback with that information as arguments. + * + * Results: + * None + * + * Side effects: + * Either evals the callback or appends elements to the result string. + */ +static int +DumpSegment(interp, key, value, command, lineno, offset, what) + Tcl_Interp *interp; + char *key; /* Segment type key */ + char *value; /* Segment value */ + char *command; /* Script callback */ + int lineno; /* Line number for indices dump */ + int offset; /* Character position */ + int what; /* Look for TK_DUMP_INDEX bit */ +{ + char buffer[30]; + sprintf(buffer, "%d.%d", lineno, offset); + if (command == (char *) NULL) { + Tcl_AppendElement(interp, key); + Tcl_AppendElement(interp, value); + Tcl_AppendElement(interp, buffer); + return TCL_OK; + } else { + char *argv[4]; + char *list; + int result; + argv[0] = key; + argv[1] = value; + argv[2] = buffer; + argv[3] = (char *) NULL; + list = Tcl_Merge(3, argv); + result = Tcl_VarEval(interp, command, " ", list, (char *) NULL); + ckfree(list); + return result; + } +} + diff --git a/tk4.2/generic/tkText.h b/tk4.2/generic/tkText.h new file mode 100644 index 0000000..1fb4bf0 --- /dev/null +++ b/tk4.2/generic/tkText.h @@ -0,0 +1,808 @@ +/* + * tkText.h -- + * + * Declarations shared among the files that implement text + * widgets. + * + * Copyright (c) 1992-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkText.h 1.44 96/02/15 18:51:31 + */ + +#ifndef _TKTEXT +#define _TKTEXT + +#ifndef _TK +#include "tk.h" +#endif + +/* + * Opaque types for structures whose guts are only needed by a single + * file: + */ + +typedef struct TkTextBTree *TkTextBTree; + +/* + * The data structure below defines a single line of text (from newline + * to newline, not necessarily what appears on one line of the screen). + */ + +typedef struct TkTextLine { + struct Node *parentPtr; /* Pointer to parent node containing + * line. */ + struct TkTextLine *nextPtr; /* Next in linked list of lines with + * same parent node in B-tree. NULL + * means end of list. */ + struct TkTextSegment *segPtr; /* First in ordered list of segments + * that make up the line. */ +} TkTextLine; + +/* + * ----------------------------------------------------------------------- + * Segments: each line is divided into one or more segments, where each + * segment is one of several things, such as a group of characters, a + * tag toggle, a mark, or an embedded widget. Each segment starts with + * a standard header followed by a body that varies from type to type. + * ----------------------------------------------------------------------- + */ + +/* + * The data structure below defines the body of a segment that represents + * a tag toggle. There is one of these structures at both the beginning + * and end of each tagged range. + */ + +typedef struct TkTextToggle { + struct TkTextTag *tagPtr; /* Tag that starts or ends here. */ + int inNodeCounts; /* 1 means this toggle has been + * accounted for in node toggle + * counts; 0 means it hasn't, yet. */ +} TkTextToggle; + +/* + * The data structure below defines line segments that represent + * marks. There is one of these for each mark in the text. + */ + +typedef struct TkTextMark { + struct TkText *textPtr; /* Overall information about text + * widget. */ + TkTextLine *linePtr; /* Line structure that contains the + * segment. */ + Tcl_HashEntry *hPtr; /* Pointer to hash table entry for mark + * (in textPtr->markTable). */ +} TkTextMark; + +/* + * A structure of the following type holds information for each window + * embedded in a text widget. This information is only used by the + * file tkTextWind.c + */ + +typedef struct TkTextEmbWindow { + struct TkText *textPtr; /* Information about the overall text + * widget. */ + TkTextLine *linePtr; /* Line structure that contains this + * window. */ + Tk_Window tkwin; /* Window for this segment. NULL + * means that the window hasn't + * been created yet. */ + char *create; /* Script to create window on-demand. + * NULL means no such script. + * Malloc-ed. */ + int align; /* How to align window in vertical + * space. See definitions in + * tkTextWind.c. */ + int padX, padY; /* Padding to leave around each side + * of window, in pixels. */ + int stretch; /* Should window stretch to fill + * vertical space of line (except for + * pady)? 0 or 1. */ + int chunkCount; /* Number of display chunks that + * refer to this window. */ + int displayed; /* Non-zero means that the window + * has been displayed on the screen + * recently. */ +} TkTextEmbWindow; + +/* + * The data structure below defines line segments. + */ + +typedef struct TkTextSegment { + struct Tk_SegType *typePtr; /* Pointer to record describing + * segment's type. */ + struct TkTextSegment *nextPtr; /* Next in list of segments for this + * line, or NULL for end of list. */ + int size; /* Size of this segment (# of bytes + * of index space it occupies). */ + union { + char chars[4]; /* Characters that make up character + * info. Actual length varies to + * hold as many characters as needed.*/ + TkTextToggle toggle; /* Information about tag toggle. */ + TkTextMark mark; /* Information about mark. */ + TkTextEmbWindow ew; /* Information about embedded + * window. */ + } body; +} TkTextSegment; + +/* + * Data structures of the type defined below are used during the + * execution of Tcl commands to keep track of various interesting + * places in a text. An index is only valid up until the next + * modification to the character structure of the b-tree so they + * can't be retained across Tcl commands. However, mods to marks + * or tags don't invalidate indices. + */ + +typedef struct TkTextIndex { + TkTextBTree tree; /* Tree containing desired position. */ + TkTextLine *linePtr; /* Pointer to line containing position + * of interest. */ + int charIndex; /* Index within line of desired + * character (0 means first one). */ +} TkTextIndex; + +/* + * Types for procedure pointers stored in TkTextDispChunk strutures: + */ + +typedef struct TkTextDispChunk TkTextDispChunk; + +typedef void Tk_ChunkDisplayProc _ANSI_ARGS_(( + TkTextDispChunk *chunkPtr, int x, int y, + int height, int baseline, Display *display, + Drawable dst, int screenY)); +typedef void Tk_ChunkUndisplayProc _ANSI_ARGS_(( + struct TkText *textPtr, + TkTextDispChunk *chunkPtr)); +typedef int Tk_ChunkMeasureProc _ANSI_ARGS_(( + TkTextDispChunk *chunkPtr, int x)); +typedef void Tk_ChunkBboxProc _ANSI_ARGS_(( + TkTextDispChunk *chunkPtr, int index, int y, + int lineHeight, int baseline, int *xPtr, + int *yPtr, int *widthPtr, int *heightPtr)); + +/* + * The structure below represents a chunk of stuff that is displayed + * together on the screen. This structure is allocated and freed by + * generic display code but most of its fields are filled in by + * segment-type-specific code. + */ + +struct TkTextDispChunk { + /* + * The fields below are set by the type-independent code before + * calling the segment-type-specific layoutProc. They should not + * be modified by segment-type-specific code. + */ + + int x; /* X position of chunk, in pixels. + * This position is measured from the + * left edge of the logical line, + * not from the left edge of the + * window (i.e. it doesn't change + * under horizontal scrolling). */ + struct TkTextDispChunk *nextPtr; /* Next chunk in the display line + * or NULL for the end of the list. */ + struct TextStyle *stylePtr; /* Display information, known only + * to tkTextDisp.c. */ + + /* + * The fields below are set by the layoutProc that creates the + * chunk. + */ + + Tk_ChunkDisplayProc *displayProc; /* Procedure to invoke to draw this + * chunk on the display or an + * off-screen pixmap. */ + Tk_ChunkUndisplayProc *undisplayProc; + /* Procedure to invoke when segment + * ceases to be displayed on screen + * anymore. */ + Tk_ChunkMeasureProc *measureProc; /* Procedure to find character under + * a given x-location. */ + Tk_ChunkBboxProc *bboxProc; /* Procedure to find bounding box + * of character in chunk. */ + int numChars; /* Number of characters that will be + * displayed in the chunk. */ + int minAscent; /* Minimum space above the baseline + * needed by this chunk. */ + int minDescent; /* Minimum space below the baseline + * needed by this chunk. */ + int minHeight; /* Minimum total line height needed + * by this chunk. */ + int width; /* Width of this chunk, in pixels. + * Initially set by chunk-specific + * code, but may be increased to + * include tab or extra space at end + * of line. */ + int breakIndex; /* Index within chunk of last + * acceptable position for a line + * (break just before this character). + * <= 0 means don't break during or + * immediately after this chunk. */ + ClientData clientData; /* Additional information for use + * of displayProc and undisplayProc. */ +}; + +/* + * One data structure of the following type is used for each tag in a + * text widget. These structures are kept in textPtr->tagTable and + * referred to in other structures. + */ + +typedef struct TkTextTag { + char *name; /* Name of this tag. This field is actually + * a pointer to the key from the entry in + * textPtr->tagTable, so it needn't be freed + * explicitly. */ + int priority; /* Priority of this tag within widget. 0 + * means lowest priority. Exactly one tag + * has each integer value between 0 and + * numTags-1. */ + struct Node *tagRootPtr; /* Pointer into the B-Tree at the lowest + * node that completely dominates the ranges + * of text occupied by the tag. At this + * node there is no information about the + * tag. One or more children of the node + * do contain information about the tag. */ + int toggleCount; /* Total number of tag toggles */ + + /* + * Information for displaying text with this tag. The information + * belows acts as an override on information specified by lower-priority + * tags. If no value is specified, then the next-lower-priority tag + * on the text determins the value. The text widget itself provides + * defaults if no tag specifies an override. + */ + + Tk_3DBorder border; /* Used for drawing background. NULL means + * no value specified here. */ + char *bdString; /* -borderwidth option string (malloc-ed). + * NULL means option not specified. */ + int borderWidth; /* Width of 3-D border for background. */ + char *reliefString; /* -relief option string (malloc-ed). + * NULL means option not specified. */ + int relief; /* 3-D relief for background. */ + Pixmap bgStipple; /* Stipple bitmap for background. None + * means no value specified here. */ + XColor *fgColor; /* Foreground color for text. NULL means + * no value specified here. */ + XFontStruct *fontPtr; /* Font for displaying text. NULL means + * no value specified here. */ + Pixmap fgStipple; /* Stipple bitmap for text and other + * foreground stuff. None means no value + * specified here.*/ + char *justifyString; /* -justify option string (malloc-ed). + * NULL means option not specified. */ + Tk_Justify justify; /* How to justify text: TK_JUSTIFY_LEFT, + * TK_JUSTIFY_RIGHT, or TK_JUSTIFY_CENTER. + * Only valid if justifyString is non-NULL. */ + char *lMargin1String; /* -lmargin1 option string (malloc-ed). + * NULL means option not specified. */ + int lMargin1; /* Left margin for first display line of + * each text line, in pixels. Only valid + * if lMargin1String is non-NULL. */ + char *lMargin2String; /* -lmargin2 option string (malloc-ed). + * NULL means option not specified. */ + int lMargin2; /* Left margin for second and later display + * lines of each text line, in pixels. Only + * valid if lMargin2String is non-NULL. */ + char *offsetString; /* -offset option string (malloc-ed). + * NULL means option not specified. */ + int offset; /* Vertical offset of text's baseline from + * baseline of line. Used for superscripts + * and subscripts. Only valid if + * offsetString is non-NULL. */ + char *overstrikeString; /* -overstrike option string (malloc-ed). + * NULL means option not specified. */ + int overstrike; /* Non-zero means draw horizontal line through + * middle of text. Only valid if + * overstrikeString is non-NULL. */ + char *rMarginString; /* -rmargin option string (malloc-ed). + * NULL means option not specified. */ + int rMargin; /* Right margin for text, in pixels. Only + * valid if rMarginString is non-NULL. */ + char *spacing1String; /* -spacing1 option string (malloc-ed). + * NULL means option not specified. */ + int spacing1; /* Extra spacing above first display + * line for text line. Only valid if + * spacing1String is non-NULL. */ + char *spacing2String; /* -spacing2 option string (malloc-ed). + * NULL means option not specified. */ + int spacing2; /* Extra spacing between display + * lines for the same text line. Only valid + * if spacing2String is non-NULL. */ + char *spacing3String; /* -spacing2 option string (malloc-ed). + * NULL means option not specified. */ + int spacing3; /* Extra spacing below last display + * line for text line. Only valid if + * spacing3String is non-NULL. */ + char *tabString; /* -tabs option string (malloc-ed). + * NULL means option not specified. */ + struct TkTextTabArray *tabArrayPtr; + /* Info about tabs for tag (malloc-ed) + * or NULL. Corresponds to tabString. */ + char *underlineString; /* -underline option string (malloc-ed). + * NULL means option not specified. */ + int underline; /* Non-zero means draw underline underneath + * text. Only valid if underlineString is + * non-NULL. */ + Tk_Uid wrapMode; /* How to handle wrap-around for this tag. + * Must be tkTextCharUid, tkTextNoneUid, + * tkTextWordUid, or NULL to use wrapMode + * for whole widget. */ + int affectsDisplay; /* Non-zero means that this tag affects the + * way information is displayed on the screen + * (so need to redisplay if tag changes). */ +} TkTextTag; + +#define TK_TAG_AFFECTS_DISPLAY 0x1 +#define TK_TAG_UNDERLINE 0x2 +#define TK_TAG_JUSTIFY 0x4 +#define TK_TAG_OFFSET 0x10 + +/* + * The data structure below is used for searching a B-tree for transitions + * on a single tag (or for all tag transitions). No code outside of + * tkTextBTree.c should ever modify any of the fields in these structures, + * but it's OK to use them for read-only information. + */ + +typedef struct TkTextSearch { + TkTextIndex curIndex; /* Position of last tag transition + * returned by TkBTreeNextTag, or + * index of start of segment + * containing starting position for + * search if TkBTreeNextTag hasn't + * been called yet, or same as + * stopIndex if search is over. */ + TkTextSegment *segPtr; /* Actual tag segment returned by last + * call to TkBTreeNextTag, or NULL if + * TkBTreeNextTag hasn't returned + * anything yet. */ + TkTextSegment *nextPtr; /* Where to resume search in next + * call to TkBTreeNextTag. */ + TkTextSegment *lastPtr; /* Stop search before just before + * considering this segment. */ + TkTextTag *tagPtr; /* Tag to search for (or tag found, if + * allTags is non-zero). */ + int linesLeft; /* Lines left to search (including + * curIndex and stopIndex). When + * this becomes <= 0 the search is + * over. */ + int allTags; /* Non-zero means ignore tag check: + * search for transitions on all + * tags. */ +} TkTextSearch; + +/* + * The following data structure describes a single tab stop. + */ + +typedef enum {LEFT, RIGHT, CENTER, NUMERIC} TkTextTabAlign; + +typedef struct TkTextTab { + int location; /* Offset in pixels of this tab stop + * from the left margin (lmargin2) of + * the text. */ + TkTextTabAlign alignment; /* Where the tab stop appears relative + * to the text. */ +} TkTextTab; + +typedef struct TkTextTabArray { + int numTabs; /* Number of tab stops. */ + TkTextTab tabs[1]; /* Array of tabs. The actual size + * will be numTabs. THIS FIELD MUST + * BE THE LAST IN THE STRUCTURE. */ +} TkTextTabArray; + +/* + * A data structure of the following type is kept for each text widget that + * currently exists for this process: + */ + +typedef struct TkText { + Tk_Window tkwin; /* Window that embodies the text. NULL + * means that the window has been destroyed + * but the data structures haven't yet been + * cleaned up.*/ + Display *display; /* Display for widget. Needed, among other + * things, to allow resources to be freed + * even after tkwin has gone away. */ + Tcl_Interp *interp; /* Interpreter associated with widget. Used + * to delete widget command. */ + Tcl_Command widgetCmd; /* Token for text's widget command. */ + TkTextBTree tree; /* B-tree representation of text and tags for + * widget. */ + Tcl_HashTable tagTable; /* Hash table that maps from tag names to + * pointers to TkTextTag structures. */ + int numTags; /* Number of tags currently defined for + * widget; needed to keep track of + * priorities. */ + Tcl_HashTable markTable; /* Hash table that maps from mark names to + * pointers to mark segments. */ + Tcl_HashTable windowTable; /* Hash table that maps from window names + * to pointers to window segments. If a + * window segment doesn't yet have an + * associated window, there is no entry for + * it here. */ + Tk_Uid state; /* Normal or disabled. Text is read-only + * when disabled. */ + + /* + * Default information for displaying (may be overridden by tags + * applied to ranges of characters). + */ + + Tk_3DBorder border; /* Structure used to draw 3-D border and + * default background. */ + int borderWidth; /* Width of 3-D border to draw around entire + * widget. */ + int padX, padY; /* Padding between text and window border. */ + int relief; /* 3-d effect for border around entire + * widget: TK_RELIEF_RAISED etc. */ + int highlightWidth; /* Width in pixels of highlight to draw + * around widget when it has the focus. + * <= 0 means don't draw a highlight. */ + XColor *highlightBgColorPtr; + /* Color for drawing traversal highlight + * area when highlight is off. */ + XColor *highlightColorPtr; /* Color for drawing traversal highlight. */ + Tk_Cursor cursor; /* Current cursor for window, or None. */ + XColor *fgColor; /* Default foreground color for text. */ + XFontStruct *fontPtr; /* Default font for displaying text. */ + int charWidth; /* Width of average character in default + * font. */ + int spacing1; /* Default extra spacing above first display + * line for each text line. */ + int spacing2; /* Default extra spacing between display lines + * for the same text line. */ + int spacing3; /* Default extra spacing below last display + * line for each text line. */ + char *tabOptionString; /* Value of -tabs option string (malloc'ed). */ + TkTextTabArray *tabArrayPtr; + /* Information about tab stops (malloc'ed). + * NULL means perform default tabbing + * behavior. */ + + /* + * Additional information used for displaying: + */ + + Tk_Uid wrapMode; /* How to handle wrap-around. Must be + * tkTextCharUid, tkTextNoneUid, or + * tkTextWordUid. */ + int width, height; /* Desired dimensions for window, measured + * in characters. */ + int setGrid; /* Non-zero means pass gridding information + * to window manager. */ + int prevWidth, prevHeight; /* Last known dimensions of window; used to + * detect changes in size. */ + TkTextIndex topIndex; /* Identifies first character in top display + * line of window. */ + struct TextDInfo *dInfoPtr; /* Information maintained by tkTextDisp.c. */ + + /* + * Information related to selection. + */ + + TkTextTag *selTagPtr; /* Pointer to "sel" tag. Used to tell when + * a new selection has been made. */ + Tk_3DBorder selBorder; /* Border and background for selected + * characters. This is a copy of information + * in *cursorTagPtr, so it shouldn't be + * explicitly freed. */ + char *selBdString; /* Value of -selectborderwidth option, or NULL + * if not specified (malloc'ed). */ + XColor *selFgColorPtr; /* Foreground color for selected text. + * This is a copy of information in + * *cursorTagPtr, so it shouldn't be + * explicitly freed. */ + int exportSelection; /* Non-zero means tie "sel" tag to X + * selection. */ + TkTextIndex selIndex; /* Used during multi-pass selection retrievals. + * This index identifies the next character + * to be returned from the selection. */ + int abortSelections; /* Set to 1 whenever the text is modified + * in a way that interferes with selection + * retrieval: used to abort incremental + * selection retrievals. */ + int selOffset; /* Offset in selection corresponding to + * selLine and selCh. -1 means neither + * this information nor selIndex is of any + * use. */ + + /* + * Information related to insertion cursor: + */ + + TkTextSegment *insertMarkPtr; + /* Points to segment for "insert" mark. */ + Tk_3DBorder insertBorder; /* Used to draw vertical bar for insertion + * cursor. */ + int insertWidth; /* Total width of insert cursor. */ + int insertBorderWidth; /* Width of 3-D border around insert cursor. */ + int insertOnTime; /* Number of milliseconds cursor should spend + * in "on" state for each blink. */ + int insertOffTime; /* Number of milliseconds cursor should spend + * in "off" state for each blink. */ + Tcl_TimerToken insertBlinkHandler; + /* Timer handler used to blink cursor on and + * off. */ + + /* + * Information used for event bindings associated with tags: + */ + + Tk_BindingTable bindingTable; + /* Table of all bindings currently defined + * for this widget. NULL means that no + * bindings exist, so the table hasn't been + * created. Each "object" used for this + * table is the address of a tag. */ + TkTextSegment *currentMarkPtr; + /* Pointer to segment for "current" mark, + * or NULL if none. */ + XEvent pickEvent; /* The event from which the current character + * was chosen. Must be saved so that we + * can repick after modifications to the + * text. */ + int numCurTags; /* Number of tags associated with character + * at current mark. */ + TkTextTag **curTagArrayPtr; /* Pointer to array of tags for current + * mark, or NULL if none. */ + + /* + * Miscellaneous additional information: + */ + + char *takeFocus; /* Value of -takeFocus option; not used in + * the C code, but used by keyboard traversal + * scripts. Malloc'ed, but may be NULL. */ + char *xScrollCmd; /* Prefix of command to issue to update + * horizontal scrollbar when view changes. */ + char *yScrollCmd; /* Prefix of command to issue to update + * vertical scrollbar when view changes. */ + int flags; /* Miscellaneous flags; see below for + * definitions. */ +} TkText; + +/* + * Flag values for TkText records: + * + * GOT_SELECTION: Non-zero means we've already claimed the + * selection. + * INSERT_ON: Non-zero means insertion cursor should be + * displayed on screen. + * GOT_FOCUS: Non-zero means this window has the input + * focus. + * BUTTON_DOWN: 1 means that a mouse button is currently + * down; this is used to implement grabs + * for the duration of button presses. + * UPDATE_SCROLLBARS: Non-zero means scrollbar(s) should be updated + * during next redisplay operation. + */ + +#define GOT_SELECTION 1 +#define INSERT_ON 2 +#define GOT_FOCUS 4 +#define BUTTON_DOWN 8 +#define UPDATE_SCROLLBARS 0x10 +#define NEED_REPICK 0x20 + +/* + * Records of the following type define segment types in terms of + * a collection of procedures that may be called to manipulate + * segments of that type. + */ + +typedef TkTextSegment * Tk_SegSplitProc _ANSI_ARGS_(( + struct TkTextSegment *segPtr, int index)); +typedef int Tk_SegDeleteProc _ANSI_ARGS_(( + struct TkTextSegment *segPtr, + TkTextLine *linePtr, int treeGone)); +typedef TkTextSegment * Tk_SegCleanupProc _ANSI_ARGS_(( + struct TkTextSegment *segPtr, TkTextLine *linePtr)); +typedef void Tk_SegLineChangeProc _ANSI_ARGS_(( + struct TkTextSegment *segPtr, TkTextLine *linePtr)); +typedef int Tk_SegLayoutProc _ANSI_ARGS_((struct TkText *textPtr, + struct TkTextIndex *indexPtr, TkTextSegment *segPtr, + int offset, int maxX, int maxChars, + int noCharsYet, Tk_Uid wrapMode, + struct TkTextDispChunk *chunkPtr)); +typedef void Tk_SegCheckProc _ANSI_ARGS_((TkTextSegment *segPtr, + TkTextLine *linePtr)); + +typedef struct Tk_SegType { + char *name; /* Name of this kind of segment. */ + int leftGravity; /* If a segment has zero size (e.g. a + * mark or tag toggle), does it + * attach to character to its left + * or right? 1 means left, 0 means + * right. */ + Tk_SegSplitProc *splitProc; /* Procedure to split large segment + * into two smaller ones. */ + Tk_SegDeleteProc *deleteProc; /* Procedure to call to delete + * segment. */ + Tk_SegCleanupProc *cleanupProc; /* After any change to a line, this + * procedure is invoked for all + * segments left in the line to + * perform any cleanup they wish + * (e.g. joining neighboring + * segments). */ + Tk_SegLineChangeProc *lineChangeProc; + /* Invoked when a segment is about + * to be moved from its current line + * to an earlier line because of + * a deletion. The linePtr is that + * for the segment's old line. + * CleanupProc will be invoked after + * the deletion is finished. */ + Tk_SegLayoutProc *layoutProc; /* Returns size information when + * figuring out what to display in + * window. */ + Tk_SegCheckProc *checkProc; /* Called during consistency checks + * to check internal consistency of + * segment. */ +} Tk_SegType; + +/* + * The constant below is used to specify a line when what is really + * wanted is the entire text. For now, just use a very big number. + */ + +#define TK_END_OF_TEXT 1000000 + +/* + * The following definition specifies the maximum number of characters + * needed in a string to hold a position specifier. + */ + +#define TK_POS_CHARS 30 + +/* + * Declarations for variables shared among the text-related files: + */ + +extern int tkBTreeDebug; +extern int tkTextDebug; +extern Tk_SegType tkTextCharType; +extern Tk_Uid tkTextCharUid; +extern Tk_Uid tkTextDisabledUid; +extern Tk_SegType tkTextLeftMarkType; +extern Tk_Uid tkTextNoneUid; +extern Tk_Uid tkTextNormalUid; +extern Tk_SegType tkTextRightMarkType; +extern Tk_SegType tkTextToggleOnType; +extern Tk_SegType tkTextToggleOffType; +extern Tk_Uid tkTextWordUid; + +/* + * Declarations for procedures that are used by the text-related files + * but shouldn't be used anywhere else in Tk (or by Tk clients): + */ + +extern int TkBTreeCharTagged _ANSI_ARGS_((TkTextIndex *indexPtr, + TkTextTag *tagPtr)); +extern void TkBTreeCheck _ANSI_ARGS_((TkTextBTree tree)); +extern int TkBTreeCharsInLine _ANSI_ARGS_((TkTextLine *linePtr)); +extern TkTextBTree TkBTreeCreate _ANSI_ARGS_((TkText *textPtr)); +extern void TkBTreeDestroy _ANSI_ARGS_((TkTextBTree tree)); +extern void TkBTreeDeleteChars _ANSI_ARGS_((TkTextIndex *index1Ptr, + TkTextIndex *index2Ptr)); +extern TkTextLine * TkBTreeFindLine _ANSI_ARGS_((TkTextBTree tree, + int line)); +extern TkTextTag ** TkBTreeGetTags _ANSI_ARGS_((TkTextIndex *indexPtr, + int *numTagsPtr)); +extern void TkBTreeInsertChars _ANSI_ARGS_((TkTextIndex *indexPtr, + char *string)); +extern int TkBTreeLineIndex _ANSI_ARGS_((TkTextLine *linePtr)); +extern void TkBTreeLinkSegment _ANSI_ARGS_((TkTextSegment *segPtr, + TkTextIndex *indexPtr)); +extern TkTextLine * TkBTreeNextLine _ANSI_ARGS_((TkTextLine *linePtr)); +extern int TkBTreeNextTag _ANSI_ARGS_((TkTextSearch *searchPtr)); +extern int TkBTreeNumLines _ANSI_ARGS_((TkTextBTree tree)); +extern TkTextLine * TkBTreePreviousLine _ANSI_ARGS_((TkTextLine *linePtr)); +extern int TkBTreePrevTag _ANSI_ARGS_((TkTextSearch *searchPtr)); +extern void TkBTreeStartSearch _ANSI_ARGS_((TkTextIndex *index1Ptr, + TkTextIndex *index2Ptr, TkTextTag *tagPtr, + TkTextSearch *searchPtr)); +extern void TkBTreeStartSearchBack _ANSI_ARGS_((TkTextIndex *index1Ptr, + TkTextIndex *index2Ptr, TkTextTag *tagPtr, + TkTextSearch *searchPtr)); +extern void TkBTreeTag _ANSI_ARGS_((TkTextIndex *index1Ptr, + TkTextIndex *index2Ptr, TkTextTag *tagPtr, + int add)); +extern void TkBTreeUnlinkSegment _ANSI_ARGS_((TkTextBTree tree, + TkTextSegment *segPtr, TkTextLine *linePtr)); +extern void TkTextBindProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +extern void TkTextChanged _ANSI_ARGS_((TkText *textPtr, + TkTextIndex *index1Ptr, TkTextIndex *index2Ptr)); +extern int TkTextCharBbox _ANSI_ARGS_((TkText *textPtr, + TkTextIndex *indexPtr, int *xPtr, int *yPtr, + int *widthPtr, int *heightPtr)); +extern int TkTextCharLayoutProc _ANSI_ARGS_((TkText *textPtr, + TkTextIndex *indexPtr, TkTextSegment *segPtr, + int offset, int maxX, int maxChars, int noBreakYet, + Tk_Uid wrapMode, TkTextDispChunk *chunkPtr)); +extern void TkTextCreateDInfo _ANSI_ARGS_((TkText *textPtr)); +extern int TkTextDLineInfo _ANSI_ARGS_((TkText *textPtr, + TkTextIndex *indexPtr, int *xPtr, int *yPtr, + int *widthPtr, int *heightPtr, int *basePtr)); +extern TkTextTag * TkTextCreateTag _ANSI_ARGS_((TkText *textPtr, + char *tagName)); +extern void TkTextFreeDInfo _ANSI_ARGS_((TkText *textPtr)); +extern void TkTextFreeTag _ANSI_ARGS_((TkText *textPtr, + TkTextTag *tagPtr)); +extern int TkTextGetIndex _ANSI_ARGS_((Tcl_Interp *interp, + TkText *textPtr, char *string, + TkTextIndex *indexPtr)); +extern TkTextTabArray * TkTextGetTabs _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, char *string)); +extern void TkTextIndexBackChars _ANSI_ARGS_((TkTextIndex *srcPtr, + int count, TkTextIndex *dstPtr)); +extern int TkTextIndexCmp _ANSI_ARGS_((TkTextIndex *index1Ptr, + TkTextIndex *index2Ptr)); +extern void TkTextIndexForwChars _ANSI_ARGS_((TkTextIndex *srcPtr, + int count, TkTextIndex *dstPtr)); +extern TkTextSegment * TkTextIndexToSeg _ANSI_ARGS_((TkTextIndex *indexPtr, + int *offsetPtr)); +extern void TkTextInsertDisplayProc _ANSI_ARGS_(( + TkTextDispChunk *chunkPtr, int x, int y, int height, + int baseline, Display *display, Drawable dst, + int screenY)); +extern void TkTextLostSelection _ANSI_ARGS_(( + ClientData clientData)); +extern TkTextIndex * TkTextMakeIndex _ANSI_ARGS_((TkTextBTree tree, + int lineIndex, int charIndex, + TkTextIndex *indexPtr)); +extern int TkTextMarkCmd _ANSI_ARGS_((TkText *textPtr, + Tcl_Interp *interp, int argc, char **argv)); +extern int TkTextMarkNameToIndex _ANSI_ARGS_((TkText *textPtr, + char *name, TkTextIndex *indexPtr)); +extern void TkTextMarkSegToIndex _ANSI_ARGS_((TkText *textPtr, + TkTextSegment *markPtr, TkTextIndex *indexPtr)); +extern void TkTextEventuallyRepick _ANSI_ARGS_((TkText *textPtr)); +extern void TkTextPickCurrent _ANSI_ARGS_((TkText *textPtr, + XEvent *eventPtr)); +extern void TkTextPixelIndex _ANSI_ARGS_((TkText *textPtr, + int x, int y, TkTextIndex *indexPtr)); +extern void TkTextPrintIndex _ANSI_ARGS_((TkTextIndex *indexPtr, + char *string)); +extern void TkTextRedrawRegion _ANSI_ARGS_((TkText *textPtr, + int x, int y, int width, int height)); +extern void TkTextRedrawTag _ANSI_ARGS_((TkText *textPtr, + TkTextIndex *index1Ptr, TkTextIndex *index2Ptr, + TkTextTag *tagPtr, int withTag)); +extern void TkTextRelayoutWindow _ANSI_ARGS_((TkText *textPtr)); +extern int TkTextScanCmd _ANSI_ARGS_((TkText *textPtr, + Tcl_Interp *interp, int argc, char **argv)); +extern int TkTextSeeCmd _ANSI_ARGS_((TkText *textPtr, + Tcl_Interp *interp, int argc, char **argv)); +extern int TkTextSegToOffset _ANSI_ARGS_((TkTextSegment *segPtr, + TkTextLine *linePtr)); +extern TkTextSegment * TkTextSetMark _ANSI_ARGS_((TkText *textPtr, char *name, + TkTextIndex *indexPtr)); +extern void TkTextSetYView _ANSI_ARGS_((TkText *textPtr, + TkTextIndex *indexPtr, int pickPlace)); +extern int TkTextTagCmd _ANSI_ARGS_((TkText *textPtr, + Tcl_Interp *interp, int argc, char **argv)); +extern int TkTextWindowCmd _ANSI_ARGS_((TkText *textPtr, + Tcl_Interp *interp, int argc, char **argv)); +extern int TkTextWindowIndex _ANSI_ARGS_((TkText *textPtr, + char *name, TkTextIndex *indexPtr)); +extern int TkTextXviewCmd _ANSI_ARGS_((TkText *textPtr, + Tcl_Interp *interp, int argc, char **argv)); +extern int TkTextYviewCmd _ANSI_ARGS_((TkText *textPtr, + Tcl_Interp *interp, int argc, char **argv)); + +#endif /* _TKTEXT */ diff --git a/tk4.2/generic/tkTextBTree.c b/tk4.2/generic/tkTextBTree.c new file mode 100644 index 0000000..7480ac6 --- /dev/null +++ b/tk4.2/generic/tkTextBTree.c @@ -0,0 +1,3594 @@ +/* + * tkTextBTree.c -- + * + * This file contains code that manages the B-tree representation + * of text for Tk's text widget and implements character and + * toggle segment types. + * + * Copyright (c) 1992-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkTextBTree.c 1.35 96/03/21 15:51:39 + */ + +#include "tkInt.h" +#include "tkPort.h" +#include "tkText.h" + +/* + * The data structure below keeps summary information about one tag as part + * of the tag information in a node. + */ + +typedef struct Summary { + TkTextTag *tagPtr; /* Handle for tag. */ + int toggleCount; /* Number of transitions into or + * out of this tag that occur in + * the subtree rooted at this node. */ + struct Summary *nextPtr; /* Next in list of all tags for same + * node, or NULL if at end of list. */ +} Summary; + +/* + * The data structure below defines a node in the B-tree. + */ + +typedef struct Node { + struct Node *parentPtr; /* Pointer to parent node, or NULL if + * this is the root. */ + struct Node *nextPtr; /* Next in list of siblings with the + * same parent node, or NULL for end + * of list. */ + Summary *summaryPtr; /* First in malloc-ed list of info + * about tags in this subtree (NULL if + * no tag info in the subtree). */ + int level; /* Level of this node in the B-tree. + * 0 refers to the bottom of the tree + * (children are lines, not nodes). */ + union { /* First in linked list of children. */ + struct Node *nodePtr; /* Used if level > 0. */ + TkTextLine *linePtr; /* Used if level == 0. */ + } children; + int numChildren; /* Number of children of this node. */ + int numLines; /* Total number of lines (leaves) in + * the subtree rooted here. */ +} Node; + +/* + * Upper and lower bounds on how many children a node may have: + * rebalance when either of these limits is exceeded. MAX_CHILDREN + * should be twice MIN_CHILDREN and MIN_CHILDREN must be >= 2. + */ + +#define MAX_CHILDREN 12 +#define MIN_CHILDREN 6 + +/* + * The data structure below defines an entire B-tree. + */ + +typedef struct BTree { + Node *rootPtr; /* Pointer to root of B-tree. */ + TkText *textPtr; /* Used to find tagTable in consistency + * checking code */ +} BTree; + +/* + * The structure below is used to pass information between + * TkBTreeGetTags and IncCount: + */ + +typedef struct TagInfo { + int numTags; /* Number of tags for which there + * is currently information in + * tags and counts. */ + int arraySize; /* Number of entries allocated for + * tags and counts. */ + TkTextTag **tagPtrs; /* Array of tags seen so far. + * Malloc-ed. */ + int *counts; /* Toggle count (so far) for each + * entry in tags. Malloc-ed. */ +} TagInfo; + +/* + * Variable that indicates whether to enable consistency checks for + * debugging. + */ + +int tkBTreeDebug = 0; + +/* + * Macros that determine how much space to allocate for new segments: + */ + +#define CSEG_SIZE(chars) ((unsigned) (Tk_Offset(TkTextSegment, body) \ + + 1 + (chars))) +#define TSEG_SIZE ((unsigned) (Tk_Offset(TkTextSegment, body) \ + + sizeof(TkTextToggle))) + +/* + * Forward declarations for procedures defined in this file: + */ + +static void ChangeNodeToggleCount _ANSI_ARGS_((Node *nodePtr, + TkTextTag *tagPtr, int delta)); +static void CharCheckProc _ANSI_ARGS_((TkTextSegment *segPtr, + TkTextLine *linePtr)); +static int CharDeleteProc _ANSI_ARGS_((TkTextSegment *segPtr, + TkTextLine *linePtr, int treeGone)); +static TkTextSegment * CharCleanupProc _ANSI_ARGS_((TkTextSegment *segPtr, + TkTextLine *linePtr)); +static TkTextSegment * CharSplitProc _ANSI_ARGS_((TkTextSegment *segPtr, + int index)); +static void CheckNodeConsistency _ANSI_ARGS_((Node *nodePtr)); +static void CleanupLine _ANSI_ARGS_((TkTextLine *linePtr)); +static void DeleteSummaries _ANSI_ARGS_((Summary *tagPtr)); +static void DestroyNode _ANSI_ARGS_((Node *nodePtr)); +static void IncCount _ANSI_ARGS_((TkTextTag *tagPtr, int inc, + TagInfo *tagInfoPtr)); +static void Rebalance _ANSI_ARGS_((BTree *treePtr, Node *nodePtr)); +static void RecomputeNodeCounts _ANSI_ARGS_((Node *nodePtr)); +static TkTextSegment * SplitSeg _ANSI_ARGS_((TkTextIndex *indexPtr)); +static void ToggleCheckProc _ANSI_ARGS_((TkTextSegment *segPtr, + TkTextLine *linePtr)); +static TkTextSegment * ToggleCleanupProc _ANSI_ARGS_((TkTextSegment *segPtr, + TkTextLine *linePtr)); +static int ToggleDeleteProc _ANSI_ARGS_((TkTextSegment *segPtr, + TkTextLine *linePtr, int treeGone)); +static void ToggleLineChangeProc _ANSI_ARGS_((TkTextSegment *segPtr, + TkTextLine *linePtr)); +static TkTextSegment * FindTagStart _ANSI_ARGS_((TkTextBTree tree, + TkTextTag *tagPtr, TkTextIndex *indexPtr)); + +/* + * Type record for character segments: + */ + +Tk_SegType tkTextCharType = { + "character", /* name */ + 0, /* leftGravity */ + CharSplitProc, /* splitProc */ + CharDeleteProc, /* deleteProc */ + CharCleanupProc, /* cleanupProc */ + (Tk_SegLineChangeProc *) NULL, /* lineChangeProc */ + TkTextCharLayoutProc, /* layoutProc */ + CharCheckProc /* checkProc */ +}; + +/* + * Type record for segments marking the beginning of a tagged + * range: + */ + +Tk_SegType tkTextToggleOnType = { + "toggleOn", /* name */ + 0, /* leftGravity */ + (Tk_SegSplitProc *) NULL, /* splitProc */ + ToggleDeleteProc, /* deleteProc */ + ToggleCleanupProc, /* cleanupProc */ + ToggleLineChangeProc, /* lineChangeProc */ + (Tk_SegLayoutProc *) NULL, /* layoutProc */ + ToggleCheckProc /* checkProc */ +}; + +/* + * Type record for segments marking the end of a tagged + * range: + */ + +Tk_SegType tkTextToggleOffType = { + "toggleOff", /* name */ + 1, /* leftGravity */ + (Tk_SegSplitProc *) NULL, /* splitProc */ + ToggleDeleteProc, /* deleteProc */ + ToggleCleanupProc, /* cleanupProc */ + ToggleLineChangeProc, /* lineChangeProc */ + (Tk_SegLayoutProc *) NULL, /* layoutProc */ + ToggleCheckProc /* checkProc */ +}; + +/* + *---------------------------------------------------------------------- + * + * TkBTreeCreate -- + * + * This procedure is called to create a new text B-tree. + * + * Results: + * The return value is a pointer to a new B-tree containing + * one line with nothing but a newline character. + * + * Side effects: + * Memory is allocated and initialized. + * + *---------------------------------------------------------------------- + */ + +TkTextBTree +TkBTreeCreate(textPtr) + TkText *textPtr; +{ + register BTree *treePtr; + register Node *rootPtr; + register TkTextLine *linePtr, *linePtr2; + register TkTextSegment *segPtr; + + /* + * The tree will initially have two empty lines. The second line + * isn't actually part of the tree's contents, but its presence + * makes several operations easier. The tree will have one node, + * which is also the root of the tree. + */ + + rootPtr = (Node *) ckalloc(sizeof(Node)); + linePtr = (TkTextLine *) ckalloc(sizeof(TkTextLine)); + linePtr2 = (TkTextLine *) ckalloc(sizeof(TkTextLine)); + rootPtr->parentPtr = NULL; + rootPtr->nextPtr = NULL; + rootPtr->summaryPtr = NULL; + rootPtr->level = 0; + rootPtr->children.linePtr = linePtr; + rootPtr->numChildren = 2; + rootPtr->numLines = 2; + + linePtr->parentPtr = rootPtr; + linePtr->nextPtr = linePtr2; + segPtr = (TkTextSegment *) ckalloc(CSEG_SIZE(1)); + linePtr->segPtr = segPtr; + segPtr->typePtr = &tkTextCharType; + segPtr->nextPtr = NULL; + segPtr->size = 1; + segPtr->body.chars[0] = '\n'; + segPtr->body.chars[1] = 0; + + linePtr2->parentPtr = rootPtr; + linePtr2->nextPtr = NULL; + segPtr = (TkTextSegment *) ckalloc(CSEG_SIZE(1)); + linePtr2->segPtr = segPtr; + segPtr->typePtr = &tkTextCharType; + segPtr->nextPtr = NULL; + segPtr->size = 1; + segPtr->body.chars[0] = '\n'; + segPtr->body.chars[1] = 0; + + treePtr = (BTree *) ckalloc(sizeof(BTree)); + treePtr->rootPtr = rootPtr; + treePtr->textPtr = textPtr; + + return (TkTextBTree) treePtr; +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreeDestroy -- + * + * Delete a B-tree, recycling all of the storage it contains. + * + * Results: + * The tree given by treePtr is deleted. TreePtr should never + * again be used. + * + * Side effects: + * Memory is freed. + * + *---------------------------------------------------------------------- + */ + +void +TkBTreeDestroy(tree) + TkTextBTree tree; /* Pointer to tree to delete. */ +{ + BTree *treePtr = (BTree *) tree; + + DestroyNode(treePtr->rootPtr); + ckfree((char *) treePtr); +} + +/* + *---------------------------------------------------------------------- + * + * DestroyNode -- + * + * This is a recursive utility procedure used during the deletion + * of a B-tree. + * + * Results: + * None. + * + * Side effects: + * All the storage for nodePtr and its descendants is freed. + * + *---------------------------------------------------------------------- + */ + +static void +DestroyNode(nodePtr) + register Node *nodePtr; +{ + if (nodePtr->level == 0) { + TkTextLine *linePtr; + TkTextSegment *segPtr; + + while (nodePtr->children.linePtr != NULL) { + linePtr = nodePtr->children.linePtr; + nodePtr->children.linePtr = linePtr->nextPtr; + while (linePtr->segPtr != NULL) { + segPtr = linePtr->segPtr; + linePtr->segPtr = segPtr->nextPtr; + (*segPtr->typePtr->deleteProc)(segPtr, linePtr, 1); + } + ckfree((char *) linePtr); + } + } else { + register Node *childPtr; + + while (nodePtr->children.nodePtr != NULL) { + childPtr = nodePtr->children.nodePtr; + nodePtr->children.nodePtr = childPtr->nextPtr; + DestroyNode(childPtr); + } + } + DeleteSummaries(nodePtr->summaryPtr); + ckfree((char *) nodePtr); +} + +/* + *---------------------------------------------------------------------- + * + * DeleteSummaries -- + * + * Free up all of the memory in a list of tag summaries associated + * with a node. + * + * Results: + * None. + * + * Side effects: + * Storage is released. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteSummaries(summaryPtr) + register Summary *summaryPtr; /* First in list of node's tag + * summaries. */ +{ + register Summary *nextPtr; + while (summaryPtr != NULL) { + nextPtr = summaryPtr->nextPtr; + ckfree((char *) summaryPtr); + summaryPtr = nextPtr; + } +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreeInsertChars -- + * + * Insert characters at a given position in a B-tree. + * + * Results: + * None. + * + * Side effects: + * Characters are added to the B-tree at the given position. + * If the string contains newlines, new lines will be added, + * which could cause the structure of the B-tree to change. + * + *---------------------------------------------------------------------- + */ + +void +TkBTreeInsertChars(indexPtr, string) + register TkTextIndex *indexPtr; /* Indicates where to insert text. + * When the procedure returns, this + * index is no longer valid because + * of changes to the segment + * structure. */ + char *string; /* Pointer to bytes to insert (may + * contain newlines, must be null- + * terminated). */ +{ + register Node *nodePtr; + register TkTextSegment *prevPtr; /* The segment just before the first + * new segment (NULL means new segment + * is at beginning of line). */ + TkTextSegment *curPtr; /* Current segment; new characters + * are inserted just after this one. + * NULL means insert at beginning of + * line. */ + TkTextLine *linePtr; /* Current line (new segments are + * added to this line). */ + register TkTextSegment *segPtr; + TkTextLine *newLinePtr; + int chunkSize; /* # characters in current chunk. */ + register char *eol; /* Pointer to character just after last + * one in current chunk. */ + int changeToLineCount; /* Counts change to total number of + * lines in file. */ + + prevPtr = SplitSeg(indexPtr); + linePtr = indexPtr->linePtr; + curPtr = prevPtr; + + /* + * Chop the string up into lines and create a new segment for + * each line, plus a new line for the leftovers from the + * previous line. + */ + + changeToLineCount = 0; + while (*string != 0) { + for (eol = string; *eol != 0; eol++) { + if (*eol == '\n') { + eol++; + break; + } + } + chunkSize = eol-string; + segPtr = (TkTextSegment *) ckalloc(CSEG_SIZE(chunkSize)); + segPtr->typePtr = &tkTextCharType; + if (curPtr == NULL) { + segPtr->nextPtr = linePtr->segPtr; + linePtr->segPtr = segPtr; + } else { + segPtr->nextPtr = curPtr->nextPtr; + curPtr->nextPtr = segPtr; + } + segPtr->size = chunkSize; + strncpy(segPtr->body.chars, string, (size_t) chunkSize); + segPtr->body.chars[chunkSize] = 0; + curPtr = segPtr; + + if (eol[-1] != '\n') { + break; + } + + /* + * The chunk ended with a newline, so create a new TkTextLine + * and move the remainder of the old line to it. + */ + + newLinePtr = (TkTextLine *) ckalloc(sizeof(TkTextLine)); + newLinePtr->parentPtr = linePtr->parentPtr; + newLinePtr->nextPtr = linePtr->nextPtr; + linePtr->nextPtr = newLinePtr; + newLinePtr->segPtr = segPtr->nextPtr; + segPtr->nextPtr = NULL; + linePtr = newLinePtr; + curPtr = NULL; + changeToLineCount++; + + string = eol; + } + + /* + * Cleanup the starting line for the insertion, plus the ending + * line if it's different. + */ + + CleanupLine(indexPtr->linePtr); + if (linePtr != indexPtr->linePtr) { + CleanupLine(linePtr); + } + + /* + * Increment the line counts in all the parent nodes of the insertion + * point, then rebalance the tree if necessary. + */ + + for (nodePtr = linePtr->parentPtr ; nodePtr != NULL; + nodePtr = nodePtr->parentPtr) { + nodePtr->numLines += changeToLineCount; + } + nodePtr = linePtr->parentPtr; + nodePtr->numChildren += changeToLineCount; + if (nodePtr->numChildren > MAX_CHILDREN) { + Rebalance((BTree *) indexPtr->tree, nodePtr); + } + + if (tkBTreeDebug) { + TkBTreeCheck(indexPtr->tree); + } +} + +/* + *-------------------------------------------------------------- + * + * SplitSeg -- + * + * This procedure is called before adding or deleting + * segments. It does three things: (a) it finds the segment + * containing indexPtr; (b) if there are several such + * segments (because some segments have zero length) then + * it picks the first segment that does not have left + * gravity; (c) if the index refers to the middle of + * a segment then it splits the segment so that the + * index now refers to the beginning of a segment. + * + * Results: + * The return value is a pointer to the segment just + * before the segment corresponding to indexPtr (as + * described above). If the segment corresponding to + * indexPtr is the first in its line then the return + * value is NULL. + * + * Side effects: + * The segment referred to by indexPtr is split unless + * indexPtr refers to its first character. + * + *-------------------------------------------------------------- + */ + +static TkTextSegment * +SplitSeg(indexPtr) + TkTextIndex *indexPtr; /* Index identifying position + * at which to split a segment. */ +{ + TkTextSegment *prevPtr, *segPtr; + int count; + + for (count = indexPtr->charIndex, prevPtr = NULL, + segPtr = indexPtr->linePtr->segPtr; segPtr != NULL; + count -= segPtr->size, prevPtr = segPtr, segPtr = segPtr->nextPtr) { + if (segPtr->size > count) { + if (count == 0) { + return prevPtr; + } + segPtr = (*segPtr->typePtr->splitProc)(segPtr, count); + if (prevPtr == NULL) { + indexPtr->linePtr->segPtr = segPtr; + } else { + prevPtr->nextPtr = segPtr; + } + return segPtr; + } else if ((segPtr->size == 0) && (count == 0) + && !segPtr->typePtr->leftGravity) { + return prevPtr; + } + } + panic("SplitSeg reached end of line!"); + return NULL; +} + +/* + *-------------------------------------------------------------- + * + * CleanupLine -- + * + * This procedure is called after modifications have been + * made to a line. It scans over all of the segments in + * the line, giving each a chance to clean itself up, e.g. + * by merging with the following segments, updating internal + * information, etc. + * + * Results: + * None. + * + * Side effects: + * Depends on what the segment-specific cleanup procedures do. + * + *-------------------------------------------------------------- + */ + +static void +CleanupLine(linePtr) + TkTextLine *linePtr; /* Line to be cleaned up. */ +{ + TkTextSegment *segPtr, **prevPtrPtr; + int anyChanges; + + /* + * Make a pass over all of the segments in the line, giving each + * a chance to clean itself up. This could potentially change + * the structure of the line, e.g. by merging two segments + * together or having two segments cancel themselves; if so, + * then repeat the whole process again, since the first structure + * change might make other structure changes possible. Repeat + * until eventually there are no changes. + */ + + while (1) { + anyChanges = 0; + for (prevPtrPtr = &linePtr->segPtr, segPtr = *prevPtrPtr; + segPtr != NULL; + prevPtrPtr = &(*prevPtrPtr)->nextPtr, segPtr = *prevPtrPtr) { + if (segPtr->typePtr->cleanupProc != NULL) { + *prevPtrPtr = (*segPtr->typePtr->cleanupProc)(segPtr, linePtr); + if (segPtr != *prevPtrPtr) { + anyChanges = 1; + } + } + } + if (!anyChanges) { + break; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreeDeleteChars -- + * + * Delete a range of characters from a B-tree. The caller + * must make sure that the final newline of the B-tree is + * never deleted. + * + * Results: + * None. + * + * Side effects: + * Information is deleted from the B-tree. This can cause the + * internal structure of the B-tree to change. Note: because + * of changes to the B-tree structure, the indices pointed + * to by index1Ptr and index2Ptr should not be used after this + * procedure returns. + * + *---------------------------------------------------------------------- + */ + +void +TkBTreeDeleteChars(index1Ptr, index2Ptr) + register TkTextIndex *index1Ptr; /* Indicates first character that is + * to be deleted. */ + register TkTextIndex *index2Ptr; /* Indicates character just after the + * last one that is to be deleted. */ +{ + TkTextSegment *prevPtr; /* The segment just before the start + * of the deletion range. */ + TkTextSegment *lastPtr; /* The segment just after the end + * of the deletion range. */ + TkTextSegment *segPtr, *nextPtr; + TkTextLine *curLinePtr; + Node *curNodePtr, *nodePtr; + + /* + * Tricky point: split at index2Ptr first; otherwise the split + * at index2Ptr may invalidate segPtr and/or prevPtr. + */ + + lastPtr = SplitSeg(index2Ptr); + if (lastPtr != NULL) { + lastPtr = lastPtr->nextPtr; + } else { + lastPtr = index2Ptr->linePtr->segPtr; + } + prevPtr = SplitSeg(index1Ptr); + if (prevPtr != NULL) { + segPtr = prevPtr->nextPtr; + prevPtr->nextPtr = lastPtr; + } else { + segPtr = index1Ptr->linePtr->segPtr; + index1Ptr->linePtr->segPtr = lastPtr; + } + + /* + * Delete all of the segments between prevPtr and lastPtr. + */ + + curLinePtr = index1Ptr->linePtr; + curNodePtr = curLinePtr->parentPtr; + while (segPtr != lastPtr) { + if (segPtr == NULL) { + TkTextLine *nextLinePtr; + + /* + * We just ran off the end of a line. First find the + * next line, then go back to the old line and delete it + * (unless it's the starting line for the range). + */ + + nextLinePtr = TkBTreeNextLine(curLinePtr); + if (curLinePtr != index1Ptr->linePtr) { + if (curNodePtr == index1Ptr->linePtr->parentPtr) { + index1Ptr->linePtr->nextPtr = curLinePtr->nextPtr; + } else { + curNodePtr->children.linePtr = curLinePtr->nextPtr; + } + for (nodePtr = curNodePtr; nodePtr != NULL; + nodePtr = nodePtr->parentPtr) { + nodePtr->numLines--; + } + curNodePtr->numChildren--; + ckfree((char *) curLinePtr); + } + curLinePtr = nextLinePtr; + segPtr = curLinePtr->segPtr; + + /* + * If the node is empty then delete it and its parents, + * recursively upwards until a non-empty node is found. + */ + + while (curNodePtr->numChildren == 0) { + Node *parentPtr; + + parentPtr = curNodePtr->parentPtr; + if (parentPtr->children.nodePtr == curNodePtr) { + parentPtr->children.nodePtr = curNodePtr->nextPtr; + } else { + Node *prevNodePtr = parentPtr->children.nodePtr; + while (prevNodePtr->nextPtr != curNodePtr) { + prevNodePtr = prevNodePtr->nextPtr; + } + prevNodePtr->nextPtr = curNodePtr->nextPtr; + } + parentPtr->numChildren--; + ckfree((char *) curNodePtr); + curNodePtr = parentPtr; + } + curNodePtr = curLinePtr->parentPtr; + continue; + } + + nextPtr = segPtr->nextPtr; + if ((*segPtr->typePtr->deleteProc)(segPtr, curLinePtr, 0) != 0) { + /* + * This segment refuses to die. Move it to prevPtr and + * advance prevPtr if the segment has left gravity. + */ + + if (prevPtr == NULL) { + segPtr->nextPtr = index1Ptr->linePtr->segPtr; + index1Ptr->linePtr->segPtr = segPtr; + } else { + segPtr->nextPtr = prevPtr->nextPtr; + prevPtr->nextPtr = segPtr; + } + if (segPtr->typePtr->leftGravity) { + prevPtr = segPtr; + } + } + segPtr = nextPtr; + } + + /* + * If the beginning and end of the deletion range are in different + * lines, join the two lines together and discard the ending line. + */ + + if (index1Ptr->linePtr != index2Ptr->linePtr) { + TkTextLine *prevLinePtr; + + for (segPtr = lastPtr; segPtr != NULL; + segPtr = segPtr->nextPtr) { + if (segPtr->typePtr->lineChangeProc != NULL) { + (*segPtr->typePtr->lineChangeProc)(segPtr, index2Ptr->linePtr); + } + } + curNodePtr = index2Ptr->linePtr->parentPtr; + for (nodePtr = curNodePtr; nodePtr != NULL; + nodePtr = nodePtr->parentPtr) { + nodePtr->numLines--; + } + curNodePtr->numChildren--; + prevLinePtr = curNodePtr->children.linePtr; + if (prevLinePtr == index2Ptr->linePtr) { + curNodePtr->children.linePtr = index2Ptr->linePtr->nextPtr; + } else { + while (prevLinePtr->nextPtr != index2Ptr->linePtr) { + prevLinePtr = prevLinePtr->nextPtr; + } + prevLinePtr->nextPtr = index2Ptr->linePtr->nextPtr; + } + ckfree((char *) index2Ptr->linePtr); + Rebalance((BTree *) index2Ptr->tree, curNodePtr); + } + + /* + * Cleanup the segments in the new line. + */ + + CleanupLine(index1Ptr->linePtr); + + /* + * Lastly, rebalance the first node of the range. + */ + + Rebalance((BTree *) index1Ptr->tree, index1Ptr->linePtr->parentPtr); + if (tkBTreeDebug) { + TkBTreeCheck(index1Ptr->tree); + } +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreeFindLine -- + * + * Find a particular line in a B-tree based on its line number. + * + * Results: + * The return value is a pointer to the line structure for the + * line whose index is "line", or NULL if no such line exists. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +TkTextLine * +TkBTreeFindLine(tree, line) + TkTextBTree tree; /* B-tree in which to find line. */ + int line; /* Index of desired line. */ +{ + BTree *treePtr = (BTree *) tree; + register Node *nodePtr; + register TkTextLine *linePtr; + int linesLeft; + + nodePtr = treePtr->rootPtr; + linesLeft = line; + if ((line < 0) || (line >= nodePtr->numLines)) { + return NULL; + } + + /* + * Work down through levels of the tree until a node is found at + * level 0. + */ + + while (nodePtr->level != 0) { + for (nodePtr = nodePtr->children.nodePtr; + nodePtr->numLines <= linesLeft; + nodePtr = nodePtr->nextPtr) { + if (nodePtr == NULL) { + panic("TkBTreeFindLine ran out of nodes"); + } + linesLeft -= nodePtr->numLines; + } + } + + /* + * Work through the lines attached to the level-0 node. + */ + + for (linePtr = nodePtr->children.linePtr; linesLeft > 0; + linePtr = linePtr->nextPtr) { + if (linePtr == NULL) { + panic("TkBTreeFindLine ran out of lines"); + } + linesLeft -= 1; + } + return linePtr; +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreeNextLine -- + * + * Given an existing line in a B-tree, this procedure locates the + * next line in the B-tree. This procedure is used for scanning + * through the B-tree. + * + * Results: + * The return value is a pointer to the line that immediately + * follows linePtr, or NULL if there is no such line. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +TkTextLine * +TkBTreeNextLine(linePtr) + register TkTextLine *linePtr; /* Pointer to existing line in + * B-tree. */ +{ + register Node *nodePtr; + + if (linePtr->nextPtr != NULL) { + return linePtr->nextPtr; + } + + /* + * This was the last line associated with the particular parent node. + * Search up the tree for the next node, then search down from that + * node to find the first line. + */ + + for (nodePtr = linePtr->parentPtr; ; nodePtr = nodePtr->parentPtr) { + if (nodePtr->nextPtr != NULL) { + nodePtr = nodePtr->nextPtr; + break; + } + if (nodePtr->parentPtr == NULL) { + return (TkTextLine *) NULL; + } + } + while (nodePtr->level > 0) { + nodePtr = nodePtr->children.nodePtr; + } + return nodePtr->children.linePtr; +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreePreviousLine -- + * + * Given an existing line in a B-tree, this procedure locates the + * previous line in the B-tree. This procedure is used for scanning + * through the B-tree in the reverse direction. + * + * Results: + * The return value is a pointer to the line that immediately + * preceeds linePtr, or NULL if there is no such line. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +TkTextLine * +TkBTreePreviousLine(linePtr) + register TkTextLine *linePtr; /* Pointer to existing line in + * B-tree. */ +{ + register Node *nodePtr; + register Node *node2Ptr; + register TkTextLine *prevPtr; + + /* + * Find the line under this node just before the starting line. + */ + prevPtr = linePtr->parentPtr->children.linePtr; /* First line at leaf */ + while (prevPtr != linePtr) { + if (prevPtr->nextPtr == linePtr) { + return prevPtr; + } + prevPtr = prevPtr->nextPtr; + if (prevPtr == (TkTextLine *) NULL) { + panic("TkBTreePreviousLine ran out of lines"); + } + } + + /* + * This was the first line associated with the particular parent node. + * Search up the tree for the previous node, then search down from that + * node to find its last line. + */ + for (nodePtr = linePtr->parentPtr; ; nodePtr = nodePtr->parentPtr) { + if (nodePtr == (Node *) NULL || nodePtr->parentPtr == (Node *) NULL) { + return (TkTextLine *) NULL; + } + if (nodePtr != nodePtr->parentPtr->children.nodePtr) { + break; + } + } + for (node2Ptr = nodePtr->parentPtr->children.nodePtr; ; + node2Ptr = node2Ptr->children.nodePtr) { + while (node2Ptr->nextPtr != nodePtr) { + node2Ptr = node2Ptr->nextPtr; + } + if (node2Ptr->level == 0) { + break; + } + nodePtr = (Node *)NULL; + } + for (prevPtr = node2Ptr->children.linePtr ; ; prevPtr = prevPtr->nextPtr) { + if (prevPtr->nextPtr == (TkTextLine *) NULL) { + return prevPtr; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreeLineIndex -- + * + * Given a pointer to a line in a B-tree, return the numerical + * index of that line. + * + * Results: + * The result is the index of linePtr within the tree, where 0 + * corresponds to the first line in the tree. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TkBTreeLineIndex(linePtr) + TkTextLine *linePtr; /* Pointer to existing line in + * B-tree. */ +{ + register TkTextLine *linePtr2; + register Node *nodePtr, *parentPtr, *nodePtr2; + int index; + + /* + * First count how many lines precede this one in its level-0 + * node. + */ + + nodePtr = linePtr->parentPtr; + index = 0; + for (linePtr2 = nodePtr->children.linePtr; linePtr2 != linePtr; + linePtr2 = linePtr2->nextPtr) { + if (linePtr2 == NULL) { + panic("TkBTreeLineIndex couldn't find line"); + } + index += 1; + } + + /* + * Now work up through the levels of the tree one at a time, + * counting how many lines are in nodes preceding the current + * node. + */ + + for (parentPtr = nodePtr->parentPtr ; parentPtr != NULL; + nodePtr = parentPtr, parentPtr = parentPtr->parentPtr) { + for (nodePtr2 = parentPtr->children.nodePtr; nodePtr2 != nodePtr; + nodePtr2 = nodePtr2->nextPtr) { + if (nodePtr2 == NULL) { + panic("TkBTreeLineIndex couldn't find node"); + } + index += nodePtr2->numLines; + } + } + return index; +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreeLinkSegment -- + * + * This procedure adds a new segment to a B-tree at a given + * location. + * + * Results: + * None. + * + * Side effects: + * SegPtr will be linked into its tree. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +void +TkBTreeLinkSegment(segPtr, indexPtr) + TkTextSegment *segPtr; /* Pointer to new segment to be added to + * B-tree. Should be completely initialized + * by caller except for nextPtr field. */ + TkTextIndex *indexPtr; /* Where to add segment: it gets linked + * in just before the segment indicated + * here. */ +{ + register TkTextSegment *prevPtr; + + prevPtr = SplitSeg(indexPtr); + if (prevPtr == NULL) { + segPtr->nextPtr = indexPtr->linePtr->segPtr; + indexPtr->linePtr->segPtr = segPtr; + } else { + segPtr->nextPtr = prevPtr->nextPtr; + prevPtr->nextPtr = segPtr; + } + CleanupLine(indexPtr->linePtr); + if (tkBTreeDebug) { + TkBTreeCheck(indexPtr->tree); + } +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreeUnlinkSegment -- + * + * This procedure unlinks a segment from its line in a B-tree. + * + * Results: + * None. + * + * Side effects: + * SegPtr will be unlinked from linePtr. The segment itself + * isn't modified by this procedure. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +void +TkBTreeUnlinkSegment(tree, segPtr, linePtr) + TkTextBTree tree; /* Tree containing segment. */ + TkTextSegment *segPtr; /* Segment to be unlinked. */ + TkTextLine *linePtr; /* Line that currently contains + * segment. */ +{ + register TkTextSegment *prevPtr; + + if (linePtr->segPtr == segPtr) { + linePtr->segPtr = segPtr->nextPtr; + } else { + for (prevPtr = linePtr->segPtr; prevPtr->nextPtr != segPtr; + prevPtr = prevPtr->nextPtr) { + /* Empty loop body. */ + } + prevPtr->nextPtr = segPtr->nextPtr; + } + CleanupLine(linePtr); +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreeTag -- + * + * Turn a given tag on or off for a given range of characters in + * a B-tree of text. + * + * Results: + * None. + * + * Side effects: + * The given tag is added to the given range of characters + * in the tree or removed from all those characters, depending + * on the "add" argument. The structure of the btree is modified + * enough that index1Ptr and index2Ptr are no longer valid after + * this procedure returns, and the indexes may be modified by + * this procedure. + * + *---------------------------------------------------------------------- + */ + +void +TkBTreeTag(index1Ptr, index2Ptr, tagPtr, add) + register TkTextIndex *index1Ptr; /* Indicates first character in + * range. */ + register TkTextIndex *index2Ptr; /* Indicates character just after the + * last one in range. */ + TkTextTag *tagPtr; /* Tag to add or remove. */ + int add; /* One means add tag to the given + * range of characters; zero means + * remove the tag from the range. */ +{ + TkTextSegment *segPtr, *prevPtr; + TkTextSearch search; + TkTextLine *cleanupLinePtr; + int oldState; + int changed; + + /* + * See whether the tag is present at the start of the range. If + * the state doesn't already match what we want then add a toggle + * there. + */ + + oldState = TkBTreeCharTagged(index1Ptr, tagPtr); + if ((add != 0) ^ oldState) { + segPtr = (TkTextSegment *) ckalloc(TSEG_SIZE); + segPtr->typePtr = (add) ? &tkTextToggleOnType : &tkTextToggleOffType; + prevPtr = SplitSeg(index1Ptr); + if (prevPtr == NULL) { + segPtr->nextPtr = index1Ptr->linePtr->segPtr; + index1Ptr->linePtr->segPtr = segPtr; + } else { + segPtr->nextPtr = prevPtr->nextPtr; + prevPtr->nextPtr = segPtr; + } + segPtr->size = 0; + segPtr->body.toggle.tagPtr = tagPtr; + segPtr->body.toggle.inNodeCounts = 0; + } + + /* + * Scan the range of characters and delete any internal tag + * transitions. Keep track of what the old state was at the end + * of the range, and add a toggle there if it's needed. + */ + + TkBTreeStartSearch(index1Ptr, index2Ptr, tagPtr, &search); + cleanupLinePtr = index1Ptr->linePtr; + while (TkBTreeNextTag(&search)) { + oldState ^= 1; + segPtr = search.segPtr; + prevPtr = search.curIndex.linePtr->segPtr; + if (prevPtr == segPtr) { + search.curIndex.linePtr->segPtr = segPtr->nextPtr; + } else { + while (prevPtr->nextPtr != segPtr) { + prevPtr = prevPtr->nextPtr; + } + prevPtr->nextPtr = segPtr->nextPtr; + } + if (segPtr->body.toggle.inNodeCounts) { + ChangeNodeToggleCount(search.curIndex.linePtr->parentPtr, + segPtr->body.toggle.tagPtr, -1); + segPtr->body.toggle.inNodeCounts = 0; + changed = 1; + } else { + changed = 0; + } + ckfree((char *) segPtr); + + /* + * The code below is a bit tricky. After deleting a toggle + * we eventually have to call CleanupLine, in order to allow + * character segments to be merged together. To do this, we + * remember in cleanupLinePtr a line that needs to be + * cleaned up, but we don't clean it up until we've moved + * on to a different line. That way the cleanup process + * won't goof up segPtr. + */ + + if (cleanupLinePtr != search.curIndex.linePtr) { + CleanupLine(cleanupLinePtr); + cleanupLinePtr = search.curIndex.linePtr; + } + /* + * Quick hack. ChangeNodeToggleCount may move the tag's root + * location around and leave the search in the void. This resets + * the search. + */ + if (changed) { + TkBTreeStartSearch(index1Ptr, index2Ptr, tagPtr, &search); + } + } + if ((add != 0) ^ oldState) { + segPtr = (TkTextSegment *) ckalloc(TSEG_SIZE); + segPtr->typePtr = (add) ? &tkTextToggleOffType : &tkTextToggleOnType; + prevPtr = SplitSeg(index2Ptr); + if (prevPtr == NULL) { + segPtr->nextPtr = index2Ptr->linePtr->segPtr; + index2Ptr->linePtr->segPtr = segPtr; + } else { + segPtr->nextPtr = prevPtr->nextPtr; + prevPtr->nextPtr = segPtr; + } + segPtr->size = 0; + segPtr->body.toggle.tagPtr = tagPtr; + segPtr->body.toggle.inNodeCounts = 0; + } + + /* + * Cleanup cleanupLinePtr and the last line of the range, if + * these are different. + */ + + CleanupLine(cleanupLinePtr); + if (cleanupLinePtr != index2Ptr->linePtr) { + CleanupLine(index2Ptr->linePtr); + } + + if (tkBTreeDebug) { + TkBTreeCheck(index1Ptr->tree); + } +} + +/* + *---------------------------------------------------------------------- + * + * ChangeNodeToggleCount -- + * + * This procedure increments or decrements the toggle count for + * a particular tag in a particular node and all its ancestors + * up to the per-tag root node. + * + * Results: + * None. + * + * Side effects: + * The toggle count for tag is adjusted up or down by "delta" in + * nodePtr. This routine maintains the tagRootPtr that identifies + * the root node for the tag, moving it up or down the tree as needed. + * + *---------------------------------------------------------------------- + */ + +static void +ChangeNodeToggleCount(nodePtr, tagPtr, delta) + register Node *nodePtr; /* Node whose toggle count for a tag + * must be changed. */ + TkTextTag *tagPtr; /* Information about tag. */ + int delta; /* Amount to add to current toggle + * count for tag (may be negative). */ +{ + register Summary *summaryPtr, *prevPtr; + register Node *node2Ptr; + int rootLevel; /* Level of original tag root */ + + tagPtr->toggleCount += delta; + if (tagPtr->tagRootPtr == (Node *) NULL) { + tagPtr->tagRootPtr = nodePtr; + return; + } + + /* + * Note the level of the existing root for the tag so we can detect + * if it needs to be moved because of the toggle count change. + */ + + rootLevel = tagPtr->tagRootPtr->level; + + /* + * Iterate over the node and its ancestors up to the tag root, adjusting + * summary counts at each node and moving the tag's root upwards if + * necessary. + */ + + for ( ; nodePtr != tagPtr->tagRootPtr; nodePtr = nodePtr->parentPtr) { + /* + * See if there's already an entry for this tag for this node. If so, + * perhaps all we have to do is adjust its count. + */ + + for (prevPtr = NULL, summaryPtr = nodePtr->summaryPtr; + summaryPtr != NULL; + prevPtr = summaryPtr, summaryPtr = summaryPtr->nextPtr) { + if (summaryPtr->tagPtr == tagPtr) { + break; + } + } + if (summaryPtr != NULL) { + summaryPtr->toggleCount += delta; + if (summaryPtr->toggleCount > 0 && + summaryPtr->toggleCount < tagPtr->toggleCount) { + continue; + } + if (summaryPtr->toggleCount != 0) { + /* + * Should never find a node with max toggle count at this + * point (there shouldn't have been a summary entry in the + * first place). + */ + + panic("ChangeNodeToggleCount: bad toggle count (%d) max (%d)", + summaryPtr->toggleCount, tagPtr->toggleCount); + } + + /* + * Zero toggle count; must remove this tag from the list. + */ + + if (prevPtr == NULL) { + nodePtr->summaryPtr = summaryPtr->nextPtr; + } else { + prevPtr->nextPtr = summaryPtr->nextPtr; + } + ckfree((char *) summaryPtr); + } else { + /* + * This tag isn't currently in the summary information list. + */ + + if (rootLevel == nodePtr->level) { + + /* + * The old tag root is at the same level in the tree as this + * node, but it isn't at this node. Move the tag root up + * a level, in the hopes that it will now cover this node + * as well as the old root (if not, we'll move it up again + * the next time through the loop). To push it up one level + * we copy the original toggle count into the summary + * information at the old root and change the root to its + * parent node. + */ + + Node *rootNodePtr = tagPtr->tagRootPtr; + summaryPtr = (Summary *) ckalloc(sizeof(Summary)); + summaryPtr->tagPtr = tagPtr; + summaryPtr->toggleCount = tagPtr->toggleCount - delta; + summaryPtr->nextPtr = rootNodePtr->summaryPtr; + rootNodePtr->summaryPtr = summaryPtr; + rootNodePtr = rootNodePtr->parentPtr; + rootLevel = rootNodePtr->level; + tagPtr->tagRootPtr = rootNodePtr; + } + summaryPtr = (Summary *) ckalloc(sizeof(Summary)); + summaryPtr->tagPtr = tagPtr; + summaryPtr->toggleCount = delta; + summaryPtr->nextPtr = nodePtr->summaryPtr; + nodePtr->summaryPtr = summaryPtr; + } + } + + /* + * If we've decremented the toggle count, then it may be necessary + * to push the tag root down one or more levels. + */ + + if (delta >= 0) { + return; + } + if (tagPtr->toggleCount == 0) { + tagPtr->tagRootPtr = (Node *) NULL; + return; + } + nodePtr = tagPtr->tagRootPtr; + while (nodePtr->level > 0) { + /* + * See if a single child node accounts for all of the tag's + * toggles. If so, push the root down one level. + */ + + for (node2Ptr = nodePtr->children.nodePtr; + node2Ptr != (Node *)NULL ; + node2Ptr = node2Ptr->nextPtr) { + for (prevPtr = NULL, summaryPtr = node2Ptr->summaryPtr; + summaryPtr != NULL; + prevPtr = summaryPtr, summaryPtr = summaryPtr->nextPtr) { + if (summaryPtr->tagPtr == tagPtr) { + break; + } + } + if (summaryPtr == NULL) { + continue; + } + if (summaryPtr->toggleCount != tagPtr->toggleCount) { + /* + * No node has all toggles, so the root is still valid. + */ + + return; + } + + /* + * This node has all the toggles, so push down the root. + */ + + if (prevPtr == NULL) { + node2Ptr->summaryPtr = summaryPtr->nextPtr; + } else { + prevPtr->nextPtr = summaryPtr->nextPtr; + } + ckfree((char *) summaryPtr); + tagPtr->tagRootPtr = node2Ptr; + break; + } + nodePtr = tagPtr->tagRootPtr; + } +} + +/* + *---------------------------------------------------------------------- + * + * FindTagStart -- + * + * Find the start of the first range of a tag. + * + * Results: + * The return value is a pointer to the first tag toggle segment + * for the tag. This can be either a tagon or tagoff segments because + * of the way TkBTreeAdd removes a tag. + * Sets *indexPtr to be the index of the tag toggle. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static TkTextSegment * +FindTagStart(tree, tagPtr, indexPtr) + TkTextBTree tree; /* Tree to search within */ + TkTextTag *tagPtr; /* Tag to search for. */ + TkTextIndex *indexPtr; /* Return - index information */ +{ + register Node *nodePtr; + register TkTextLine *linePtr; + register TkTextSegment *segPtr; + register Summary *summaryPtr; + int offset = 0; + + nodePtr = tagPtr->tagRootPtr; + if (nodePtr == (Node *) NULL) { + return NULL; + } + + /* + * Search from the root of the subtree that contains the tag down + * to the level 0 node. + */ + + while (nodePtr->level > 0) { + for (nodePtr = nodePtr->children.nodePtr ; nodePtr != (Node *) NULL; + nodePtr = nodePtr->nextPtr) { + for (summaryPtr = nodePtr->summaryPtr ; summaryPtr != NULL; + summaryPtr = summaryPtr->nextPtr) { + if (summaryPtr->tagPtr == tagPtr) { + goto gotNodeWithTag; + } + } + } + gotNodeWithTag: + continue; + } + + /* + * Work through the lines attached to the level-0 node. + */ + + for (linePtr = nodePtr->children.linePtr; linePtr != (TkTextLine *) NULL; + linePtr = linePtr->nextPtr) { + for (offset = 0, segPtr = linePtr->segPtr ; segPtr != NULL; + offset += segPtr->size, segPtr = segPtr->nextPtr) { + if (((segPtr->typePtr == &tkTextToggleOnType) + || (segPtr->typePtr == &tkTextToggleOffType)) + && (segPtr->body.toggle.tagPtr == tagPtr)) { + /* + * It is possible that this is a tagoff tag, but that + * gets cleaned up later. + */ + indexPtr->tree = tree; + indexPtr->linePtr = linePtr; + indexPtr->charIndex = offset; + return segPtr; + } + } + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * FindTagEnd -- + * + * Find the end of the last range of a tag. + * + * Results: + * The return value is a pointer to the last tag toggle segment + * for the tag. This can be either a tagon or tagoff segments because + * of the way TkBTreeAdd removes a tag. + * Sets *indexPtr to be the index of the tag toggle. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static TkTextSegment * +FindTagEnd(tree, tagPtr, indexPtr) + TkTextBTree tree; /* Tree to search within */ + TkTextTag *tagPtr; /* Tag to search for. */ + TkTextIndex *indexPtr; /* Return - index information */ +{ + register Node *nodePtr, *lastNodePtr; + register TkTextLine *linePtr ,*lastLinePtr; + register TkTextSegment *segPtr, *lastSegPtr, *last2SegPtr; + register Summary *summaryPtr; + int lastoffset, lastoffset2, offset = 0; + + nodePtr = tagPtr->tagRootPtr; + if (nodePtr == (Node *) NULL) { + return NULL; + } + + /* + * Search from the root of the subtree that contains the tag down + * to the level 0 node. + */ + + while (nodePtr->level > 0) { + for (lastNodePtr = NULL, nodePtr = nodePtr->children.nodePtr ; + nodePtr != (Node *) NULL; nodePtr = nodePtr->nextPtr) { + for (summaryPtr = nodePtr->summaryPtr ; summaryPtr != NULL; + summaryPtr = summaryPtr->nextPtr) { + if (summaryPtr->tagPtr == tagPtr) { + lastNodePtr = nodePtr; + break; + } + } + } + nodePtr = lastNodePtr; + } + + /* + * Work through the lines attached to the level-0 node. + */ + last2SegPtr = NULL; + lastoffset2 = 0; + lastoffset = 0; + for (lastLinePtr = NULL, linePtr = nodePtr->children.linePtr; + linePtr != (TkTextLine *) NULL; linePtr = linePtr->nextPtr) { + for (offset = 0, lastSegPtr = NULL, segPtr = linePtr->segPtr ; + segPtr != NULL; + offset += segPtr->size, segPtr = segPtr->nextPtr) { + if (((segPtr->typePtr == &tkTextToggleOnType) + || (segPtr->typePtr == &tkTextToggleOffType)) + && (segPtr->body.toggle.tagPtr == tagPtr)) { + lastSegPtr = segPtr; + lastoffset = offset; + } + } + if (lastSegPtr != NULL) { + lastLinePtr = linePtr; + last2SegPtr = lastSegPtr; + lastoffset2 = lastoffset; + } + } + indexPtr->tree = tree; + indexPtr->linePtr = lastLinePtr; + indexPtr->charIndex = lastoffset2; + return last2SegPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreeStartSearch -- + * + * This procedure sets up a search for tag transitions involving + * a given tag (or all tags) in a given range of the text. + * + * Results: + * None. + * + * Side effects: + * The information at *searchPtr is set up so that subsequent calls + * to TkBTreeNextTag or TkBTreePrevTag will return information about the + * locations of tag transitions. Note that TkBTreeNextTag or + * TkBTreePrevTag must be called to get the first transition. + * Note: unlike TkBTreeNextTag and TkBTreePrevTag, this routine does not + * guarantee that searchPtr->curIndex is equal to *index1Ptr. It may be + * greater than that if *index1Ptr is less than the first tag transition. + * + *---------------------------------------------------------------------- + */ + +void +TkBTreeStartSearch(index1Ptr, index2Ptr, tagPtr, searchPtr) + TkTextIndex *index1Ptr; /* Search starts here. Tag toggles + * at this position will not be + * returned. */ + TkTextIndex *index2Ptr; /* Search stops here. Tag toggles + * at this position *will* be + * returned. */ + TkTextTag *tagPtr; /* Tag to search for. NULL means + * search for any tag. */ + register TkTextSearch *searchPtr; /* Where to store information about + * search's progress. */ +{ + int offset; + TkTextIndex index0; /* First index of the tag */ + TkTextSegment *seg0Ptr; /* First segment of the tag */ + + /* + * Find the segment that contains the first toggle for the tag. This + * may become the starting point in the search. + */ + + seg0Ptr = FindTagStart(index1Ptr->tree, tagPtr, &index0); + if (seg0Ptr == (TkTextSegment *) NULL) { + /* + * Even though there are no toggles, the display code still + * uses the search curIndex, so initialize that anyway. + */ + + searchPtr->linesLeft = 0; + searchPtr->curIndex = *index1Ptr; + searchPtr->segPtr = NULL; + searchPtr->nextPtr = NULL; + return; + } + if (TkTextIndexCmp(index1Ptr, &index0) < 0) { + /* + * Adjust start of search up to the first range of the tag + */ + + searchPtr->curIndex = index0; + searchPtr->segPtr = NULL; + searchPtr->nextPtr = seg0Ptr; /* Will be returned by NextTag */ + index1Ptr = &index0; + } else { + searchPtr->curIndex = *index1Ptr; + searchPtr->segPtr = NULL; + searchPtr->nextPtr = TkTextIndexToSeg(index1Ptr, &offset); + searchPtr->curIndex.charIndex -= offset; + } + searchPtr->lastPtr = TkTextIndexToSeg(index2Ptr, (int *) NULL); + searchPtr->tagPtr = tagPtr; + searchPtr->linesLeft = TkBTreeLineIndex(index2Ptr->linePtr) + 1 + - TkBTreeLineIndex(index1Ptr->linePtr); + searchPtr->allTags = (tagPtr == NULL); + if (searchPtr->linesLeft == 1) { + /* + * Starting and stopping segments are in the same line; mark the + * search as over immediately if the second segment is before the + * first. A search does not return a toggle at the very start of + * the range, unless the range is artificially moved up to index0. + */ + if (((index1Ptr == &index0) && + (index1Ptr->charIndex > index2Ptr->charIndex)) || + ((index1Ptr != &index0) && + (index1Ptr->charIndex >= index2Ptr->charIndex))) { + searchPtr->linesLeft = 0; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreeStartSearchBack -- + * + * This procedure sets up a search backwards for tag transitions involving + * a given tag (or all tags) in a given range of the text. In the + * normal case the first index (*index1Ptr) is beyond the second + * index (*index2Ptr). + * + * + * Results: + * None. + * + * Side effects: + * The information at *searchPtr is set up so that subsequent calls + * to TkBTreePrevTag will return information about the + * locations of tag transitions. Note that TkBTreePrevTag must be called + * to get the first transition. + * Note: unlike TkBTreeNextTag and TkBTreePrevTag, this routine does not + * guarantee that searchPtr->curIndex is equal to *index1Ptr. It may be + * less than that if *index1Ptr is greater than the last tag transition. + * + *---------------------------------------------------------------------- + */ + +void +TkBTreeStartSearchBack(index1Ptr, index2Ptr, tagPtr, searchPtr) + TkTextIndex *index1Ptr; /* Search starts here. Tag toggles + * at this position will not be + * returned. */ + TkTextIndex *index2Ptr; /* Search stops here. Tag toggles + * at this position *will* be + * returned. */ + TkTextTag *tagPtr; /* Tag to search for. NULL means + * search for any tag. */ + register TkTextSearch *searchPtr; /* Where to store information about + * search's progress. */ +{ + int offset; + TkTextIndex index0; /* Last index of the tag */ + TkTextIndex backOne; /* One character before starting index */ + TkTextSegment *seg0Ptr; /* Last segment of the tag */ + + /* + * Find the segment that contains the last toggle for the tag. This + * may become the starting point in the search. + */ + + seg0Ptr = FindTagEnd(index1Ptr->tree, tagPtr, &index0); + if (seg0Ptr == (TkTextSegment *) NULL) { + /* + * Even though there are no toggles, the display code still + * uses the search curIndex, so initialize that anyway. + */ + + searchPtr->linesLeft = 0; + searchPtr->curIndex = *index1Ptr; + searchPtr->segPtr = NULL; + searchPtr->nextPtr = NULL; + return; + } + + /* + * Adjust the start of the search so it doesn't find any tag toggles + * that are right at the index specified by the user. + */ + + if (TkTextIndexCmp(index1Ptr, &index0) > 0) { + searchPtr->curIndex = index0; + index1Ptr = &index0; + } else { + TkTextIndexBackChars(index1Ptr, 1, &searchPtr->curIndex); + } + searchPtr->segPtr = NULL; + searchPtr->nextPtr = TkTextIndexToSeg(&searchPtr->curIndex, &offset); + searchPtr->curIndex.charIndex -= offset; + + /* + * Adjust the end of the search so it does find toggles that are right + * at the second index specified by the user. + */ + + if ((TkBTreeLineIndex(index2Ptr->linePtr) == 0) && + (index2Ptr->charIndex == 0)) { + backOne = *index2Ptr; + searchPtr->lastPtr = NULL; /* Signals special case for 1.0 */ + } else { + TkTextIndexBackChars(index2Ptr, 1, &backOne); + searchPtr->lastPtr = TkTextIndexToSeg(&backOne, (int *) NULL); + } + searchPtr->tagPtr = tagPtr; + searchPtr->linesLeft = TkBTreeLineIndex(index1Ptr->linePtr) + 1 + - TkBTreeLineIndex(backOne.linePtr); + searchPtr->allTags = (tagPtr == NULL); + if (searchPtr->linesLeft == 1) { + /* + * Starting and stopping segments are in the same line; mark the + * search as over immediately if the second segment is after the + * first. + */ + + if (index1Ptr->charIndex <= backOne.charIndex) { + searchPtr->linesLeft = 0; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreeNextTag -- + * + * Once a tag search has begun, successive calls to this procedure + * return successive tag toggles. Note: it is NOT SAFE to call this + * procedure if characters have been inserted into or deleted from + * the B-tree since the call to TkBTreeStartSearch. + * + * Results: + * The return value is 1 if another toggle was found that met the + * criteria specified in the call to TkBTreeStartSearch; in this + * case searchPtr->curIndex gives the toggle's position and + * searchPtr->curTagPtr points to its segment. 0 is returned if + * no more matching tag transitions were found; in this case + * searchPtr->curIndex is the same as searchPtr->stopIndex. + * + * Side effects: + * Information in *searchPtr is modified to update the state of the + * search and indicate where the next tag toggle is located. + * + *---------------------------------------------------------------------- + */ + +int +TkBTreeNextTag(searchPtr) + register TkTextSearch *searchPtr; /* Information about search in + * progress; must have been set up by + * call to TkBTreeStartSearch. */ +{ + register TkTextSegment *segPtr; + register Node *nodePtr; + register Summary *summaryPtr; + + if (searchPtr->linesLeft <= 0) { + goto searchOver; + } + + /* + * The outermost loop iterates over lines that may potentially contain + * a relevant tag transition, starting from the current segment in + * the current line. + */ + + segPtr = searchPtr->nextPtr; + while (1) { + /* + * Check for more tags on the current line. + */ + + for ( ; segPtr != NULL; segPtr = segPtr->nextPtr) { + if (segPtr == searchPtr->lastPtr) { + goto searchOver; + } + if (((segPtr->typePtr == &tkTextToggleOnType) + || (segPtr->typePtr == &tkTextToggleOffType)) + && (searchPtr->allTags + || (segPtr->body.toggle.tagPtr == searchPtr->tagPtr))) { + searchPtr->segPtr = segPtr; + searchPtr->nextPtr = segPtr->nextPtr; + searchPtr->tagPtr = segPtr->body.toggle.tagPtr; + return 1; + } + searchPtr->curIndex.charIndex += segPtr->size; + } + + /* + * See if there are more lines associated with the current parent + * node. If so, go back to the top of the loop to search the next + * one. + */ + + nodePtr = searchPtr->curIndex.linePtr->parentPtr; + searchPtr->curIndex.linePtr = searchPtr->curIndex.linePtr->nextPtr; + searchPtr->linesLeft--; + if (searchPtr->linesLeft <= 0) { + goto searchOver; + } + if (searchPtr->curIndex.linePtr != NULL) { + segPtr = searchPtr->curIndex.linePtr->segPtr; + searchPtr->curIndex.charIndex = 0; + continue; + } + if (nodePtr == searchPtr->tagPtr->tagRootPtr) { + goto searchOver; + } + + /* + * Search across and up through the B-tree's node hierarchy looking + * for the next node that has a relevant tag transition somewhere in + * its subtree. Be sure to update linesLeft as we skip over large + * chunks of lines. + */ + + while (1) { + while (nodePtr->nextPtr == NULL) { + if (nodePtr->parentPtr == NULL || + nodePtr->parentPtr == searchPtr->tagPtr->tagRootPtr) { + goto searchOver; + } + nodePtr = nodePtr->parentPtr; + } + nodePtr = nodePtr->nextPtr; + for (summaryPtr = nodePtr->summaryPtr; summaryPtr != NULL; + summaryPtr = summaryPtr->nextPtr) { + if ((searchPtr->allTags) || + (summaryPtr->tagPtr == searchPtr->tagPtr)) { + goto gotNodeWithTag; + } + } + searchPtr->linesLeft -= nodePtr->numLines; + } + + /* + * At this point we've found a subtree that has a relevant tag + * transition. Now search down (and across) through that subtree + * to find the first level-0 node that has a relevant tag transition. + */ + + gotNodeWithTag: + while (nodePtr->level > 0) { + for (nodePtr = nodePtr->children.nodePtr; ; + nodePtr = nodePtr->nextPtr) { + for (summaryPtr = nodePtr->summaryPtr; summaryPtr != NULL; + summaryPtr = summaryPtr->nextPtr) { + if ((searchPtr->allTags) + || (summaryPtr->tagPtr == searchPtr->tagPtr)) { + goto nextChild; + } + } + searchPtr->linesLeft -= nodePtr->numLines; + if (nodePtr->nextPtr == NULL) { + panic("TkBTreeNextTag found incorrect tag summary info."); + } + } + nextChild: + continue; + } + + /* + * Now we're down to a level-0 node that contains a line that contains + * a relevant tag transition. Set up line information and go back to + * the beginning of the loop to search through lines. + */ + + searchPtr->curIndex.linePtr = nodePtr->children.linePtr; + searchPtr->curIndex.charIndex = 0; + segPtr = searchPtr->curIndex.linePtr->segPtr; + if (searchPtr->linesLeft <= 0) { + goto searchOver; + } + continue; + } + + searchOver: + searchPtr->linesLeft = 0; + searchPtr->segPtr = NULL; + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreePrevTag -- + * + * Once a tag search has begun, successive calls to this procedure + * return successive tag toggles in the reverse direction. + * Note: it is NOT SAFE to call this + * procedure if characters have been inserted into or deleted from + * the B-tree since the call to TkBTreeStartSearch. + * + * Results: + * The return value is 1 if another toggle was found that met the + * criteria specified in the call to TkBTreeStartSearch; in this + * case searchPtr->curIndex gives the toggle's position and + * searchPtr->curTagPtr points to its segment. 0 is returned if + * no more matching tag transitions were found; in this case + * searchPtr->curIndex is the same as searchPtr->stopIndex. + * + * Side effects: + * Information in *searchPtr is modified to update the state of the + * search and indicate where the next tag toggle is located. + * + *---------------------------------------------------------------------- + */ + +int +TkBTreePrevTag(searchPtr) + register TkTextSearch *searchPtr; /* Information about search in + * progress; must have been set up by + * call to TkBTreeStartSearch. */ +{ + register TkTextSegment *segPtr, *prevPtr; + register TkTextLine *linePtr, *prevLinePtr; + register Node *nodePtr, *node2Ptr, *prevNodePtr; + register Summary *summaryPtr; + int charIndex; + int pastLast; /* Saw last marker during scan */ + int linesSkipped; + + if (searchPtr->linesLeft <= 0) { + goto searchOver; + } + + /* + * The outermost loop iterates over lines that may potentially contain + * a relevant tag transition, starting from the current segment in + * the current line. "nextPtr" is maintained as the last segment in + * a line that we can look at. + */ + + while (1) { + /* + * Check for the last toggle before the current segment on this line. + */ + charIndex = 0; + if (searchPtr->lastPtr == NULL) { + /* + * Search back to the very beginning, so pastLast is irrelevent. + */ + pastLast = 1; + } else { + pastLast = 0; + } + for (prevPtr = NULL, segPtr = searchPtr->curIndex.linePtr->segPtr ; + segPtr != NULL && segPtr != searchPtr->nextPtr; + segPtr = segPtr->nextPtr) { + if (((segPtr->typePtr == &tkTextToggleOnType) + || (segPtr->typePtr == &tkTextToggleOffType)) + && (searchPtr->allTags + || (segPtr->body.toggle.tagPtr == searchPtr->tagPtr))) { + prevPtr = segPtr; + searchPtr->curIndex.charIndex = charIndex; + } + if (segPtr == searchPtr->lastPtr) { + prevPtr = NULL; /* Segments earlier than last don't count */ + pastLast = 1; + } + charIndex += segPtr->size; + } + if (prevPtr != NULL) { + if (searchPtr->linesLeft == 1 && !pastLast) { + /* + * We found a segment that is before the stopping index. + * Note that it is OK if prevPtr == lastPtr. + */ + goto searchOver; + } + searchPtr->segPtr = prevPtr; + searchPtr->nextPtr = prevPtr; + searchPtr->tagPtr = prevPtr->body.toggle.tagPtr; + return 1; + } + + searchPtr->linesLeft--; + if (searchPtr->linesLeft <= 0) { + goto searchOver; + } + + /* + * See if there are more lines associated with the current parent + * node. If so, go back to the top of the loop to search the previous + * one. + */ + + nodePtr = searchPtr->curIndex.linePtr->parentPtr; + for (prevLinePtr = NULL, linePtr = nodePtr->children.linePtr; + linePtr != NULL && linePtr != searchPtr->curIndex.linePtr; + prevLinePtr = linePtr, linePtr = linePtr->nextPtr) { + /* empty loop body */ ; + } + if (prevLinePtr != NULL) { + searchPtr->curIndex.linePtr = prevLinePtr; + searchPtr->nextPtr = NULL; + continue; + } + if (nodePtr == searchPtr->tagPtr->tagRootPtr) { + goto searchOver; + } + + /* + * Search across and up through the B-tree's node hierarchy looking + * for the previous node that has a relevant tag transition somewhere in + * its subtree. The search and line counting is trickier with/out + * back pointers. We'll scan all the nodes under a parent up to + * the current node, searching all of them for tag state. The last + * one we find, if any, is recorded in prevNodePtr, and any nodes + * past prevNodePtr that don't have tag state increment linesSkipped. + */ + + while (1) { + for (prevNodePtr = NULL, linesSkipped = 0, + node2Ptr = nodePtr->parentPtr->children.nodePtr ; + node2Ptr != nodePtr; node2Ptr = node2Ptr->nextPtr) { + for (summaryPtr = node2Ptr->summaryPtr; summaryPtr != NULL; + summaryPtr = summaryPtr->nextPtr) { + if ((searchPtr->allTags) || + (summaryPtr->tagPtr == searchPtr->tagPtr)) { + prevNodePtr = node2Ptr; + linesSkipped = 0; + goto keepLooking; + } + } + linesSkipped += node2Ptr->numLines; + + keepLooking: + continue; + } + if (prevNodePtr != NULL) { + nodePtr = prevNodePtr; + searchPtr->linesLeft -= linesSkipped; + goto gotNodeWithTag; + } + nodePtr = nodePtr->parentPtr; + if (nodePtr->parentPtr == NULL || + nodePtr == searchPtr->tagPtr->tagRootPtr) { + goto searchOver; + } + } + + /* + * At this point we've found a subtree that has a relevant tag + * transition. Now search down (and across) through that subtree + * to find the last level-0 node that has a relevant tag transition. + */ + + gotNodeWithTag: + while (nodePtr->level > 0) { + for (linesSkipped = 0, prevNodePtr = NULL, + nodePtr = nodePtr->children.nodePtr; nodePtr != NULL ; + nodePtr = nodePtr->nextPtr) { + for (summaryPtr = nodePtr->summaryPtr; summaryPtr != NULL; + summaryPtr = summaryPtr->nextPtr) { + if ((searchPtr->allTags) + || (summaryPtr->tagPtr == searchPtr->tagPtr)) { + prevNodePtr = nodePtr; + linesSkipped = 0; + goto keepLooking2; + } + } + linesSkipped += nodePtr->numLines; + + keepLooking2: + continue; + } + if (prevNodePtr == NULL) { + panic("TkBTreePrevTag found incorrect tag summary info."); + } + searchPtr->linesLeft -= linesSkipped; + nodePtr = prevNodePtr; + } + + /* + * Now we're down to a level-0 node that contains a line that contains + * a relevant tag transition. Set up line information and go back to + * the beginning of the loop to search through lines. We start with + * the last line below the node. + */ + + for (prevLinePtr = NULL, linePtr = nodePtr->children.linePtr; + linePtr != NULL ; + prevLinePtr = linePtr, linePtr = linePtr->nextPtr) { + /* empty loop body */ ; + } + searchPtr->curIndex.linePtr = prevLinePtr; + searchPtr->curIndex.charIndex = 0; + if (searchPtr->linesLeft <= 0) { + goto searchOver; + } + continue; + } + + searchOver: + searchPtr->linesLeft = 0; + searchPtr->segPtr = NULL; + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreeCharTagged -- + * + * Determine whether a particular character has a particular tag. + * + * Results: + * The return value is 1 if the given tag is in effect at the + * character given by linePtr and ch, and 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TkBTreeCharTagged(indexPtr, tagPtr) + TkTextIndex *indexPtr; /* Indicates a character position at + * which to check for a tag. */ + TkTextTag *tagPtr; /* Tag of interest. */ +{ + register Node *nodePtr; + register TkTextLine *siblingLinePtr; + register TkTextSegment *segPtr; + TkTextSegment *toggleSegPtr; + int toggles, index; + + /* + * Check for toggles for the tag in indexPtr's line but before + * indexPtr. If there is one, its type indicates whether or + * not the character is tagged. + */ + + toggleSegPtr = NULL; + for (index = 0, segPtr = indexPtr->linePtr->segPtr; + (index + segPtr->size) <= indexPtr->charIndex; + index += segPtr->size, segPtr = segPtr->nextPtr) { + if (((segPtr->typePtr == &tkTextToggleOnType) + || (segPtr->typePtr == &tkTextToggleOffType)) + && (segPtr->body.toggle.tagPtr == tagPtr)) { + toggleSegPtr = segPtr; + } + } + if (toggleSegPtr != NULL) { + return (toggleSegPtr->typePtr == &tkTextToggleOnType); + } + + /* + * No toggle in this line. Look for toggles for the tag in lines + * that are predecessors of indexPtr->linePtr but under the same + * level-0 node. + */ + + toggles = 0; + for (siblingLinePtr = indexPtr->linePtr->parentPtr->children.linePtr; + siblingLinePtr != indexPtr->linePtr; + siblingLinePtr = siblingLinePtr->nextPtr) { + for (segPtr = siblingLinePtr->segPtr; segPtr != NULL; + segPtr = segPtr->nextPtr) { + if (((segPtr->typePtr == &tkTextToggleOnType) + || (segPtr->typePtr == &tkTextToggleOffType)) + && (segPtr->body.toggle.tagPtr == tagPtr)) { + toggleSegPtr = segPtr; + } + } + } + if (toggleSegPtr != NULL) { + return (toggleSegPtr->typePtr == &tkTextToggleOnType); + } + + /* + * No toggle in this node. Scan upwards through the ancestors of + * this node, counting the number of toggles of the given tag in + * siblings that precede that node. + */ + + toggles = 0; + for (nodePtr = indexPtr->linePtr->parentPtr; nodePtr->parentPtr != NULL; + nodePtr = nodePtr->parentPtr) { + register Node *siblingPtr; + register Summary *summaryPtr; + + for (siblingPtr = nodePtr->parentPtr->children.nodePtr; + siblingPtr != nodePtr; siblingPtr = siblingPtr->nextPtr) { + for (summaryPtr = siblingPtr->summaryPtr; summaryPtr != NULL; + summaryPtr = summaryPtr->nextPtr) { + if (summaryPtr->tagPtr == tagPtr) { + toggles += summaryPtr->toggleCount; + } + } + } + if (nodePtr == tagPtr->tagRootPtr) { + break; + } + } + + /* + * An odd number of toggles means that the tag is present at the + * given point. + */ + + return toggles & 1; +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreeGetTags -- + * + * Return information about all of the tags that are associated + * with a particular character in a B-tree of text. + * + * Results: + * The return value is a malloc-ed array containing pointers to + * information for each of the tags that is associated with + * the character at the position given by linePtr and ch. The + * word at *numTagsPtr is filled in with the number of pointers + * in the array. It is up to the caller to free the array by + * passing it to free. If there are no tags at the given character + * then a NULL pointer is returned and *numTagsPtr will be set to 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +TkTextTag ** +TkBTreeGetTags(indexPtr, numTagsPtr) + TkTextIndex *indexPtr; /* Indicates a particular position in + * the B-tree. */ + int *numTagsPtr; /* Store number of tags found at this + * location. */ +{ + register Node *nodePtr; + register TkTextLine *siblingLinePtr; + register TkTextSegment *segPtr; + int src, dst, index; + TagInfo tagInfo; +#define NUM_TAG_INFOS 10 + + tagInfo.numTags = 0; + tagInfo.arraySize = NUM_TAG_INFOS; + tagInfo.tagPtrs = (TkTextTag **) ckalloc((unsigned) + NUM_TAG_INFOS*sizeof(TkTextTag *)); + tagInfo.counts = (int *) ckalloc((unsigned) + NUM_TAG_INFOS*sizeof(int)); + + /* + * Record tag toggles within the line of indexPtr but preceding + * indexPtr. + */ + + for (index = 0, segPtr = indexPtr->linePtr->segPtr; + (index + segPtr->size) <= indexPtr->charIndex; + index += segPtr->size, segPtr = segPtr->nextPtr) { + if ((segPtr->typePtr == &tkTextToggleOnType) + || (segPtr->typePtr == &tkTextToggleOffType)) { + IncCount(segPtr->body.toggle.tagPtr, 1, &tagInfo); + } + } + + /* + * Record toggles for tags in lines that are predecessors of + * indexPtr->linePtr but under the same level-0 node. + */ + + for (siblingLinePtr = indexPtr->linePtr->parentPtr->children.linePtr; + siblingLinePtr != indexPtr->linePtr; + siblingLinePtr = siblingLinePtr->nextPtr) { + for (segPtr = siblingLinePtr->segPtr; segPtr != NULL; + segPtr = segPtr->nextPtr) { + if ((segPtr->typePtr == &tkTextToggleOnType) + || (segPtr->typePtr == &tkTextToggleOffType)) { + IncCount(segPtr->body.toggle.tagPtr, 1, &tagInfo); + } + } + } + + /* + * For each node in the ancestry of this line, record tag toggles + * for all siblings that precede that node. + */ + + for (nodePtr = indexPtr->linePtr->parentPtr; nodePtr->parentPtr != NULL; + nodePtr = nodePtr->parentPtr) { + register Node *siblingPtr; + register Summary *summaryPtr; + + for (siblingPtr = nodePtr->parentPtr->children.nodePtr; + siblingPtr != nodePtr; siblingPtr = siblingPtr->nextPtr) { + for (summaryPtr = siblingPtr->summaryPtr; summaryPtr != NULL; + summaryPtr = summaryPtr->nextPtr) { + if (summaryPtr->toggleCount & 1) { + IncCount(summaryPtr->tagPtr, summaryPtr->toggleCount, + &tagInfo); + } + } + } + } + + /* + * Go through the tag information and squash out all of the tags + * that have even toggle counts (these tags exist before the point + * of interest, but not at the desired character itself). + */ + + for (src = 0, dst = 0; src < tagInfo.numTags; src++) { + if (tagInfo.counts[src] & 1) { + tagInfo.tagPtrs[dst] = tagInfo.tagPtrs[src]; + dst++; + } + } + *numTagsPtr = dst; + ckfree((char *) tagInfo.counts); + if (dst == 0) { + ckfree((char *) tagInfo.tagPtrs); + return NULL; + } + return tagInfo.tagPtrs; +} + +/* + *---------------------------------------------------------------------- + * + * IncCount -- + * + * This is a utility procedure used by TkBTreeGetTags. It + * increments the count for a particular tag, adding a new + * entry for that tag if there wasn't one previously. + * + * Results: + * None. + * + * Side effects: + * The information at *tagInfoPtr may be modified, and the arrays + * may be reallocated to make them larger. + * + *---------------------------------------------------------------------- + */ + +static void +IncCount(tagPtr, inc, tagInfoPtr) + TkTextTag *tagPtr; /* Handle for tag. */ + int inc; /* Amount by which to increment tag count. */ + TagInfo *tagInfoPtr; /* Holds cumulative information about tags; + * increment count here. */ +{ + register TkTextTag **tagPtrPtr; + int count; + + for (tagPtrPtr = tagInfoPtr->tagPtrs, count = tagInfoPtr->numTags; + count > 0; tagPtrPtr++, count--) { + if (*tagPtrPtr == tagPtr) { + tagInfoPtr->counts[tagInfoPtr->numTags-count] += inc; + return; + } + } + + /* + * There isn't currently an entry for this tag, so we have to + * make a new one. If the arrays are full, then enlarge the + * arrays first. + */ + + if (tagInfoPtr->numTags == tagInfoPtr->arraySize) { + TkTextTag **newTags; + int *newCounts, newSize; + + newSize = 2*tagInfoPtr->arraySize; + newTags = (TkTextTag **) ckalloc((unsigned) + (newSize*sizeof(TkTextTag *))); + memcpy((VOID *) newTags, (VOID *) tagInfoPtr->tagPtrs, + tagInfoPtr->arraySize * sizeof(TkTextTag *)); + ckfree((char *) tagInfoPtr->tagPtrs); + tagInfoPtr->tagPtrs = newTags; + newCounts = (int *) ckalloc((unsigned) (newSize*sizeof(int))); + memcpy((VOID *) newCounts, (VOID *) tagInfoPtr->counts, + tagInfoPtr->arraySize * sizeof(int)); + ckfree((char *) tagInfoPtr->counts); + tagInfoPtr->counts = newCounts; + tagInfoPtr->arraySize = newSize; + } + + tagInfoPtr->tagPtrs[tagInfoPtr->numTags] = tagPtr; + tagInfoPtr->counts[tagInfoPtr->numTags] = inc; + tagInfoPtr->numTags++; +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreeCheck -- + * + * This procedure runs a set of consistency checks over a B-tree + * and panics if any inconsistencies are found. + * + * Results: + * None. + * + * Side effects: + * If a structural defect is found, the procedure panics with an + * error message. + * + *---------------------------------------------------------------------- + */ + +void +TkBTreeCheck(tree) + TkTextBTree tree; /* Tree to check. */ +{ + BTree *treePtr = (BTree *) tree; + register Summary *summaryPtr; + register Node *nodePtr; + register TkTextLine *linePtr; + register TkTextSegment *segPtr; + register TkTextTag *tagPtr; + Tcl_HashEntry *entryPtr; + Tcl_HashSearch search; + int count; + + /* + * Make sure that the tag toggle counts and the tag root pointers are OK. + */ + for (entryPtr = Tcl_FirstHashEntry(&treePtr->textPtr->tagTable, &search); + entryPtr != NULL ; entryPtr = Tcl_NextHashEntry(&search)) { + tagPtr = (TkTextTag *) Tcl_GetHashValue(entryPtr); + nodePtr = tagPtr->tagRootPtr; + if (nodePtr == (Node *) NULL) { + if (tagPtr->toggleCount != 0) { + panic("TkBTreeCheck found \"%s\" with toggles (%d) but no root", + tagPtr->name, tagPtr->toggleCount); + } + continue; /* no ranges for the tag */ + } else if (tagPtr->toggleCount == 0) { + panic("TkBTreeCheck found root for \"%s\" with no toggles", + tagPtr->name); + } else if (tagPtr->toggleCount & 1) { + panic("TkBTreeCheck found odd toggle count for \"%s\" (%d)", + tagPtr->name, tagPtr->toggleCount); + } + for (summaryPtr = nodePtr->summaryPtr; summaryPtr != NULL; + summaryPtr = summaryPtr->nextPtr) { + if (summaryPtr->tagPtr == tagPtr) { + panic("TkBTreeCheck found root node with summary info"); + } + } + count = 0; + if (nodePtr->level > 0) { + for (nodePtr = nodePtr->children.nodePtr ; nodePtr != NULL ; + nodePtr = nodePtr->nextPtr) { + for (summaryPtr = nodePtr->summaryPtr; summaryPtr != NULL; + summaryPtr = summaryPtr->nextPtr) { + if (summaryPtr->tagPtr == tagPtr) { + count += summaryPtr->toggleCount; + } + } + } + } else { + for (linePtr = nodePtr->children.linePtr ; linePtr != NULL ; + linePtr = linePtr->nextPtr) { + for (segPtr = linePtr->segPtr; segPtr != NULL; + segPtr = segPtr->nextPtr) { + if ((segPtr->typePtr == &tkTextToggleOnType || + segPtr->typePtr == &tkTextToggleOffType) && + segPtr->body.toggle.tagPtr == tagPtr) { + count++; + } + } + } + } + if (count != tagPtr->toggleCount) { + panic("TkBTreeCheck toggleCount (%d) wrong for \"%s\" should be (%d)", + tagPtr->toggleCount, tagPtr->name, count); + } + } + + /* + * Call a recursive procedure to do the main body of checks. + */ + + nodePtr = treePtr->rootPtr; + CheckNodeConsistency(treePtr->rootPtr); + + /* + * Make sure that there are at least two lines in the text and + * that the last line has no characters except a newline. + */ + + if (nodePtr->numLines < 2) { + panic("TkBTreeCheck: less than 2 lines in tree"); + } + while (nodePtr->level > 0) { + nodePtr = nodePtr->children.nodePtr; + while (nodePtr->nextPtr != NULL) { + nodePtr = nodePtr->nextPtr; + } + } + linePtr = nodePtr->children.linePtr; + while (linePtr->nextPtr != NULL) { + linePtr = linePtr->nextPtr; + } + segPtr = linePtr->segPtr; + while ((segPtr->typePtr == &tkTextToggleOffType) + || (segPtr->typePtr == &tkTextRightMarkType) + || (segPtr->typePtr == &tkTextLeftMarkType)) { + /* + * It's OK to toggle a tag off in the last line, but + * not to start a new range. It's also OK to have marks + * in the last line. + */ + + segPtr = segPtr->nextPtr; + } + if (segPtr->typePtr != &tkTextCharType) { + panic("TkBTreeCheck: last line has bogus segment type"); + } + if (segPtr->nextPtr != NULL) { + panic("TkBTreeCheck: last line has too many segments"); + } + if (segPtr->size != 1) { + panic("TkBTreeCheck: last line has wrong # characters: %d", + segPtr->size); + } + if ((segPtr->body.chars[0] != '\n') || (segPtr->body.chars[1] != 0)) { + panic("TkBTreeCheck: last line had bad value: %s", + segPtr->body.chars); + } +} + +/* + *---------------------------------------------------------------------- + * + * CheckNodeConsistency -- + * + * This procedure is called as part of consistency checking for + * B-trees: it checks several aspects of a node and also runs + * checks recursively on the node's children. + * + * Results: + * None. + * + * Side effects: + * If anything suspicious is found in the tree structure, the + * procedure panics. + * + *---------------------------------------------------------------------- + */ + +static void +CheckNodeConsistency(nodePtr) + register Node *nodePtr; /* Node whose subtree should be + * checked. */ +{ + register Node *childNodePtr; + register Summary *summaryPtr, *summaryPtr2; + register TkTextLine *linePtr; + register TkTextSegment *segPtr; + int numChildren, numLines, toggleCount, minChildren; + + if (nodePtr->parentPtr != NULL) { + minChildren = MIN_CHILDREN; + } else if (nodePtr->level > 0) { + minChildren = 2; + } else { + minChildren = 1; + } + if ((nodePtr->numChildren < minChildren) + || (nodePtr->numChildren > MAX_CHILDREN)) { + panic("CheckNodeConsistency: bad child count (%d)", + nodePtr->numChildren); + } + + numChildren = 0; + numLines = 0; + if (nodePtr->level == 0) { + for (linePtr = nodePtr->children.linePtr; linePtr != NULL; + linePtr = linePtr->nextPtr) { + if (linePtr->parentPtr != nodePtr) { + panic("CheckNodeConsistency: line doesn't point to parent"); + } + if (linePtr->segPtr == NULL) { + panic("CheckNodeConsistency: line has no segments"); + } + for (segPtr = linePtr->segPtr; segPtr != NULL; + segPtr = segPtr->nextPtr) { + if (segPtr->typePtr->checkProc != NULL) { + (*segPtr->typePtr->checkProc)(segPtr, linePtr); + } + if ((segPtr->size == 0) && (!segPtr->typePtr->leftGravity) + && (segPtr->nextPtr != NULL) + && (segPtr->nextPtr->size == 0) + && (segPtr->nextPtr->typePtr->leftGravity)) { + panic("CheckNodeConsistency: wrong segment order for gravity"); + } + if ((segPtr->nextPtr == NULL) + && (segPtr->typePtr != &tkTextCharType)) { + panic("CheckNodeConsistency: line ended with wrong type"); + } + } + numChildren++; + numLines++; + } + } else { + for (childNodePtr = nodePtr->children.nodePtr; childNodePtr != NULL; + childNodePtr = childNodePtr->nextPtr) { + if (childNodePtr->parentPtr != nodePtr) { + panic("CheckNodeConsistency: node doesn't point to parent"); + } + if (childNodePtr->level != (nodePtr->level-1)) { + panic("CheckNodeConsistency: level mismatch (%d %d)", + nodePtr->level, childNodePtr->level); + } + CheckNodeConsistency(childNodePtr); + for (summaryPtr = childNodePtr->summaryPtr; summaryPtr != NULL; + summaryPtr = summaryPtr->nextPtr) { + for (summaryPtr2 = nodePtr->summaryPtr; ; + summaryPtr2 = summaryPtr2->nextPtr) { + if (summaryPtr2 == NULL) { + if (summaryPtr->tagPtr->tagRootPtr == nodePtr) { + break; + } + panic("CheckNodeConsistency: node tag \"%s\" not %s", + summaryPtr->tagPtr->name, + "present in parent summaries"); + } + if (summaryPtr->tagPtr == summaryPtr2->tagPtr) { + break; + } + } + } + numChildren++; + numLines += childNodePtr->numLines; + } + } + if (numChildren != nodePtr->numChildren) { + panic("CheckNodeConsistency: mismatch in numChildren (%d %d)", + numChildren, nodePtr->numChildren); + } + if (numLines != nodePtr->numLines) { + panic("CheckNodeConsistency: mismatch in numLines (%d %d)", + numLines, nodePtr->numLines); + } + + for (summaryPtr = nodePtr->summaryPtr; summaryPtr != NULL; + summaryPtr = summaryPtr->nextPtr) { + if (summaryPtr->tagPtr->toggleCount == summaryPtr->toggleCount) { + panic("CheckNodeConsistency: found unpruned root for \"%s\"", + summaryPtr->tagPtr->name); + } + toggleCount = 0; + if (nodePtr->level == 0) { + for (linePtr = nodePtr->children.linePtr; linePtr != NULL; + linePtr = linePtr->nextPtr) { + for (segPtr = linePtr->segPtr; segPtr != NULL; + segPtr = segPtr->nextPtr) { + if ((segPtr->typePtr != &tkTextToggleOnType) + && (segPtr->typePtr != &tkTextToggleOffType)) { + continue; + } + if (segPtr->body.toggle.tagPtr == summaryPtr->tagPtr) { + toggleCount ++; + } + } + } + } else { + for (childNodePtr = nodePtr->children.nodePtr; + childNodePtr != NULL; + childNodePtr = childNodePtr->nextPtr) { + for (summaryPtr2 = childNodePtr->summaryPtr; + summaryPtr2 != NULL; + summaryPtr2 = summaryPtr2->nextPtr) { + if (summaryPtr2->tagPtr == summaryPtr->tagPtr) { + toggleCount += summaryPtr2->toggleCount; + } + } + } + } + if (toggleCount != summaryPtr->toggleCount) { + panic("CheckNodeConsistency: mismatch in toggleCount (%d %d)", + toggleCount, summaryPtr->toggleCount); + } + for (summaryPtr2 = summaryPtr->nextPtr; summaryPtr2 != NULL; + summaryPtr2 = summaryPtr2->nextPtr) { + if (summaryPtr2->tagPtr == summaryPtr->tagPtr) { + panic("CheckNodeConsistency: duplicated node tag: %s", + summaryPtr->tagPtr->name); + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Rebalance -- + * + * This procedure is called when a node of a B-tree appears to be + * out of balance (too many children, or too few). It rebalances + * that node and all of its ancestors in the tree. + * + * Results: + * None. + * + * Side effects: + * The internal structure of treePtr may change. + * + *---------------------------------------------------------------------- + */ + +static void +Rebalance(treePtr, nodePtr) + BTree *treePtr; /* Tree that is being rebalanced. */ + register Node *nodePtr; /* Node that may be out of balance. */ +{ + /* + * Loop over the entire ancestral chain of the node, working up + * through the tree one node at a time until the root node has + * been processed. + */ + + for ( ; nodePtr != NULL; nodePtr = nodePtr->parentPtr) { + register Node *newPtr, *childPtr; + register TkTextLine *linePtr; + int i; + + /* + * Check to see if the node has too many children. If it does, + * then split off all but the first MIN_CHILDREN into a separate + * node following the original one. Then repeat until the + * node has a decent size. + */ + + if (nodePtr->numChildren > MAX_CHILDREN) { + while (1) { + /* + * If the node being split is the root node, then make a + * new root node above it first. + */ + + if (nodePtr->parentPtr == NULL) { + newPtr = (Node *) ckalloc(sizeof(Node)); + newPtr->parentPtr = NULL; + newPtr->nextPtr = NULL; + newPtr->summaryPtr = NULL; + newPtr->level = nodePtr->level + 1; + newPtr->children.nodePtr = nodePtr; + newPtr->numChildren = 1; + newPtr->numLines = nodePtr->numLines; + RecomputeNodeCounts(newPtr); + treePtr->rootPtr = newPtr; + } + newPtr = (Node *) ckalloc(sizeof(Node)); + newPtr->parentPtr = nodePtr->parentPtr; + newPtr->nextPtr = nodePtr->nextPtr; + nodePtr->nextPtr = newPtr; + newPtr->summaryPtr = NULL; + newPtr->level = nodePtr->level; + newPtr->numChildren = nodePtr->numChildren - MIN_CHILDREN; + if (nodePtr->level == 0) { + for (i = MIN_CHILDREN-1, + linePtr = nodePtr->children.linePtr; + i > 0; i--, linePtr = linePtr->nextPtr) { + /* Empty loop body. */ + } + newPtr->children.linePtr = linePtr->nextPtr; + linePtr->nextPtr = NULL; + } else { + for (i = MIN_CHILDREN-1, + childPtr = nodePtr->children.nodePtr; + i > 0; i--, childPtr = childPtr->nextPtr) { + /* Empty loop body. */ + } + newPtr->children.nodePtr = childPtr->nextPtr; + childPtr->nextPtr = NULL; + } + RecomputeNodeCounts(nodePtr); + nodePtr->parentPtr->numChildren++; + nodePtr = newPtr; + if (nodePtr->numChildren <= MAX_CHILDREN) { + RecomputeNodeCounts(nodePtr); + break; + } + } + } + + while (nodePtr->numChildren < MIN_CHILDREN) { + register Node *otherPtr; + Node *halfwayNodePtr = NULL; /* Initialization needed only */ + TkTextLine *halfwayLinePtr = NULL; /* to prevent cc warnings. */ + int totalChildren, firstChildren, i; + + /* + * Too few children for this node. If this is the root then, + * it's OK for it to have less than MIN_CHILDREN children + * as long as it's got at least two. If it has only one + * (and isn't at level 0), then chop the root node out of + * the tree and use its child as the new root. + */ + + if (nodePtr->parentPtr == NULL) { + if ((nodePtr->numChildren == 1) && (nodePtr->level > 0)) { + treePtr->rootPtr = nodePtr->children.nodePtr; + treePtr->rootPtr->parentPtr = NULL; + DeleteSummaries(nodePtr->summaryPtr); + ckfree((char *) nodePtr); + } + return; + } + + /* + * Not the root. Make sure that there are siblings to + * balance with. + */ + + if (nodePtr->parentPtr->numChildren < 2) { + Rebalance(treePtr, nodePtr->parentPtr); + continue; + } + + /* + * Find a sibling neighbor to borrow from, and arrange for + * nodePtr to be the earlier of the pair. + */ + + if (nodePtr->nextPtr == NULL) { + for (otherPtr = nodePtr->parentPtr->children.nodePtr; + otherPtr->nextPtr != nodePtr; + otherPtr = otherPtr->nextPtr) { + /* Empty loop body. */ + } + nodePtr = otherPtr; + } + otherPtr = nodePtr->nextPtr; + + /* + * We're going to either merge the two siblings together + * into one node or redivide the children among them to + * balance their loads. As preparation, join their two + * child lists into a single list and remember the half-way + * point in the list. + */ + + totalChildren = nodePtr->numChildren + otherPtr->numChildren; + firstChildren = totalChildren/2; + if (nodePtr->children.nodePtr == NULL) { + nodePtr->children = otherPtr->children; + otherPtr->children.nodePtr = NULL; + otherPtr->children.linePtr = NULL; + } + if (nodePtr->level == 0) { + register TkTextLine *linePtr; + + for (linePtr = nodePtr->children.linePtr, i = 1; + linePtr->nextPtr != NULL; + linePtr = linePtr->nextPtr, i++) { + if (i == firstChildren) { + halfwayLinePtr = linePtr; + } + } + linePtr->nextPtr = otherPtr->children.linePtr; + while (i <= firstChildren) { + halfwayLinePtr = linePtr; + linePtr = linePtr->nextPtr; + i++; + } + } else { + register Node *childPtr; + + for (childPtr = nodePtr->children.nodePtr, i = 1; + childPtr->nextPtr != NULL; + childPtr = childPtr->nextPtr, i++) { + if (i <= firstChildren) { + if (i == firstChildren) { + halfwayNodePtr = childPtr; + } + } + } + childPtr->nextPtr = otherPtr->children.nodePtr; + while (i <= firstChildren) { + halfwayNodePtr = childPtr; + childPtr = childPtr->nextPtr; + i++; + } + } + + /* + * If the two siblings can simply be merged together, do it. + */ + + if (totalChildren <= MAX_CHILDREN) { + RecomputeNodeCounts(nodePtr); + nodePtr->nextPtr = otherPtr->nextPtr; + nodePtr->parentPtr->numChildren--; + DeleteSummaries(otherPtr->summaryPtr); + ckfree((char *) otherPtr); + continue; + } + + /* + * The siblings can't be merged, so just divide their + * children evenly between them. + */ + + if (nodePtr->level == 0) { + otherPtr->children.linePtr = halfwayLinePtr->nextPtr; + halfwayLinePtr->nextPtr = NULL; + } else { + otherPtr->children.nodePtr = halfwayNodePtr->nextPtr; + halfwayNodePtr->nextPtr = NULL; + } + RecomputeNodeCounts(nodePtr); + RecomputeNodeCounts(otherPtr); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * RecomputeNodeCounts -- + * + * This procedure is called to recompute all the counts in a node + * (tags, child information, etc.) by scanning the information in + * its descendants. This procedure is called during rebalancing + * when a node's child structure has changed. + * + * Results: + * None. + * + * Side effects: + * The tag counts for nodePtr are modified to reflect its current + * child structure, as are its numChildren and numLines fields. + * Also, all of the childrens' parentPtr fields are made to point + * to nodePtr. + * + *---------------------------------------------------------------------- + */ + +static void +RecomputeNodeCounts(nodePtr) + register Node *nodePtr; /* Node whose tag summary information + * must be recomputed. */ +{ + register Summary *summaryPtr, *summaryPtr2; + register Node *childPtr; + register TkTextLine *linePtr; + register TkTextSegment *segPtr; + TkTextTag *tagPtr; + + /* + * Zero out all the existing counts for the node, but don't delete + * the existing Summary records (most of them will probably be reused). + */ + + for (summaryPtr = nodePtr->summaryPtr; summaryPtr != NULL; + summaryPtr = summaryPtr->nextPtr) { + summaryPtr->toggleCount = 0; + } + nodePtr->numChildren = 0; + nodePtr->numLines = 0; + + /* + * Scan through the children, adding the childrens' tag counts into + * the node's tag counts and adding new Summary structures if + * necessary. + */ + + if (nodePtr->level == 0) { + for (linePtr = nodePtr->children.linePtr; linePtr != NULL; + linePtr = linePtr->nextPtr) { + nodePtr->numChildren++; + nodePtr->numLines++; + linePtr->parentPtr = nodePtr; + for (segPtr = linePtr->segPtr; segPtr != NULL; + segPtr = segPtr->nextPtr) { + if (((segPtr->typePtr != &tkTextToggleOnType) + && (segPtr->typePtr != &tkTextToggleOffType)) + || !(segPtr->body.toggle.inNodeCounts)) { + continue; + } + tagPtr = segPtr->body.toggle.tagPtr; + for (summaryPtr = nodePtr->summaryPtr; ; + summaryPtr = summaryPtr->nextPtr) { + if (summaryPtr == NULL) { + summaryPtr = (Summary *) ckalloc(sizeof(Summary)); + summaryPtr->tagPtr = tagPtr; + summaryPtr->toggleCount = 1; + summaryPtr->nextPtr = nodePtr->summaryPtr; + nodePtr->summaryPtr = summaryPtr; + break; + } + if (summaryPtr->tagPtr == tagPtr) { + summaryPtr->toggleCount++; + break; + } + } + } + } + } else { + for (childPtr = nodePtr->children.nodePtr; childPtr != NULL; + childPtr = childPtr->nextPtr) { + nodePtr->numChildren++; + nodePtr->numLines += childPtr->numLines; + childPtr->parentPtr = nodePtr; + for (summaryPtr2 = childPtr->summaryPtr; summaryPtr2 != NULL; + summaryPtr2 = summaryPtr2->nextPtr) { + for (summaryPtr = nodePtr->summaryPtr; ; + summaryPtr = summaryPtr->nextPtr) { + if (summaryPtr == NULL) { + summaryPtr = (Summary *) ckalloc(sizeof(Summary)); + summaryPtr->tagPtr = summaryPtr2->tagPtr; + summaryPtr->toggleCount = summaryPtr2->toggleCount; + summaryPtr->nextPtr = nodePtr->summaryPtr; + nodePtr->summaryPtr = summaryPtr; + break; + } + if (summaryPtr->tagPtr == summaryPtr2->tagPtr) { + summaryPtr->toggleCount += summaryPtr2->toggleCount; + break; + } + } + } + } + } + + /* + * Scan through the node's tag records again and delete any Summary + * records that still have a zero count, or that have all the toggles. + * The node with the children that account for all the tags toggles + * have no summary information, and they become the tagRootPtr for the tag. + */ + + summaryPtr2 = NULL; + for (summaryPtr = nodePtr->summaryPtr; summaryPtr != NULL; ) { + if (summaryPtr->toggleCount > 0 && + summaryPtr->toggleCount < summaryPtr->tagPtr->toggleCount) { + if (nodePtr->level == summaryPtr->tagPtr->tagRootPtr->level) { + /* + * The tag's root node split and some toggles left. + * The tag root must move up a level. + */ + summaryPtr->tagPtr->tagRootPtr = nodePtr->parentPtr; + } + summaryPtr2 = summaryPtr; + summaryPtr = summaryPtr->nextPtr; + continue; + } + if (summaryPtr->toggleCount == summaryPtr->tagPtr->toggleCount) { + /* + * A node merge has collected all the toggles under one node. + * Push the root down to this level. + */ + summaryPtr->tagPtr->tagRootPtr = nodePtr; + } + if (summaryPtr2 != NULL) { + summaryPtr2->nextPtr = summaryPtr->nextPtr; + ckfree((char *) summaryPtr); + summaryPtr = summaryPtr2->nextPtr; + } else { + nodePtr->summaryPtr = summaryPtr->nextPtr; + ckfree((char *) summaryPtr); + summaryPtr = nodePtr->summaryPtr; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreeNumLines -- + * + * This procedure returns a count of the number of lines of + * text present in a given B-tree. + * + * Results: + * The return value is a count of the number of usable lines + * in tree (i.e. it doesn't include the dummy line that is just + * used to mark the end of the tree). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TkBTreeNumLines(tree) + TkTextBTree tree; /* Information about tree. */ +{ + BTree *treePtr = (BTree *) tree; + return treePtr->rootPtr->numLines - 1; +} + +/* + *-------------------------------------------------------------- + * + * CharSplitProc -- + * + * This procedure implements splitting for character segments. + * + * Results: + * The return value is a pointer to a chain of two segments + * that have the same characters as segPtr except split + * among the two segments. + * + * Side effects: + * Storage for segPtr is freed. + * + *-------------------------------------------------------------- + */ + +static TkTextSegment * +CharSplitProc(segPtr, index) + TkTextSegment *segPtr; /* Pointer to segment to split. */ + int index; /* Position within segment at which + * to split. */ +{ + TkTextSegment *newPtr1, *newPtr2; + + newPtr1 = (TkTextSegment *) ckalloc(CSEG_SIZE(index)); + newPtr2 = (TkTextSegment *) ckalloc( + CSEG_SIZE(segPtr->size - index)); + newPtr1->typePtr = &tkTextCharType; + newPtr1->nextPtr = newPtr2; + newPtr1->size = index; + strncpy(newPtr1->body.chars, segPtr->body.chars, (size_t) index); + newPtr1->body.chars[index] = 0; + newPtr2->typePtr = &tkTextCharType; + newPtr2->nextPtr = segPtr->nextPtr; + newPtr2->size = segPtr->size - index; + strcpy(newPtr2->body.chars, segPtr->body.chars + index); + ckfree((char*) segPtr); + return newPtr1; +} + +/* + *-------------------------------------------------------------- + * + * CharCleanupProc -- + * + * This procedure merges adjacent character segments into + * a single character segment, if possible. + * + * Results: + * The return value is a pointer to the first segment in + * the (new) list of segments that used to start with segPtr. + * + * Side effects: + * Storage for the segments may be allocated and freed. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static TkTextSegment * +CharCleanupProc(segPtr, linePtr) + TkTextSegment *segPtr; /* Pointer to first of two adjacent + * segments to join. */ + TkTextLine *linePtr; /* Line containing segments (not + * used). */ +{ + TkTextSegment *segPtr2, *newPtr; + + segPtr2 = segPtr->nextPtr; + if ((segPtr2 == NULL) || (segPtr2->typePtr != &tkTextCharType)) { + return segPtr; + } + newPtr = (TkTextSegment *) ckalloc(CSEG_SIZE( + segPtr->size + segPtr2->size)); + newPtr->typePtr = &tkTextCharType; + newPtr->nextPtr = segPtr2->nextPtr; + newPtr->size = segPtr->size + segPtr2->size; + strcpy(newPtr->body.chars, segPtr->body.chars); + strcpy(newPtr->body.chars + segPtr->size, segPtr2->body.chars); + ckfree((char*) segPtr); + ckfree((char*) segPtr2); + return newPtr; +} + +/* + *-------------------------------------------------------------- + * + * CharDeleteProc -- + * + * This procedure is invoked to delete a character segment. + * + * Results: + * Always returns 0 to indicate that the segment was deleted. + * + * Side effects: + * Storage for the segment is freed. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +CharDeleteProc(segPtr, linePtr, treeGone) + TkTextSegment *segPtr; /* Segment to delete. */ + TkTextLine *linePtr; /* Line containing segment. */ + int treeGone; /* Non-zero means the entire tree is + * being deleted, so everything must + * get cleaned up. */ +{ + ckfree((char*) segPtr); + return 0; +} + +/* + *-------------------------------------------------------------- + * + * CharCheckProc -- + * + * This procedure is invoked to perform consistency checks + * on character segments. + * + * Results: + * None. + * + * Side effects: + * If the segment isn't inconsistent then the procedure + * panics. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +CharCheckProc(segPtr, linePtr) + TkTextSegment *segPtr; /* Segment to check. */ + TkTextLine *linePtr; /* Line containing segment. */ +{ + /* + * Make sure that the segment contains the number of + * characters indicated by its header, and that the last + * segment in a line ends in a newline. Also make sure + * that there aren't ever two character segments adjacent + * to each other: they should be merged together. + */ + + if (segPtr->size <= 0) { + panic("CharCheckProc: segment has size <= 0"); + } + if (strlen(segPtr->body.chars) != segPtr->size) { + panic("CharCheckProc: segment has wrong size"); + } + if (segPtr->nextPtr == NULL) { + if (segPtr->body.chars[segPtr->size-1] != '\n') { + panic("CharCheckProc: line doesn't end with newline"); + } + } else { + if (segPtr->nextPtr->typePtr == &tkTextCharType) { + panic("CharCheckProc: adjacent character segments weren't merged"); + } + } +} + +/* + *-------------------------------------------------------------- + * + * ToggleDeleteProc -- + * + * This procedure is invoked to delete toggle segments. + * + * Results: + * Returns 1 to indicate that the segment may not be deleted, + * unless the entire B-tree is going away. + * + * Side effects: + * If the tree is going away then the toggle's memory is + * freed; otherwise the toggle counts in nodes above the + * segment get updated. + * + *-------------------------------------------------------------- + */ + +static int +ToggleDeleteProc(segPtr, linePtr, treeGone) + TkTextSegment *segPtr; /* Segment to check. */ + TkTextLine *linePtr; /* Line containing segment. */ + int treeGone; /* Non-zero means the entire tree is + * being deleted, so everything must + * get cleaned up. */ +{ + if (treeGone) { + ckfree((char *) segPtr); + return 0; + } + + /* + * This toggle is in the middle of a range of characters that's + * being deleted. Refuse to die. We'll be moved to the end of + * the deleted range and our cleanup procedure will be called + * later. Decrement node toggle counts here, and set a flag + * so we'll re-increment them in the cleanup procedure. + */ + + if (segPtr->body.toggle.inNodeCounts) { + ChangeNodeToggleCount(linePtr->parentPtr, + segPtr->body.toggle.tagPtr, -1); + segPtr->body.toggle.inNodeCounts = 0; + } + return 1; +} + +/* + *-------------------------------------------------------------- + * + * ToggleCleanupProc -- + * + * This procedure is called when a toggle is part of a line that's + * been modified in some way. It's invoked after the + * modifications are complete. + * + * Results: + * The return value is the head segment in a new list + * that is to replace the tail of the line that used to + * start at segPtr. This allows the procedure to delete + * or modify segPtr. + * + * Side effects: + * Toggle counts in the nodes above the new line will be + * updated if they're not already. Toggles may be collapsed + * if there are duplicate toggles at the same position. + * + *-------------------------------------------------------------- + */ + +static TkTextSegment * +ToggleCleanupProc(segPtr, linePtr) + TkTextSegment *segPtr; /* Segment to check. */ + TkTextLine *linePtr; /* Line that now contains segment. */ +{ + TkTextSegment *segPtr2, *prevPtr; + int counts; + + /* + * If this is a toggle-off segment, look ahead through the next + * segments to see if there's a toggle-on segment for the same tag + * before any segments with non-zero size. If so then the two + * toggles cancel each other; remove them both. + */ + + if (segPtr->typePtr == &tkTextToggleOffType) { + for (prevPtr = segPtr, segPtr2 = prevPtr->nextPtr; + (segPtr2 != NULL) && (segPtr2->size == 0); + prevPtr = segPtr2, segPtr2 = prevPtr->nextPtr) { + if (segPtr2->typePtr != &tkTextToggleOnType) { + continue; + } + if (segPtr2->body.toggle.tagPtr != segPtr->body.toggle.tagPtr) { + continue; + } + counts = segPtr->body.toggle.inNodeCounts + + segPtr2->body.toggle.inNodeCounts; + if (counts != 0) { + ChangeNodeToggleCount(linePtr->parentPtr, + segPtr->body.toggle.tagPtr, -counts); + } + prevPtr->nextPtr = segPtr2->nextPtr; + ckfree((char *) segPtr2); + segPtr2 = segPtr->nextPtr; + ckfree((char *) segPtr); + return segPtr2; + } + } + + if (!segPtr->body.toggle.inNodeCounts) { + ChangeNodeToggleCount(linePtr->parentPtr, + segPtr->body.toggle.tagPtr, 1); + segPtr->body.toggle.inNodeCounts = 1; + } + return segPtr; +} + +/* + *-------------------------------------------------------------- + * + * ToggleLineChangeProc -- + * + * This procedure is invoked when a toggle segment is about + * to move from one line to another. + * + * Results: + * None. + * + * Side effects: + * Toggle counts are decremented in the nodes above the line. + * + *-------------------------------------------------------------- + */ + +static void +ToggleLineChangeProc(segPtr, linePtr) + TkTextSegment *segPtr; /* Segment to check. */ + TkTextLine *linePtr; /* Line that used to contain segment. */ +{ + if (segPtr->body.toggle.inNodeCounts) { + ChangeNodeToggleCount(linePtr->parentPtr, + segPtr->body.toggle.tagPtr, -1); + segPtr->body.toggle.inNodeCounts = 0; + } +} + +/* + *-------------------------------------------------------------- + * + * ToggleCheckProc -- + * + * This procedure is invoked to perform consistency checks + * on toggle segments. + * + * Results: + * None. + * + * Side effects: + * If a consistency problem is found the procedure panics. + * + *-------------------------------------------------------------- + */ + +static void +ToggleCheckProc(segPtr, linePtr) + TkTextSegment *segPtr; /* Segment to check. */ + TkTextLine *linePtr; /* Line containing segment. */ +{ + register Summary *summaryPtr; + int needSummary; + + if (segPtr->size != 0) { + panic("ToggleCheckProc: segment had non-zero size"); + } + if (!segPtr->body.toggle.inNodeCounts) { + panic("ToggleCheckProc: toggle counts not updated in nodes"); + } + needSummary = (segPtr->body.toggle.tagPtr->tagRootPtr != linePtr->parentPtr); + for (summaryPtr = linePtr->parentPtr->summaryPtr; ; + summaryPtr = summaryPtr->nextPtr) { + if (summaryPtr == NULL) { + if (needSummary) { + panic("ToggleCheckProc: tag not present in node"); + } else { + break; + } + } + if (summaryPtr->tagPtr == segPtr->body.toggle.tagPtr) { + if (!needSummary) { + panic("ToggleCheckProc: tag present in root node summary"); + } + break; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreeCharsInLine -- + * + * This procedure returns a count of the number of characters + * in a given line. + * + * Results: + * The return value is the character count for linePtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TkBTreeCharsInLine(linePtr) + TkTextLine *linePtr; /* Line whose characters should be + * counted. */ +{ + TkTextSegment *segPtr; + int count; + + count = 0; + for (segPtr = linePtr->segPtr; segPtr != NULL; segPtr = segPtr->nextPtr) { + count += segPtr->size; + } + return count; +} diff --git a/tk4.2/generic/tkTextDisp.c b/tk4.2/generic/tkTextDisp.c new file mode 100644 index 0000000..abf8490 --- /dev/null +++ b/tk4.2/generic/tkTextDisp.c @@ -0,0 +1,4833 @@ +/* + * tkTextDisp.c -- + * + * This module provides facilities to display text widgets. It is + * the only place where information is kept about the screen layout + * of text widgets. + * + * Copyright (c) 1992-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkTextDisp.c 1.114 96/09/05 09:59:43 + */ + +#include "tkPort.h" +#include "tkInt.h" +#include "tkText.h" + +/* + * The following structure describes how to display a range of characters. + * The information is generated by scanning all of the tags associated + * with the characters and combining that with default information for + * the overall widget. These structures form the hash keys for + * dInfoPtr->styleTable. + */ + +typedef struct StyleValues { + Tk_3DBorder border; /* Used for drawing background under text. + * NULL means use widget background. */ + int borderWidth; /* Width of 3-D border for background. */ + int relief; /* 3-D relief for background. */ + Pixmap bgStipple; /* Stipple bitmap for background. None + * means draw solid. */ + XColor *fgColor; /* Foreground color for text. */ + XFontStruct *fontPtr; /* Font for displaying text. */ + Pixmap fgStipple; /* Stipple bitmap for text and other + * foreground stuff. None means draw + * solid.*/ + int justify; /* Justification style for text. */ + int lMargin1; /* Left margin, in pixels, for first display + * line of each text line. */ + int lMargin2; /* Left margin, in pixels, for second and + * later display lines of each text line. */ + int offset; /* Offset in pixels of baseline, relative to + * baseline of line. */ + int overstrike; /* Non-zero means draw overstrike through + * text. */ + int rMargin; /* Right margin, in pixels. */ + int spacing1; /* Spacing above first dline in text line. */ + int spacing2; /* Spacing between lines of dline. */ + int spacing3; /* Spacing below last dline in text line. */ + TkTextTabArray *tabArrayPtr;/* Locations and types of tab stops (may + * be NULL). */ + int underline; /* Non-zero means draw underline underneath + * text. */ + Tk_Uid wrapMode; /* How to handle wrap-around for this tag. + * One of tkTextCharUid, tkTextNoneUid, + * or tkTextWordUid. */ +} StyleValues; + +/* + * The following structure extends the StyleValues structure above with + * graphics contexts used to actually draw the characters. The entries + * in dInfoPtr->styleTable point to structures of this type. + */ + +typedef struct TextStyle { + int refCount; /* Number of times this structure is + * referenced in Chunks. */ + GC bgGC; /* Graphics context for background. None + * means use widget background. */ + GC fgGC; /* Graphics context for foreground. */ + StyleValues *sValuePtr; /* Raw information from which GCs were + * derived. */ + Tcl_HashEntry *hPtr; /* Pointer to entry in styleTable. Used + * to delete entry. */ +} TextStyle; + +/* + * The following macro determines whether two styles have the same + * background so that, for example, no beveled border should be drawn + * between them. + */ + +#define SAME_BACKGROUND(s1, s2) \ + (((s1)->sValuePtr->border == (s2)->sValuePtr->border) \ + && ((s1)->sValuePtr->borderWidth == (s2)->sValuePtr->borderWidth) \ + && ((s1)->sValuePtr->relief == (s2)->sValuePtr->relief) \ + && ((s1)->sValuePtr->bgStipple == (s2)->sValuePtr->bgStipple)) + +/* + * The following structure describes one line of the display, which may + * be either part or all of one line of the text. + */ + +typedef struct DLine { + TkTextIndex index; /* Identifies first character in text + * that is displayed on this line. */ + int count; /* Number of characters accounted for by this + * display line, including a trailing space + * or newline that isn't actually displayed. */ + int y; /* Y-position at which line is supposed to + * be drawn (topmost pixel of rectangular + * area occupied by line). */ + int oldY; /* Y-position at which line currently + * appears on display. -1 means line isn't + * currently visible on display and must be + * redrawn. This is used to move lines by + * scrolling rather than re-drawing. */ + int height; /* Height of line, in pixels. */ + int baseline; /* Offset of text baseline from y, in + * pixels. */ + int spaceAbove; /* How much extra space was added to the + * top of the line because of spacing + * options. This is included in height + * and baseline. */ + int spaceBelow; /* How much extra space was added to the + * bottom of the line because of spacing + * options. This is included in height. */ + int length; /* Total length of line, in pixels. */ + TkTextDispChunk *chunkPtr; /* Pointer to first chunk in list of all + * of those that are displayed on this + * line of the screen. */ + struct DLine *nextPtr; /* Next in list of all display lines for + * this window. The list is sorted in + * order from top to bottom. Note: the + * next DLine doesn't always correspond + * to the next line of text: (a) can have + * multiple DLines for one text line, and + * (b) can have gaps where DLine's have been + * deleted because they're out of date. */ + int flags; /* Various flag bits: see below for values. */ +} DLine; + +/* + * Flag bits for DLine structures: + * + * HAS_3D_BORDER - Non-zero means that at least one of the + * chunks in this line has a 3D border, so + * it potentially interacts with 3D borders + * in neighboring lines (see + * DisplayLineBackground). + * NEW_LAYOUT - Non-zero means that the line has been + * re-layed out since the last time the + * display was updated. + * TOP_LINE - Non-zero means that this was the top line + * in the window the last time that the window + * was laid out. This is important because + * a line may be displayed differently if its + * at the top or bottom than if it's in the + * middle (e.g. beveled edges aren't displayed + * for middle lines if the adjacent line has + * a similar background). + * BOTTOM_LINE - Non-zero means that this was the bottom line + * in the window the last time that the window + * was laid out. + */ + +#define HAS_3D_BORDER 1 +#define NEW_LAYOUT 2 +#define TOP_LINE 4 +#define BOTTOM_LINE 8 + +/* + * Overall display information for a text widget: + */ + +typedef struct TextDInfo { + Tcl_HashTable styleTable; /* Hash table that maps from StyleValues + * to TextStyles for this widget. */ + DLine *dLinePtr; /* First in list of all display lines for + * this widget, in order from top to bottom. */ + GC copyGC; /* Graphics context for copying from off- + * screen pixmaps onto screen. */ + GC scrollGC; /* Graphics context for copying from one place + * in the window to another (scrolling): + * differs from copyGC in that we need to get + * GraphicsExpose events. */ + int x; /* First x-coordinate that may be used for + * actually displaying line information. + * Leaves space for border, etc. */ + int y; /* First y-coordinate that may be used for + * actually displaying line information. + * Leaves space for border, etc. */ + int maxX; /* First x-coordinate to right of available + * space for displaying lines. */ + int maxY; /* First y-coordinate below available + * space for displaying lines. */ + int topOfEof; /* Top-most pixel (lowest y-value) that has + * been drawn in the appropriate fashion for + * the portion of the window after the last + * line of the text. This field is used to + * figure out when to redraw part or all of + * the eof field. */ + + /* + * Information used for scrolling: + */ + + int newCharOffset; /* Desired x scroll position, measured as the + * number of average-size characters off-screen + * to the left for a line with no left + * margin. */ + int curPixelOffset; /* Actual x scroll position, measured as the + * number of pixels off-screen to the left. */ + int maxLength; /* Length in pixels of longest line that's + * visible in window (length may exceed window + * size). If there's no wrapping, this will + * be zero. */ + double xScrollFirst, xScrollLast; + /* Most recent values reported to horizontal + * scrollbar; used to eliminate unnecessary + * reports. */ + double yScrollFirst, yScrollLast; + /* Most recent values reported to vertical + * scrollbar; used to eliminate unnecessary + * reports. */ + + /* + * The following information is used to implement scanning: + */ + + int scanMarkChar; /* Character that was at the left edge of + * the window when the scan started. */ + int scanMarkX; /* X-position of mouse at time scan started. */ + int scanTotalScroll; /* Total scrolling (in screen lines) that has + * occurred since scanMarkY was set. */ + int scanMarkY; /* Y-position of mouse at time scan started. */ + + /* + * Miscellaneous information: + */ + + int dLinesInvalidated; /* This value is set to 1 whenever something + * happens that invalidates information in + * DLine structures; if a redisplay + * is in progress, it will see this and + * abort the redisplay. This is needed + * because, for example, an embedded window + * could change its size when it is first + * displayed, invalidating the DLine that + * is currently being displayed. If redisplay + * continues, it will use freed memory and + * could dump core. */ + int flags; /* Various flag values: see below for + * definitions. */ +} TextDInfo; + +/* + * In TkTextDispChunk structures for character segments, the clientData + * field points to one of the following structures: + */ + +typedef struct CharInfo { + int numChars; /* Number of characters to display. */ + char chars[4]; /* Characters to display. Actual size + * will be numChars, not 4. THIS MUST BE + * THE LAST FIELD IN THE STRUCTURE. */ +} CharInfo; + +/* + * Flag values for TextDInfo structures: + * + * DINFO_OUT_OF_DATE: Non-zero means that the DLine structures + * for this window are partially or completely + * out of date and need to be recomputed. + * REDRAW_PENDING: Means that a when-idle handler has been + * scheduled to update the display. + * REDRAW_BORDERS: Means window border or pad area has + * potentially been damaged and must be redrawn. + * REPICK_NEEDED: 1 means that the widget has been modified + * in a way that could change the current + * character (a different character might be + * under the mouse cursor now). Need to + * recompute the current character before + * the next redisplay. + */ + +#define DINFO_OUT_OF_DATE 1 +#define REDRAW_PENDING 2 +#define REDRAW_BORDERS 4 +#define REPICK_NEEDED 8 + +/* + * The following counters keep statistics about redisplay that can be + * checked to see how clever this code is at reducing redisplays. + */ + +static int numRedisplays; /* Number of calls to DisplayText. */ +static int linesRedrawn; /* Number of calls to DisplayDLine. */ +static int numCopies; /* Number of calls to XCopyArea to copy part + * of the screen. */ + +/* + * Forward declarations for procedures defined later in this file: + */ + +static void AdjustForTab _ANSI_ARGS_((TkText *textPtr, + TkTextTabArray *tabArrayPtr, int index, + TkTextDispChunk *chunkPtr)); +static void CharBboxProc _ANSI_ARGS_((TkTextDispChunk *chunkPtr, + int index, int y, int lineHeight, int baseline, + int *xPtr, int *yPtr, int *widthPtr, + int *heightPtr)); +static void CharDisplayProc _ANSI_ARGS_((TkTextDispChunk *chunkPtr, + int x, int y, int height, int baseline, + Display *display, Drawable dst, int screenY)); +static int CharMeasureProc _ANSI_ARGS_((TkTextDispChunk *chunkPtr, + int x)); +static void CharUndisplayProc _ANSI_ARGS_((TkText *textPtr, + TkTextDispChunk *chunkPtr)); +static void DisplayDLine _ANSI_ARGS_((TkText *textPtr, + DLine *dlPtr, DLine *prevPtr, Pixmap pixmap)); +static void DisplayLineBackground _ANSI_ARGS_((TkText *textPtr, + DLine *dlPtr, DLine *prevPtr, Pixmap pixmap)); +static void DisplayText _ANSI_ARGS_((ClientData clientData)); +static DLine * FindDLine _ANSI_ARGS_((DLine *dlPtr, + TkTextIndex *indexPtr)); +static void FreeDLines _ANSI_ARGS_((TkText *textPtr, + DLine *firstPtr, DLine *lastPtr, int unlink)); +static void FreeStyle _ANSI_ARGS_((TkText *textPtr, + TextStyle *stylePtr)); +static TextStyle * GetStyle _ANSI_ARGS_((TkText *textPtr, + TkTextIndex *indexPtr)); +static void GetXView _ANSI_ARGS_((Tcl_Interp *interp, + TkText *textPtr, int report)); +static void GetYView _ANSI_ARGS_((Tcl_Interp *interp, + TkText *textPtr, int report)); +static DLine * LayoutDLine _ANSI_ARGS_((TkText *textPtr, + TkTextIndex *indexPtr)); +static void MeasureUp _ANSI_ARGS_((TkText *textPtr, + TkTextIndex *srcPtr, int distance, + TkTextIndex *dstPtr)); +static void UpdateDisplayInfo _ANSI_ARGS_((TkText *textPtr)); +static void ScrollByLines _ANSI_ARGS_((TkText *textPtr, + int offset)); +static int SizeOfTab _ANSI_ARGS_((TkText *textPtr, + TkTextTabArray *tabArrayPtr, int index, int x, + int maxX)); +static void TextInvalidateRegion _ANSI_ARGS_((TkText *textPtr, + TkRegion region)); + + +/* + *---------------------------------------------------------------------- + * + * TkTextCreateDInfo -- + * + * This procedure is called when a new text widget is created. + * Its job is to set up display-related information for the widget. + * + * Results: + * None. + * + * Side effects: + * A TextDInfo data structure is allocated and initialized and attached + * to textPtr. + * + *---------------------------------------------------------------------- + */ + +void +TkTextCreateDInfo(textPtr) + TkText *textPtr; /* Overall information for text widget. */ +{ + register TextDInfo *dInfoPtr; + XGCValues gcValues; + + dInfoPtr = (TextDInfo *) ckalloc(sizeof(TextDInfo)); + Tcl_InitHashTable(&dInfoPtr->styleTable, sizeof(StyleValues)/sizeof(int)); + dInfoPtr->dLinePtr = NULL; + dInfoPtr->copyGC = None; + gcValues.graphics_exposures = True; + dInfoPtr->scrollGC = Tk_GetGC(textPtr->tkwin, GCGraphicsExposures, + &gcValues); + dInfoPtr->topOfEof = 0; + dInfoPtr->newCharOffset = 0; + dInfoPtr->curPixelOffset = 0; + dInfoPtr->maxLength = 0; + dInfoPtr->xScrollFirst = -1; + dInfoPtr->xScrollLast = -1; + dInfoPtr->yScrollFirst = -1; + dInfoPtr->yScrollLast = -1; + dInfoPtr->scanMarkChar = 0; + dInfoPtr->scanMarkX = 0; + dInfoPtr->scanTotalScroll = 0; + dInfoPtr->scanMarkY = 0; + dInfoPtr->dLinesInvalidated = 0; + dInfoPtr->flags = DINFO_OUT_OF_DATE; + textPtr->dInfoPtr = dInfoPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TkTextFreeDInfo -- + * + * This procedure is called to free up all of the private display + * information kept by this file for a text widget. + * + * Results: + * None. + * + * Side effects: + * Lots of resources get freed. + * + *---------------------------------------------------------------------- + */ + +void +TkTextFreeDInfo(textPtr) + TkText *textPtr; /* Overall information for text widget. */ +{ + register TextDInfo *dInfoPtr = textPtr->dInfoPtr; + + /* + * Be careful to free up styleTable *after* freeing up all the + * DLines, so that the hash table is still intact to free up the + * style-related information from the lines. Once the lines are + * all free then styleTable will be empty. + */ + + FreeDLines(textPtr, dInfoPtr->dLinePtr, (DLine *) NULL, 1); + Tcl_DeleteHashTable(&dInfoPtr->styleTable); + if (dInfoPtr->copyGC != None) { + Tk_FreeGC(textPtr->display, dInfoPtr->copyGC); + } + Tk_FreeGC(textPtr->display, dInfoPtr->scrollGC); + if (dInfoPtr->flags & REDRAW_PENDING) { + Tcl_CancelIdleCall(DisplayText, (ClientData) textPtr); + } + ckfree((char *) dInfoPtr); +} + +/* + *---------------------------------------------------------------------- + * + * GetStyle -- + * + * This procedure creates all the information needed to display + * text at a particular location. + * + * Results: + * The return value is a pointer to a TextStyle structure that + * corresponds to *sValuePtr. + * + * Side effects: + * A new entry may be created in the style table for the widget. + * + *---------------------------------------------------------------------- + */ + +static TextStyle * +GetStyle(textPtr, indexPtr) + TkText *textPtr; /* Overall information about text widget. */ + TkTextIndex *indexPtr; /* The character in the text for which + * display information is wanted. */ +{ + TkTextTag **tagPtrs; + register TkTextTag *tagPtr; + StyleValues styleValues; + TextStyle *stylePtr; + Tcl_HashEntry *hPtr; + int numTags, new, i; + XGCValues gcValues; + unsigned long mask; + + /* + * The variables below keep track of the highest-priority specification + * that has occurred for each of the various fields of the StyleValues. + */ + + int borderPrio, borderWidthPrio, reliefPrio, bgStipplePrio; + int fgPrio, fontPrio, fgStipplePrio; + int underlinePrio, justifyPrio, offsetPrio; + int lMargin1Prio, lMargin2Prio, rMarginPrio; + int spacing1Prio, spacing2Prio, spacing3Prio; + int overstrikePrio, tabPrio, wrapPrio; + + /* + * Find out what tags are present for the character, then compute + * a StyleValues structure corresponding to those tags (scan + * through all of the tags, saving information for the highest- + * priority tag). + */ + + tagPtrs = TkBTreeGetTags(indexPtr, &numTags); + borderPrio = borderWidthPrio = reliefPrio = bgStipplePrio = -1; + fgPrio = fontPrio = fgStipplePrio = -1; + underlinePrio = justifyPrio = offsetPrio = -1; + lMargin1Prio = lMargin2Prio = rMarginPrio = -1; + spacing1Prio = spacing2Prio = spacing3Prio = -1; + overstrikePrio = tabPrio = wrapPrio = -1; + memset((VOID *) &styleValues, 0, sizeof(StyleValues)); + styleValues.relief = TK_RELIEF_FLAT; + styleValues.fgColor = textPtr->fgColor; + styleValues.fontPtr = textPtr->fontPtr; + styleValues.justify = TK_JUSTIFY_LEFT; + styleValues.spacing1 = textPtr->spacing1; + styleValues.spacing2 = textPtr->spacing2; + styleValues.spacing3 = textPtr->spacing3; + styleValues.tabArrayPtr = textPtr->tabArrayPtr; + styleValues.wrapMode = textPtr->wrapMode; + for (i = 0 ; i < numTags; i++) { + tagPtr = tagPtrs[i]; + if ((tagPtr->border != NULL) && (tagPtr->priority > borderPrio)) { + styleValues.border = tagPtr->border; + borderPrio = tagPtr->priority; + } + if ((tagPtr->bdString != NULL) + && (tagPtr->priority > borderWidthPrio)) { + styleValues.borderWidth = tagPtr->borderWidth; + borderWidthPrio = tagPtr->priority; + } + if ((tagPtr->reliefString != NULL) + && (tagPtr->priority > reliefPrio)) { + if (styleValues.border == NULL) { + styleValues.border = textPtr->border; + } + styleValues.relief = tagPtr->relief; + reliefPrio = tagPtr->priority; + } + if ((tagPtr->bgStipple != None) + && (tagPtr->priority > bgStipplePrio)) { + styleValues.bgStipple = tagPtr->bgStipple; + bgStipplePrio = tagPtr->priority; + } + if ((tagPtr->fgColor != None) && (tagPtr->priority > fgPrio)) { + styleValues.fgColor = tagPtr->fgColor; + fgPrio = tagPtr->priority; + } + if ((tagPtr->fontPtr != None) && (tagPtr->priority > fontPrio)) { + styleValues.fontPtr = tagPtr->fontPtr; + fontPrio = tagPtr->priority; + } + if ((tagPtr->fgStipple != None) + && (tagPtr->priority > fgStipplePrio)) { + styleValues.fgStipple = tagPtr->fgStipple; + fgStipplePrio = tagPtr->priority; + } + if ((tagPtr->justifyString != NULL) + && (tagPtr->priority > justifyPrio)) { + styleValues.justify = tagPtr->justify; + justifyPrio = tagPtr->priority; + } + if ((tagPtr->lMargin1String != NULL) + && (tagPtr->priority > lMargin1Prio)) { + styleValues.lMargin1 = tagPtr->lMargin1; + lMargin1Prio = tagPtr->priority; + } + if ((tagPtr->lMargin2String != NULL) + && (tagPtr->priority > lMargin2Prio)) { + styleValues.lMargin2 = tagPtr->lMargin2; + lMargin2Prio = tagPtr->priority; + } + if ((tagPtr->offsetString != NULL) + && (tagPtr->priority > offsetPrio)) { + styleValues.offset = tagPtr->offset; + offsetPrio = tagPtr->priority; + } + if ((tagPtr->overstrikeString != NULL) + && (tagPtr->priority > overstrikePrio)) { + styleValues.overstrike = tagPtr->overstrike; + overstrikePrio = tagPtr->priority; + } + if ((tagPtr->rMarginString != NULL) + && (tagPtr->priority > rMarginPrio)) { + styleValues.rMargin = tagPtr->rMargin; + rMarginPrio = tagPtr->priority; + } + if ((tagPtr->spacing1String != NULL) + && (tagPtr->priority > spacing1Prio)) { + styleValues.spacing1 = tagPtr->spacing1; + spacing1Prio = tagPtr->priority; + } + if ((tagPtr->spacing2String != NULL) + && (tagPtr->priority > spacing2Prio)) { + styleValues.spacing2 = tagPtr->spacing2; + spacing2Prio = tagPtr->priority; + } + if ((tagPtr->spacing3String != NULL) + && (tagPtr->priority > spacing3Prio)) { + styleValues.spacing3 = tagPtr->spacing3; + spacing3Prio = tagPtr->priority; + } + if ((tagPtr->tabString != NULL) + && (tagPtr->priority > tabPrio)) { + styleValues.tabArrayPtr = tagPtr->tabArrayPtr; + tabPrio = tagPtr->priority; + } + if ((tagPtr->underlineString != NULL) + && (tagPtr->priority > underlinePrio)) { + styleValues.underline = tagPtr->underline; + underlinePrio = tagPtr->priority; + } + if ((tagPtr->wrapMode != NULL) + && (tagPtr->priority > wrapPrio)) { + styleValues.wrapMode = tagPtr->wrapMode; + wrapPrio = tagPtr->priority; + } + } + if (tagPtrs != NULL) { + ckfree((char *) tagPtrs); + } + + /* + * Use an existing style if there's one around that matches. + */ + + hPtr = Tcl_CreateHashEntry(&textPtr->dInfoPtr->styleTable, + (char *) &styleValues, &new); + if (!new) { + stylePtr = (TextStyle *) Tcl_GetHashValue(hPtr); + stylePtr->refCount++; + return stylePtr; + } + + /* + * No existing style matched. Make a new one. + */ + + stylePtr = (TextStyle *) ckalloc(sizeof(TextStyle)); + stylePtr->refCount = 1; + if (styleValues.border != NULL) { + gcValues.foreground = Tk_3DBorderColor(styleValues.border)->pixel; + mask = GCForeground; + if (styleValues.bgStipple != None) { + gcValues.stipple = styleValues.bgStipple; + gcValues.fill_style = FillStippled; + mask |= GCStipple|GCFillStyle; + } + stylePtr->bgGC = Tk_GetGC(textPtr->tkwin, mask, &gcValues); + } else { + stylePtr->bgGC = None; + } + mask = GCForeground|GCFont; + gcValues.foreground = styleValues.fgColor->pixel; + gcValues.font = styleValues.fontPtr->fid; + if (styleValues.fgStipple != None) { + gcValues.stipple = styleValues.fgStipple; + gcValues.fill_style = FillStippled; + mask |= GCStipple|GCFillStyle; + } + stylePtr->fgGC = Tk_GetGC(textPtr->tkwin, mask, &gcValues); + stylePtr->sValuePtr = (StyleValues *) + Tcl_GetHashKey(&textPtr->dInfoPtr->styleTable, hPtr); + stylePtr->hPtr = hPtr; + Tcl_SetHashValue(hPtr, stylePtr); + return stylePtr; +} + +/* + *---------------------------------------------------------------------- + * + * FreeStyle -- + * + * This procedure is called when a TextStyle structure is no longer + * needed. It decrements the reference count and frees up the + * space for the style structure if the reference count is 0. + * + * Results: + * None. + * + * Side effects: + * The storage and other resources associated with the style + * are freed up if no-one's still using it. + * + *---------------------------------------------------------------------- + */ + +static void +FreeStyle(textPtr, stylePtr) + TkText *textPtr; /* Information about overall widget. */ + register TextStyle *stylePtr; /* Information about style to free. */ + +{ + stylePtr->refCount--; + if (stylePtr->refCount == 0) { + if (stylePtr->bgGC != None) { + Tk_FreeGC(textPtr->display, stylePtr->bgGC); + } + Tk_FreeGC(textPtr->display, stylePtr->fgGC); + Tcl_DeleteHashEntry(stylePtr->hPtr); + ckfree((char *) stylePtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * LayoutDLine -- + * + * This procedure generates a single DLine structure for a display + * line whose leftmost character is given by indexPtr. + * + * Results: + * The return value is a pointer to a DLine structure desribing the + * display line. All fields are filled in and correct except for + * y and nextPtr. + * + * Side effects: + * Storage is allocated for the new DLine. + * + *---------------------------------------------------------------------- + */ + +static DLine * +LayoutDLine(textPtr, indexPtr) + TkText *textPtr; /* Overall information about text widget. */ + TkTextIndex *indexPtr; /* Beginning of display line. May not + * necessarily point to a character segment. */ +{ + register DLine *dlPtr; /* New display line. */ + TkTextSegment *segPtr; /* Current segment in text. */ + TkTextDispChunk *lastChunkPtr; /* Last chunk allocated so far + * for line. */ + TkTextDispChunk *chunkPtr; /* Current chunk. */ + TkTextIndex curIndex; + TkTextDispChunk *breakChunkPtr; /* Chunk containing best word break + * point, if any. */ + TkTextIndex breakIndex; /* Index of first character in + * breakChunkPtr. */ + int breakCharOffset; /* Character within breakChunkPtr just + * to right of best break point. */ + int noCharsYet; /* Non-zero means that no characters + * have been placed on the line yet. */ + int justify; /* How to justify line: taken from + * style for first character in line. */ + int jIndent; /* Additional indentation (beyond + * margins) due to justification. */ + int rMargin; /* Right margin width for line. */ + Tk_Uid wrapMode; /* Wrap mode to use for this line. */ + int x = 0, maxX = 0; /* Initializations needed only to + * stop compiler warnings. */ + int wholeLine; /* Non-zero means this display line + * runs to the end of the text line. */ + int tabIndex; /* Index of the current tab stop. */ + int gotTab; /* Non-zero means the current chunk + * contains a tab. */ + TkTextDispChunk *tabChunkPtr; /* Pointer to the chunk containing + * the previous tab stop. */ + int maxChars; /* Maximum number of characters to + * include in this chunk. */ + TkTextTabArray *tabArrayPtr; /* Tab stops for line; taken from + * style for first character on line. */ + int tabSize; /* Number of pixels consumed by current + * tab stop. */ + TkTextDispChunk *lastCharChunkPtr; /* Pointer to last chunk in display + * lines with numChars > 0. Used to + * drop 0-sized chunks from the end + * of the line. */ + int offset, ascent, descent, code; + StyleValues *sValuePtr; + + /* + * Create and initialize a new DLine structure. + */ + + dlPtr = (DLine *) ckalloc(sizeof(DLine)); + dlPtr->index = *indexPtr; + dlPtr->count = 0; + dlPtr->y = 0; + dlPtr->oldY = -1; + dlPtr->height = 0; + dlPtr->baseline = 0; + dlPtr->chunkPtr = NULL; + dlPtr->nextPtr = NULL; + dlPtr->flags = NEW_LAYOUT; + + /* + * Each iteration of the loop below creates one TkTextDispChunk for + * the new display line. The line will always have at least one + * chunk (for the newline character at the end, if there's nothing + * else available). + */ + + curIndex = *indexPtr; + lastChunkPtr = NULL; + chunkPtr = NULL; + noCharsYet = 1; + breakChunkPtr = NULL; + breakCharOffset = 0; + justify = TK_JUSTIFY_LEFT; + tabIndex = -1; + tabChunkPtr = NULL; + tabArrayPtr = NULL; + rMargin = 0; + wrapMode = tkTextCharUid; + tabSize = 0; + lastCharChunkPtr = NULL; + + /* + * Find the first segment to consider for the line. Can't call + * TkTextIndexToSeg for this because it won't return a segment + * with zero size (such as the insertion cursor's mark). + */ + + for (offset = curIndex.charIndex, segPtr = curIndex.linePtr->segPtr; + (offset > 0) && (offset >= segPtr->size); + offset -= segPtr->size, segPtr = segPtr->nextPtr) { + /* Empty loop body. */ + } + + while (segPtr != NULL) { + if (segPtr->typePtr->layoutProc == NULL) { + segPtr = segPtr->nextPtr; + offset = 0; + continue; + } + if (chunkPtr == NULL) { + chunkPtr = (TkTextDispChunk *) ckalloc(sizeof(TkTextDispChunk)); + chunkPtr->nextPtr = NULL; + } + chunkPtr->stylePtr = GetStyle(textPtr, &curIndex); + + /* + * Save style information such as justification and indentation, + * up until the first character is encountered, then retain that + * information for the rest of the line. + */ + + if (noCharsYet) { + tabArrayPtr = chunkPtr->stylePtr->sValuePtr->tabArrayPtr; + justify = chunkPtr->stylePtr->sValuePtr->justify; + rMargin = chunkPtr->stylePtr->sValuePtr->rMargin; + wrapMode = chunkPtr->stylePtr->sValuePtr->wrapMode; + x = ((curIndex.charIndex == 0) + ? chunkPtr->stylePtr->sValuePtr->lMargin1 + : chunkPtr->stylePtr->sValuePtr->lMargin2); + if (wrapMode == tkTextNoneUid) { + maxX = INT_MAX; + } else { + maxX = textPtr->dInfoPtr->maxX - textPtr->dInfoPtr->x + - rMargin; + if (maxX < x) { + maxX = x; + } + } + } + + /* + * See if there is a tab in the current chunk; if so, only + * layout characters up to (and including) the tab. + */ + + gotTab = 0; + maxChars = segPtr->size - offset; + if (justify == TK_JUSTIFY_LEFT) { + if (segPtr->typePtr == &tkTextCharType) { + char *p; + + for (p = segPtr->body.chars + offset; *p != 0; p++) { + if (*p == '\t') { + maxChars = (p + 1 - segPtr->body.chars) - offset; + gotTab = 1; + break; + } + } + } + } + + chunkPtr->x = x; + code = (*segPtr->typePtr->layoutProc)(textPtr, &curIndex, segPtr, + offset, maxX-tabSize, maxChars, noCharsYet, wrapMode, + chunkPtr); + if (code <= 0) { + FreeStyle(textPtr, chunkPtr->stylePtr); + if (code < 0) { + /* + * This segment doesn't wish to display itself (e.g. most + * marks). + */ + + segPtr = segPtr->nextPtr; + offset = 0; + continue; + } + + /* + * No characters from this segment fit in the window: this + * means we're at the end of the display line. + */ + + if (chunkPtr != NULL) { + ckfree((char *) chunkPtr); + } + break; + } + if (chunkPtr->numChars > 0) { + noCharsYet = 0; + lastCharChunkPtr = chunkPtr; + } + if (lastChunkPtr == NULL) { + dlPtr->chunkPtr = chunkPtr; + } else { + lastChunkPtr->nextPtr = chunkPtr; + } + lastChunkPtr = chunkPtr; + x += chunkPtr->width; + if (chunkPtr->breakIndex > 0) { + breakCharOffset = chunkPtr->breakIndex; + breakIndex = curIndex; + breakChunkPtr = chunkPtr; + } + if (chunkPtr->numChars != maxChars) { + break; + } + + /* + * If we're at a new tab, adjust the layout for all the chunks + * pertaining to the previous tab. Also adjust the amount of + * space left in the line to account for space that will be eaten + * up by the tab. + */ + + if (gotTab) { + if (tabIndex >= 0) { + AdjustForTab(textPtr, tabArrayPtr, tabIndex, tabChunkPtr); + x = chunkPtr->x + chunkPtr->width; + } + tabIndex++; + tabChunkPtr = chunkPtr; + tabSize = SizeOfTab(textPtr, tabArrayPtr, tabIndex, x, maxX); + if (tabSize >= (maxX - x)) { + break; + } + } + curIndex.charIndex += chunkPtr->numChars; + offset += chunkPtr->numChars; + if (offset >= segPtr->size) { + offset = 0; + segPtr = segPtr->nextPtr; + } + chunkPtr = NULL; + } + if (noCharsYet) { + panic("LayoutDLine couldn't place any characters on a line"); + } + wholeLine = (segPtr == NULL); + + /* + * We're at the end of the display line. Throw away everything + * after the most recent word break, if there is one; this may + * potentially require the last chunk to be layed out again. + */ + + if (breakChunkPtr == NULL) { + /* + * This code makes sure that we don't accidentally display + * chunks with no characters at the end of the line (such as + * the insertion cursor). These chunks belong on the next + * line. So, throw away everything after the last chunk that + * has characters in it. + */ + + breakChunkPtr = lastCharChunkPtr; + breakCharOffset = breakChunkPtr->numChars; + } + if ((breakChunkPtr != NULL) && ((lastChunkPtr != breakChunkPtr) + || (breakCharOffset != lastChunkPtr->numChars))) { + while (1) { + chunkPtr = breakChunkPtr->nextPtr; + if (chunkPtr == NULL) { + break; + } + FreeStyle(textPtr, chunkPtr->stylePtr); + breakChunkPtr->nextPtr = chunkPtr->nextPtr; + (*chunkPtr->undisplayProc)(textPtr, chunkPtr); + ckfree((char *) chunkPtr); + } + if (breakCharOffset != breakChunkPtr->numChars) { + (*breakChunkPtr->undisplayProc)(textPtr, breakChunkPtr); + segPtr = TkTextIndexToSeg(&breakIndex, &offset); + (*segPtr->typePtr->layoutProc)(textPtr, &breakIndex, + segPtr, offset, maxX, breakCharOffset, 0, + wrapMode, breakChunkPtr); + } + lastChunkPtr = breakChunkPtr; + wholeLine = 0; + } + + /* + * Make tab adjustments for the last tab stop, if there is one. + */ + + if ((tabIndex >= 0) && (tabChunkPtr != NULL)) { + AdjustForTab(textPtr, tabArrayPtr, tabIndex, tabChunkPtr); + } + + /* + * Make one more pass over the line to recompute various things + * like its height, length, and total number of characters. Also + * modify the x-locations of chunks to reflect justification. + * If we're not wrapping, I'm not sure what is the best way to + * handle left and center justification: should the total length, + * for purposes of justification, be (a) the window width, (b) + * the length of the longest line in the window, or (c) the length + * of the longest line in the text? (c) isn't available, (b) seems + * weird, since it can change with vertical scrolling, so (a) is + * what is implemented below. + */ + + if (wrapMode == tkTextNoneUid) { + maxX = textPtr->dInfoPtr->maxX - textPtr->dInfoPtr->x - rMargin; + } + dlPtr->length = lastChunkPtr->x + lastChunkPtr->width; + if (justify == TK_JUSTIFY_LEFT) { + jIndent = 0; + } else if (justify == TK_JUSTIFY_RIGHT) { + jIndent = maxX - dlPtr->length; + } else { + jIndent = (maxX - dlPtr->length)/2; + } + ascent = descent = 0; + for (chunkPtr = dlPtr->chunkPtr; chunkPtr != NULL; + chunkPtr = chunkPtr->nextPtr) { + chunkPtr->x += jIndent; + dlPtr->count += chunkPtr->numChars; + if (chunkPtr->minAscent > ascent) { + ascent = chunkPtr->minAscent; + } + if (chunkPtr->minDescent > descent) { + descent = chunkPtr->minDescent; + } + if (chunkPtr->minHeight > dlPtr->height) { + dlPtr->height = chunkPtr->minHeight; + } + sValuePtr = chunkPtr->stylePtr->sValuePtr; + if ((sValuePtr->borderWidth > 0) + && (sValuePtr->relief != TK_RELIEF_FLAT)) { + dlPtr->flags |= HAS_3D_BORDER; + } + } + if (dlPtr->height < (ascent + descent)) { + dlPtr->height = ascent + descent; + dlPtr->baseline = ascent; + } else { + dlPtr->baseline = ascent + (dlPtr->height - ascent - descent)/2; + } + sValuePtr = dlPtr->chunkPtr->stylePtr->sValuePtr; + if (dlPtr->index.charIndex == 0) { + dlPtr->spaceAbove = sValuePtr->spacing1; + } else { + dlPtr->spaceAbove = sValuePtr->spacing2 - sValuePtr->spacing2/2; + } + if (wholeLine) { + dlPtr->spaceBelow = sValuePtr->spacing3; + } else { + dlPtr->spaceBelow = sValuePtr->spacing2/2; + } + dlPtr->height += dlPtr->spaceAbove + dlPtr->spaceBelow; + dlPtr->baseline += dlPtr->spaceAbove; + + /* + * Recompute line length: may have changed because of justification. + */ + + dlPtr->length = lastChunkPtr->x + lastChunkPtr->width; + return dlPtr; +} + +/* + *---------------------------------------------------------------------- + * + * UpdateDisplayInfo -- + * + * This procedure is invoked to recompute some or all of the + * DLine structures for a text widget. At the time it is called + * the DLine structures still left in the widget are guaranteed + * to be correct except that (a) the y-coordinates aren't + * necessarily correct, (b) there may be missing structures + * (the DLine structures get removed as soon as they are potentially + * out-of-date), and (c) DLine structures that don't start at the + * beginning of a line may be incorrect if previous information in + * the same line changed size in a way that moved a line boundary + * (DLines for any info that changed will have been deleted, but + * not DLines for unchanged info in the same text line). + * + * Results: + * None. + * + * Side effects: + * Upon return, the DLine information for textPtr correctly reflects + * the positions where characters will be displayed. However, this + * procedure doesn't actually bring the display up-to-date. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateDisplayInfo(textPtr) + TkText *textPtr; /* Text widget to update. */ +{ + register TextDInfo *dInfoPtr = textPtr->dInfoPtr; + register DLine *dlPtr, *prevPtr; + TkTextIndex index; + TkTextLine *lastLinePtr; + int y, maxY, pixelOffset, maxOffset; + + if (!(dInfoPtr->flags & DINFO_OUT_OF_DATE)) { + return; + } + dInfoPtr->flags &= ~DINFO_OUT_OF_DATE; + + /* + * Delete any DLines that are now above the top of the window. + */ + + index = textPtr->topIndex; + dlPtr = FindDLine(dInfoPtr->dLinePtr, &index); + if ((dlPtr != NULL) && (dlPtr != dInfoPtr->dLinePtr)) { + FreeDLines(textPtr, dInfoPtr->dLinePtr, dlPtr, 1); + } + + /* + *-------------------------------------------------------------- + * Scan through the contents of the window from top to bottom, + * recomputing information for lines that are missing. + *-------------------------------------------------------------- + */ + + lastLinePtr = TkBTreeFindLine(textPtr->tree, + TkBTreeNumLines(textPtr->tree)); + dlPtr = dInfoPtr->dLinePtr; + prevPtr = NULL; + y = dInfoPtr->y; + maxY = dInfoPtr->maxY; + while (1) { + register DLine *newPtr; + + if (index.linePtr == lastLinePtr) { + break; + } + + /* + * There are three possibilities right now: + * (a) the next DLine (dlPtr) corresponds exactly to the next + * information we want to display: just use it as-is. + * (b) the next DLine corresponds to a different line, or to + * a segment that will be coming later in the same line: + * leave this DLine alone in the hopes that we'll be able + * to use it later, then create a new DLine in front of + * it. + * (c) the next DLine corresponds to a segment in the line we + * want, but it's a segment that has already been processed + * or will never be processed. Delete the DLine and try + * again. + * + * One other twist on all this. It's possible for 3D borders + * to interact between lines (see DisplayLineBackground) so if + * a line is relayed out and has styles with 3D borders, its + * neighbors have to be redrawn if they have 3D borders too, + * since the interactions could have changed (the neighbors + * don't have to be relayed out, just redrawn). + */ + + if ((dlPtr == NULL) || (dlPtr->index.linePtr != index.linePtr)) { + /* + * Case (b) -- must make new DLine. + */ + + makeNewDLine: + if (tkTextDebug) { + char string[TK_POS_CHARS]; + + /* + * Debugging is enabled, so keep a log of all the lines + * that were re-layed out. The test suite uses this + * information. + */ + + TkTextPrintIndex(&index, string); + Tcl_SetVar2(textPtr->interp, "tk_textRelayout", (char *) NULL, + string, + TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT); + } + newPtr = LayoutDLine(textPtr, &index); + if (prevPtr == NULL) { + dInfoPtr->dLinePtr = newPtr; + } else { + prevPtr->nextPtr = newPtr; + if (prevPtr->flags & HAS_3D_BORDER) { + prevPtr->oldY = -1; + } + } + newPtr->nextPtr = dlPtr; + dlPtr = newPtr; + } else { + /* + * DlPtr refers to the line we want. Next check the + * index within the line. + */ + + if (index.charIndex == dlPtr->index.charIndex) { + /* + * Case (a) -- can use existing display line as-is. + */ + + if ((dlPtr->flags & HAS_3D_BORDER) && (prevPtr != NULL) + && (prevPtr->flags & (NEW_LAYOUT))) { + dlPtr->oldY = -1; + } + goto lineOK; + } + if (index.charIndex < dlPtr->index.charIndex) { + goto makeNewDLine; + } + + /* + * Case (c) -- dlPtr is useless. Discard it and start + * again with the next display line. + */ + + newPtr = dlPtr->nextPtr; + FreeDLines(textPtr, dlPtr, newPtr, 0); + dlPtr = newPtr; + if (prevPtr != NULL) { + prevPtr->nextPtr = newPtr; + } else { + dInfoPtr->dLinePtr = newPtr; + } + continue; + } + + /* + * Advance to the start of the next line. + */ + + lineOK: + dlPtr->y = y; + y += dlPtr->height; + TkTextIndexForwChars(&index, dlPtr->count, &index); + prevPtr = dlPtr; + dlPtr = dlPtr->nextPtr; + + /* + * If we switched text lines, delete any DLines left for the + * old text line. + */ + + if (index.linePtr != prevPtr->index.linePtr) { + register DLine *nextPtr; + + nextPtr = dlPtr; + while ((nextPtr != NULL) + && (nextPtr->index.linePtr == prevPtr->index.linePtr)) { + nextPtr = nextPtr->nextPtr; + } + if (nextPtr != dlPtr) { + FreeDLines(textPtr, dlPtr, nextPtr, 0); + prevPtr->nextPtr = nextPtr; + dlPtr = nextPtr; + } + } + + /* + * It's important to have the following check here rather than in + * the while statement for the loop, so that there's always at least + * one DLine generated, regardless of how small the window is. This + * keeps a lot of other code from breaking. + */ + + if (y >= maxY) { + break; + } + } + + /* + * Delete any DLine structures that don't fit on the screen. + */ + + FreeDLines(textPtr, dlPtr, (DLine *) NULL, 1); + + /* + *-------------------------------------------------------------- + * If there is extra space at the bottom of the window (because + * we've hit the end of the text), then bring in more lines at + * the top of the window, if there are any, to fill in the view. + *-------------------------------------------------------------- + */ + + if (y < maxY) { + int lineNum, spaceLeft, charsToCount; + DLine *lowestPtr; + + /* + * Layout an entire text line (potentially > 1 display line), + * then link in as many display lines as fit without moving + * the bottom line out of the window. Repeat this until + * all the extra space has been used up or we've reached the + * beginning of the text. + */ + + spaceLeft = maxY - y; + lineNum = TkBTreeLineIndex(dInfoPtr->dLinePtr->index.linePtr); + charsToCount = dInfoPtr->dLinePtr->index.charIndex; + if (charsToCount == 0) { + charsToCount = INT_MAX; + lineNum--; + } + for ( ; (lineNum >= 0) && (spaceLeft > 0); lineNum--) { + index.linePtr = TkBTreeFindLine(textPtr->tree, lineNum); + index.charIndex = 0; + lowestPtr = NULL; + do { + dlPtr = LayoutDLine(textPtr, &index); + dlPtr->nextPtr = lowestPtr; + lowestPtr = dlPtr; + TkTextIndexForwChars(&index, dlPtr->count, &index); + charsToCount -= dlPtr->count; + } while ((charsToCount > 0) + && (index.linePtr == lowestPtr->index.linePtr)); + + /* + * Scan through the display lines from the bottom one up to + * the top one. + */ + + while (lowestPtr != NULL) { + dlPtr = lowestPtr; + spaceLeft -= dlPtr->height; + if (spaceLeft < 0) { + break; + } + lowestPtr = dlPtr->nextPtr; + dlPtr->nextPtr = dInfoPtr->dLinePtr; + dInfoPtr->dLinePtr = dlPtr; + if (tkTextDebug) { + char string[TK_POS_CHARS]; + + TkTextPrintIndex(&dlPtr->index, string); + Tcl_SetVar2(textPtr->interp, "tk_textRelayout", + (char *) NULL, string, + TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT); + } + } + FreeDLines(textPtr, lowestPtr, (DLine *) NULL, 0); + charsToCount = INT_MAX; + } + + /* + * Now we're all done except that the y-coordinates in all the + * DLines are wrong and the top index for the text is wrong. + * Update them. + */ + + textPtr->topIndex = dInfoPtr->dLinePtr->index; + y = dInfoPtr->y; + for (dlPtr = dInfoPtr->dLinePtr; dlPtr != NULL; + dlPtr = dlPtr->nextPtr) { + if (y > dInfoPtr->maxY) { + panic("Added too many new lines in UpdateDisplayInfo"); + } + dlPtr->y = y; + y += dlPtr->height; + } + } + + /* + *-------------------------------------------------------------- + * If the old top or bottom line has scrolled elsewhere on the + * screen, we may not be able to re-use its old contents by + * copying bits (e.g., a beveled edge that was drawn when it was + * at the top or bottom won't be drawn when the line is in the + * middle and its neighbor has a matching background). Similarly, + * if the new top or bottom line came from somewhere else on the + * screen, we may not be able to copy the old bits. + *-------------------------------------------------------------- + */ + + dlPtr = dInfoPtr->dLinePtr; + if ((dlPtr->flags & HAS_3D_BORDER) && !(dlPtr->flags & TOP_LINE)) { + dlPtr->oldY = -1; + } + while (1) { + if ((dlPtr->flags & TOP_LINE) && (dlPtr != dInfoPtr->dLinePtr) + && (dlPtr->flags & HAS_3D_BORDER)) { + dlPtr->oldY = -1; + } + if ((dlPtr->flags & BOTTOM_LINE) && (dlPtr->nextPtr != NULL) + && (dlPtr->flags & HAS_3D_BORDER)) { + dlPtr->oldY = -1; + } + if (dlPtr->nextPtr == NULL) { + if ((dlPtr->flags & HAS_3D_BORDER) + && !(dlPtr->flags & BOTTOM_LINE)) { + dlPtr->oldY = -1; + } + dlPtr->flags &= ~TOP_LINE; + dlPtr->flags |= BOTTOM_LINE; + break; + } + dlPtr->flags &= ~(TOP_LINE|BOTTOM_LINE); + dlPtr = dlPtr->nextPtr; + } + dInfoPtr->dLinePtr->flags |= TOP_LINE; + + /* + * Arrange for scrollbars to be updated. + */ + + textPtr->flags |= UPDATE_SCROLLBARS; + + /* + *-------------------------------------------------------------- + * Deal with horizontal scrolling: + * 1. If there's empty space to the right of the longest line, + * shift the screen to the right to fill in the empty space. + * 2. If the desired horizontal scroll position has changed, + * force a full redisplay of all the lines in the widget. + * 3. If the wrap mode isn't "none" then re-scroll to the base + * position. + *-------------------------------------------------------------- + */ + + dInfoPtr->maxLength = 0; + for (dlPtr = dInfoPtr->dLinePtr; dlPtr != NULL; + dlPtr = dlPtr->nextPtr) { + if (dlPtr->length > dInfoPtr->maxLength) { + dInfoPtr->maxLength = dlPtr->length; + } + } + maxOffset = (dInfoPtr->maxLength - (dInfoPtr->maxX - dInfoPtr->x) + + textPtr->charWidth - 1)/textPtr->charWidth; + if (dInfoPtr->newCharOffset > maxOffset) { + dInfoPtr->newCharOffset = maxOffset; + } + if (dInfoPtr->newCharOffset < 0) { + dInfoPtr->newCharOffset = 0; + } + pixelOffset = dInfoPtr->newCharOffset * textPtr->charWidth; + if (pixelOffset != dInfoPtr->curPixelOffset) { + dInfoPtr->curPixelOffset = pixelOffset; + for (dlPtr = dInfoPtr->dLinePtr; dlPtr != NULL; + dlPtr = dlPtr->nextPtr) { + dlPtr->oldY = -1; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * FreeDLines -- + * + * This procedure is called to free up all of the resources + * associated with one or more DLine structures. + * + * Results: + * None. + * + * Side effects: + * Memory gets freed and various other resources are released. + * + *---------------------------------------------------------------------- + */ + +static void +FreeDLines(textPtr, firstPtr, lastPtr, unlink) + TkText *textPtr; /* Information about overall text + * widget. */ + register DLine *firstPtr; /* Pointer to first DLine to free up. */ + DLine *lastPtr; /* Pointer to DLine just after last + * one to free (NULL means everything + * starting with firstPtr). */ + int unlink; /* 1 means DLines are currently linked + * into the list rooted at + * textPtr->dInfoPtr->dLinePtr and + * they have to be unlinked. 0 means + * just free without unlinking. */ +{ + register TkTextDispChunk *chunkPtr, *nextChunkPtr; + register DLine *nextDLinePtr; + + if (unlink) { + if (textPtr->dInfoPtr->dLinePtr == firstPtr) { + textPtr->dInfoPtr->dLinePtr = lastPtr; + } else { + register DLine *prevPtr; + for (prevPtr = textPtr->dInfoPtr->dLinePtr; + prevPtr->nextPtr != firstPtr; prevPtr = prevPtr->nextPtr) { + /* Empty loop body. */ + } + prevPtr->nextPtr = lastPtr; + } + } + while (firstPtr != lastPtr) { + nextDLinePtr = firstPtr->nextPtr; + for (chunkPtr = firstPtr->chunkPtr; chunkPtr != NULL; + chunkPtr = nextChunkPtr) { + if (chunkPtr->undisplayProc != NULL) { + (*chunkPtr->undisplayProc)(textPtr, chunkPtr); + } + FreeStyle(textPtr, chunkPtr->stylePtr); + nextChunkPtr = chunkPtr->nextPtr; + ckfree((char *) chunkPtr); + } + ckfree((char *) firstPtr); + firstPtr = nextDLinePtr; + } + textPtr->dInfoPtr->dLinesInvalidated = 1; +} + +/* + *---------------------------------------------------------------------- + * + * DisplayDLine -- + * + * This procedure is invoked to draw a single line on the + * screen. + * + * Results: + * None. + * + * Side effects: + * The line given by dlPtr is drawn at its correct position in + * textPtr's window. Note that this is one *display* line, not + * one *text* line. + * + *---------------------------------------------------------------------- + */ + +static void +DisplayDLine(textPtr, dlPtr, prevPtr, pixmap) + TkText *textPtr; /* Text widget in which to draw line. */ + register DLine *dlPtr; /* Information about line to draw. */ + DLine *prevPtr; /* Line just before one to draw, or NULL + * if dlPtr is the top line. */ + Pixmap pixmap; /* Pixmap to use for double-buffering. + * Caller must make sure it's large enough + * to hold line. */ +{ + register TkTextDispChunk *chunkPtr; + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + Display *display; + int height, x; + + /* + * First, clear the area of the line to the background color for the + * text widget. + */ + + display = Tk_Display(textPtr->tkwin); + Tk_Fill3DRectangle(textPtr->tkwin, pixmap, textPtr->border, 0, 0, + Tk_Width(textPtr->tkwin), dlPtr->height, 0, TK_RELIEF_FLAT); + + /* + * Next, draw background information for the whole line. + */ + + DisplayLineBackground(textPtr, dlPtr, prevPtr, pixmap); + + /* + * Make another pass through all of the chunks to redraw the + * insertion cursor, if it is visible on this line. Must do + * it here rather than in the foreground pass below because + * otherwise a wide insertion cursor will obscure the character + * to its left. + */ + + if (textPtr->state == tkNormalUid) { + for (chunkPtr = dlPtr->chunkPtr; (chunkPtr != NULL); + chunkPtr = chunkPtr->nextPtr) { + x = chunkPtr->x + dInfoPtr->x - dInfoPtr->curPixelOffset; + if (chunkPtr->displayProc == TkTextInsertDisplayProc) { + (*chunkPtr->displayProc)(chunkPtr, x, dlPtr->spaceAbove, + dlPtr->height - dlPtr->spaceAbove - dlPtr->spaceBelow, + dlPtr->baseline - dlPtr->spaceAbove, display, pixmap, + dlPtr->y + dlPtr->spaceAbove); + } + } + } + + /* + * Make yet another pass through all of the chunks to redraw all of + * foreground information. Note: we have to call the displayProc + * even for chunks that are off-screen. This is needed, for + * example, so that embedded windows can be unmapped in this case. + * Conve + */ + + for (chunkPtr = dlPtr->chunkPtr; (chunkPtr != NULL); + chunkPtr = chunkPtr->nextPtr) { + if (chunkPtr->displayProc == TkTextInsertDisplayProc) { + /* + * Already displayed the insertion cursor above. Don't + * do it again here. + */ + + continue; + } + x = chunkPtr->x + dInfoPtr->x - dInfoPtr->curPixelOffset; + if ((x + chunkPtr->width <= 0) || (x >= dInfoPtr->maxX)) { + /* + * Note: we have to call the displayProc even for chunks + * that are off-screen. This is needed, for example, so + * that embedded windows can be unmapped in this case. + * Display the chunk at a coordinate that can be clearly + * identified by the displayProc as being off-screen to + * the left (the displayProc may not be able to tell if + * something is off to the right). + */ + + (*chunkPtr->displayProc)(chunkPtr, -chunkPtr->width, + dlPtr->spaceAbove, + dlPtr->height - dlPtr->spaceAbove - dlPtr->spaceBelow, + dlPtr->baseline - dlPtr->spaceAbove, display, pixmap, + dlPtr->y + dlPtr->spaceAbove); + } else { + (*chunkPtr->displayProc)(chunkPtr, x, dlPtr->spaceAbove, + dlPtr->height - dlPtr->spaceAbove - dlPtr->spaceBelow, + dlPtr->baseline - dlPtr->spaceAbove, display, pixmap, + dlPtr->y + dlPtr->spaceAbove); + } + if (dInfoPtr->dLinesInvalidated) { + return; + } + } + + /* + * Copy the pixmap onto the screen. If this is the last line on + * the screen then copy a piece of the line, so that it doesn't + * overflow into the border area. Another special trick: copy the + * padding area to the left of the line; this is because the + * insertion cursor sometimes overflows onto that area and we want + * to get as much of the cursor as possible. + */ + + height = dlPtr->height; + if ((height + dlPtr->y) > dInfoPtr->maxY) { + height = dInfoPtr->maxY - dlPtr->y; + } + XCopyArea(display, pixmap, Tk_WindowId(textPtr->tkwin), dInfoPtr->copyGC, + dInfoPtr->x, 0, (unsigned) (dInfoPtr->maxX - dInfoPtr->x), + (unsigned) height, dInfoPtr->x, dlPtr->y); + linesRedrawn++; +} + +/* + *-------------------------------------------------------------- + * + * DisplayLineBackground -- + * + * This procedure is called to fill in the background for + * a display line. It draws 3D borders cleverly so that + * adjacent chunks with the same style (whether on the same + * line or different lines) have a single 3D border around + * the whole region. + * + * Results: + * There is no return value. Pixmap is filled in with background + * information for dlPtr. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static void +DisplayLineBackground(textPtr, dlPtr, prevPtr, pixmap) + TkText *textPtr; /* Text widget containing line. */ + register DLine *dlPtr; /* Information about line to draw. */ + DLine *prevPtr; /* Line just above dlPtr, or NULL if dlPtr + * is the top-most line in the window. */ + Pixmap pixmap; /* Pixmap to use for double-buffering. + * Caller must make sure it's large enough + * to hold line. Caller must also have + * filled it with the background color for + * the widget. */ +{ + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + TkTextDispChunk *chunkPtr; /* Pointer to chunk in the current line. */ + TkTextDispChunk *chunkPtr2; /* Pointer to chunk in the line above or + * below the current one. NULL if we're to + * the left of or to the right of the chunks + * in the line. */ + TkTextDispChunk *nextPtr2; /* Next chunk after chunkPtr2 (it's not the + * same as chunkPtr2->nextPtr in the case + * where chunkPtr2 is NULL because the line + * is indented). */ + int leftX; /* The left edge of the region we're + * currently working on. */ + int leftXIn; /* 1 means beveled edge at leftX slopes right + * as it goes down, 0 means it slopes left + * as it goes down. */ + int rightX; /* Right edge of chunkPtr. */ + int rightX2; /* Right edge of chunkPtr2. */ + int matchLeft; /* Does the style of this line match that + * of its neighbor just to the left of + * the current x coordinate? */ + int matchRight; /* Does line's style match its neighbor + * just to the right of the current x-coord? */ + int minX, maxX, xOffset; + StyleValues *sValuePtr; + Display *display; + + /* + * Pass 1: scan through dlPtr from left to right. For each range of + * chunks with the same style, draw the main background for the style + * plus the vertical parts of the 3D borders (the left and right + * edges). + */ + + display = Tk_Display(textPtr->tkwin); + minX = dInfoPtr->curPixelOffset; + xOffset = dInfoPtr->x - minX; + maxX = minX + dInfoPtr->maxX - dInfoPtr->x; + chunkPtr = dlPtr->chunkPtr; + leftX = chunkPtr->x; + for (; leftX < maxX; chunkPtr = chunkPtr->nextPtr) { + if ((chunkPtr->nextPtr != NULL) + && SAME_BACKGROUND(chunkPtr->nextPtr->stylePtr, + chunkPtr->stylePtr)) { + continue; + } + sValuePtr = chunkPtr->stylePtr->sValuePtr; + rightX = chunkPtr->x + chunkPtr->width; + if ((chunkPtr->nextPtr == NULL) && (rightX < maxX)) { + rightX = maxX; + } + if (chunkPtr->stylePtr->bgGC != None) { + XFillRectangle(display, pixmap, chunkPtr->stylePtr->bgGC, + leftX + xOffset, 0, (unsigned int) (rightX - leftX), + (unsigned int) dlPtr->height); + if (sValuePtr->relief != TK_RELIEF_FLAT) { + Tk_3DVerticalBevel(textPtr->tkwin, pixmap, sValuePtr->border, + leftX + xOffset, 0, sValuePtr->borderWidth, + dlPtr->height, 1, sValuePtr->relief); + Tk_3DVerticalBevel(textPtr->tkwin, pixmap, sValuePtr->border, + rightX - sValuePtr->borderWidth + xOffset, + 0, sValuePtr->borderWidth, dlPtr->height, 0, + sValuePtr->relief); + } + } + leftX = rightX; + } + + /* + * Pass 2: draw the horizontal bevels along the top of the line. To + * do this, scan through dlPtr from left to right while simultaneously + * scanning through the line just above dlPtr. ChunkPtr2 and nextPtr2 + * refer to two adjacent chunks in the line above. + */ + + chunkPtr = dlPtr->chunkPtr; + leftX = chunkPtr->x; + leftXIn = 1; + rightX = chunkPtr->x + chunkPtr->width; + if ((chunkPtr->nextPtr == NULL) && (rightX < maxX)) { + rightX = maxX; + } + chunkPtr2 = NULL; + if (prevPtr != NULL) { + /* + * Find the chunk in the previous line that covers leftX. + */ + + nextPtr2 = prevPtr->chunkPtr; + rightX2 = nextPtr2->x; + while (rightX2 <= leftX) { + chunkPtr2 = nextPtr2; + if (chunkPtr2 == NULL) { + break; + } + nextPtr2 = chunkPtr2->nextPtr; + rightX2 = chunkPtr2->x + chunkPtr2->width; + if (nextPtr2 == NULL) { + rightX2 = INT_MAX; + } + } + } else { + nextPtr2 = NULL; + rightX2 = INT_MAX; + } + + while (leftX < maxX) { + matchLeft = (chunkPtr2 != NULL) + && SAME_BACKGROUND(chunkPtr2->stylePtr, chunkPtr->stylePtr); + sValuePtr = chunkPtr->stylePtr->sValuePtr; + if (rightX <= rightX2) { + /* + * The chunk in our line is about to end. If its style + * changes then draw the bevel for the current style. + */ + + if ((chunkPtr->nextPtr == NULL) + || !SAME_BACKGROUND(chunkPtr->stylePtr, + chunkPtr->nextPtr->stylePtr)) { + if (!matchLeft && (sValuePtr->relief != TK_RELIEF_FLAT)) { + Tk_3DHorizontalBevel(textPtr->tkwin, pixmap, + sValuePtr->border, leftX + xOffset, 0, + rightX - leftX, sValuePtr->borderWidth, leftXIn, + 1, 1, sValuePtr->relief); + } + leftX = rightX; + leftXIn = 1; + + /* + * If the chunk in the line above is also ending at + * the same point then advance to the next chunk in + * that line. + */ + + if ((rightX == rightX2) && (chunkPtr2 != NULL)) { + goto nextChunk2; + } + } + chunkPtr = chunkPtr->nextPtr; + if (chunkPtr == NULL) { + break; + } + rightX = chunkPtr->x + chunkPtr->width; + if ((chunkPtr->nextPtr == NULL) && (rightX < maxX)) { + rightX = maxX; + } + continue; + } + + /* + * The chunk in the line above is ending at an x-position where + * there is no change in the style of the current line. If the + * style above matches the current line on one side of the change + * but not on the other, we have to draw an L-shaped piece of + * bevel. + */ + + matchRight = (nextPtr2 != NULL) + && SAME_BACKGROUND(nextPtr2->stylePtr, chunkPtr->stylePtr); + if (matchLeft && !matchRight) { + if (sValuePtr->relief != TK_RELIEF_FLAT) { + Tk_3DVerticalBevel(textPtr->tkwin, pixmap, sValuePtr->border, + rightX2 - sValuePtr->borderWidth + xOffset, 0, + sValuePtr->borderWidth, sValuePtr->borderWidth, 0, + sValuePtr->relief); + } + leftX = rightX2 - sValuePtr->borderWidth; + leftXIn = 0; + } else if (!matchLeft && matchRight + && (sValuePtr->relief != TK_RELIEF_FLAT)) { + Tk_3DVerticalBevel(textPtr->tkwin, pixmap, sValuePtr->border, + rightX2 + xOffset, 0, sValuePtr->borderWidth, + sValuePtr->borderWidth, 1, sValuePtr->relief); + Tk_3DHorizontalBevel(textPtr->tkwin, pixmap, sValuePtr->border, + leftX + xOffset, 0, rightX2 + sValuePtr->borderWidth -leftX, + sValuePtr->borderWidth, leftXIn, 0, 1, + sValuePtr->relief); + } + + nextChunk2: + chunkPtr2 = nextPtr2; + if (chunkPtr2 == NULL) { + rightX2 = INT_MAX; + } else { + nextPtr2 = chunkPtr2->nextPtr; + rightX2 = chunkPtr2->x + chunkPtr2->width; + if (nextPtr2 == NULL) { + rightX2 = INT_MAX; + } + } + } + /* + * Pass 3: draw the horizontal bevels along the bottom of the line. + * This uses the same approach as pass 2. + */ + + chunkPtr = dlPtr->chunkPtr; + leftX = chunkPtr->x; + leftXIn = 0; + rightX = chunkPtr->x + chunkPtr->width; + if ((chunkPtr->nextPtr == NULL) && (rightX < maxX)) { + rightX = maxX; + } + chunkPtr2 = NULL; + if (dlPtr->nextPtr != NULL) { + /* + * Find the chunk in the previous line that covers leftX. + */ + + nextPtr2 = dlPtr->nextPtr->chunkPtr; + rightX2 = nextPtr2->x; + while (rightX2 <= leftX) { + chunkPtr2 = nextPtr2; + if (chunkPtr2 == NULL) { + break; + } + nextPtr2 = chunkPtr2->nextPtr; + rightX2 = chunkPtr2->x + chunkPtr2->width; + if (nextPtr2 == NULL) { + rightX2 = INT_MAX; + } + } + } else { + nextPtr2 = NULL; + rightX2 = INT_MAX; + } + + while (leftX < maxX) { + matchLeft = (chunkPtr2 != NULL) + && SAME_BACKGROUND(chunkPtr2->stylePtr, chunkPtr->stylePtr); + sValuePtr = chunkPtr->stylePtr->sValuePtr; + if (rightX <= rightX2) { + if ((chunkPtr->nextPtr == NULL) + || !SAME_BACKGROUND(chunkPtr->stylePtr, + chunkPtr->nextPtr->stylePtr)) { + if (!matchLeft && (sValuePtr->relief != TK_RELIEF_FLAT)) { + Tk_3DHorizontalBevel(textPtr->tkwin, pixmap, + sValuePtr->border, leftX + xOffset, + dlPtr->height - sValuePtr->borderWidth, + rightX - leftX, sValuePtr->borderWidth, leftXIn, + 0, 0, sValuePtr->relief); + } + leftX = rightX; + leftXIn = 0; + if ((rightX == rightX2) && (chunkPtr2 != NULL)) { + goto nextChunk2b; + } + } + chunkPtr = chunkPtr->nextPtr; + if (chunkPtr == NULL) { + break; + } + rightX = chunkPtr->x + chunkPtr->width; + if ((chunkPtr->nextPtr == NULL) && (rightX < maxX)) { + rightX = maxX; + } + continue; + } + + matchRight = (nextPtr2 != NULL) + && SAME_BACKGROUND(nextPtr2->stylePtr, chunkPtr->stylePtr); + if (matchLeft && !matchRight) { + if (sValuePtr->relief != TK_RELIEF_FLAT) { + Tk_3DVerticalBevel(textPtr->tkwin, pixmap, sValuePtr->border, + rightX2 - sValuePtr->borderWidth + xOffset, + dlPtr->height - sValuePtr->borderWidth, + sValuePtr->borderWidth, sValuePtr->borderWidth, 0, + sValuePtr->relief); + } + leftX = rightX2 - sValuePtr->borderWidth; + leftXIn = 1; + } else if (!matchLeft && matchRight + && (sValuePtr->relief != TK_RELIEF_FLAT)) { + Tk_3DVerticalBevel(textPtr->tkwin, pixmap, sValuePtr->border, + rightX2 + xOffset, dlPtr->height - sValuePtr->borderWidth, + sValuePtr->borderWidth, sValuePtr->borderWidth, + 1, sValuePtr->relief); + Tk_3DHorizontalBevel(textPtr->tkwin, pixmap, sValuePtr->border, + leftX + xOffset, dlPtr->height - sValuePtr->borderWidth, + rightX2 + sValuePtr->borderWidth - leftX, + sValuePtr->borderWidth, leftXIn, 1, 0, sValuePtr->relief); + } + + nextChunk2b: + chunkPtr2 = nextPtr2; + if (chunkPtr2 == NULL) { + rightX2 = INT_MAX; + } else { + nextPtr2 = chunkPtr2->nextPtr; + rightX2 = chunkPtr2->x + chunkPtr2->width; + if (nextPtr2 == NULL) { + rightX2 = INT_MAX; + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * DisplayText -- + * + * This procedure is invoked as a when-idle handler to update the + * display. It only redisplays the parts of the text widget that + * are out of date. + * + * Results: + * None. + * + * Side effects: + * Information is redrawn on the screen. + * + *---------------------------------------------------------------------- + */ + +static void +DisplayText(clientData) + ClientData clientData; /* Information about widget. */ +{ + register TkText *textPtr = (TkText *) clientData; + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + Tk_Window tkwin; + register DLine *dlPtr; + DLine *prevPtr; + Pixmap pixmap; + int maxHeight, borders; + int bottomY = 0; /* Initialization needed only to stop + * compiler warnings. */ + Tcl_Interp *interp; + + if (textPtr->tkwin == NULL) { + + /* + * The widget has been deleted. Don't do anything. + */ + + return; + } + + interp = textPtr->interp; + Tcl_Preserve((ClientData) interp); + + if (tkTextDebug) { + Tcl_SetVar2(interp, "tk_textRelayout", (char *) NULL, "", + TCL_GLOBAL_ONLY); + } + + if (textPtr->tkwin == NULL) { + + /* + * The widget has been deleted. Don't do anything. + */ + + goto end; + } + + if (!Tk_IsMapped(textPtr->tkwin) || (dInfoPtr->maxX <= dInfoPtr->x) + || (dInfoPtr->maxY <= dInfoPtr->y)) { + UpdateDisplayInfo(textPtr); + dInfoPtr->flags &= ~REDRAW_PENDING; + goto doScrollbars; + } + numRedisplays++; + if (tkTextDebug) { + Tcl_SetVar2(interp, "tk_textRedraw", (char *) NULL, "", + TCL_GLOBAL_ONLY); + } + + if (textPtr->tkwin == NULL) { + + /* + * The widget has been deleted. Don't do anything. + */ + + goto end; + } + + /* + * Choose a new current item if that is needed (this could cause + * event handlers to be invoked, hence the preserve/release calls + * and the loop, since the handlers could conceivably necessitate + * yet another current item calculation). The tkwin check is because + * the whole window could go away in the Tcl_Release call. + */ + + while (dInfoPtr->flags & REPICK_NEEDED) { + Tcl_Preserve((ClientData) textPtr); + dInfoPtr->flags &= ~REPICK_NEEDED; + TkTextPickCurrent(textPtr, &textPtr->pickEvent); + tkwin = textPtr->tkwin; + Tcl_Release((ClientData) textPtr); + if (tkwin == NULL) { + goto end; + } + } + + /* + * First recompute what's supposed to be displayed. + */ + + UpdateDisplayInfo(textPtr); + dInfoPtr->dLinesInvalidated = 0; + + /* + * See if it's possible to bring some parts of the screen up-to-date + * by scrolling (copying from other parts of the screen). + */ + + for (dlPtr = dInfoPtr->dLinePtr; dlPtr != NULL; dlPtr = dlPtr->nextPtr) { + register DLine *dlPtr2; + int offset, height, y, oldY; + TkRegion damageRgn; + + if ((dlPtr->oldY == -1) || (dlPtr->y == dlPtr->oldY) + || ((dlPtr->oldY + dlPtr->height) > dInfoPtr->maxY)) { + continue; + } + + /* + * This line is already drawn somewhere in the window so it only + * needs to be copied to its new location. See if there's a group + * of lines that can all be copied together. + */ + + offset = dlPtr->y - dlPtr->oldY; + height = dlPtr->height; + y = dlPtr->y; + for (dlPtr2 = dlPtr->nextPtr; dlPtr2 != NULL; + dlPtr2 = dlPtr2->nextPtr) { + if ((dlPtr2->oldY == -1) + || ((dlPtr2->oldY + offset) != dlPtr2->y) + || ((dlPtr2->oldY + dlPtr2->height) > dInfoPtr->maxY)) { + break; + } + height += dlPtr2->height; + } + + /* + * Reduce the height of the area being copied if necessary to + * avoid overwriting the border area. + */ + + if ((y + height) > dInfoPtr->maxY) { + height = dInfoPtr->maxY -y; + } + oldY = dlPtr->oldY; + + /* + * Update the lines we are going to scroll to show that they + * have been copied. + */ + + while (1) { + dlPtr->oldY = dlPtr->y; + if (dlPtr->nextPtr == dlPtr2) { + break; + } + dlPtr = dlPtr->nextPtr; + } + + /* + * Scan through the lines following the copied ones to see if + * we are going to overwrite them with the copy operation. + * If so, mark them for redisplay. + */ + + for ( ; dlPtr2 != NULL; dlPtr2 = dlPtr2->nextPtr) { + if ((dlPtr2->oldY != -1) + && ((dlPtr2->oldY + dlPtr2->height) > y) + && (dlPtr2->oldY < (y + height))) { + dlPtr2->oldY = -1; + } + } + + /* + * Now scroll the lines. This may generate damage which we + * handle by calling TextInvalidateRegion to mark the display + * blocks as stale. + */ + + damageRgn = TkCreateRegion(); + if (TkScrollWindow(textPtr->tkwin, dInfoPtr->scrollGC, + dInfoPtr->x - textPtr->padX, oldY, + (dInfoPtr->maxX - (dInfoPtr->x - textPtr->padX)), height, + 0, y - oldY, damageRgn)) { + TextInvalidateRegion(textPtr, damageRgn); + } + numCopies++; + TkDestroyRegion(damageRgn); + } + + /* + * Clear the REDRAW_PENDING flag here. This is actually pretty + * tricky. We want to wait until *after* doing the scrolling, + * since that could generate more areas to redraw and don't + * want to reschedule a redisplay for them. On the other hand, + * we can't wait until after all the redisplaying, because the + * act of redisplaying could actually generate more redisplays + * (e.g. in the case of a nested window with event bindings triggered + * by redisplay). + */ + + dInfoPtr->flags &= ~REDRAW_PENDING; + + /* + * Redraw the borders if that's needed. + */ + + if (dInfoPtr->flags & REDRAW_BORDERS) { + if (tkTextDebug) { + Tcl_SetVar2(interp, "tk_textRedraw", (char *) NULL, "borders", + TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT); + } + + if (textPtr->tkwin == NULL) { + + /* + * The widget has been deleted. Don't do anything. + */ + + goto end; + } + + Tk_Draw3DRectangle(textPtr->tkwin, Tk_WindowId(textPtr->tkwin), + textPtr->border, textPtr->highlightWidth, + textPtr->highlightWidth, + Tk_Width(textPtr->tkwin) - 2*textPtr->highlightWidth, + Tk_Height(textPtr->tkwin) - 2*textPtr->highlightWidth, + textPtr->borderWidth, textPtr->relief); + if (textPtr->highlightWidth != 0) { + GC gc; + + if (textPtr->flags & GOT_FOCUS) { + gc = Tk_GCForColor(textPtr->highlightColorPtr, + Tk_WindowId(textPtr->tkwin)); + } else { + gc = Tk_GCForColor(textPtr->highlightBgColorPtr, + Tk_WindowId(textPtr->tkwin)); + } + Tk_DrawFocusHighlight(textPtr->tkwin, gc, textPtr->highlightWidth, + Tk_WindowId(textPtr->tkwin)); + } + borders = textPtr->borderWidth + textPtr->highlightWidth; + if (textPtr->padY > 0) { + Tk_Fill3DRectangle(textPtr->tkwin, Tk_WindowId(textPtr->tkwin), + textPtr->border, borders, borders, + Tk_Width(textPtr->tkwin) - 2*borders, textPtr->padY, + 0, TK_RELIEF_FLAT); + Tk_Fill3DRectangle(textPtr->tkwin, Tk_WindowId(textPtr->tkwin), + textPtr->border, borders, + Tk_Height(textPtr->tkwin) - borders - textPtr->padY, + Tk_Width(textPtr->tkwin) - 2*borders, + textPtr->padY, 0, TK_RELIEF_FLAT); + } + if (textPtr->padX > 0) { + Tk_Fill3DRectangle(textPtr->tkwin, Tk_WindowId(textPtr->tkwin), + textPtr->border, borders, borders + textPtr->padY, + textPtr->padX, + Tk_Height(textPtr->tkwin) - 2*borders -2*textPtr->padY, + 0, TK_RELIEF_FLAT); + Tk_Fill3DRectangle(textPtr->tkwin, Tk_WindowId(textPtr->tkwin), + textPtr->border, + Tk_Width(textPtr->tkwin) - borders - textPtr->padX, + borders + textPtr->padY, textPtr->padX, + Tk_Height(textPtr->tkwin) - 2*borders -2*textPtr->padY, + 0, TK_RELIEF_FLAT); + } + dInfoPtr->flags &= ~REDRAW_BORDERS; + } + + /* + * Now we have to redraw the lines that couldn't be updated by + * scrolling. First, compute the height of the largest line and + * allocate an off-screen pixmap to use for double-buffered + * displays. + */ + + maxHeight = -1; + for (dlPtr = dInfoPtr->dLinePtr; dlPtr != NULL; + dlPtr = dlPtr->nextPtr) { + if ((dlPtr->height > maxHeight) && (dlPtr->oldY != dlPtr->y)) { + maxHeight = dlPtr->height; + } + bottomY = dlPtr->y + dlPtr->height; + } + if (maxHeight > dInfoPtr->maxY) { + maxHeight = dInfoPtr->maxY; + } + if (maxHeight > 0) { + pixmap = Tk_GetPixmap(Tk_Display(textPtr->tkwin), + Tk_WindowId(textPtr->tkwin), Tk_Width(textPtr->tkwin), + maxHeight, Tk_Depth(textPtr->tkwin)); + for (prevPtr = NULL, dlPtr = textPtr->dInfoPtr->dLinePtr; + (dlPtr != NULL) && (dlPtr->y < dInfoPtr->maxY); + prevPtr = dlPtr, dlPtr = dlPtr->nextPtr) { + if (dlPtr->oldY != dlPtr->y) { + if (tkTextDebug) { + char string[TK_POS_CHARS]; + TkTextPrintIndex(&dlPtr->index, string); + Tcl_SetVar2(textPtr->interp, "tk_textRedraw", + (char *) NULL, string, + TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT); + } + DisplayDLine(textPtr, dlPtr, prevPtr, pixmap); + if (dInfoPtr->dLinesInvalidated) { + Tk_FreePixmap(Tk_Display(textPtr->tkwin), pixmap); + return; + } + dlPtr->oldY = dlPtr->y; + dlPtr->flags &= ~NEW_LAYOUT; + } + } + Tk_FreePixmap(Tk_Display(textPtr->tkwin), pixmap); + } + + /* + * See if we need to refresh the part of the window below the + * last line of text (if there is any such area). Refresh the + * padding area on the left too, since the insertion cursor might + * have been displayed there previously). + */ + + if (dInfoPtr->topOfEof > dInfoPtr->maxY) { + dInfoPtr->topOfEof = dInfoPtr->maxY; + } + if (bottomY < dInfoPtr->topOfEof) { + if (tkTextDebug) { + Tcl_SetVar2(textPtr->interp, "tk_textRedraw", + (char *) NULL, "eof", + TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT); + } + + if (textPtr->tkwin == NULL) { + + /* + * The widget has been deleted. Don't do anything. + */ + + goto end; + } + + Tk_Fill3DRectangle(textPtr->tkwin, Tk_WindowId(textPtr->tkwin), + textPtr->border, dInfoPtr->x - textPtr->padX, bottomY, + dInfoPtr->maxX - (dInfoPtr->x - textPtr->padX), + dInfoPtr->topOfEof-bottomY, 0, TK_RELIEF_FLAT); + } + dInfoPtr->topOfEof = bottomY; + + doScrollbars: + + /* + * Update the vertical scrollbar, if there is one. Note: it's + * important to clear REDRAW_PENDING here, just in case the + * scroll procedure does something that requires redisplay. + */ + + if (textPtr->flags & UPDATE_SCROLLBARS) { + textPtr->flags &= ~UPDATE_SCROLLBARS; + if (textPtr->yScrollCmd != NULL) { + GetYView(textPtr->interp, textPtr, 1); + } + + if (textPtr->tkwin == NULL) { + + /* + * The widget has been deleted. Don't do anything. + */ + + goto end; + } + + /* + * Update the horizontal scrollbar, if any. + */ + + if (textPtr->xScrollCmd != NULL) { + GetXView(textPtr->interp, textPtr, 1); + } + } + +end: + Tcl_Release((ClientData) interp); +} + +/* + *---------------------------------------------------------------------- + * + * TkTextEventuallyRepick -- + * + * This procedure is invoked whenever something happens that + * could change the current character or the tags associated + * with it. + * + * Results: + * None. + * + * Side effects: + * A repick is scheduled as an idle handler. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +void +TkTextEventuallyRepick(textPtr) + TkText *textPtr; /* Widget record for text widget. */ +{ + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + + dInfoPtr->flags |= REPICK_NEEDED; + if (!(dInfoPtr->flags & REDRAW_PENDING)) { + dInfoPtr->flags |= REDRAW_PENDING; + Tcl_DoWhenIdle(DisplayText, (ClientData) textPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * TkTextRedrawRegion -- + * + * This procedure is invoked to schedule a redisplay for a given + * region of a text widget. The redisplay itself may not occur + * immediately: it's scheduled as a when-idle handler. + * + * Results: + * None. + * + * Side effects: + * Information will eventually be redrawn on the screen. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +void +TkTextRedrawRegion(textPtr, x, y, width, height) + TkText *textPtr; /* Widget record for text widget. */ + int x, y; /* Coordinates of upper-left corner of area + * to be redrawn, in pixels relative to + * textPtr's window. */ + int width, height; /* Width and height of area to be redrawn. */ +{ + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + TkRegion damageRgn = TkCreateRegion(); + XRectangle rect; + + rect.x = x; + rect.y = y; + rect.width = width; + rect.height = height; + TkUnionRectWithRegion(&rect, damageRgn, damageRgn); + + TextInvalidateRegion(textPtr, damageRgn); + + if (!(dInfoPtr->flags & REDRAW_PENDING)) { + dInfoPtr->flags |= REDRAW_PENDING; + Tcl_DoWhenIdle(DisplayText, (ClientData) textPtr); + } + TkDestroyRegion(damageRgn); +} + +/* + *---------------------------------------------------------------------- + * + * TextInvalidateRegion -- + * + * Mark a region of text as invalid. + * + * Results: + * None. + * + * Side effects: + * Updates the display information for the text widget. + * + *---------------------------------------------------------------------- + */ + +static void +TextInvalidateRegion(textPtr, region) + TkText *textPtr; /* Widget record for text widget. */ + TkRegion region; /* Region of area to redraw. */ +{ + register DLine *dlPtr; + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + int maxY, inset; + XRectangle rect; + + /* + * Find all lines that overlap the given region and mark them for + * redisplay. + */ + + TkClipBox(region, &rect); + maxY = rect.y + rect.height; + for (dlPtr = dInfoPtr->dLinePtr; dlPtr != NULL; + dlPtr = dlPtr->nextPtr) { + if ((dlPtr->oldY != -1) && (TkRectInRegion(region, rect.x, dlPtr->y, + rect.width, (unsigned int) dlPtr->height) != RectangleOut)) { + dlPtr->oldY = -1; + } + } + if (dInfoPtr->topOfEof < maxY) { + dInfoPtr->topOfEof = maxY; + } + + /* + * Schedule the redisplay operation if there isn't one already + * scheduled. + */ + + inset = textPtr->borderWidth + textPtr->highlightWidth; + if ((rect.x < inset) || (rect.y < inset) + || ((rect.x + rect.width) > (Tk_Width(textPtr->tkwin) - inset)) + || (maxY > (Tk_Height(textPtr->tkwin) - inset))) { + dInfoPtr->flags |= REDRAW_BORDERS; + } +} + +/* + *---------------------------------------------------------------------- + * + * TkTextChanged -- + * + * This procedure is invoked when info in a text widget is about + * to be modified in a way that changes how it is displayed (e.g. + * characters were inserted or deleted, or tag information was + * changed). This procedure must be called *before* a change is + * made, so that indexes in the display information are still + * valid. + * + * Results: + * None. + * + * Side effects: + * The range of character between index1Ptr (inclusive) and + * index2Ptr (exclusive) will be redisplayed at some point in the + * future (the actual redisplay is scheduled as a when-idle handler). + * + *---------------------------------------------------------------------- + */ + +void +TkTextChanged(textPtr, index1Ptr, index2Ptr) + TkText *textPtr; /* Widget record for text widget. */ + TkTextIndex *index1Ptr; /* Index of first character to redisplay. */ + TkTextIndex *index2Ptr; /* Index of character just after last one + * to redisplay. */ +{ + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + DLine *firstPtr, *lastPtr; + TkTextIndex rounded; + + /* + * Schedule both a redisplay and a recomputation of display information. + * It's done here rather than the end of the procedure for two reasons: + * + * 1. If there are no display lines to update we'll want to return + * immediately, well before the end of the procedure. + * 2. It's important to arrange for the redisplay BEFORE calling + * FreeDLines. The reason for this is subtle and has to do with + * embedded windows. The chunk delete procedure for an embedded + * window will schedule an idle handler to unmap the window. + * However, we want the idle handler for redisplay to be called + * first, so that it can put the embedded window back on the screen + * again (if appropriate). This will prevent the window from ever + * being unmapped, and thereby avoid flashing. + */ + + if (!(dInfoPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(DisplayText, (ClientData) textPtr); + } + dInfoPtr->flags |= REDRAW_PENDING|DINFO_OUT_OF_DATE|REPICK_NEEDED; + + /* + * Find the DLines corresponding to index1Ptr and index2Ptr. There + * is one tricky thing here, which is that we have to relayout in + * units of whole text lines: round index1Ptr back to the beginning + * of its text line, and include all the display lines after index2, + * up to the end of its text line. This is necessary because the + * indices stored in the display lines will no longer be valid. It's + * also needed because any edit could change the way lines wrap. + */ + + rounded = *index1Ptr; + rounded.charIndex = 0; + firstPtr = FindDLine(dInfoPtr->dLinePtr, &rounded); + if (firstPtr == NULL) { + return; + } + lastPtr = FindDLine(dInfoPtr->dLinePtr, index2Ptr); + while ((lastPtr != NULL) + && (lastPtr->index.linePtr == index2Ptr->linePtr)) { + lastPtr = lastPtr->nextPtr; + } + + /* + * Delete all the DLines from firstPtr up to but not including lastPtr. + */ + + FreeDLines(textPtr, firstPtr, lastPtr, 1); +} + +/* + *---------------------------------------------------------------------- + * + * TkTextRedrawTag -- + * + * This procedure is invoked to request a redraw of all characters + * in a given range that have a particular tag on or off. It's + * called, for example, when tag options change. + * + * Results: + * None. + * + * Side effects: + * Information on the screen may be redrawn, and the layout of + * the screen may change. + * + *---------------------------------------------------------------------- + */ + +void +TkTextRedrawTag(textPtr, index1Ptr, index2Ptr, tagPtr, withTag) + TkText *textPtr; /* Widget record for text widget. */ + TkTextIndex *index1Ptr; /* First character in range to consider + * for redisplay. NULL means start at + * beginning of text. */ + TkTextIndex *index2Ptr; /* Character just after last one to consider + * for redisplay. NULL means process all + * the characters in the text. */ + TkTextTag *tagPtr; /* Information about tag. */ + int withTag; /* 1 means redraw characters that have the + * tag, 0 means redraw those without. */ +{ + register DLine *dlPtr; + DLine *endPtr; + int tagOn; + TkTextSearch search; + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + TkTextIndex *curIndexPtr; + TkTextIndex endOfText, *endIndexPtr; + + /* + * Round up the starting position if it's before the first line + * visible on the screen (we only care about what's on the screen). + */ + + dlPtr = dInfoPtr->dLinePtr; + if (dlPtr == NULL) { + return; + } + if ((index1Ptr == NULL) || (TkTextIndexCmp(&dlPtr->index, index1Ptr) > 0)) { + index1Ptr = &dlPtr->index; + } + + /* + * Set the stopping position if it wasn't specified. + */ + + if (index2Ptr == NULL) { + index2Ptr = TkTextMakeIndex(textPtr->tree, + TkBTreeNumLines(textPtr->tree), 0, &endOfText); + } + + /* + * Initialize a search through all transitions on the tag, starting + * with the first transition where the tag's current state is different + * from what it will eventually be. + */ + + TkBTreeStartSearch(index1Ptr, index2Ptr, tagPtr, &search); + /* + * Make our own curIndex because at this point search.curIndex + * may not equal index1Ptr->curIndex in the case the first tag toggle + * comes after index1Ptr (See the use of FindTagStart in TkBTreeStartSearch) + */ + curIndexPtr = index1Ptr; + tagOn = TkBTreeCharTagged(index1Ptr, tagPtr); + if (tagOn != withTag) { + if (!TkBTreeNextTag(&search)) { + return; + } + curIndexPtr = &search.curIndex; + } + + /* + * Schedule a redisplay and layout recalculation if they aren't + * already pending. This has to be done before calling FreeDLines, + * for the reason given in TkTextChanged. + */ + + if (!(dInfoPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(DisplayText, (ClientData) textPtr); + } + dInfoPtr->flags |= REDRAW_PENDING|DINFO_OUT_OF_DATE|REPICK_NEEDED; + + /* + * Each loop through the loop below is for one range of characters + * where the tag's current state is different than its eventual + * state. At the top of the loop, search contains information about + * the first character in the range. + */ + + while (1) { + /* + * Find the first DLine structure in the range. Note: if the + * desired character isn't the first in its text line, then look + * for the character just before it instead. This is needed to + * handle the case where the first character of a wrapped + * display line just got smaller, so that it now fits on the + * line before: need to relayout the line containing the + * previous character. + */ + + if (curIndexPtr->charIndex == 0) { + dlPtr = FindDLine(dlPtr, curIndexPtr); + } else { + TkTextIndex tmp; + + tmp = *curIndexPtr; + tmp.charIndex -= 1; + dlPtr = FindDLine(dlPtr, &tmp); + } + if (dlPtr == NULL) { + break; + } + + /* + * Find the first DLine structure that's past the end of the range. + */ + + if (!TkBTreeNextTag(&search)) { + endIndexPtr = index2Ptr; + } else { + curIndexPtr = &search.curIndex; + endIndexPtr = curIndexPtr; + } + endPtr = FindDLine(dlPtr, endIndexPtr); + if ((endPtr != NULL) && (endPtr->index.linePtr == endIndexPtr->linePtr) + && (endPtr->index.charIndex < endIndexPtr->charIndex)) { + endPtr = endPtr->nextPtr; + } + + /* + * Delete all of the display lines in the range, so that they'll + * be re-layed out and redrawn. + */ + + FreeDLines(textPtr, dlPtr, endPtr, 1); + dlPtr = endPtr; + + /* + * Find the first text line in the next range. + */ + + if (!TkBTreeNextTag(&search)) { + break; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TkTextRelayoutWindow -- + * + * This procedure is called when something has happened that + * invalidates the whole layout of characters on the screen, such + * as a change in a configuration option for the overall text + * widget or a change in the window size. It causes all display + * information to be recomputed and the window to be redrawn. + * + * Results: + * None. + * + * Side effects: + * All the display information will be recomputed for the window + * and the window will be redrawn. + * + *---------------------------------------------------------------------- + */ + +void +TkTextRelayoutWindow(textPtr) + TkText *textPtr; /* Widget record for text widget. */ +{ + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + GC new; + XGCValues gcValues; + + /* + * Schedule the window redisplay. See TkTextChanged for the + * reason why this has to be done before any calls to FreeDLines. + */ + + if (!(dInfoPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(DisplayText, (ClientData) textPtr); + } + dInfoPtr->flags |= REDRAW_PENDING|REDRAW_BORDERS|DINFO_OUT_OF_DATE + |REPICK_NEEDED; + + /* + * (Re-)create the graphics context for drawing the traversal + * highlight. + */ + + gcValues.graphics_exposures = False; + new = Tk_GetGC(textPtr->tkwin, GCGraphicsExposures, &gcValues); + if (dInfoPtr->copyGC != None) { + Tk_FreeGC(textPtr->display, dInfoPtr->copyGC); + } + dInfoPtr->copyGC = new; + + /* + * Throw away all the current layout information. + */ + + FreeDLines(textPtr, dInfoPtr->dLinePtr, (DLine *) NULL, 1); + dInfoPtr->dLinePtr = NULL; + + /* + * Recompute some overall things for the layout. Even if the + * window gets very small, pretend that there's at least one + * pixel of drawing space in it. + */ + + if (textPtr->highlightWidth < 0) { + textPtr->highlightWidth = 0; + } + dInfoPtr->x = textPtr->highlightWidth + textPtr->borderWidth + + textPtr->padX; + dInfoPtr->y = textPtr->highlightWidth + textPtr->borderWidth + + textPtr->padY; + dInfoPtr->maxX = Tk_Width(textPtr->tkwin) - textPtr->highlightWidth + - textPtr->borderWidth - textPtr->padX; + if (dInfoPtr->maxX <= dInfoPtr->x) { + dInfoPtr->maxX = dInfoPtr->x + 1; + } + dInfoPtr->maxY = Tk_Height(textPtr->tkwin) - textPtr->highlightWidth + - textPtr->borderWidth - textPtr->padY; + if (dInfoPtr->maxY <= dInfoPtr->y) { + dInfoPtr->maxY = dInfoPtr->y + 1; + } + dInfoPtr->topOfEof = dInfoPtr->maxY; + + /* + * If the upper-left character isn't the first in a line, recompute + * it. This is necessary because a change in the window's size + * or options could change the way lines wrap. + */ + + if (textPtr->topIndex.charIndex != 0) { + MeasureUp(textPtr, &textPtr->topIndex, 0, &textPtr->topIndex); + } + + /* + * Invalidate cached scrollbar positions, so that scrollbars + * sliders will be udpated. + */ + + dInfoPtr->xScrollFirst = dInfoPtr->xScrollLast = -1; + dInfoPtr->yScrollFirst = dInfoPtr->yScrollLast = -1; +} + +/* + *---------------------------------------------------------------------- + * + * TkTextSetYView -- + * + * This procedure is called to specify what lines are to be + * displayed in a text widget. + * + * Results: + * None. + * + * Side effects: + * The display will (eventually) be updated so that the position + * given by "indexPtr" is visible on the screen at the position + * determined by "pickPlace". + * + *---------------------------------------------------------------------- + */ + +void +TkTextSetYView(textPtr, indexPtr, pickPlace) + TkText *textPtr; /* Widget record for text widget. */ + TkTextIndex *indexPtr; /* Position that is to appear somewhere + * in the view. */ + int pickPlace; /* 0 means topLine must appear at top of + * screen. 1 means we get to pick where it + * appears: minimize screen motion or else + * display line at center of screen. */ +{ + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + register DLine *dlPtr; + int bottomY, close, lineIndex, lineHeight; + TkTextIndex tmpIndex, rounded; + + /* + * If the specified position is the extra line at the end of the + * text, round it back to the last real line. + */ + + lineIndex = TkBTreeLineIndex(indexPtr->linePtr); + if (lineIndex == TkBTreeNumLines(indexPtr->tree)) { + TkTextIndexBackChars(indexPtr, 1, &rounded); + indexPtr = &rounded; + } + + if (!pickPlace) { + /* + * The specified position must go at the top of the screen. + * Just leave all the DLine's alone: we may be able to reuse + * some of the information that's currently on the screen + * without redisplaying it all. + */ + + if (indexPtr->charIndex == 0) { + textPtr->topIndex = *indexPtr; + } else { + MeasureUp(textPtr, indexPtr, 0, &textPtr->topIndex); + } + goto scheduleUpdate; + } + + /* + * We have to pick where to display the index. First, bring + * the display information up to date and see if the index will be + * completely visible in the current screen configuration. If so + * then there's nothing to do. + */ + + if (dInfoPtr->flags & DINFO_OUT_OF_DATE) { + UpdateDisplayInfo(textPtr); + } + dlPtr = FindDLine(dInfoPtr->dLinePtr, indexPtr); + if (dlPtr != NULL) { + if ((dlPtr->y + dlPtr->height) > dInfoPtr->maxY) { + /* + * Part of the line hangs off the bottom of the screen; + * pretend the whole line is off-screen. + */ + + dlPtr = NULL; + } else if ((dlPtr->index.linePtr == indexPtr->linePtr) + && (dlPtr->index.charIndex <= indexPtr->charIndex)) { + return; + } + } + + /* + * The desired line isn't already on-screen. Figure out what + * it means to be "close" to the top or bottom of the screen. + * Close means within 1/3 of the screen height or within three + * lines, whichever is greater. Add one extra line also, to + * account for the way MeasureUp rounds. + */ + + lineHeight = textPtr->fontPtr->ascent + textPtr->fontPtr->descent; + bottomY = (dInfoPtr->y + dInfoPtr->maxY + lineHeight)/2; + close = (dInfoPtr->maxY - dInfoPtr->y)/3; + if (close < 3*lineHeight) { + close = 3*lineHeight; + } + close += lineHeight; + if (dlPtr != NULL) { + /* + * The desired line is above the top of screen. If it is + * "close" to the top of the window then make it the top + * line on the screen. + */ + + MeasureUp(textPtr, &textPtr->topIndex, close, &tmpIndex); + if (TkTextIndexCmp(&tmpIndex, indexPtr) <= 0) { + MeasureUp(textPtr, indexPtr, 0, &textPtr->topIndex); + goto scheduleUpdate; + } + } else { + /* + * The desired line is below the bottom of the screen. If it is + * "close" to the bottom of the screen then position it at the + * bottom of the screen. + */ + + MeasureUp(textPtr, indexPtr, close, &tmpIndex); + if (FindDLine(dInfoPtr->dLinePtr, &tmpIndex) != NULL) { + bottomY = dInfoPtr->maxY - dInfoPtr->y; + } + } + + /* + * Our job now is to arrange the display so that indexPtr appears + * as low on the screen as possible but with its bottom no lower + * than bottomY. BottomY is the bottom of the window if the + * desired line is just below the current screen, otherwise it + * is a half-line lower than the center of the window. + */ + + MeasureUp(textPtr, indexPtr, bottomY, &textPtr->topIndex); + + scheduleUpdate: + if (!(dInfoPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(DisplayText, (ClientData) textPtr); + } + dInfoPtr->flags |= REDRAW_PENDING|DINFO_OUT_OF_DATE|REPICK_NEEDED; +} + +/* + *-------------------------------------------------------------- + * + * MeasureUp -- + * + * Given one index, find the index of the first character + * on the highest display line that would be displayed no more + * than "distance" pixels above the given index. + * + * Results: + * *dstPtr is filled in with the index of the first character + * on a display line. The display line is found by measuring + * up "distance" pixels above the pixel just below an imaginary + * display line that contains srcPtr. If the display line + * that covers this coordinate actually extends above the + * coordinate, then return the index of the next lower line + * instead (i.e. the returned index will be completely visible + * at or below the given y-coordinate). + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static void +MeasureUp(textPtr, srcPtr, distance, dstPtr) + TkText *textPtr; /* Text widget in which to measure. */ + TkTextIndex *srcPtr; /* Index of character from which to start + * measuring. */ + int distance; /* Vertical distance in pixels measured + * from the pixel just below the lowest + * one in srcPtr's line. */ + TkTextIndex *dstPtr; /* Index to fill in with result. */ +{ + int lineNum; /* Number of current line. */ + int charsToCount; /* Maximum number of characters to measure + * in current line. */ + TkTextIndex bestIndex; /* Best candidate seen so far for result. */ + TkTextIndex index; + DLine *dlPtr, *lowestPtr; + int noBestYet; /* 1 means bestIndex hasn't been set. */ + + noBestYet = 1; + charsToCount = srcPtr->charIndex + 1; + index.tree = srcPtr->tree; + for (lineNum = TkBTreeLineIndex(srcPtr->linePtr); lineNum >= 0; + lineNum--) { + /* + * Layout an entire text line (potentially > 1 display line). + * For the first line, which contains srcPtr, only layout the + * part up through srcPtr (charsToCount is non-infinite to + * accomplish this). Make a list of all the display lines + * in backwards order (the lowest DLine on the screen is first + * in the list). + */ + + index.linePtr = TkBTreeFindLine(srcPtr->tree, lineNum); + index.charIndex = 0; + lowestPtr = NULL; + do { + dlPtr = LayoutDLine(textPtr, &index); + dlPtr->nextPtr = lowestPtr; + lowestPtr = dlPtr; + TkTextIndexForwChars(&index, dlPtr->count, &index); + charsToCount -= dlPtr->count; + } while ((charsToCount > 0) && (index.linePtr == dlPtr->index.linePtr)); + + /* + * Scan through the display lines to see if we've covered enough + * vertical distance. If so, save the starting index for the + * line at the desired location. + */ + + for (dlPtr = lowestPtr; dlPtr != NULL; dlPtr = dlPtr->nextPtr) { + distance -= dlPtr->height; + if (distance < 0) { + *dstPtr = (noBestYet) ? dlPtr->index : bestIndex; + break; + } + bestIndex = dlPtr->index; + noBestYet = 0; + } + + /* + * Discard the display lines, then either return or prepare + * for the next display line to lay out. + */ + + FreeDLines(textPtr, lowestPtr, (DLine *) NULL, 0); + if (distance < 0) { + return; + } + charsToCount = INT_MAX; /* Consider all chars. in next line. */ + } + + /* + * Ran off the beginning of the text. Return the first character + * in the text. + */ + + TkTextMakeIndex(textPtr->tree, 0, 0, dstPtr); +} + +/* + *-------------------------------------------------------------- + * + * TkTextSeeCmd -- + * + * This procedure is invoked to process the "see" option for + * the widget command for text widgets. See the user documentation + * for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +int +TkTextSeeCmd(textPtr, interp, argc, argv) + TkText *textPtr; /* Information about text widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. Someone else has already + * parsed this command enough to know that + * argv[1] is "see". */ +{ + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + TkTextIndex index; + int x, y, width, height, lineWidth, charCount, oneThird, delta; + DLine *dlPtr; + TkTextDispChunk *chunkPtr; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " see index\"", (char *) NULL); + return TCL_ERROR; + } + if (TkTextGetIndex(interp, textPtr, argv[2], &index) != TCL_OK) { + return TCL_ERROR; + } + + /* + * If the specified position is the extra line at the end of the + * text, round it back to the last real line. + */ + + if (TkBTreeLineIndex(index.linePtr) == TkBTreeNumLines(index.tree)) { + TkTextIndexBackChars(&index, 1, &index); + } + + /* + * First get the desired position into the vertical range of the window. + */ + + TkTextSetYView(textPtr, &index, 1); + + /* + * Now make sure that the character is in view horizontally. + */ + + if (dInfoPtr->flags & DINFO_OUT_OF_DATE) { + UpdateDisplayInfo(textPtr); + } + lineWidth = dInfoPtr->maxX - dInfoPtr->x; + if (dInfoPtr->maxLength < lineWidth) { + return TCL_OK; + } + + /* + * Find the chunk that contains the desired index. + */ + + dlPtr = FindDLine(dInfoPtr->dLinePtr, &index); + charCount = index.charIndex - dlPtr->index.charIndex; + for (chunkPtr = dlPtr->chunkPtr; ; chunkPtr = chunkPtr->nextPtr) { + if (charCount < chunkPtr->numChars) { + break; + } + charCount -= chunkPtr->numChars; + } + + /* + * Call a chunk-specific procedure to find the horizontal range of + * the character within the chunk. + */ + + (*chunkPtr->bboxProc)(chunkPtr, charCount, dlPtr->y + dlPtr->spaceAbove, + dlPtr->height - dlPtr->spaceAbove - dlPtr->spaceBelow, + dlPtr->baseline - dlPtr->spaceAbove, &x, &y, &width, + &height); + delta = x - dInfoPtr->curPixelOffset; + oneThird = lineWidth/3; + if (delta < 0) { + if (delta < -oneThird) { + dInfoPtr->newCharOffset = (x - lineWidth/2)/textPtr->charWidth; + } else { + dInfoPtr->newCharOffset -= ((-delta) + textPtr->charWidth - 1) + / textPtr->charWidth; + } + } else { + delta -= (lineWidth - width); + if (delta > 0) { + if (delta > oneThird) { + dInfoPtr->newCharOffset = (x - lineWidth/2)/textPtr->charWidth; + } else { + dInfoPtr->newCharOffset += (delta + textPtr->charWidth - 1) + / textPtr->charWidth; + } + } else { + return TCL_OK; + } + } + dInfoPtr->flags |= DINFO_OUT_OF_DATE; + if (!(dInfoPtr->flags & REDRAW_PENDING)) { + dInfoPtr->flags |= REDRAW_PENDING; + Tcl_DoWhenIdle(DisplayText, (ClientData) textPtr); + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * TkTextXviewCmd -- + * + * This procedure is invoked to process the "xview" option for + * the widget command for text widgets. See the user documentation + * for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +int +TkTextXviewCmd(textPtr, interp, argc, argv) + TkText *textPtr; /* Information about text widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. Someone else has already + * parsed this command enough to know that + * argv[1] is "xview". */ +{ + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + int type, charsPerPage, count, newOffset; + double fraction; + + if (dInfoPtr->flags & DINFO_OUT_OF_DATE) { + UpdateDisplayInfo(textPtr); + } + + if (argc == 2) { + GetXView(interp, textPtr, 0); + return TCL_OK; + } + + newOffset = dInfoPtr->newCharOffset; + type = Tk_GetScrollInfo(interp, argc, argv, &fraction, &count); + switch (type) { + case TK_SCROLL_ERROR: + return TCL_ERROR; + case TK_SCROLL_MOVETO: + if (fraction > 1.0) { + fraction = 1.0; + } + if (fraction < 0) { + fraction = 0; + } + newOffset = ((fraction * dInfoPtr->maxLength) / textPtr->charWidth) + + 0.5; + break; + case TK_SCROLL_PAGES: + charsPerPage = ((dInfoPtr->maxX - dInfoPtr->x) / textPtr->charWidth) + - 2; + if (charsPerPage < 1) { + charsPerPage = 1; + } + newOffset += charsPerPage*count; + break; + case TK_SCROLL_UNITS: + newOffset += count; + break; + } + + dInfoPtr->newCharOffset = newOffset; + dInfoPtr->flags |= DINFO_OUT_OF_DATE; + if (!(dInfoPtr->flags & REDRAW_PENDING)) { + dInfoPtr->flags |= REDRAW_PENDING; + Tcl_DoWhenIdle(DisplayText, (ClientData) textPtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ScrollByLines -- + * + * This procedure is called to scroll a text widget up or down + * by a given number of lines. + * + * Results: + * None. + * + * Side effects: + * The view in textPtr's window changes to reflect the value + * of "offset". + * + *---------------------------------------------------------------------- + */ + +static void +ScrollByLines(textPtr, offset) + TkText *textPtr; /* Widget to scroll. */ + int offset; /* Amount by which to scroll, in *screen* + * lines. Positive means that information + * later in text becomes visible, negative + * means that information earlier in the + * text becomes visible. */ +{ + int i, charsToCount, lineNum; + TkTextIndex new, index; + TkTextLine *lastLinePtr; + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + DLine *dlPtr, *lowestPtr; + + if (offset < 0) { + /* + * Must scroll up (to show earlier information in the text). + * The code below is similar to that in MeasureUp, except that + * it counts lines instead of pixels. + */ + + charsToCount = textPtr->topIndex.charIndex + 1; + index.tree = textPtr->tree; + offset--; /* Skip line containing topIndex. */ + for (lineNum = TkBTreeLineIndex(textPtr->topIndex.linePtr); + lineNum >= 0; lineNum--) { + index.linePtr = TkBTreeFindLine(textPtr->tree, lineNum); + index.charIndex = 0; + lowestPtr = NULL; + do { + dlPtr = LayoutDLine(textPtr, &index); + dlPtr->nextPtr = lowestPtr; + lowestPtr = dlPtr; + TkTextIndexForwChars(&index, dlPtr->count, &index); + charsToCount -= dlPtr->count; + } while ((charsToCount > 0) + && (index.linePtr == dlPtr->index.linePtr)); + + for (dlPtr = lowestPtr; dlPtr != NULL; dlPtr = dlPtr->nextPtr) { + offset++; + if (offset == 0) { + textPtr->topIndex = dlPtr->index; + break; + } + } + + /* + * Discard the display lines, then either return or prepare + * for the next display line to lay out. + */ + + FreeDLines(textPtr, lowestPtr, (DLine *) NULL, 0); + if (offset >= 0) { + goto scheduleUpdate; + } + charsToCount = INT_MAX; + } + + /* + * Ran off the beginning of the text. Return the first character + * in the text. + */ + + TkTextMakeIndex(textPtr->tree, 0, 0, &textPtr->topIndex); + } else { + /* + * Scrolling down, to show later information in the text. + * Just count lines from the current top of the window. + */ + + lastLinePtr = TkBTreeFindLine(textPtr->tree, + TkBTreeNumLines(textPtr->tree)); + for (i = 0; i < offset; i++) { + dlPtr = LayoutDLine(textPtr, &textPtr->topIndex); + dlPtr->nextPtr = NULL; + TkTextIndexForwChars(&textPtr->topIndex, dlPtr->count, &new); + FreeDLines(textPtr, dlPtr, (DLine *) NULL, 0); + if (new.linePtr == lastLinePtr) { + break; + } + textPtr->topIndex = new; + } + } + + scheduleUpdate: + if (!(dInfoPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(DisplayText, (ClientData) textPtr); + } + dInfoPtr->flags |= REDRAW_PENDING|DINFO_OUT_OF_DATE|REPICK_NEEDED; +} + +/* + *-------------------------------------------------------------- + * + * TkTextYviewCmd -- + * + * This procedure is invoked to process the "yview" option for + * the widget command for text widgets. See the user documentation + * for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +int +TkTextYviewCmd(textPtr, interp, argc, argv) + TkText *textPtr; /* Information about text widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. Someone else has already + * parsed this command enough to know that + * argv[1] is "yview". */ +{ + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + int pickPlace, lineNum, type, lineHeight, charsInLine; + int pixels, count; + size_t switchLength; + double fraction; + TkTextIndex index, new; + TkTextLine *lastLinePtr; + DLine *dlPtr; + + if (dInfoPtr->flags & DINFO_OUT_OF_DATE) { + UpdateDisplayInfo(textPtr); + } + + if (argc == 2) { + GetYView(interp, textPtr, 0); + return TCL_OK; + } + + /* + * Next, handle the old syntax: "pathName yview ?-pickplace? where" + */ + + pickPlace = 0; + if (argv[2][0] == '-') { + switchLength = strlen(argv[2]); + if ((switchLength >= 2) + && (strncmp(argv[2], "-pickplace", switchLength) == 0)) { + pickPlace = 1; + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " yview -pickplace lineNum|index\"", + (char *) NULL); + return TCL_ERROR; + } + } + } + if ((argc == 3) || pickPlace) { + if (Tcl_GetInt(interp, argv[2+pickPlace], &lineNum) == TCL_OK) { + TkTextMakeIndex(textPtr->tree, lineNum, 0, &index); + TkTextSetYView(textPtr, &index, 0); + return TCL_OK; + } + + /* + * The argument must be a regular text index. + */ + + Tcl_ResetResult(interp); + if (TkTextGetIndex(interp, textPtr, argv[2+pickPlace], + &index) != TCL_OK) { + return TCL_ERROR; + } + TkTextSetYView(textPtr, &index, pickPlace); + return TCL_OK; + } + + /* + * New syntax: dispatch based on argv[2]. + */ + + type = Tk_GetScrollInfo(interp, argc, argv, &fraction, &count); + switch (type) { + case TK_SCROLL_ERROR: + return TCL_ERROR; + case TK_SCROLL_MOVETO: + if (fraction > 1.0) { + fraction = 1.0; + } + if (fraction < 0) { + fraction = 0; + } + fraction *= TkBTreeNumLines(textPtr->tree); + lineNum = fraction; + TkTextMakeIndex(textPtr->tree, lineNum, 0, &index); + charsInLine = TkBTreeCharsInLine(index.linePtr); + index.charIndex = (charsInLine * (fraction-lineNum)) + 0.5; + if (index.charIndex >= charsInLine) { + TkTextMakeIndex(textPtr->tree, lineNum+1, 0, &index); + } + TkTextSetYView(textPtr, &index, 0); + break; + case TK_SCROLL_PAGES: + /* + * Scroll up or down by screenfuls. Actually, use the + * window height minus two lines, so that there's some + * overlap between adjacent pages. + */ + + lineHeight = textPtr->fontPtr->ascent + textPtr->fontPtr->descent; + if (count < 0) { + pixels = (dInfoPtr->maxY - 2*lineHeight - dInfoPtr->y)*(-count) + + lineHeight; + MeasureUp(textPtr, &textPtr->topIndex, pixels, &new); + if (TkTextIndexCmp(&textPtr->topIndex, &new) == 0) { + /* + * A page of scrolling ended up being less than one line. + * Scroll one line anyway. + */ + + count = -1; + goto scrollByLines; + } + textPtr->topIndex = new; + } else { + /* + * Scrolling down by pages. Layout lines starting at the + * top index and count through the desired vertical distance. + */ + + pixels = (dInfoPtr->maxY - 2*lineHeight - dInfoPtr->y)*count; + lastLinePtr = TkBTreeFindLine(textPtr->tree, + TkBTreeNumLines(textPtr->tree)); + do { + dlPtr = LayoutDLine(textPtr, &textPtr->topIndex); + dlPtr->nextPtr = NULL; + TkTextIndexForwChars(&textPtr->topIndex, dlPtr->count, + &new); + pixels -= dlPtr->height; + FreeDLines(textPtr, dlPtr, (DLine *) NULL, 0); + if (new.linePtr == lastLinePtr) { + break; + } + textPtr->topIndex = new; + } while (pixels > 0); + } + if (!(dInfoPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(DisplayText, (ClientData) textPtr); + } + dInfoPtr->flags |= REDRAW_PENDING|DINFO_OUT_OF_DATE|REPICK_NEEDED; + break; + case TK_SCROLL_UNITS: + scrollByLines: + ScrollByLines(textPtr, count); + break; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * TkTextScanCmd -- + * + * This procedure is invoked to process the "scan" option for + * the widget command for text widgets. See the user documentation + * for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +int +TkTextScanCmd(textPtr, interp, argc, argv) + register TkText *textPtr; /* Information about text widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. Someone else has already + * parsed this command enough to know that + * argv[1] is "scan". */ +{ + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + TkTextIndex index; + int c, x, y, totalScroll, newChar, maxChar; + size_t length; + + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " scan mark|dragto x y\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[3], &x) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[4], &y) != TCL_OK) { + return TCL_ERROR; + } + c = argv[2][0]; + length = strlen(argv[2]); + if ((c == 'd') && (strncmp(argv[2], "dragto", length) == 0)) { + /* + * Amplify the difference between the current position and the + * mark position to compute how much the view should shift, then + * update the mark position to correspond to the new view. If we + * run off the edge of the text, reset the mark point so that the + * current position continues to correspond to the edge of the + * window. This means that the picture will start dragging as + * soon as the mouse reverses direction (without this reset, might + * have to slide mouse a long ways back before the picture starts + * moving again). + */ + + newChar = dInfoPtr->scanMarkChar + (10*(dInfoPtr->scanMarkX - x)) + / (textPtr->charWidth); + maxChar = 1 + (dInfoPtr->maxLength - (dInfoPtr->maxX - dInfoPtr->x) + + textPtr->charWidth - 1)/textPtr->charWidth; + if (newChar < 0) { + dInfoPtr->scanMarkChar = newChar = 0; + dInfoPtr->scanMarkX = x; + } else if (newChar > maxChar) { + dInfoPtr->scanMarkChar = newChar = maxChar; + dInfoPtr->scanMarkX = x; + } + dInfoPtr->newCharOffset = newChar; + + totalScroll = (10*(dInfoPtr->scanMarkY - y)) + / (textPtr->fontPtr->ascent + textPtr->fontPtr->descent); + if (totalScroll != dInfoPtr->scanTotalScroll) { + index = textPtr->topIndex; + ScrollByLines(textPtr, totalScroll-dInfoPtr->scanTotalScroll); + dInfoPtr->scanTotalScroll = totalScroll; + if ((index.linePtr == textPtr->topIndex.linePtr) && + (index.charIndex == textPtr->topIndex.charIndex)) { + dInfoPtr->scanTotalScroll = 0; + dInfoPtr->scanMarkY = y; + } + } + } else if ((c == 'm') && (strncmp(argv[2], "mark", length) == 0)) { + dInfoPtr->scanMarkChar = dInfoPtr->newCharOffset; + dInfoPtr->scanMarkX = x; + dInfoPtr->scanTotalScroll = 0; + dInfoPtr->scanMarkY = y; + } else { + Tcl_AppendResult(interp, "bad scan option \"", argv[2], + "\": must be mark or dragto", (char *) NULL); + return TCL_ERROR; + } + dInfoPtr->flags |= DINFO_OUT_OF_DATE; + if (!(dInfoPtr->flags & REDRAW_PENDING)) { + dInfoPtr->flags |= REDRAW_PENDING; + Tcl_DoWhenIdle(DisplayText, (ClientData) textPtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * GetXView -- + * + * This procedure computes the fractions that indicate what's + * visible in a text window and, optionally, evaluates a + * Tcl script to report them to the text's associated scrollbar. + * + * Results: + * If report is zero, then interp->result is filled in with + * two real numbers separated by a space, giving the position of + * the left and right edges of the window as fractions from 0 to + * 1, where 0 means the left edge of the text and 1 means the right + * edge. If report is non-zero, then interp->result isn't modified + * directly, but instead a script is evaluated in interp to report + * the new horizontal scroll position to the scrollbar (if the scroll + * position hasn't changed then no script is invoked). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +GetXView(interp, textPtr, report) + Tcl_Interp *interp; /* If "report" is FALSE, string + * describing visible range gets + * stored in interp->result. */ + TkText *textPtr; /* Information about text widget. */ + int report; /* Non-zero means report info to + * scrollbar if it has changed. */ +{ + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + char buffer[200]; + double first, last; + int code; + + if (dInfoPtr->maxLength > 0) { + first = ((double) dInfoPtr->curPixelOffset) + / dInfoPtr->maxLength; + last = first + ((double) (dInfoPtr->maxX - dInfoPtr->x)) + / dInfoPtr->maxLength; + if (last > 1.0) { + last = 1.0; + } + } else { + first = 0; + last = 1.0; + } + if (!report) { + sprintf(interp->result, "%g %g", first, last); + return; + } + if ((first == dInfoPtr->xScrollFirst) && (last == dInfoPtr->xScrollLast)) { + return; + } + dInfoPtr->xScrollFirst = first; + dInfoPtr->xScrollLast = last; + sprintf(buffer, " %g %g", first, last); + code = Tcl_VarEval(interp, textPtr->xScrollCmd, + buffer, (char *) NULL); + if (code != TCL_OK) { + Tcl_AddErrorInfo(interp, + "\n (horizontal scrolling command executed by text)"); + Tcl_BackgroundError(interp); + } +} + +/* + *---------------------------------------------------------------------- + * + * GetYView -- + * + * This procedure computes the fractions that indicate what's + * visible in a text window and, optionally, evaluates a + * Tcl script to report them to the text's associated scrollbar. + * + * Results: + * If report is zero, then interp->result is filled in with + * two real numbers separated by a space, giving the position of + * the top and bottom of the window as fractions from 0 to 1, where + * 0 means the beginning of the text and 1 means the end. If + * report is non-zero, then interp->result isn't modified directly, + * but a script is evaluated in interp to report the new scroll + * position to the scrollbar (if the scroll position hasn't changed + * then no script is invoked). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +GetYView(interp, textPtr, report) + Tcl_Interp *interp; /* If "report" is FALSE, string + * describing visible range gets + * stored in interp->result. */ + TkText *textPtr; /* Information about text widget. */ + int report; /* Non-zero means report info to + * scrollbar if it has changed. */ +{ + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + char buffer[200]; + double first, last; + DLine *dlPtr; + int totalLines, code, count; + + dlPtr = dInfoPtr->dLinePtr; + totalLines = TkBTreeNumLines(textPtr->tree); + first = ((double) TkBTreeLineIndex(dlPtr->index.linePtr)) + + ((double) dlPtr->index.charIndex) + / (TkBTreeCharsInLine(dlPtr->index.linePtr)); + first /= totalLines; + while (1) { + if ((dlPtr->y + dlPtr->height) > dInfoPtr->maxY) { + /* + * The last line is only partially visible, so don't + * count its characters in what's visible. + */ + count = 0; + break; + } + if (dlPtr->nextPtr == NULL) { + count = dlPtr->count; + break; + } + dlPtr = dlPtr->nextPtr; + } + last = ((double) TkBTreeLineIndex(dlPtr->index.linePtr)) + + ((double) (dlPtr->index.charIndex + count)) + / (TkBTreeCharsInLine(dlPtr->index.linePtr)); + last /= totalLines; + if (!report) { + sprintf(interp->result, "%g %g", first, last); + return; + } + if ((first == dInfoPtr->yScrollFirst) && (last == dInfoPtr->yScrollLast)) { + return; + } + dInfoPtr->yScrollFirst = first; + dInfoPtr->yScrollLast = last; + sprintf(buffer, " %g %g", first, last); + code = Tcl_VarEval(interp, textPtr->yScrollCmd, + buffer, (char *) NULL); + if (code != TCL_OK) { + Tcl_AddErrorInfo(interp, + "\n (vertical scrolling command executed by text)"); + Tcl_BackgroundError(interp); + } +} + +/* + *---------------------------------------------------------------------- + * + * FindDLine -- + * + * This procedure is called to find the DLine corresponding to a + * given text index. + * + * Results: + * The return value is a pointer to the first DLine found in the + * list headed by dlPtr that displays information at or after the + * specified position. If there is no such line in the list then + * NULL is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static DLine * +FindDLine(dlPtr, indexPtr) + register DLine *dlPtr; /* Pointer to first in list of DLines + * to search. */ + TkTextIndex *indexPtr; /* Index of desired character. */ +{ + TkTextLine *linePtr; + + if (dlPtr == NULL) { + return NULL; + } + if (TkBTreeLineIndex(indexPtr->linePtr) + < TkBTreeLineIndex(dlPtr->index.linePtr)) { + /* + * The first display line is already past the desired line. + */ + return dlPtr; + } + + /* + * Find the first display line that covers the desired text line. + */ + + linePtr = dlPtr->index.linePtr; + while (linePtr != indexPtr->linePtr) { + while (dlPtr->index.linePtr == linePtr) { + dlPtr = dlPtr->nextPtr; + if (dlPtr == NULL) { + return NULL; + } + } + linePtr = TkBTreeNextLine(linePtr); + if (linePtr == NULL) { + panic("FindDLine reached end of text"); + } + } + if (indexPtr->linePtr != dlPtr->index.linePtr) { + return dlPtr; + } + + /* + * Now get to the right position within the text line. + */ + + while (indexPtr->charIndex >= (dlPtr->index.charIndex + dlPtr->count)) { + dlPtr = dlPtr->nextPtr; + if ((dlPtr == NULL) || (dlPtr->index.linePtr != indexPtr->linePtr)) { + break; + } + } + return dlPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TkTextPixelIndex -- + * + * Given an (x,y) coordinate on the screen, find the location of + * the character closest to that location. + * + * Results: + * The index at *indexPtr is modified to refer to the character + * on the display that is closest to (x,y). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TkTextPixelIndex(textPtr, x, y, indexPtr) + TkText *textPtr; /* Widget record for text widget. */ + int x, y; /* Pixel coordinates of point in widget's + * window. */ + TkTextIndex *indexPtr; /* This index gets filled in with the + * index of the character nearest to (x,y). */ +{ + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + register DLine *dlPtr; + register TkTextDispChunk *chunkPtr; + + /* + * Make sure that all of the layout information about what's + * displayed where on the screen is up-to-date. + */ + + if (dInfoPtr->flags & DINFO_OUT_OF_DATE) { + UpdateDisplayInfo(textPtr); + } + + /* + * If the coordinates are above the top of the window, then adjust + * them to refer to the upper-right corner of the window. If they're + * off to one side or the other, then adjust to the closest side. + */ + + if (y < dInfoPtr->y) { + y = dInfoPtr->y; + x = dInfoPtr->x; + } + if (x >= dInfoPtr->maxX) { + x = dInfoPtr->maxX - 1; + } + if (x < dInfoPtr->x) { + x = dInfoPtr->x; + } + + /* + * Find the display line containing the desired y-coordinate. + */ + + for (dlPtr = dInfoPtr->dLinePtr; y >= (dlPtr->y + dlPtr->height); + dlPtr = dlPtr->nextPtr) { + if (dlPtr->nextPtr == NULL) { + /* + * Y-coordinate is off the bottom of the displayed text. + * Use the last character on the last line. + */ + + x = dInfoPtr->maxX - 1; + break; + } + } + + /* + * Scan through the line's chunks to find the one that contains + * the desired x-coordinate. Before doing this, translate the + * x-coordinate from the coordinate system of the window to the + * coordinate system of the line (to take account of x-scrolling). + */ + + *indexPtr = dlPtr->index; + x = x - dInfoPtr->x + dInfoPtr->curPixelOffset; + for (chunkPtr = dlPtr->chunkPtr; x >= (chunkPtr->x + chunkPtr->width); + indexPtr->charIndex += chunkPtr->numChars, + chunkPtr = chunkPtr->nextPtr) { + if (chunkPtr->nextPtr == NULL) { + indexPtr->charIndex += chunkPtr->numChars - 1; + return; + } + } + + /* + * If the chunk has more than one character in it, ask it which + * character is at the desired location. + */ + + if (chunkPtr->numChars > 1) { + indexPtr->charIndex += (*chunkPtr->measureProc)(chunkPtr, x); + } +} + +/* + *---------------------------------------------------------------------- + * + * TkTextCharBbox -- + * + * Given an index, find the bounding box of the screen area + * occupied by that character. + * + * Results: + * Zero is returned if the character is on the screen. -1 + * means the character isn't on the screen. If the return value + * is 0, then the bounding box of the part of the character that's + * visible on the screen is returned to *xPtr, *yPtr, *widthPtr, + * and *heightPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TkTextCharBbox(textPtr, indexPtr, xPtr, yPtr, widthPtr, heightPtr) + TkText *textPtr; /* Widget record for text widget. */ + TkTextIndex *indexPtr; /* Index of character whose bounding + * box is desired. */ + int *xPtr, *yPtr; /* Filled with character's upper-left + * coordinate. */ + int *widthPtr, *heightPtr; /* Filled in with character's dimensions. */ +{ + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + DLine *dlPtr; + register TkTextDispChunk *chunkPtr; + int index; + + /* + * Make sure that all of the screen layout information is up to date. + */ + + if (dInfoPtr->flags & DINFO_OUT_OF_DATE) { + UpdateDisplayInfo(textPtr); + } + + /* + * Find the display line containing the desired index. + */ + + dlPtr = FindDLine(dInfoPtr->dLinePtr, indexPtr); + if ((dlPtr == NULL) || (TkTextIndexCmp(&dlPtr->index, indexPtr) > 0)) { + return -1; + } + + /* + * Find the chunk within the line that contains the desired + * index. + */ + + index = indexPtr->charIndex - dlPtr->index.charIndex; + for (chunkPtr = dlPtr->chunkPtr; ; chunkPtr = chunkPtr->nextPtr) { + if (chunkPtr == NULL) { + return -1; + } + if (index < chunkPtr->numChars) { + break; + } + index -= chunkPtr->numChars; + } + + /* + * Call a chunk-specific procedure to find the horizontal range of + * the character within the chunk, then fill in the vertical range. + * The x-coordinate returned by bboxProc is a coordinate within a + * line, not a coordinate on the screen. Translate it to reflect + * horizontal scrolling. + */ + + (*chunkPtr->bboxProc)(chunkPtr, index, dlPtr->y + dlPtr->spaceAbove, + dlPtr->height - dlPtr->spaceAbove - dlPtr->spaceBelow, + dlPtr->baseline - dlPtr->spaceAbove, xPtr, yPtr, widthPtr, + heightPtr); + *xPtr = *xPtr + dInfoPtr->x - dInfoPtr->curPixelOffset; + if ((index == (chunkPtr->numChars-1)) && (chunkPtr->nextPtr == NULL)) { + /* + * Last character in display line. Give it all the space up to + * the line. + */ + + if (*xPtr > dInfoPtr->maxX) { + *xPtr = dInfoPtr->maxX; + } + *widthPtr = dInfoPtr->maxX - *xPtr; + } + if ((*xPtr + *widthPtr) <= dInfoPtr->x) { + return -1; + } + if ((*xPtr + *widthPtr) > dInfoPtr->maxX) { + *widthPtr = dInfoPtr->maxX - *xPtr; + if (*widthPtr <= 0) { + return -1; + } + } + if ((*yPtr + *heightPtr) > dInfoPtr->maxY) { + *heightPtr = dInfoPtr->maxY - *yPtr; + if (*heightPtr <= 0) { + return -1; + } + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * TkTextDLineInfo -- + * + * Given an index, return information about the display line + * containing that character. + * + * Results: + * Zero is returned if the character is on the screen. -1 + * means the character isn't on the screen. If the return value + * is 0, then information is returned in the variables pointed + * to by xPtr, yPtr, widthPtr, heightPtr, and basePtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TkTextDLineInfo(textPtr, indexPtr, xPtr, yPtr, widthPtr, heightPtr, basePtr) + TkText *textPtr; /* Widget record for text widget. */ + TkTextIndex *indexPtr; /* Index of character whose bounding + * box is desired. */ + int *xPtr, *yPtr; /* Filled with line's upper-left + * coordinate. */ + int *widthPtr, *heightPtr; /* Filled in with line's dimensions. */ + int *basePtr; /* Filled in with the baseline position, + * measured as an offset down from *yPtr. */ +{ + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + DLine *dlPtr; + + /* + * Make sure that all of the screen layout information is up to date. + */ + + if (dInfoPtr->flags & DINFO_OUT_OF_DATE) { + UpdateDisplayInfo(textPtr); + } + + /* + * Find the display line containing the desired index. + */ + + dlPtr = FindDLine(dInfoPtr->dLinePtr, indexPtr); + if ((dlPtr == NULL) || (TkTextIndexCmp(&dlPtr->index, indexPtr) > 0)) { + return -1; + } + + *xPtr = dInfoPtr->x - dInfoPtr->curPixelOffset + dlPtr->chunkPtr->x; + *widthPtr = dlPtr->length - dlPtr->chunkPtr->x; + *yPtr = dlPtr->y; + if ((dlPtr->y + dlPtr->height) > dInfoPtr->maxY) { + *heightPtr = dInfoPtr->maxY - dlPtr->y; + } else { + *heightPtr = dlPtr->height; + } + *basePtr = dlPtr->baseline; + return 0; +} + +/* + *-------------------------------------------------------------- + * + * TkTextCharLayoutProc -- + * + * This procedure is the "layoutProc" for character segments. + * + * Results: + * If there is something to display for the chunk then a + * non-zero value is returned and the fields of chunkPtr + * will be filled in (see the declaration of TkTextDispChunk + * in tkText.h for details). If zero is returned it means + * that no characters from this chunk fit in the window. + * If -1 is returned it means that this segment just doesn't + * need to be displayed (never happens for text). + * + * Side effects: + * Memory is allocated to hold additional information about + * the chunk. + * + *-------------------------------------------------------------- + */ + +int +TkTextCharLayoutProc(textPtr, indexPtr, segPtr, offset, maxX, maxChars, + noCharsYet, wrapMode, chunkPtr) + TkText *textPtr; /* Text widget being layed out. */ + TkTextIndex *indexPtr; /* Index of first character to lay out + * (corresponds to segPtr and offset). */ + TkTextSegment *segPtr; /* Segment being layed out. */ + int offset; /* Offset within segment of first character + * to consider. */ + int maxX; /* Chunk must not occupy pixels at this + * position or higher. */ + int maxChars; /* Chunk must not include more than this + * many characters. */ + int noCharsYet; /* Non-zero means no characters have been + * assigned to this display line yet. */ + Tk_Uid wrapMode; /* How to handle line wrapping: tkTextCharUid, + * tkTextNoneUid, or tkTextWordUid. */ + register TkTextDispChunk *chunkPtr; + /* Structure to fill in with information + * about this chunk. The x field has already + * been set by the caller. */ +{ + XFontStruct *fontPtr; + int nextX, charsThatFit, count; + CharInfo *ciPtr; + char *p; + TkTextSegment *nextPtr; + + /* + * Figure out how many characters will fit in the space we've got. + * Include the next character, even though it won't fit completely, + * if any of the following is true: + * (a) the chunk contains no characters and the display line contains + * no characters yet (i.e. the line isn't wide enough to hold + * even a single character). + * (b) at least one pixel of the character is visible, we haven't + * already exceeded the character limit, and the next character + * is a white space character. + */ + + p = segPtr->body.chars + offset; + fontPtr = chunkPtr->stylePtr->sValuePtr->fontPtr; + charsThatFit = TkMeasureChars(fontPtr, p, maxChars, chunkPtr->x, + maxX, 0, TK_IGNORE_TABS, &nextX); + if (charsThatFit < maxChars) { + if ((charsThatFit == 0) && noCharsYet) { + charsThatFit = 1; + TkMeasureChars(fontPtr, p, 1, chunkPtr->x, INT_MAX, 0, + TK_IGNORE_TABS, &nextX); + } + if ((nextX < maxX) && ((p[charsThatFit] == ' ') + || (p[charsThatFit] == '\t'))) { + /* + * Space characters are funny, in that they are considered + * to fit if there is at least one pixel of space left on the + * line. Just give the space character whatever space is left. + */ + + nextX = maxX; + charsThatFit++; + } + if (p[charsThatFit] == '\n') { + /* + * A newline character takes up no space, so if the previous + * character fits then so does the newline. + */ + + charsThatFit++; + } + if (charsThatFit == 0) { + return 0; + } + } + + /* + * Fill in the chunk structure and allocate and initialize a + * CharInfo structure. If the last character is a newline + * then don't bother to display it. + */ + + chunkPtr->displayProc = CharDisplayProc; + chunkPtr->undisplayProc = CharUndisplayProc; + chunkPtr->measureProc = CharMeasureProc; + chunkPtr->bboxProc = CharBboxProc; + chunkPtr->numChars = charsThatFit; + chunkPtr->minAscent = fontPtr->ascent + + chunkPtr->stylePtr->sValuePtr->offset; + chunkPtr->minDescent = fontPtr->descent + - chunkPtr->stylePtr->sValuePtr->offset;; + chunkPtr->minHeight = 0; + chunkPtr->width = nextX - chunkPtr->x; + chunkPtr->breakIndex = -1; + ciPtr = (CharInfo *) ckalloc((unsigned) + (sizeof(CharInfo) - 3 + charsThatFit)); + chunkPtr->clientData = (ClientData) ciPtr; + ciPtr->numChars = charsThatFit; + strncpy(ciPtr->chars, p, (size_t) charsThatFit); + if (p[charsThatFit-1] == '\n' || p[charsThatFit-1] == '\r') { + ciPtr->numChars--; + } + + /* + * Compute a break location. If we're in word wrap mode, a + * break can occur after any space character, or at the end of + * the chunk if the next segment (ignoring those with zero size) + * is not a character segment. + */ + + if (wrapMode != tkTextWordUid) { + chunkPtr->breakIndex = chunkPtr->numChars; + } else { + for (count = charsThatFit, p += charsThatFit-1; count > 0; + count--, p--) { + if (isspace(UCHAR(*p))) { + chunkPtr->breakIndex = count; + break; + } + } + if ((charsThatFit+offset) == segPtr->size) { + for (nextPtr = segPtr->nextPtr; nextPtr != NULL; + nextPtr = nextPtr->nextPtr) { + if (nextPtr->size != 0) { + if (nextPtr->typePtr != &tkTextCharType) { + chunkPtr->breakIndex = chunkPtr->numChars; + } + break; + } + } + } + } + return 1; +} + +/* + *-------------------------------------------------------------- + * + * CharDisplayProc -- + * + * This procedure is called to display a character chunk on + * the screen or in an off-screen pixmap. + * + * Results: + * None. + * + * Side effects: + * Graphics are drawn. + * + *-------------------------------------------------------------- + */ + +static void +CharDisplayProc(chunkPtr, x, y, height, baseline, display, dst, screenY) + TkTextDispChunk *chunkPtr; /* Chunk that is to be drawn. */ + int x; /* X-position in dst at which to + * draw this chunk (may differ from + * the x-position in the chunk because + * of scrolling). */ + int y; /* Y-position at which to draw this + * chunk in dst. */ + int height; /* Total height of line. */ + int baseline; /* Offset of baseline from y. */ + Display *display; /* Display to use for drawing. */ + Drawable dst; /* Pixmap or window in which to draw + * chunk. */ + int screenY; /* Y-coordinate in text window that + * corresponds to y. */ +{ + CharInfo *ciPtr = (CharInfo *) chunkPtr->clientData; + TextStyle *stylePtr; + StyleValues *sValuePtr; + int offsetChars, offsetX; + + if ((x + chunkPtr->width) <= 0) { + /* + * The chunk is off-screen. + */ + + return; + } + + stylePtr = chunkPtr->stylePtr; + sValuePtr = stylePtr->sValuePtr; + + /* + * If the text sticks out way to the left of the window, skip + * over the characters that aren't in the visible part of the + * window. This is essential if x is very negative (such as + * less than 32K); otherwise overflow problems will occur + * in servers that use 16-bit arithmetic, like X. + */ + + offsetX = x; + offsetChars = 0; + if (x < 0) { + offsetChars = TkMeasureChars(sValuePtr->fontPtr, ciPtr->chars, + ciPtr->numChars, x, 0, x - chunkPtr->x, TK_IGNORE_TABS, &offsetX); + } + + /* + * Draw the text, underline, and overstrike for this chunk. + */ + + if (ciPtr->numChars > offsetChars) { + TkDisplayChars(display, dst, stylePtr->fgGC, sValuePtr->fontPtr, + ciPtr->chars + offsetChars, ciPtr->numChars - offsetChars, + offsetX, y + baseline - sValuePtr->offset, x - chunkPtr->x, + TK_IGNORE_TABS); + if (sValuePtr->underline) { + TkUnderlineChars(display, dst, stylePtr->fgGC, + sValuePtr->fontPtr, ciPtr->chars + offsetChars, offsetX, + y + baseline - sValuePtr->offset, x - chunkPtr->x, + TK_IGNORE_TABS, 0, ciPtr->numChars-offsetChars-1); + } + if (sValuePtr->overstrike) { + TkUnderlineChars(display, dst, stylePtr->fgGC, + sValuePtr->fontPtr, ciPtr->chars + offsetChars, offsetX, + y + baseline - sValuePtr->offset + - sValuePtr->fontPtr->descent + - (sValuePtr->fontPtr->ascent*3)/10, + x - chunkPtr->x, TK_IGNORE_TABS, 0, + ciPtr->numChars-offsetChars-1); + } + } +} + +/* + *-------------------------------------------------------------- + * + * CharUndisplayProc -- + * + * This procedure is called when a character chunk is no + * longer going to be displayed. It frees up resources + * that were allocated to display the chunk. + * + * Results: + * None. + * + * Side effects: + * Memory and other resources get freed. + * + *-------------------------------------------------------------- + */ + +static void +CharUndisplayProc(textPtr, chunkPtr) + TkText *textPtr; /* Overall information about text + * widget. */ + TkTextDispChunk *chunkPtr; /* Chunk that is about to be freed. */ +{ + CharInfo *ciPtr = (CharInfo *) chunkPtr->clientData; + + ckfree((char *) ciPtr); +} + +/* + *-------------------------------------------------------------- + * + * CharMeasureProc -- + * + * This procedure is called to determine which character in + * a character chunk lies over a given x-coordinate. + * + * Results: + * The return value is the index *within the chunk* of the + * character that covers the position given by "x". + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static int +CharMeasureProc(chunkPtr, x) + TkTextDispChunk *chunkPtr; /* Chunk containing desired coord. */ + int x; /* X-coordinate, in same coordinate + * system as chunkPtr->x. */ +{ + CharInfo *ciPtr = (CharInfo *) chunkPtr->clientData; + int endX; + + return TkMeasureChars(chunkPtr->stylePtr->sValuePtr->fontPtr, + ciPtr->chars, chunkPtr->numChars-1, chunkPtr->x, x, 0, + TK_IGNORE_TABS, &endX); +} + +/* + *-------------------------------------------------------------- + * + * CharBboxProc -- + * + * This procedure is called to compute the bounding box of + * the area occupied by a single character. + * + * Results: + * There is no return value. *xPtr and *yPtr are filled in + * with the coordinates of the upper left corner of the + * character, and *widthPtr and *heightPtr are filled in with + * the dimensions of the character in pixels. Note: not all + * of the returned bbox is necessarily visible on the screen + * (the rightmost part might be off-screen to the right, + * and the bottommost part might be off-screen to the bottom). + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static void +CharBboxProc(chunkPtr, index, y, lineHeight, baseline, xPtr, yPtr, + widthPtr, heightPtr) + TkTextDispChunk *chunkPtr; /* Chunk containing desired char. */ + int index; /* Index of desired character within + * the chunk. */ + int y; /* Topmost pixel in area allocated + * for this line. */ + int lineHeight; /* Height of line, in pixels. */ + int baseline; /* Location of line's baseline, in + * pixels measured down from y. */ + int *xPtr, *yPtr; /* Gets filled in with coords of + * character's upper-left pixel. + * X-coord is in same coordinate + * system as chunkPtr->x. */ + int *widthPtr; /* Gets filled in with width of + * character, in pixels. */ + int *heightPtr; /* Gets filled in with height of + * character, in pixels. */ +{ + CharInfo *ciPtr = (CharInfo *) chunkPtr->clientData; + int maxX; + + maxX = chunkPtr->width + chunkPtr->x; + TkMeasureChars(chunkPtr->stylePtr->sValuePtr->fontPtr, + ciPtr->chars, index, chunkPtr->x, 1000000, 0, TK_IGNORE_TABS, + xPtr); + if (index == ciPtr->numChars) { + /* + * This situation only happens if the last character in a line + * is a space character, in which case it absorbs all of the + * extra space in the line (see TkTextCharLayoutProc). + */ + + *widthPtr = maxX - *xPtr; + } else if ((ciPtr->chars[index] == '\t') + && (index == (ciPtr->numChars-1))) { + /* + * The desired character is a tab character that terminates a + * chunk; give it all the space left in the chunk. + */ + + *widthPtr = maxX - *xPtr; + } else { + TkMeasureChars(chunkPtr->stylePtr->sValuePtr->fontPtr, + ciPtr->chars + index, 1, *xPtr, 1000000, 0, TK_IGNORE_TABS, + widthPtr); + if (*widthPtr > maxX) { + *widthPtr = maxX - *xPtr; + } else { + *widthPtr -= *xPtr; + } + } + *yPtr = y + baseline - chunkPtr->minAscent; + *heightPtr = chunkPtr->minAscent + chunkPtr->minDescent; +} + +/* + *---------------------------------------------------------------------- + * + * AdjustForTab -- + * + * This procedure is called to move a series of chunks right + * in order to align them with a tab stop. + * + * Results: + * None. + * + * Side effects: + * The width of chunkPtr gets adjusted so that it absorbs the + * extra space due to the tab. The x locations in all the chunks + * after chunkPtr are adjusted rightward to align with the tab + * stop given by tabArrayPtr and index. + * + *---------------------------------------------------------------------- + */ + +static void +AdjustForTab(textPtr, tabArrayPtr, index, chunkPtr) + TkText *textPtr; /* Information about the text widget as + * a whole. */ + TkTextTabArray *tabArrayPtr; /* Information about the tab stops + * that apply to this line. May be + * NULL to indicate default tabbing + * (every 8 chars). */ + int index; /* Index of current tab stop. */ + TkTextDispChunk *chunkPtr; /* Chunk whose last character is + * the tab; the following chunks + * contain information to be shifted + * right. */ + +{ + int x, desired, delta, width, decimal, i, gotDigit; + TkTextDispChunk *chunkPtr2, *decimalChunkPtr; + TkTextTab *tabPtr; + CharInfo *ciPtr = NULL; /* Initialization needed only to + * prevent compiler warnings. */ + int tabX, prev, spaceWidth; + char *p; + TkTextTabAlign alignment; + + if (chunkPtr->nextPtr == NULL) { + /* + * Nothing after the actual tab; just return. + */ + + return; + } + + /* + * If no tab information has been given, do the usual thing: + * round up to the next boundary of 8 average-sized characters. + */ + + x = chunkPtr->nextPtr->x; + if ((tabArrayPtr == NULL) || (tabArrayPtr->numTabs == 0)) { + /* + * No tab information has been given, so use the default + * interpretation of tabs. + */ + + TkMeasureChars(textPtr->fontPtr, "\t", 1, x, INT_MAX, 0, 0, &desired); + goto update; + } + + if (index < tabArrayPtr->numTabs) { + alignment = tabArrayPtr->tabs[index].alignment; + tabX = tabArrayPtr->tabs[index].location; + } else { + /* + * Ran out of tab stops; compute a tab position by extrapolating + * from the last two tab positions. + */ + + if (tabArrayPtr->numTabs > 1) { + prev = tabArrayPtr->tabs[tabArrayPtr->numTabs-2].location; + } else { + prev = 0; + } + alignment = tabArrayPtr->tabs[tabArrayPtr->numTabs-1].alignment; + tabX = tabArrayPtr->tabs[tabArrayPtr->numTabs-1].location + + (index + 1 - tabArrayPtr->numTabs) + * (tabArrayPtr->tabs[tabArrayPtr->numTabs-1].location - prev); + } + + tabPtr = &tabArrayPtr->tabs[index]; + if (alignment == LEFT) { + desired = tabX; + goto update; + } + + if ((alignment == CENTER) || (alignment == RIGHT)) { + /* + * Compute the width of all the information in the tab group, + * then use it to pick a desired location. + */ + + width = 0; + for (chunkPtr2 = chunkPtr->nextPtr; chunkPtr2 != NULL; + chunkPtr2 = chunkPtr2->nextPtr) { + width += chunkPtr2->width; + } + if (alignment == CENTER) { + desired = tabX - width/2; + } else { + desired = tabX - width; + } + goto update; + } + + /* + * Must be numeric alignment. Search through the text to be + * tabbed, looking for the last , or . before the first character + * that isn't a number, comma, period, or sign. + */ + + decimalChunkPtr = NULL; + decimal = gotDigit = 0; + for (chunkPtr2 = chunkPtr->nextPtr; chunkPtr2 != NULL; + chunkPtr2 = chunkPtr2->nextPtr) { + if (chunkPtr2->displayProc != CharDisplayProc) { + continue; + } + ciPtr = (CharInfo *) chunkPtr2->clientData; + for (p = ciPtr->chars, i = 0; i < ciPtr->numChars; p++, i++) { + if (isdigit(UCHAR(*p))) { + gotDigit = 1; + } else if ((*p == '.') || (*p == ',')) { + decimal = p-ciPtr->chars; + decimalChunkPtr = chunkPtr2; + } else if (gotDigit) { + if (decimalChunkPtr == NULL) { + decimal = p-ciPtr->chars; + decimalChunkPtr = chunkPtr2; + } + goto endOfNumber; + } + } + } + endOfNumber: + if (decimalChunkPtr != NULL) { + int curX; + + ciPtr = (CharInfo *) decimalChunkPtr->clientData; + TkMeasureChars(decimalChunkPtr->stylePtr->sValuePtr->fontPtr, + ciPtr->chars, decimal, decimalChunkPtr->x, 1000000, 0, + TK_IGNORE_TABS, &curX); + desired = tabX - (curX - x); + goto update; + } else { + /* + * There wasn't a decimal point. Right justify the text. + */ + + width = 0; + for (chunkPtr2 = chunkPtr->nextPtr; chunkPtr2 != NULL; + chunkPtr2 = chunkPtr2->nextPtr) { + width += chunkPtr2->width; + } + desired = tabX - width; + } + + /* + * Shift all of the chunks to the right so that the left edge is + * at the desired location, then expand the chunk containing the + * tab. Be sure that the tab occupies at least the width of a + * space character. + */ + + update: + delta = desired - x; + TkMeasureChars(textPtr->fontPtr, " ", 1, 0, INT_MAX, 0, 0, &spaceWidth); + if (delta < spaceWidth) { + delta = spaceWidth; + } + for (chunkPtr2 = chunkPtr->nextPtr; chunkPtr2 != NULL; + chunkPtr2 = chunkPtr2->nextPtr) { + chunkPtr2->x += delta; + } + chunkPtr->width += delta; +} + +/* + *---------------------------------------------------------------------- + * + * SizeOfTab -- + * + * This returns an estimate of the amount of white space that will + * be consumed by a tab. + * + * Results: + * The return value is the minimum number of pixels that will + * be occupied by the index'th tab of tabArrayPtr, assuming that + * the current position on the line is x and the end of the + * line is maxX. For numeric tabs, this is a conservative + * estimate. The return value is always >= 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +SizeOfTab(textPtr, tabArrayPtr, index, x, maxX) + TkText *textPtr; /* Information about the text widget as + * a whole. */ + TkTextTabArray *tabArrayPtr; /* Information about the tab stops + * that apply to this line. NULL + * means use default tabbing (every + * 8 chars.) */ + int index; /* Index of current tab stop. */ + int x; /* Current x-location in line. Only + * used if tabArrayPtr == NULL. */ + int maxX; /* X-location of pixel just past the + * right edge of the line. */ +{ + int tabX, prev, result, spaceWidth; + TkTextTabAlign alignment; + + if ((tabArrayPtr == NULL) || (tabArrayPtr->numTabs == 0)) { + TkMeasureChars(textPtr->fontPtr, "\t", 1, x, INT_MAX, 0, 0, &tabX); + return tabX - x; + } + if (index < tabArrayPtr->numTabs) { + tabX = tabArrayPtr->tabs[index].location; + alignment = tabArrayPtr->tabs[index].alignment; + } else { + /* + * Ran out of tab stops; compute a tab position by extrapolating + * from the last two tab positions. + */ + + if (tabArrayPtr->numTabs > 1) { + prev = tabArrayPtr->tabs[tabArrayPtr->numTabs-2].location; + } else { + prev = 0; + } + tabX = tabArrayPtr->tabs[tabArrayPtr->numTabs-1].location + + (index + 1 - tabArrayPtr->numTabs) + * (tabArrayPtr->tabs[tabArrayPtr->numTabs-1].location - prev); + alignment = tabArrayPtr->tabs[tabArrayPtr->numTabs-1].alignment; + } + if (alignment == CENTER) { + /* + * Be very careful in the arithmetic below, because maxX may + * be the largest positive number: watch out for integer + * overflow. + */ + + if ((maxX-tabX) < (tabX - x)) { + result = (maxX - x) - 2*(maxX - tabX); + } else { + result = 0; + } + goto done; + } + if (alignment == RIGHT) { + result = 0; + goto done; + } + + /* + * Note: this treats NUMERIC alignment the same as LEFT + * alignment, which is somewhat conservative. However, it's + * pretty tricky at this point to figure out exactly where + * the damn decimal point will be. + */ + + if (tabX > x) { + result = tabX - x; + } else { + result = 0; + } + + done: + TkMeasureChars(textPtr->fontPtr, " ", 1, 0, INT_MAX, 0, 0, &spaceWidth); + if (result < spaceWidth) { + result = spaceWidth; + } + return result; +} diff --git a/tk4.2/generic/tkTextIndex.c b/tk4.2/generic/tkTextIndex.c new file mode 100644 index 0000000..729845d --- /dev/null +++ b/tk4.2/generic/tkTextIndex.c @@ -0,0 +1,828 @@ +/* + * tkTextIndex.c -- + * + * This module provides procedures that manipulate indices for + * text widgets. + * + * Copyright (c) 1992-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkTextIndex.c 1.13 96/02/15 18:52:57 + */ + +#include "default.h" +#include "tkPort.h" +#include "tkInt.h" +#include "tkText.h" + +/* + * Index to use to select last character in line (very large integer): + */ + +#define LAST_CHAR 1000000 + +/* + * Forward declarations for procedures defined later in this file: + */ + +static char * ForwBack _ANSI_ARGS_((char *string, + TkTextIndex *indexPtr)); +static char * StartEnd _ANSI_ARGS_(( char *string, + TkTextIndex *indexPtr)); + +/* + *-------------------------------------------------------------- + * + * TkTextMakeIndex -- + * + * Given a line index and a character index, look things up + * in the B-tree and fill in a TkTextIndex structure. + * + * Results: + * The structure at *indexPtr is filled in with information + * about the character at lineIndex and charIndex (or the + * closest existing character, if the specified one doesn't + * exist), and indexPtr is returned as result. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +TkTextIndex * +TkTextMakeIndex(tree, lineIndex, charIndex, indexPtr) + TkTextBTree tree; /* Tree that lineIndex and charIndex refer + * to. */ + int lineIndex; /* Index of desired line (0 means first + * line of text). */ + int charIndex; /* Index of desired character. */ + TkTextIndex *indexPtr; /* Structure to fill in. */ +{ + register TkTextSegment *segPtr; + int index; + + indexPtr->tree = tree; + if (lineIndex < 0) { + lineIndex = 0; + charIndex = 0; + } + if (charIndex < 0) { + charIndex = 0; + } + indexPtr->linePtr = TkBTreeFindLine(tree, lineIndex); + if (indexPtr->linePtr == NULL) { + indexPtr->linePtr = TkBTreeFindLine(tree, TkBTreeNumLines(tree)); + charIndex = 0; + } + + /* + * Verify that the index is within the range of the line. + * If not, just use the index of the last character in the line. + */ + + for (index = 0, segPtr = indexPtr->linePtr->segPtr; ; + segPtr = segPtr->nextPtr) { + if (segPtr == NULL) { + indexPtr->charIndex = index-1; + break; + } + index += segPtr->size; + if (index > charIndex) { + indexPtr->charIndex = charIndex; + break; + } + } + return indexPtr; +} + +/* + *-------------------------------------------------------------- + * + * TkTextIndexToSeg -- + * + * Given an index, this procedure returns the segment and + * offset within segment for the index. + * + * Results: + * The return value is a pointer to the segment referred to + * by indexPtr; this will always be a segment with non-zero + * size. The variable at *offsetPtr is set to hold the + * integer offset within the segment of the character + * given by indexPtr. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +TkTextSegment * +TkTextIndexToSeg(indexPtr, offsetPtr) + TkTextIndex *indexPtr; /* Text index. */ + int *offsetPtr; /* Where to store offset within + * segment, or NULL if offset isn't + * wanted. */ +{ + register TkTextSegment *segPtr; + int offset; + + for (offset = indexPtr->charIndex, segPtr = indexPtr->linePtr->segPtr; + offset >= segPtr->size; + offset -= segPtr->size, segPtr = segPtr->nextPtr) { + /* Empty loop body. */ + } + if (offsetPtr != NULL) { + *offsetPtr = offset; + } + return segPtr; +} + +/* + *-------------------------------------------------------------- + * + * TkTextSegToOffset -- + * + * Given a segment pointer and the line containing it, this + * procedure returns the offset of the segment within its + * line. + * + * Results: + * The return value is the offset (within its line) of the + * first character in segPtr. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +TkTextSegToOffset(segPtr, linePtr) + TkTextSegment *segPtr; /* Segment whose offset is desired. */ + TkTextLine *linePtr; /* Line containing segPtr. */ +{ + TkTextSegment *segPtr2; + int offset; + + offset = 0; + for (segPtr2 = linePtr->segPtr; segPtr2 != segPtr; + segPtr2 = segPtr2->nextPtr) { + offset += segPtr2->size; + } + return offset; +} + +/* + *---------------------------------------------------------------------- + * + * TkTextGetIndex -- + * + * Given a string, return the line and character indices that + * it describes. + * + * Results: + * The return value is a standard Tcl return result. If + * TCL_OK is returned, then everything went well and the index + * at *indexPtr is filled in; otherwise TCL_ERROR is returned + * and an error message is left in interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TkTextGetIndex(interp, textPtr, string, indexPtr) + Tcl_Interp *interp; /* Use this for error reporting. */ + TkText *textPtr; /* Information about text widget. */ + char *string; /* Textual description of position. */ + TkTextIndex *indexPtr; /* Index structure to fill in. */ +{ + register char *p; + char *end, *endOfBase; + Tcl_HashEntry *hPtr; + TkTextTag *tagPtr; + TkTextSearch search; + TkTextIndex first, last; + int wantLast, result; + char c; + + /* + *--------------------------------------------------------------------- + * Stage 1: check to see if the index consists of nothing but a mar + * name. We do this check now even though it's also done later, in + * order to allow mark names that include funny characters such as + * spaces or "+1c". + *--------------------------------------------------------------------- + */ + + if (TkTextMarkNameToIndex(textPtr, string, indexPtr) == TCL_OK) { + return TCL_OK; + } + + /* + *------------------------------------------------ + * Stage 2: start again by parsing the base index. + *------------------------------------------------ + */ + + indexPtr->tree = textPtr->tree; + + /* + * First look for the form "tag.first" or "tag.last" where "tag" + * is the name of a valid tag. Try to use up as much as possible + * of the string in this check (strrchr instead of strchr below). + * Doing the check now, and in this way, allows tag names to include + * funny characters like "@" or "+1c". + */ + + p = strrchr(string, '.'); + if (p != NULL) { + if ((p[1] == 'f') && (strncmp(p+1, "first", 5) == 0)) { + wantLast = 0; + endOfBase = p+6; + } else if ((p[1] == 'l') && (strncmp(p+1, "last", 4) == 0)) { + wantLast = 1; + endOfBase = p+5; + } else { + goto tryxy; + } + *p = 0; + hPtr = Tcl_FindHashEntry(&textPtr->tagTable, string); + *p = '.'; + if (hPtr == NULL) { + goto tryxy; + } + tagPtr = (TkTextTag *) Tcl_GetHashValue(hPtr); + TkTextMakeIndex(textPtr->tree, 0, 0, &first); + TkTextMakeIndex(textPtr->tree, TkBTreeNumLines(textPtr->tree), 0, + &last); + TkBTreeStartSearch(&first, &last, tagPtr, &search); + if (!TkBTreeCharTagged(&first, tagPtr) && !TkBTreeNextTag(&search)) { + Tcl_AppendResult(interp, + "text doesn't contain any characters tagged with \"", + Tcl_GetHashKey(&textPtr->tagTable, hPtr), "\"", + (char *) NULL); + return TCL_ERROR; + } + *indexPtr = search.curIndex; + if (wantLast) { + while (TkBTreeNextTag(&search)) { + *indexPtr = search.curIndex; + } + } + goto gotBase; + } + + tryxy: + if (string[0] == '@') { + /* + * Find character at a given x,y location in the window. + */ + + int x, y; + + p = string+1; + x = strtol(p, &end, 0); + if ((end == p) || (*end != ',')) { + goto error; + } + p = end+1; + y = strtol(p, &end, 0); + if (end == p) { + goto error; + } + TkTextPixelIndex(textPtr, x, y, indexPtr); + endOfBase = end; + goto gotBase; + } + + if (isdigit(UCHAR(string[0])) || (string[0] == '-')) { + int lineIndex, charIndex; + + /* + * Base is identified with line and character indices. + */ + + lineIndex = strtol(string, &end, 0) - 1; + if ((end == string) || (*end != '.')) { + goto error; + } + p = end+1; + if ((*p == 'e') && (strncmp(p, "end", 3) == 0)) { + charIndex = LAST_CHAR; + endOfBase = p+3; + } else { + charIndex = strtol(p, &end, 0); + if (end == p) { + goto error; + } + endOfBase = end; + } + TkTextMakeIndex(textPtr->tree, lineIndex, charIndex, indexPtr); + goto gotBase; + } + + for (p = string; *p != 0; p++) { + if (isspace(UCHAR(*p)) || (*p == '+') || (*p == '-')) { + break; + } + } + endOfBase = p; + if (string[0] == '.') { + /* + * See if the base position is the name of an embedded window. + */ + + c = *endOfBase; + *endOfBase = 0; + result = TkTextWindowIndex(textPtr, string, indexPtr); + *endOfBase = c; + if (result != 0) { + goto gotBase; + } + } + if ((string[0] == 'e') + && (strncmp(string, "end", (size_t) (endOfBase-string)) == 0)) { + /* + * Base position is end of text. + */ + + TkTextMakeIndex(textPtr->tree, TkBTreeNumLines(textPtr->tree), + 0, indexPtr); + goto gotBase; + } else { + /* + * See if the base position is the name of a mark. + */ + + c = *endOfBase; + *endOfBase = 0; + result = TkTextMarkNameToIndex(textPtr, string, indexPtr); + *endOfBase = c; + if (result == TCL_OK) { + goto gotBase; + } + } + goto error; + + /* + *------------------------------------------------------------------- + * Stage 3: process zero or more modifiers. Each modifier is either + * a keyword like "wordend" or "linestart", or it has the form + * "op count units" where op is + or -, count is a number, and units + * is "chars" or "lines". + *------------------------------------------------------------------- + */ + + gotBase: + p = endOfBase; + while (1) { + while (isspace(UCHAR(*p))) { + p++; + } + if (*p == 0) { + break; + } + + if ((*p == '+') || (*p == '-')) { + p = ForwBack(p, indexPtr); + } else { + p = StartEnd(p, indexPtr); + } + if (p == NULL) { + goto error; + } + } + return TCL_OK; + + error: + Tcl_AppendResult(interp, "bad text index \"", string, "\"", + (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * TkTextPrintIndex -- + * + * + * This procedure generates a string description of an index, + * suitable for reading in again later. + * + * Results: + * The characters pointed to by string are modified. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TkTextPrintIndex(indexPtr, string) + TkTextIndex *indexPtr; /* Pointer to index. */ + char *string; /* Place to store the position. Must have + * at least TK_POS_CHARS characters. */ +{ + sprintf(string, "%d.%d", TkBTreeLineIndex(indexPtr->linePtr) + 1, + indexPtr->charIndex); +} + +/* + *-------------------------------------------------------------- + * + * TkTextIndexCmp -- + * + * Compare two indices to see which one is earlier in + * the text. + * + * Results: + * The return value is 0 if index1Ptr and index2Ptr refer + * to the same position in the file, -1 if index1Ptr refers + * to an earlier position than index2Ptr, and 1 otherwise. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +TkTextIndexCmp(index1Ptr, index2Ptr) + TkTextIndex *index1Ptr; /* First index. */ + TkTextIndex *index2Ptr; /* Second index. */ +{ + int line1, line2; + + if (index1Ptr->linePtr == index2Ptr->linePtr) { + if (index1Ptr->charIndex < index2Ptr->charIndex) { + return -1; + } else if (index1Ptr->charIndex > index2Ptr->charIndex) { + return 1; + } else { + return 0; + } + } + line1 = TkBTreeLineIndex(index1Ptr->linePtr); + line2 = TkBTreeLineIndex(index2Ptr->linePtr); + if (line1 < line2) { + return -1; + } + if (line1 > line2) { + return 1; + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * ForwBack -- + * + * This procedure handles +/- modifiers for indices to adjust + * the index forwards or backwards. + * + * Results: + * If the modifier in string is successfully parsed then the + * return value is the address of the first character after the + * modifier, and *indexPtr is updated to reflect the modifier. + * If there is a syntax error in the modifier then NULL is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +ForwBack(string, indexPtr) + char *string; /* String to parse for additional info + * about modifier (count and units). + * Points to "+" or "-" that starts + * modifier. */ + TkTextIndex *indexPtr; /* Index to update as specified in string. */ +{ + register char *p; + char *end, *units; + int count, lineIndex; + size_t length; + + /* + * Get the count (how many units forward or backward). + */ + + p = string+1; + while (isspace(UCHAR(*p))) { + p++; + } + count = strtol(p, &end, 0); + if (end == p) { + return NULL; + } + p = end; + while (isspace(UCHAR(*p))) { + p++; + } + + /* + * Find the end of this modifier (next space or + or - character), + * then parse the unit specifier and update the position + * accordingly. + */ + + units = p; + while ((*p != 0) && !isspace(UCHAR(*p)) && (*p != '+') && (*p != '-')) { + p++; + } + length = p - units; + if ((*units == 'c') && (strncmp(units, "chars", length) == 0)) { + if (*string == '+') { + TkTextIndexForwChars(indexPtr, count, indexPtr); + } else { + TkTextIndexBackChars(indexPtr, count, indexPtr); + } + } else if ((*units == 'l') && (strncmp(units, "lines", length) == 0)) { + lineIndex = TkBTreeLineIndex(indexPtr->linePtr); + if (*string == '+') { + lineIndex += count; + } else { + lineIndex -= count; + + /* + * The check below retains the character position, even + * if the line runs off the start of the file. Without + * it, the character position will get reset to 0 by + * TkTextMakeIndex. + */ + + if (lineIndex < 0) { + lineIndex = 0; + } + } + TkTextMakeIndex(indexPtr->tree, lineIndex, indexPtr->charIndex, + indexPtr); + } else { + return NULL; + } + return p; +} + +/* + *---------------------------------------------------------------------- + * + * TkTextIndexForwChars -- + * + * Given an index for a text widget, this procedure creates a + * new index that points "count" characters ahead of the source + * index. + * + * Results: + * *dstPtr is modified to refer to the character "count" characters + * after srcPtr, or to the last character in the file if there aren't + * "count" characters left in the file. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +void +TkTextIndexForwChars(srcPtr, count, dstPtr) + TkTextIndex *srcPtr; /* Source index. */ + int count; /* How many characters forward to + * move. May be negative. */ + TkTextIndex *dstPtr; /* Destination index: gets modified. */ +{ + TkTextLine *linePtr; + TkTextSegment *segPtr; + int lineLength; + + if (count < 0) { + TkTextIndexBackChars(srcPtr, -count, dstPtr); + return; + } + + *dstPtr = *srcPtr; + dstPtr->charIndex += count; + while (1) { + /* + * Compute the length of the current line. + */ + + lineLength = 0; + for (segPtr = dstPtr->linePtr->segPtr; segPtr != NULL; + segPtr = segPtr->nextPtr) { + lineLength += segPtr->size; + } + + /* + * If the new index is in the same line then we're done. + * Otherwise go on to the next line. + */ + + if (dstPtr->charIndex < lineLength) { + return; + } + dstPtr->charIndex -= lineLength; + linePtr = TkBTreeNextLine(dstPtr->linePtr); + if (linePtr == NULL) { + dstPtr->charIndex = lineLength - 1; + return; + } + dstPtr->linePtr = linePtr; + } +} + +/* + *---------------------------------------------------------------------- + * + * TkTextIndexBackChars -- + * + * Given an index for a text widget, this procedure creates a + * new index that points "count" characters earlier than the + * source index. + * + * Results: + * *dstPtr is modified to refer to the character "count" characters + * before srcPtr, or to the first character in the file if there aren't + * "count" characters earlier than srcPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TkTextIndexBackChars(srcPtr, count, dstPtr) + TkTextIndex *srcPtr; /* Source index. */ + int count; /* How many characters backward to + * move. May be negative. */ + TkTextIndex *dstPtr; /* Destination index: gets modified. */ +{ + TkTextSegment *segPtr; + int lineIndex; + + if (count < 0) { + TkTextIndexForwChars(srcPtr, -count, dstPtr); + return; + } + + *dstPtr = *srcPtr; + dstPtr->charIndex -= count; + lineIndex = -1; + while (dstPtr->charIndex < 0) { + /* + * Move back one line in the text. If we run off the beginning + * of the file then just return the first character in the text. + */ + + if (lineIndex < 0) { + lineIndex = TkBTreeLineIndex(dstPtr->linePtr); + } + if (lineIndex == 0) { + dstPtr->charIndex = 0; + return; + } + lineIndex--; + dstPtr->linePtr = TkBTreeFindLine(dstPtr->tree, lineIndex); + + /* + * Compute the length of the line and add that to dstPtr->charIndex. + */ + + for (segPtr = dstPtr->linePtr->segPtr; segPtr != NULL; + segPtr = segPtr->nextPtr) { + dstPtr->charIndex += segPtr->size; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * StartEnd -- + * + * This procedure handles modifiers like "wordstart" and "lineend" + * to adjust indices forwards or backwards. + * + * Results: + * If the modifier is successfully parsed then the return value + * is the address of the first character after the modifier, and + * *indexPtr is updated to reflect the modifier. If there is a + * syntax error in the modifier then NULL is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +StartEnd(string, indexPtr) + char *string; /* String to parse for additional info + * about modifier (count and units). + * Points to first character of modifer + * word. */ + TkTextIndex *indexPtr; /* Index to mdoify based on string. */ +{ + char *p; + int c, offset; + size_t length; + register TkTextSegment *segPtr; + + /* + * Find the end of the modifier word. + */ + + for (p = string; isalnum(UCHAR(*p)); p++) { + /* Empty loop body. */ + } + length = p-string; + if ((*string == 'l') && (strncmp(string, "lineend", length) == 0) + && (length >= 5)) { + indexPtr->charIndex = 0; + for (segPtr = indexPtr->linePtr->segPtr; segPtr != NULL; + segPtr = segPtr->nextPtr) { + indexPtr->charIndex += segPtr->size; + } + indexPtr->charIndex -= 1; + } else if ((*string == 'l') && (strncmp(string, "linestart", length) == 0) + && (length >= 5)) { + indexPtr->charIndex = 0; + } else if ((*string == 'w') && (strncmp(string, "wordend", length) == 0) + && (length >= 5)) { + int firstChar = 1; + + /* + * If the current character isn't part of a word then just move + * forward one character. Otherwise move forward until finding + * a character that isn't part of a word and stop there. + */ + + segPtr = TkTextIndexToSeg(indexPtr, &offset); + while (1) { + if (segPtr->typePtr == &tkTextCharType) { + c = segPtr->body.chars[offset]; + if (!isalnum(UCHAR(c)) && (c != '_')) { + break; + } + firstChar = 0; + } + offset += 1; + indexPtr->charIndex += 1; + if (offset >= segPtr->size) { + segPtr = TkTextIndexToSeg(indexPtr, &offset); + } + } + if (firstChar) { + TkTextIndexForwChars(indexPtr, 1, indexPtr); + } + } else if ((*string == 'w') && (strncmp(string, "wordstart", length) == 0) + && (length >= 5)) { + int firstChar = 1; + + /* + * Starting with the current character, look for one that's not + * part of a word and keep moving backward until you find one. + * Then if the character found wasn't the first one, move forward + * again one position. + */ + + segPtr = TkTextIndexToSeg(indexPtr, &offset); + while (1) { + if (segPtr->typePtr == &tkTextCharType) { + c = segPtr->body.chars[offset]; + if (!isalnum(UCHAR(c)) && (c != '_')) { + break; + } + firstChar = 0; + } + offset -= 1; + indexPtr->charIndex -= 1; + if (offset < 0) { + if (indexPtr->charIndex < 0) { + indexPtr->charIndex = 0; + goto done; + } + segPtr = TkTextIndexToSeg(indexPtr, &offset); + } + } + if (!firstChar) { + TkTextIndexForwChars(indexPtr, 1, indexPtr); + } + } else { + return NULL; + } + done: + return p; +} diff --git a/tk4.2/generic/tkTextMark.c b/tk4.2/generic/tkTextMark.c new file mode 100644 index 0000000..d2ff969 --- /dev/null +++ b/tk4.2/generic/tkTextMark.c @@ -0,0 +1,775 @@ +/* + * tkTextMark.c -- + * + * This file contains the procedure that implement marks for + * text widgets. + * + * Copyright (c) 1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkTextMark.c 1.15 96/02/15 18:52:59 + */ + +#include "tkInt.h" +#include "tkText.h" +#include "tkPort.h" + +/* + * Macro that determines the size of a mark segment: + */ + +#define MSEG_SIZE ((unsigned) (Tk_Offset(TkTextSegment, body) \ + + sizeof(TkTextMark))) + +/* + * Forward references for procedures defined in this file: + */ + +static void InsertUndisplayProc _ANSI_ARGS_((TkText *textPtr, + TkTextDispChunk *chunkPtr)); +static int MarkDeleteProc _ANSI_ARGS_((TkTextSegment *segPtr, + TkTextLine *linePtr, int treeGone)); +static TkTextSegment * MarkCleanupProc _ANSI_ARGS_((TkTextSegment *segPtr, + TkTextLine *linePtr)); +static void MarkCheckProc _ANSI_ARGS_((TkTextSegment *segPtr, + TkTextLine *linePtr)); +static int MarkLayoutProc _ANSI_ARGS_((TkText *textPtr, + TkTextIndex *indexPtr, TkTextSegment *segPtr, + int offset, int maxX, int maxChars, + int noCharsYet, Tk_Uid wrapMode, + TkTextDispChunk *chunkPtr)); +static int MarkFindNext _ANSI_ARGS_((Tcl_Interp *interp, + TkText *textPtr, char *markName)); +static int MarkFindPrev _ANSI_ARGS_((Tcl_Interp *interp, + TkText *textPtr, char *markName)); + + +/* + * The following structures declare the "mark" segment types. + * There are actually two types for marks, one with left gravity + * and one with right gravity. They are identical except for + * their gravity property. + */ + +Tk_SegType tkTextRightMarkType = { + "mark", /* name */ + 0, /* leftGravity */ + (Tk_SegSplitProc *) NULL, /* splitProc */ + MarkDeleteProc, /* deleteProc */ + MarkCleanupProc, /* cleanupProc */ + (Tk_SegLineChangeProc *) NULL, /* lineChangeProc */ + MarkLayoutProc, /* layoutProc */ + MarkCheckProc /* checkProc */ +}; + +Tk_SegType tkTextLeftMarkType = { + "mark", /* name */ + 1, /* leftGravity */ + (Tk_SegSplitProc *) NULL, /* splitProc */ + MarkDeleteProc, /* deleteProc */ + MarkCleanupProc, /* cleanupProc */ + (Tk_SegLineChangeProc *) NULL, /* lineChangeProc */ + MarkLayoutProc, /* layoutProc */ + MarkCheckProc /* checkProc */ +}; + +/* + *-------------------------------------------------------------- + * + * TkTextMarkCmd -- + * + * This procedure is invoked to process the "mark" options of + * the widget command for text widgets. See the user documentation + * for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +int +TkTextMarkCmd(textPtr, interp, argc, argv) + register TkText *textPtr; /* Information about text widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. Someone else has already + * parsed this command enough to know that + * argv[1] is "mark". */ +{ + int c, i; + size_t length; + Tcl_HashEntry *hPtr; + TkTextSegment *markPtr; + Tcl_HashSearch search; + TkTextIndex index; + Tk_SegType *newTypePtr; + + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " mark option ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + c = argv[2][0]; + length = strlen(argv[2]); + if ((c == 'g') && (strncmp(argv[2], "gravity", length) == 0)) { + if (argc > 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " mark gravity markName ?gravity?", + (char *) NULL); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&textPtr->markTable, argv[3]); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "there is no mark named \"", + argv[3], "\"", (char *) NULL); + return TCL_ERROR; + } + markPtr = (TkTextSegment *) Tcl_GetHashValue(hPtr); + if (argc == 4) { + if (markPtr->typePtr == &tkTextRightMarkType) { + interp->result = "right"; + } else { + interp->result = "left"; + } + return TCL_OK; + } + length = strlen(argv[4]); + c = argv[4][0]; + if ((c == 'l') && (strncmp(argv[4], "left", length) == 0)) { + newTypePtr = &tkTextLeftMarkType; + } else if ((c == 'r') && (strncmp(argv[4], "right", length) == 0)) { + newTypePtr = &tkTextRightMarkType; + } else { + Tcl_AppendResult(interp, "bad mark gravity \"", + argv[4], "\": must be left or right", (char *) NULL); + return TCL_ERROR; + } + TkTextMarkSegToIndex(textPtr, markPtr, &index); + TkBTreeUnlinkSegment(textPtr->tree, markPtr, + markPtr->body.mark.linePtr); + markPtr->typePtr = newTypePtr; + TkBTreeLinkSegment(markPtr, &index); + } else if ((c == 'n') && (strncmp(argv[2], "names", length) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " mark names\"", (char *) NULL); + return TCL_ERROR; + } + for (hPtr = Tcl_FirstHashEntry(&textPtr->markTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + Tcl_AppendElement(interp, + Tcl_GetHashKey(&textPtr->markTable, hPtr)); + } + } else if ((c == 'n') && (strncmp(argv[2], "next", length) == 0)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " mark next index\"", (char *) NULL); + return TCL_ERROR; + } + return MarkFindNext(interp, textPtr, argv[3]); + } else if ((c == 'p') && (strncmp(argv[2], "previous", length) == 0)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " mark previous index\"", (char *) NULL); + return TCL_ERROR; + } + return MarkFindPrev(interp, textPtr, argv[3]); + } else if ((c == 's') && (strncmp(argv[2], "set", length) == 0)) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " mark set markName index\"", (char *) NULL); + return TCL_ERROR; + } + if (TkTextGetIndex(interp, textPtr, argv[4], &index) != TCL_OK) { + return TCL_ERROR; + } + TkTextSetMark(textPtr, argv[3], &index); + } else if ((c == 'u') && (strncmp(argv[2], "unset", length) == 0)) { + for (i = 3; i < argc; i++) { + hPtr = Tcl_FindHashEntry(&textPtr->markTable, argv[i]); + if (hPtr != NULL) { + markPtr = (TkTextSegment *) Tcl_GetHashValue(hPtr); + if ((markPtr == textPtr->insertMarkPtr) + || (markPtr == textPtr->currentMarkPtr)) { + continue; + } + TkBTreeUnlinkSegment(textPtr->tree, markPtr, + markPtr->body.mark.linePtr); + Tcl_DeleteHashEntry(hPtr); + ckfree((char *) markPtr); + } + } + } else { + Tcl_AppendResult(interp, "bad mark option \"", argv[2], + "\": must be gravity, names, next, previous, set, or unset", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TkTextSetMark -- + * + * Set a mark to a particular position, creating a new mark if + * one doesn't already exist. + * + * Results: + * The return value is a pointer to the mark that was just set. + * + * Side effects: + * A new mark is created, or an existing mark is moved. + * + *---------------------------------------------------------------------- + */ + +TkTextSegment * +TkTextSetMark(textPtr, name, indexPtr) + TkText *textPtr; /* Text widget in which to create mark. */ + char *name; /* Name of mark to set. */ + TkTextIndex *indexPtr; /* Where to set mark. */ +{ + Tcl_HashEntry *hPtr; + TkTextSegment *markPtr; + TkTextIndex insertIndex; + int new; + + hPtr = Tcl_CreateHashEntry(&textPtr->markTable, name, &new); + markPtr = (TkTextSegment *) Tcl_GetHashValue(hPtr); + if (!new) { + /* + * If this is the insertion point that's being moved, be sure + * to force a display update at the old position. Also, don't + * let the insertion cursor be after the final newline of the + * file. + */ + + if (markPtr == textPtr->insertMarkPtr) { + TkTextIndex index, index2; + TkTextMarkSegToIndex(textPtr, textPtr->insertMarkPtr, &index); + TkTextIndexForwChars(&index, 1, &index2); + TkTextChanged(textPtr, &index, &index2); + if (TkBTreeLineIndex(indexPtr->linePtr) + == TkBTreeNumLines(textPtr->tree)) { + TkTextIndexBackChars(indexPtr, 1, &insertIndex); + indexPtr = &insertIndex; + } + } + TkBTreeUnlinkSegment(textPtr->tree, markPtr, + markPtr->body.mark.linePtr); + } else { + markPtr = (TkTextSegment *) ckalloc(MSEG_SIZE); + markPtr->typePtr = &tkTextRightMarkType; + markPtr->size = 0; + markPtr->body.mark.textPtr = textPtr; + markPtr->body.mark.linePtr = indexPtr->linePtr; + markPtr->body.mark.hPtr = hPtr; + Tcl_SetHashValue(hPtr, markPtr); + } + TkBTreeLinkSegment(markPtr, indexPtr); + + /* + * If the mark is the insertion cursor, then update the screen at the + * mark's new location. + */ + + if (markPtr == textPtr->insertMarkPtr) { + TkTextIndex index2; + + TkTextIndexForwChars(indexPtr, 1, &index2); + TkTextChanged(textPtr, indexPtr, &index2); + } + return markPtr; +} + +/* + *-------------------------------------------------------------- + * + * TkTextMarkSegToIndex -- + * + * Given a segment that is a mark, create an index that + * refers to the next text character (or other text segment + * with non-zero size) after the mark. + * + * Results: + * *IndexPtr is filled in with index information. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +void +TkTextMarkSegToIndex(textPtr, markPtr, indexPtr) + TkText *textPtr; /* Text widget containing mark. */ + TkTextSegment *markPtr; /* Mark segment. */ + TkTextIndex *indexPtr; /* Index information gets stored here. */ +{ + TkTextSegment *segPtr; + + indexPtr->tree = textPtr->tree; + indexPtr->linePtr = markPtr->body.mark.linePtr; + indexPtr->charIndex = 0; + for (segPtr = indexPtr->linePtr->segPtr; segPtr != markPtr; + segPtr = segPtr->nextPtr) { + indexPtr->charIndex += segPtr->size; + } +} + +/* + *-------------------------------------------------------------- + * + * TkTextMarkNameToIndex -- + * + * Given the name of a mark, return an index corresponding + * to the mark name. + * + * Results: + * The return value is TCL_OK if "name" exists as a mark in + * the text widget. In this case *indexPtr is filled in with + * the next segment whose after the mark whose size is + * non-zero. TCL_ERROR is returned if the mark doesn't exist + * in the text widget. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +TkTextMarkNameToIndex(textPtr, name, indexPtr) + TkText *textPtr; /* Text widget containing mark. */ + char *name; /* Name of mark. */ + TkTextIndex *indexPtr; /* Index information gets stored here. */ +{ + Tcl_HashEntry *hPtr; + + hPtr = Tcl_FindHashEntry(&textPtr->markTable, name); + if (hPtr == NULL) { + return TCL_ERROR; + } + TkTextMarkSegToIndex(textPtr, (TkTextSegment *) Tcl_GetHashValue(hPtr), + indexPtr); + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * MarkDeleteProc -- + * + * This procedure is invoked by the text B-tree code whenever + * a mark lies in a range of characters being deleted. + * + * Results: + * Returns 1 to indicate that deletion has been rejected. + * + * Side effects: + * None (even if the whole tree is being deleted we don't + * free up the mark; it will be done elsewhere). + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +MarkDeleteProc(segPtr, linePtr, treeGone) + TkTextSegment *segPtr; /* Segment being deleted. */ + TkTextLine *linePtr; /* Line containing segment. */ + int treeGone; /* Non-zero means the entire tree is + * being deleted, so everything must + * get cleaned up. */ +{ + return 1; +} + +/* + *-------------------------------------------------------------- + * + * MarkCleanupProc -- + * + * This procedure is invoked by the B-tree code whenever a + * mark segment is moved from one line to another. + * + * Results: + * None. + * + * Side effects: + * The linePtr field of the segment gets updated. + * + *-------------------------------------------------------------- + */ + +static TkTextSegment * +MarkCleanupProc(markPtr, linePtr) + TkTextSegment *markPtr; /* Mark segment that's being moved. */ + TkTextLine *linePtr; /* Line that now contains segment. */ +{ + markPtr->body.mark.linePtr = linePtr; + return markPtr; +} + +/* + *-------------------------------------------------------------- + * + * MarkLayoutProc -- + * + * This procedure is the "layoutProc" for mark segments. + * + * Results: + * If the mark isn't the insertion cursor then the return + * value is -1 to indicate that this segment shouldn't be + * displayed. If the mark is the insertion character then + * 1 is returned and the chunkPtr structure is filled in. + * + * Side effects: + * None, except for filling in chunkPtr. + * + *-------------------------------------------------------------- + */ + + /*ARGSUSED*/ +static int +MarkLayoutProc(textPtr, indexPtr, segPtr, offset, maxX, maxChars, + noCharsYet, wrapMode, chunkPtr) + TkText *textPtr; /* Text widget being layed out. */ + TkTextIndex *indexPtr; /* Identifies first character in chunk. */ + TkTextSegment *segPtr; /* Segment corresponding to indexPtr. */ + int offset; /* Offset within segPtr corresponding to + * indexPtr (always 0). */ + int maxX; /* Chunk must not occupy pixels at this + * position or higher. */ + int maxChars; /* Chunk must not include more than this + * many characters. */ + int noCharsYet; /* Non-zero means no characters have been + * assigned to this line yet. */ + Tk_Uid wrapMode; /* Not used. */ + register TkTextDispChunk *chunkPtr; + /* Structure to fill in with information + * about this chunk. The x field has already + * been set by the caller. */ +{ + if (segPtr != textPtr->insertMarkPtr) { + return -1; + } + + chunkPtr->displayProc = TkTextInsertDisplayProc; + chunkPtr->undisplayProc = InsertUndisplayProc; + chunkPtr->measureProc = (Tk_ChunkMeasureProc *) NULL; + chunkPtr->bboxProc = (Tk_ChunkBboxProc *) NULL; + chunkPtr->numChars = 0; + chunkPtr->minAscent = 0; + chunkPtr->minDescent = 0; + chunkPtr->minHeight = 0; + chunkPtr->width = 0; + + /* + * Note: can't break a line after the insertion cursor: this + * prevents the insertion cursor from being stranded at the end + * of a line. + */ + + chunkPtr->breakIndex = -1; + chunkPtr->clientData = (ClientData) textPtr; + return 1; +} + +/* + *-------------------------------------------------------------- + * + * TkTextInsertDisplayProc -- + * + * This procedure is called to display the insertion + * cursor. + * + * Results: + * None. + * + * Side effects: + * Graphics are drawn. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +void +TkTextInsertDisplayProc(chunkPtr, x, y, height, baseline, display, dst, screenY) + TkTextDispChunk *chunkPtr; /* Chunk that is to be drawn. */ + int x; /* X-position in dst at which to + * draw this chunk (may differ from + * the x-position in the chunk because + * of scrolling). */ + int y; /* Y-position at which to draw this + * chunk in dst (x-position is in + * the chunk itself). */ + int height; /* Total height of line. */ + int baseline; /* Offset of baseline from y. */ + Display *display; /* Display to use for drawing. */ + Drawable dst; /* Pixmap or window in which to draw + * chunk. */ + int screenY; /* Y-coordinate in text window that + * corresponds to y. */ +{ + TkText *textPtr = (TkText *) chunkPtr->clientData; + int halfWidth = textPtr->insertWidth/2; + + if ((x + halfWidth) <= 0) { + /* + * The insertion cursor is off-screen. Just return. + */ + + return; + } + + /* + * As a special hack to keep the cursor visible on mono displays + * (or anywhere else that the selection and insertion cursors + * have the same color) write the default background in the cursor + * area (instead of nothing) when the cursor isn't on. Otherwise + * the selection might hide the cursor. + */ + + if (textPtr->flags & INSERT_ON) { + Tk_Fill3DRectangle(textPtr->tkwin, dst, textPtr->insertBorder, + x - textPtr->insertWidth/2, y, textPtr->insertWidth, + height, textPtr->insertBorderWidth, TK_RELIEF_RAISED); + } else if (textPtr->selBorder == textPtr->insertBorder) { + Tk_Fill3DRectangle(textPtr->tkwin, dst, textPtr->border, + x - textPtr->insertWidth/2, y, textPtr->insertWidth, + height, 0, TK_RELIEF_FLAT); + } +} + +/* + *-------------------------------------------------------------- + * + * InsertUndisplayProc -- + * + * This procedure is called when the insertion cursor is no + * longer at a visible point on the display. It does nothing + * right now. + * + * Results: + * None. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +InsertUndisplayProc(textPtr, chunkPtr) + TkText *textPtr; /* Overall information about text + * widget. */ + TkTextDispChunk *chunkPtr; /* Chunk that is about to be freed. */ +{ + return; +} + +/* + *-------------------------------------------------------------- + * + * MarkCheckProc -- + * + * This procedure is invoked by the B-tree code to perform + * consistency checks on mark segments. + * + * Results: + * None. + * + * Side effects: + * The procedure panics if it detects anything wrong with + * the mark. + * + *-------------------------------------------------------------- + */ + +static void +MarkCheckProc(markPtr, linePtr) + TkTextSegment *markPtr; /* Segment to check. */ + TkTextLine *linePtr; /* Line containing segment. */ +{ + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + + if (markPtr->body.mark.linePtr != linePtr) { + panic("MarkCheckProc: markPtr->body.mark.linePtr bogus"); + } + + /* + * Make sure that the mark is still present in the text's mark + * hash table. + */ + + for (hPtr = Tcl_FirstHashEntry(&markPtr->body.mark.textPtr->markTable, + &search); hPtr != markPtr->body.mark.hPtr; + hPtr = Tcl_NextHashEntry(&search)) { + if (hPtr == NULL) { + panic("MarkCheckProc couldn't find hash table entry for mark"); + } + } +} + +/* + *-------------------------------------------------------------- + * + * MarkFindNext -- + * + * This procedure searches forward for the next mark. + * + * Results: + * A standard Tcl result, which is a mark name or an empty string. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static int +MarkFindNext(interp, textPtr, string) + Tcl_Interp *interp; /* For error reporting */ + TkText *textPtr; /* The widget */ + char *string; /* The starting index or mark name */ +{ + TkTextIndex index; + Tcl_HashEntry *hPtr; + register TkTextSegment *segPtr; + int offset; + + + hPtr = Tcl_FindHashEntry(&textPtr->markTable, string); + if (hPtr != NULL) { + /* + * If given a mark name, return the next mark in the list of + * segments, even if it happens to be at the same character position. + */ + segPtr = (TkTextSegment *) Tcl_GetHashValue(hPtr); + TkTextMarkSegToIndex(textPtr, segPtr, &index); + segPtr = segPtr->nextPtr; + } else { + /* + * For non-mark name indices we want to return any marks that + * are right at the index. + */ + if (TkTextGetIndex(interp, textPtr, string, &index) != TCL_OK) { + return TCL_ERROR; + } + for (offset = 0, segPtr = index.linePtr->segPtr; + segPtr != NULL && offset < index.charIndex; + offset += segPtr->size, segPtr = segPtr->nextPtr) { + /* Empty loop body */ ; + } + } + while (1) { + /* + * segPtr points at the first possible candidate, + * or NULL if we ran off the end of the line. + */ + for ( ; segPtr != NULL ; segPtr = segPtr->nextPtr) { + if (segPtr->typePtr == &tkTextRightMarkType || + segPtr->typePtr == &tkTextLeftMarkType) { + Tcl_SetResult(interp, + Tcl_GetHashKey(&textPtr->markTable, segPtr->body.mark.hPtr), + TCL_STATIC); + return TCL_OK; + } + } + index.linePtr = TkBTreeNextLine(index.linePtr); + if (index.linePtr == (TkTextLine *) NULL) { + return TCL_OK; + } + index.charIndex = 0; + segPtr = index.linePtr->segPtr; + } +} + +/* + *-------------------------------------------------------------- + * + * MarkFindPrev -- + * + * This procedure searches backwards for the previous mark. + * + * Results: + * A standard Tcl result, which is a mark name or an empty string. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static int +MarkFindPrev(interp, textPtr, string) + Tcl_Interp *interp; /* For error reporting */ + TkText *textPtr; /* The widget */ + char *string; /* The starting index or mark name */ +{ + TkTextIndex index; + Tcl_HashEntry *hPtr; + register TkTextSegment *segPtr, *seg2Ptr, *prevPtr; + int offset; + + + hPtr = Tcl_FindHashEntry(&textPtr->markTable, string); + if (hPtr != NULL) { + /* + * If given a mark name, return the previous mark in the list of + * segments, even if it happens to be at the same character position. + */ + segPtr = (TkTextSegment *) Tcl_GetHashValue(hPtr); + TkTextMarkSegToIndex(textPtr, segPtr, &index); + } else { + /* + * For non-mark name indices we do not return any marks that + * are right at the index. + */ + if (TkTextGetIndex(interp, textPtr, string, &index) != TCL_OK) { + return TCL_ERROR; + } + for (offset = 0, segPtr = index.linePtr->segPtr; + segPtr != NULL && offset < index.charIndex; + offset += segPtr->size, segPtr = segPtr->nextPtr) { + /* Empty loop body */ ; + } + } + while (1) { + /* + * segPtr points just past the first possible candidate, + * or at the begining of the line. + */ + for (prevPtr = NULL, seg2Ptr = index.linePtr->segPtr; + seg2Ptr != NULL && seg2Ptr != segPtr; + seg2Ptr = seg2Ptr->nextPtr) { + if (seg2Ptr->typePtr == &tkTextRightMarkType || + seg2Ptr->typePtr == &tkTextLeftMarkType) { + prevPtr = seg2Ptr; + } + } + if (prevPtr != NULL) { + Tcl_SetResult(interp, + Tcl_GetHashKey(&textPtr->markTable, prevPtr->body.mark.hPtr), + TCL_STATIC); + return TCL_OK; + } + index.linePtr = TkBTreePreviousLine(index.linePtr); + if (index.linePtr == (TkTextLine *) NULL) { + return TCL_OK; + } + segPtr = NULL; + } +} diff --git a/tk3.6/tkTextTag.c b/tk4.2/generic/tkTextTag.c similarity index 52% rename from tk3.6/tkTextTag.c rename to tk4.2/generic/tkTextTag.c index 68a0dff..d05ebab 100644 --- a/tk3.6/tkTextTag.c +++ b/tk4.2/generic/tkTextTag.c @@ -5,33 +5,17 @@ * for text widgets, plus most of the other high-level functions * related to tags. * - * Copyright (c) 1992-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1992-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tkTextTag.c 1.36 96/03/07 15:30:43 */ -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkTextTag.c,v 1.7 93/06/16 17:16:35 ouster Exp $ SPRITE (Berkeley)"; -#endif - #include "default.h" -#include "tkConfig.h" +#include "tkPort.h" #include "tk.h" #include "tkText.h" @@ -44,30 +28,48 @@ static Tk_ConfigSpec tagConfigSpecs[] = { (char *) NULL, Tk_Offset(TkTextTag, border), TK_CONFIG_NULL_OK}, {TK_CONFIG_BITMAP, "-bgstipple", (char *) NULL, (char *) NULL, (char *) NULL, Tk_Offset(TkTextTag, bgStipple), TK_CONFIG_NULL_OK}, - {TK_CONFIG_PIXELS, "-borderwidth", (char *) NULL, (char *) NULL, - "0", Tk_Offset(TkTextTag, borderWidth), TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_STRING, "-borderwidth", (char *) NULL, (char *) NULL, + "0", Tk_Offset(TkTextTag, bdString), + TK_CONFIG_DONT_SET_DEFAULT|TK_CONFIG_NULL_OK}, {TK_CONFIG_BITMAP, "-fgstipple", (char *) NULL, (char *) NULL, (char *) NULL, Tk_Offset(TkTextTag, fgStipple), TK_CONFIG_NULL_OK}, {TK_CONFIG_FONT, "-font", (char *) NULL, (char *) NULL, (char *) NULL, Tk_Offset(TkTextTag, fontPtr), TK_CONFIG_NULL_OK}, {TK_CONFIG_COLOR, "-foreground", (char *) NULL, (char *) NULL, (char *) NULL, Tk_Offset(TkTextTag, fgColor), TK_CONFIG_NULL_OK}, - {TK_CONFIG_RELIEF, "-relief", (char *) NULL, (char *) NULL, - "flat", Tk_Offset(TkTextTag, relief), TK_CONFIG_DONT_SET_DEFAULT}, - {TK_CONFIG_BOOLEAN, "-underline", (char *) NULL, (char *) NULL, - "0", Tk_Offset(TkTextTag, underline), TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_STRING, "-justify", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextTag, justifyString), TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-lmargin1", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextTag, lMargin1String), TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-lmargin2", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextTag, lMargin2String), TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-offset", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextTag, offsetString), TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-overstrike", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextTag, overstrikeString), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-relief", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextTag, reliefString), TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-rmargin", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextTag, rMarginString), TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-spacing1", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextTag, spacing1String), TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-spacing2", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextTag, spacing2String), TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-spacing3", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextTag, spacing3String), TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-tabs", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextTag, tabString), TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-underline", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextTag, underlineString), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_UID, "-wrap", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextTag, wrapMode), + TK_CONFIG_NULL_OK}, {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, (char *) NULL, 0, 0} }; - -/* - * The following definition specifies the maximum number of characters - * needed in a string to hold a position specifier. - */ - -#define POS_CHARS 30 - /* * Forward declarations for procedures defined later in this file: */ @@ -80,8 +82,6 @@ static void SortTags _ANSI_ARGS_((int numTags, TkTextTag **tagArrayPtr)); static int TagSortProc _ANSI_ARGS_((CONST VOID *first, CONST VOID *second)); -static void TextDoEvent _ANSI_ARGS_((TkText *textPtr, - XEvent *eventPtr)); /* *-------------------------------------------------------------- @@ -110,10 +110,11 @@ TkTextTagCmd(textPtr, interp, argc, argv) * parsed this command enough to know that * argv[1] is "tag". */ { - int length, line1, ch1, line2, ch2, i, addTag; - char c; + int c, i, addTag; + size_t length; char *fullOption; register TkTextTag *tagPtr; + TkTextIndex first, last, index1, index2; if (argc < 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", @@ -127,44 +128,58 @@ TkTextTagCmd(textPtr, interp, argc, argv) addTag = 1; addAndRemove: - if ((argc != 5) && (argc != 6)) { + if (argc < 5) { Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " tag ", fullOption, " tagName index1 ?index2?\"", + argv[0], " tag ", fullOption, + " tagName index1 ?index2 index1 index2 ...?\"", (char *) NULL); return TCL_ERROR; } tagPtr = TkTextCreateTag(textPtr, argv[3]); - if (TkTextGetIndex(interp, textPtr, argv[4], &line1, &ch1) != TCL_OK) { - return TCL_ERROR; - } - if (argc == 6) { - if (TkTextGetIndex(interp, textPtr, argv[5], &line2, &ch2) - != TCL_OK) { + for (i = 4; i < argc; i += 2) { + if (TkTextGetIndex(interp, textPtr, argv[i], &index1) != TCL_OK) { return TCL_ERROR; } - } else { - line2 = line1; - ch2 = ch1+1; - } - if (TK_TAG_AFFECTS_DISPLAY(tagPtr)) { - TkTextRedrawTag(textPtr, line1, ch1, line2, ch2, tagPtr, !addTag); - } - TkBTreeTag(textPtr->tree, line1, ch1, line2, ch2, tagPtr, addTag); - - /* - * If the tag is "sel" then grab the selection if we're supposed - * to export it and don't already have it. Also, invalidate - * partially-completed selection retrievals. - */ - - if (tagPtr == textPtr->selTagPtr) { - if (addTag && textPtr->exportSelection - && !(textPtr->flags & GOT_SELECTION)) { - Tk_OwnSelection(textPtr->tkwin, TkTextLostSelection, - (ClientData) textPtr); - textPtr->flags |= GOT_SELECTION; + if (argc > (i+1)) { + if (TkTextGetIndex(interp, textPtr, argv[i+1], &index2) + != TCL_OK) { + return TCL_ERROR; + } + if (TkTextIndexCmp(&index1, &index2) >= 0) { + return TCL_OK; + } + } else { + index2 = index1; + TkTextIndexForwChars(&index2, 1, &index2); + } + + if (tagPtr->affectsDisplay) { + TkTextRedrawTag(textPtr, &index1, &index2, tagPtr, !addTag); + } else { + /* + * Still need to trigger enter/leave events on tags that + * have changed. + */ + + TkTextEventuallyRepick(textPtr); + } + TkBTreeTag(&index1, &index2, tagPtr, addTag); + + /* + * If the tag is "sel" then grab the selection if we're supposed + * to export it and don't already have it. Also, invalidate + * partially-completed selection retrievals. + */ + + if (tagPtr == textPtr->selTagPtr) { + if (addTag && textPtr->exportSelection + && !(textPtr->flags & GOT_SELECTION)) { + Tk_OwnSelection(textPtr->tkwin, XA_PRIMARY, + TkTextLostSelection, (ClientData) textPtr); + textPtr->flags |= GOT_SELECTION; + } + textPtr->abortSelections = 1; } - textPtr->selOffset = -1; } } else if ((c == 'b') && (strncmp(argv[2], "bind", length) == 0)) { if ((argc < 4) || (argc > 6)) { @@ -201,11 +216,11 @@ TkTextTagCmd(textPtr, interp, argc, argv) if (mask == 0) { return TCL_ERROR; } - if (mask & ~(ButtonMotionMask|Button1MotionMask|Button2MotionMask - |Button3MotionMask|Button4MotionMask|Button5MotionMask - |ButtonPressMask|ButtonReleaseMask|EnterWindowMask - |LeaveWindowMask|KeyPressMask|KeyReleaseMask - |PointerMotionMask)) { + if (mask & (unsigned) ~(ButtonMotionMask|Button1MotionMask + |Button2MotionMask|Button3MotionMask|Button4MotionMask + |Button5MotionMask|ButtonPressMask|ButtonReleaseMask + |EnterWindowMask|LeaveWindowMask|KeyPressMask + |KeyReleaseMask|PointerMotionMask)) { Tk_DeleteBinding(interp, textPtr->bindingTable, (ClientData) tagPtr, argv[4]); Tcl_ResetResult(interp); @@ -227,7 +242,22 @@ TkTextTagCmd(textPtr, interp, argc, argv) Tk_GetAllBindings(interp, textPtr->bindingTable, (ClientData) tagPtr); } - } else if ((c == 'c') && (strncmp(argv[2], "configure", length) == 0)) { + } else if ((c == 'c') && (strncmp(argv[2], "cget", length) == 0) + && (length >= 2)) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " tag cget tagName option\"", + (char *) NULL); + return TCL_ERROR; + } + tagPtr = FindTag(interp, textPtr, argv[3]); + if (tagPtr == NULL) { + return TCL_ERROR; + } + return Tk_ConfigureValue(interp, textPtr->tkwin, tagConfigSpecs, + (char *) tagPtr, argv[4], 0); + } else if ((c == 'c') && (strncmp(argv[2], "configure", length) == 0) + && (length >= 2)) { if (argc < 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " tag configure tagName ?option? ?value? ", @@ -246,6 +276,118 @@ TkTextTagCmd(textPtr, interp, argc, argv) result = Tk_ConfigureWidget(interp, textPtr->tkwin, tagConfigSpecs, argc-4, argv+4, (char *) tagPtr, 0); + /* + * Some of the configuration options, like -underline + * and -justify, require additional translation (this is + * needed because we need to distinguish a particular value + * of an option from "unspecified"). + */ + + if (tagPtr->bdString != NULL) { + if (Tk_GetPixels(interp, textPtr->tkwin, tagPtr->bdString, + &tagPtr->borderWidth) != TCL_OK) { + return TCL_ERROR; + } + if (tagPtr->borderWidth < 0) { + tagPtr->borderWidth = 0; + } + } + if (tagPtr->reliefString != NULL) { + if (Tk_GetRelief(interp, tagPtr->reliefString, + &tagPtr->relief) != TCL_OK) { + return TCL_ERROR; + } + } + if (tagPtr->justifyString != NULL) { + if (Tk_GetJustify(interp, tagPtr->justifyString, + &tagPtr->justify) != TCL_OK) { + return TCL_ERROR; + } + } + if (tagPtr->lMargin1String != NULL) { + if (Tk_GetPixels(interp, textPtr->tkwin, + tagPtr->lMargin1String, &tagPtr->lMargin1) != TCL_OK) { + return TCL_ERROR; + } + } + if (tagPtr->lMargin2String != NULL) { + if (Tk_GetPixels(interp, textPtr->tkwin, + tagPtr->lMargin2String, &tagPtr->lMargin2) != TCL_OK) { + return TCL_ERROR; + } + } + if (tagPtr->offsetString != NULL) { + if (Tk_GetPixels(interp, textPtr->tkwin, tagPtr->offsetString, + &tagPtr->offset) != TCL_OK) { + return TCL_ERROR; + } + } + if (tagPtr->overstrikeString != NULL) { + if (Tcl_GetBoolean(interp, tagPtr->overstrikeString, + &tagPtr->overstrike) != TCL_OK) { + return TCL_ERROR; + } + } + if (tagPtr->rMarginString != NULL) { + if (Tk_GetPixels(interp, textPtr->tkwin, + tagPtr->rMarginString, &tagPtr->rMargin) != TCL_OK) { + return TCL_ERROR; + } + } + if (tagPtr->spacing1String != NULL) { + if (Tk_GetPixels(interp, textPtr->tkwin, + tagPtr->spacing1String, &tagPtr->spacing1) != TCL_OK) { + return TCL_ERROR; + } + if (tagPtr->spacing1 < 0) { + tagPtr->spacing1 = 0; + } + } + if (tagPtr->spacing2String != NULL) { + if (Tk_GetPixels(interp, textPtr->tkwin, + tagPtr->spacing2String, &tagPtr->spacing2) != TCL_OK) { + return TCL_ERROR; + } + if (tagPtr->spacing2 < 0) { + tagPtr->spacing2 = 0; + } + } + if (tagPtr->spacing3String != NULL) { + if (Tk_GetPixels(interp, textPtr->tkwin, + tagPtr->spacing3String, &tagPtr->spacing3) != TCL_OK) { + return TCL_ERROR; + } + if (tagPtr->spacing3 < 0) { + tagPtr->spacing3 = 0; + } + } + if (tagPtr->tabArrayPtr != NULL) { + ckfree((char *) tagPtr->tabArrayPtr); + tagPtr->tabArrayPtr = NULL; + } + if (tagPtr->tabString != NULL) { + tagPtr->tabArrayPtr = TkTextGetTabs(interp, textPtr->tkwin, + tagPtr->tabString); + if (tagPtr->tabArrayPtr == NULL) { + return TCL_ERROR; + } + } + if (tagPtr->underlineString != NULL) { + if (Tcl_GetBoolean(interp, tagPtr->underlineString, + &tagPtr->underline) != TCL_OK) { + return TCL_ERROR; + } + } + if ((tagPtr->wrapMode != NULL) + && (tagPtr->wrapMode != tkTextCharUid) + && (tagPtr->wrapMode != tkTextNoneUid) + && (tagPtr->wrapMode != tkTextWordUid)) { + Tcl_AppendResult(interp, "bad wrap mode \"", tagPtr->wrapMode, + "\": must be char, none, or word", (char *) NULL); + tagPtr->wrapMode = NULL; + return TCL_ERROR; + } + /* * If the "sel" tag was changed, be sure to mirror information * from the tag back into the text widget record. NOTE: we @@ -256,11 +398,32 @@ TkTextTagCmd(textPtr, interp, argc, argv) if (tagPtr == textPtr->selTagPtr) { textPtr->selBorder = tagPtr->border; - textPtr->selBorderWidth = tagPtr->borderWidth; + textPtr->selBdString = tagPtr->bdString; textPtr->selFgColorPtr = tagPtr->fgColor; } - TkTextRedrawTag(textPtr, 0, 0, TkBTreeNumLines(textPtr->tree), - 0, tagPtr, 1); + tagPtr->affectsDisplay = 0; + if ((tagPtr->border != NULL) + || (tagPtr->bdString != NULL) + || (tagPtr->reliefString != NULL) + || (tagPtr->bgStipple != None) + || (tagPtr->fgColor != NULL) || (tagPtr->fontPtr != None) + || (tagPtr->fgStipple != None) + || (tagPtr->justifyString != NULL) + || (tagPtr->lMargin1String != NULL) + || (tagPtr->lMargin2String != NULL) + || (tagPtr->offsetString != NULL) + || (tagPtr->overstrikeString != NULL) + || (tagPtr->rMarginString != NULL) + || (tagPtr->spacing1String != NULL) + || (tagPtr->spacing2String != NULL) + || (tagPtr->spacing3String != NULL) + || (tagPtr->tabString != NULL) + || (tagPtr->underlineString != NULL) + || (tagPtr->wrapMode != NULL)) { + tagPtr->affectsDisplay = 1; + } + TkTextRedrawTag(textPtr, (TkTextIndex *) NULL, + (TkTextIndex *) NULL, tagPtr, 1); return result; } } else if ((c == 'd') && (strncmp(argv[2], "delete", length) == 0)) { @@ -279,15 +442,16 @@ TkTextTagCmd(textPtr, interp, argc, argv) } tagPtr = (TkTextTag *) Tcl_GetHashValue(hPtr); if (tagPtr == textPtr->selTagPtr) { - interp->result = "can't delete selection tag"; - return TCL_ERROR; + continue; } - if (TK_TAG_AFFECTS_DISPLAY(tagPtr)) { - TkTextRedrawTag(textPtr, 0, 0, TkBTreeNumLines(textPtr->tree), - 0, tagPtr, 1); + if (tagPtr->affectsDisplay) { + TkTextRedrawTag(textPtr, (TkTextIndex *) NULL, + (TkTextIndex *) NULL, tagPtr, 1); } - TkBTreeTag(textPtr->tree, 0, 0, TkBTreeNumLines(textPtr->tree), - 0, tagPtr, 0); + TkBTreeTag(TkTextMakeIndex(textPtr->tree, 0, 0, &first), + TkTextMakeIndex(textPtr->tree, + TkBTreeNumLines(textPtr->tree), 0, &last), + tagPtr, 0); Tcl_DeleteHashEntry(hPtr); if (textPtr->bindingTable != NULL) { Tk_DeleteAllBindings(textPtr->bindingTable, @@ -312,7 +476,7 @@ TkTextTagCmd(textPtr, interp, argc, argv) (char *) NULL); return TCL_ERROR; } - tagPtr = FindTag(interp, textPtr, argv[3]); + tagPtr = FindTag(interp, textPtr, argv[3]); if (tagPtr == NULL) { return TCL_ERROR; } @@ -330,13 +494,12 @@ TkTextTagCmd(textPtr, interp, argc, argv) prio = 0; } ChangeTagPriority(textPtr, tagPtr, prio); - TkTextRedrawTag(textPtr, 0, 0, TkBTreeNumLines(textPtr->tree), - 0, tagPtr, 1); + TkTextRedrawTag(textPtr, (TkTextIndex *) NULL, (TkTextIndex *) NULL, + tagPtr, 1); } else if ((c == 'n') && (strncmp(argv[2], "names", length) == 0) && (length >= 2)) { TkTextTag **arrayPtr; int arraySize; - TkTextLine *linePtr; if ((argc != 3) && (argc != 4)) { Tcl_AppendResult(interp, "wrong # args: should be \"", @@ -356,15 +519,11 @@ TkTextTagCmd(textPtr, interp, argc, argv) } arraySize = textPtr->numTags; } else { - if (TkTextGetIndex(interp, textPtr, argv[3], &line1, &ch1) + if (TkTextGetIndex(interp, textPtr, argv[3], &index1) != TCL_OK) { return TCL_ERROR; } - linePtr = TkBTreeFindLine(textPtr->tree, line1); - if (linePtr == NULL) { - return TCL_OK; - } - arrayPtr = TkBTreeGetTags(textPtr->tree, linePtr, ch1, &arraySize); + arrayPtr = TkBTreeGetTags(&index1, &arraySize); if (arrayPtr == NULL) { return TCL_OK; } @@ -378,7 +537,7 @@ TkTextTagCmd(textPtr, interp, argc, argv) } else if ((c == 'n') && (strncmp(argv[2], "nextrange", length) == 0) && (length >= 2)) { TkTextSearch tSearch; - char position[POS_CHARS]; + char position[TK_POS_CHARS]; if ((argc != 5) && (argc != 6)) { Tcl_AppendResult(interp, "wrong # args: should be \"", @@ -390,46 +549,123 @@ TkTextTagCmd(textPtr, interp, argc, argv) if (tagPtr == NULL) { return TCL_OK; } - if (TkTextGetIndex(interp, textPtr, argv[4], &line1, &ch1) != TCL_OK) { + if (TkTextGetIndex(interp, textPtr, argv[4], &index1) != TCL_OK) { return TCL_ERROR; } + TkTextMakeIndex(textPtr->tree, TkBTreeNumLines(textPtr->tree), + 0, &last); if (argc == 5) { - line2 = TkBTreeNumLines(textPtr->tree); - ch2 = 0; - } else if (TkTextGetIndex(interp, textPtr, argv[5], &line2, &ch2) + index2 = last; + } else if (TkTextGetIndex(interp, textPtr, argv[5], &index2) != TCL_OK) { return TCL_ERROR; } /* * The search below is a bit tricky. Rather than use the B-tree - * facilities to stop the search at line2.ch2, let it search up - * until the end of the file but check for a position past line2.ch2 + * facilities to stop the search at index2, let it search up + * until the end of the file but check for a position past index2 * ourselves. The reason for doing it this way is that we only - * care whether the *start* of the range is before line2.ch2; once + * care whether the *start* of the range is before index2; once * we find the start, we don't want TkBTreeNextTag to abort the - * search because the end of the range is after line2.ch2. + * search because the end of the range is after index2. */ - TkBTreeStartSearch(textPtr->tree, line1, ch1, - TkBTreeNumLines(textPtr->tree), 0, tagPtr, &tSearch); - if (!TkBTreeNextTag(&tSearch)) { - return TCL_OK; - } - if (!TkBTreeCharTagged(tSearch.linePtr, tSearch.ch1, tagPtr)) { + TkBTreeStartSearch(&index1, &last, tagPtr, &tSearch); + if (TkBTreeCharTagged(&index1, tagPtr)) { + TkTextSegment *segPtr; + int offset; + + /* + * The first character is tagged. See if there is an + * on-toggle just before the character. If not, then + * skip to the end of this tagged range. + */ + + for (segPtr = index1.linePtr->segPtr, offset = index1.charIndex; + offset >= 0; + offset -= segPtr->size, segPtr = segPtr->nextPtr) { + if ((offset == 0) && (segPtr->typePtr == &tkTextToggleOnType) + && (segPtr->body.toggle.tagPtr == tagPtr)) { + goto gotStart; + } + } if (!TkBTreeNextTag(&tSearch)) { - return TCL_OK; + return TCL_OK; } } - if ((tSearch.line1 > line2) || ((tSearch.line1 == line2) - && (tSearch.ch1 >= ch2))) { + + /* + * Find the start of the tagged range. + */ + + if (!TkBTreeNextTag(&tSearch)) { return TCL_OK; } - TkTextPrintIndex(tSearch.line1, tSearch.ch1, position); + gotStart: + if (TkTextIndexCmp(&tSearch.curIndex, &index2) >= 0) { + return TCL_OK; + } + TkTextPrintIndex(&tSearch.curIndex, position); Tcl_AppendElement(interp, position); TkBTreeNextTag(&tSearch); - TkTextPrintIndex(tSearch.line1, tSearch.ch1, position); + TkTextPrintIndex(&tSearch.curIndex, position); Tcl_AppendElement(interp, position); + } else if ((c == 'p') && (strncmp(argv[2], "prevrange", length) == 0) + && (length >= 2)) { + TkTextSearch tSearch; + char position1[TK_POS_CHARS]; + char position2[TK_POS_CHARS]; + + if ((argc != 5) && (argc != 6)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " tag prevrange tagName index1 ?index2?\"", + (char *) NULL); + return TCL_ERROR; + } + tagPtr = FindTag((Tcl_Interp *) NULL, textPtr, argv[3]); + if (tagPtr == NULL) { + return TCL_OK; + } + if (TkTextGetIndex(interp, textPtr, argv[4], &index1) != TCL_OK) { + return TCL_ERROR; + } + if (argc == 5) { + TkTextMakeIndex(textPtr->tree, 0, 0, &index2); + } else if (TkTextGetIndex(interp, textPtr, argv[5], &index2) + != TCL_OK) { + return TCL_ERROR; + } + + /* + * The search below is a bit weird. The previous toggle can be + * either an on or off toggle. If it is an on toggle, then we + * need to turn around and search forward for the end toggle. + * Otherwise we keep searching backwards. + */ + + TkBTreeStartSearchBack(&index1, &index2, tagPtr, &tSearch); + + if (!TkBTreePrevTag(&tSearch)) { + return TCL_OK; + } + if (tSearch.segPtr->typePtr == &tkTextToggleOnType) { + TkTextPrintIndex(&tSearch.curIndex, position1); + TkTextMakeIndex(textPtr->tree, TkBTreeNumLines(textPtr->tree), + 0, &last); + TkBTreeStartSearch(&tSearch.curIndex, &last, tagPtr, &tSearch); + TkBTreeNextTag(&tSearch); + TkTextPrintIndex(&tSearch.curIndex, position2); + } else { + TkTextPrintIndex(&tSearch.curIndex, position2); + TkBTreePrevTag(&tSearch); + if (TkTextIndexCmp(&tSearch.curIndex, &index2) < 0) { + return TCL_OK; + } + TkTextPrintIndex(&tSearch.curIndex, position1); + } + Tcl_AppendElement(interp, position1); + Tcl_AppendElement(interp, position2); } else if ((c == 'r') && (strncmp(argv[2], "raise", length) == 0) && (length >= 3)) { TkTextTag *tagPtr2; @@ -459,12 +695,12 @@ TkTextTagCmd(textPtr, interp, argc, argv) prio = textPtr->numTags-1; } ChangeTagPriority(textPtr, tagPtr, prio); - TkTextRedrawTag(textPtr, 0, 0, TkBTreeNumLines(textPtr->tree), - 0, tagPtr, 1); + TkTextRedrawTag(textPtr, (TkTextIndex *) NULL, (TkTextIndex *) NULL, + tagPtr, 1); } else if ((c == 'r') && (strncmp(argv[2], "ranges", length) == 0) && (length >= 3)) { TkTextSearch tSearch; - char position[POS_CHARS]; + char position[TK_POS_CHARS]; if (argc != 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", @@ -475,10 +711,16 @@ TkTextTagCmd(textPtr, interp, argc, argv) if (tagPtr == NULL) { return TCL_OK; } - TkBTreeStartSearch(textPtr->tree, 0, 0, TkBTreeNumLines(textPtr->tree), - 0, tagPtr, &tSearch); + TkTextMakeIndex(textPtr->tree, 0, 0, &first); + TkTextMakeIndex(textPtr->tree, TkBTreeNumLines(textPtr->tree), + 0, &last); + TkBTreeStartSearch(&first, &last, tagPtr, &tSearch); + if (TkBTreeCharTagged(&first, tagPtr)) { + TkTextPrintIndex(&first, position); + Tcl_AppendElement(interp, position); + } while (TkBTreeNextTag(&tSearch)) { - TkTextPrintIndex(tSearch.line1, tSearch.ch1, position); + TkTextPrintIndex(&tSearch.curIndex, position); Tcl_AppendElement(interp, position); } } else if ((c == 'r') && (strncmp(argv[2], "remove", length) == 0) @@ -488,7 +730,7 @@ TkTextTagCmd(textPtr, interp, argc, argv) goto addAndRemove; } else { Tcl_AppendResult(interp, "bad tag option \"", argv[2], - "\": must be add, bind, configure, delete, lower, ", + "\": must be add, bind, cget, configure, delete, lower, ", "names, nextrange, raise, ranges, or remove", (char *) NULL); return TCL_ERROR; @@ -535,15 +777,42 @@ TkTextCreateTag(textPtr, tagName) tagPtr = (TkTextTag *) ckalloc(sizeof(TkTextTag)); tagPtr->name = Tcl_GetHashKey(&textPtr->tagTable, hPtr); + tagPtr->toggleCount = 0; + tagPtr->tagRootPtr = NULL; tagPtr->priority = textPtr->numTags; tagPtr->border = NULL; - tagPtr->borderWidth = 1; + tagPtr->bdString = NULL; + tagPtr->borderWidth = 0; + tagPtr->reliefString = NULL; tagPtr->relief = TK_RELIEF_FLAT; tagPtr->bgStipple = None; tagPtr->fgColor = NULL; tagPtr->fontPtr = NULL; tagPtr->fgStipple = None; + tagPtr->justifyString = NULL; + tagPtr->justify = TK_JUSTIFY_LEFT; + tagPtr->lMargin1String = NULL; + tagPtr->lMargin1 = 0; + tagPtr->lMargin2String = NULL; + tagPtr->lMargin2 = 0; + tagPtr->offsetString = NULL; + tagPtr->offset = 0; + tagPtr->overstrikeString = NULL; + tagPtr->overstrike = 0; + tagPtr->rMarginString = NULL; + tagPtr->rMargin = 0; + tagPtr->spacing1String = NULL; + tagPtr->spacing1 = 0; + tagPtr->spacing2String = NULL; + tagPtr->spacing2 = 0; + tagPtr->spacing3String = NULL; + tagPtr->spacing3 = 0; + tagPtr->tabString = NULL; + tagPtr->tabArrayPtr = NULL; + tagPtr->underlineString = NULL; tagPtr->underline = 0; + tagPtr->wrapMode = NULL; + tagPtr->affectsDisplay = 0; textPtr->numTags++; Tcl_SetHashValue(hPtr, tagPtr); return tagPtr; @@ -614,15 +883,60 @@ TkTextFreeTag(textPtr, tagPtr) if (tagPtr->border != None) { Tk_Free3DBorder(tagPtr->border); } + if (tagPtr->bdString != NULL) { + ckfree(tagPtr->bdString); + } + if (tagPtr->reliefString != NULL) { + ckfree(tagPtr->reliefString); + } if (tagPtr->bgStipple != None) { Tk_FreeBitmap(textPtr->display, tagPtr->bgStipple); } if (tagPtr->fgColor != None) { Tk_FreeColor(tagPtr->fgColor); } + if (tagPtr->fontPtr != None) { + Tk_FreeFontStruct(tagPtr->fontPtr); + } if (tagPtr->fgStipple != None) { Tk_FreeBitmap(textPtr->display, tagPtr->fgStipple); } + if (tagPtr->justifyString != NULL) { + ckfree(tagPtr->justifyString); + } + if (tagPtr->lMargin1String != NULL) { + ckfree(tagPtr->lMargin1String); + } + if (tagPtr->lMargin2String != NULL) { + ckfree(tagPtr->lMargin2String); + } + if (tagPtr->offsetString != NULL) { + ckfree(tagPtr->offsetString); + } + if (tagPtr->overstrikeString != NULL) { + ckfree(tagPtr->overstrikeString); + } + if (tagPtr->rMarginString != NULL) { + ckfree(tagPtr->rMarginString); + } + if (tagPtr->spacing1String != NULL) { + ckfree(tagPtr->spacing1String); + } + if (tagPtr->spacing2String != NULL) { + ckfree(tagPtr->spacing2String); + } + if (tagPtr->spacing3String != NULL) { + ckfree(tagPtr->spacing3String); + } + if (tagPtr->tabString != NULL) { + ckfree(tagPtr->tabString); + } + if (tagPtr->tabArrayPtr != NULL) { + ckfree((char *) tagPtr->tabArrayPtr); + } + if (tagPtr->underlineString != NULL) { + ckfree(tagPtr->underlineString); + } ckfree((char *) tagPtr); } @@ -671,7 +985,7 @@ SortTags(numTags, tagArrayPtr) *tagArrayPtr = tmp; } } else { - qsort((VOID *) tagArrayPtr, numTags, sizeof (TkTextTag *), + qsort((VOID *) tagArrayPtr, (unsigned) numTags, sizeof (TkTextTag *), TagSortProc); } } @@ -713,7 +1027,7 @@ TagSortProc(first, second) * ChangeTagPriority -- * * This procedure changes the priority of a tag by modifying - * its priority and all other ones whose priority is affected + * its priority and the priorities of other tags that are affected * by the change. * * Results: @@ -794,12 +1108,15 @@ TkTextBindProc(clientData, eventPtr) TkText *textPtr = (TkText *) clientData; int repick = 0; - Tk_Preserve((ClientData) textPtr); +# define AnyButtonMask (Button1Mask|Button2Mask|Button3Mask\ + |Button4Mask|Button5Mask) + + Tcl_Preserve((ClientData) textPtr); /* - * This code simulates grabs for mouse buttons by refusing to - * pick a new current character between the time a mouse button goes - * down and the time when the last mouse button is released. + * This code simulates grabs for mouse buttons by keeping track + * of whether a button is pressed and refusing to pick a new current + * character while a button is pressed. */ if (eventPtr->type == ButtonPress) { @@ -827,19 +1144,32 @@ TkTextBindProc(clientData, eventPtr) mask = 0; break; } - if ((eventPtr->xbutton.state & (Button1Mask|Button2Mask - |Button3Mask|Button4Mask|Button5Mask)) == mask) { + if ((eventPtr->xbutton.state & AnyButtonMask) == mask) { textPtr->flags &= ~BUTTON_DOWN; repick = 1; } } else if ((eventPtr->type == EnterNotify) || (eventPtr->type == LeaveNotify)) { + if (eventPtr->xcrossing.state & AnyButtonMask) { + textPtr->flags |= BUTTON_DOWN; + } else { + textPtr->flags &= ~BUTTON_DOWN; + } TkTextPickCurrent(textPtr, eventPtr); goto done; } else if (eventPtr->type == MotionNotify) { + if (eventPtr->xmotion.state & AnyButtonMask) { + textPtr->flags |= BUTTON_DOWN; + } else { + textPtr->flags &= ~BUTTON_DOWN; + } TkTextPickCurrent(textPtr, eventPtr); } - TextDoEvent(textPtr, eventPtr); + if ((textPtr->numCurTags > 0) && (textPtr->bindingTable != NULL) + && (textPtr->tkwin != NULL)) { + Tk_BindEvent(textPtr->bindingTable, eventPtr, textPtr->tkwin, + textPtr->numCurTags, (ClientData *) textPtr->curTagArrayPtr); + } if (repick) { unsigned int oldState; @@ -851,7 +1181,7 @@ TkTextBindProc(clientData, eventPtr) } done: - Tk_Release((ClientData) textPtr); + Tcl_Release((ClientData) textPtr); } /* @@ -859,19 +1189,21 @@ TkTextBindProc(clientData, eventPtr) * * TkTextPickCurrent -- * - * Find the topmost item in a canvas that contains a given - * location and mark the the current item. If the current - * item has changed, generate a fake exit event on the old - * current item and a fake enter event on the new current - * item. + * Find the character containing the coordinates in an event + * and place the "current" mark on that character. If the + * "current" mark has moved then generate a fake leave event + * on the old current character and a fake enter event on the new + * current character. * * Results: * None. * * Side effects: - * The current item for textPtr may change. If it does, - * then the commands associated with item entry and exit - * could do just about anything. + * The current mark for textPtr may change. If it does, + * then the commands associated with character entry and leave + * could do just about anything. For example, the text widget + * might be deleted. It is up to the caller to protect itself + * with calls to Tcl_Preserve and Tcl_Release. * *-------------------------------------------------------------- */ @@ -885,8 +1217,13 @@ TkTextPickCurrent(textPtr, eventPtr) * LeaveWindow, ButtonRelease, or * MotionNotify. */ { - TkTextLine *linePtr; - int ch; + TkTextIndex index; + TkTextTag **oldArrayPtr, **newArrayPtr; + TkTextTag **copyArrayPtr = NULL; /* Initialization needed to prevent + * compiler warning. */ + + int numOldTags, numNewTags, i, j, size; + XEvent event; /* * If a button is down, then don't do anything at all; we'll be @@ -895,13 +1232,26 @@ TkTextPickCurrent(textPtr, eventPtr) */ if (textPtr->flags & BUTTON_DOWN) { - return; + if (((eventPtr->type == EnterNotify) || (eventPtr->type == LeaveNotify)) + && ((eventPtr->xcrossing.mode == NotifyGrab) + || (eventPtr->xcrossing.mode == NotifyUngrab))) { + /* + * Special case: the window is being entered or left because + * of a grab or ungrab. In this case, repick after all. + * Furthermore, clear BUTTON_DOWN to release the simulated + * grab. + */ + + textPtr->flags &= ~BUTTON_DOWN; + } else { + return; + } } /* - * Save information about this event in the widget for use if we have + * Save information about this event in the widget in case we have * to synthesize more enter and leave events later (e.g. because a - * character was deleting, causing a new character to be underneath + * character was deleted, causing a new character to be underneath * the mouse cursor). Also translate MotionNotify events into * EnterNotify events, since that's what gets reported to event * handlers when the current character changes. @@ -934,146 +1284,95 @@ TkTextPickCurrent(textPtr, eventPtr) } } - linePtr = NULL; + /* + * Find the new current character, then find and sort all of the + * tags associated with it. + */ + if (textPtr->pickEvent.type != LeaveNotify) { - linePtr = TkTextCharAtLoc(textPtr, textPtr->pickEvent.xcrossing.x, - textPtr->pickEvent.xcrossing.y, &ch); - } - - /* - * Simulate a LeaveNotify event on the previous current character and - * an EnterNotify event on the new current character. Also, move the - * "current" mark to its new place. - */ - - if (textPtr->flags & IN_CURRENT) { - if ((linePtr == textPtr->currentAnnotPtr->linePtr) - && (ch == textPtr->currentAnnotPtr->ch)) { - return; - } + TkTextPixelIndex(textPtr, textPtr->pickEvent.xcrossing.x, + textPtr->pickEvent.xcrossing.y, &index); + newArrayPtr = TkBTreeGetTags(&index, &numNewTags); + SortTags(numNewTags, newArrayPtr); } else { - if (linePtr == NULL) { - return; + newArrayPtr = NULL; + numNewTags = 0; + } + + /* + * Resort the tags associated with the previous marked character + * (the priorities might have changed), then make a copy of the + * new tags, and compare the old tags to the copy, nullifying + * any tags that are present in both groups (i.e. the tags that + * haven't changed). + */ + + SortTags(textPtr->numCurTags, textPtr->curTagArrayPtr); + if (numNewTags > 0) { + size = numNewTags * sizeof(TkTextTag *); + copyArrayPtr = (TkTextTag **) ckalloc((unsigned) size); + memcpy((VOID *) copyArrayPtr, (VOID *) newArrayPtr, (size_t) size); + for (i = 0; i < textPtr->numCurTags; i++) { + for (j = 0; j < numNewTags; j++) { + if (textPtr->curTagArrayPtr[i] == copyArrayPtr[j]) { + textPtr->curTagArrayPtr[i] = NULL; + copyArrayPtr[j] = NULL; + break; + } + } } } - if (textPtr->flags & IN_CURRENT) { - XEvent event; - event = textPtr->pickEvent; - event.type = LeaveNotify; - TextDoEvent(textPtr, &event); - textPtr->flags &= ~IN_CURRENT; - } - if (linePtr != NULL) { - XEvent event; + /* + * Invoke the binding system with a LeaveNotify event for all of + * the tags that have gone away. We have to be careful here, + * because it's possible that the binding could do something + * (like calling tkwait) that eventually modifies + * textPtr->curTagArrayPtr. To avoid problems in situations like + * this, update curTagArrayPtr to its new value before invoking + * any bindings, and don't use it any more here. + */ - TkBTreeRemoveAnnotation(textPtr->currentAnnotPtr); - textPtr->currentAnnotPtr->linePtr = linePtr; - textPtr->currentAnnotPtr->ch = ch; - TkBTreeAddAnnotation(textPtr->currentAnnotPtr); - event = textPtr->pickEvent; - event.type = EnterNotify; - TextDoEvent(textPtr, &event); - textPtr->flags |= IN_CURRENT; - } -} - -/* - *---------------------------------------------------------------------- - * - * TkTextUnpickCurrent -- - * - * This procedure is called when the "current" character is - * deleted: it synthesizes a "leave" event for the character. - * - * Results: - * None. - * - * Side effects: - * A binding associated with one of the tags on the current - * character may be triggered. - * - *---------------------------------------------------------------------- - */ + numOldTags = textPtr->numCurTags; + textPtr->numCurTags = numNewTags; + oldArrayPtr = textPtr->curTagArrayPtr; + textPtr->curTagArrayPtr = newArrayPtr; + if (numOldTags != 0) { + if ((textPtr->bindingTable != NULL) && (textPtr->tkwin != NULL)) { + event = textPtr->pickEvent; + event.type = LeaveNotify; -void -TkTextUnpickCurrent(textPtr) - TkText *textPtr; /* Text widget information. */ -{ - if (textPtr->flags & IN_CURRENT) { - XEvent event; + /* + * Always use a detail of NotifyAncestor. Besides being + * consistent, this avoids problems where the binding code + * will discard NotifyInferior events. + */ - event = textPtr->pickEvent; - event.type = LeaveNotify; - TextDoEvent(textPtr, &event); - textPtr->flags &= ~IN_CURRENT; - } -} - -/* - *-------------------------------------------------------------- - * - * TextDoEvent -- - * - * This procedure is called to invoke binding processing - * for a new event that is associated with the current character - * for a text widget. - * - * Results: - * None. - * - * Side effects: - * Depends on the bindings for the text. - * - *-------------------------------------------------------------- - */ - -static void -TextDoEvent(textPtr, eventPtr) - TkText *textPtr; /* Text widget in which event - * occurred. */ - XEvent *eventPtr; /* Real or simulated X event that - * is to be processed. */ -{ - TkTextTag **tagArrayPtr, **p1, **p2, *tmp; - int numTags; - - if (textPtr->bindingTable == NULL) { - return; + event.xcrossing.detail = NotifyAncestor; + Tk_BindEvent(textPtr->bindingTable, &event, textPtr->tkwin, + numOldTags, (ClientData *) oldArrayPtr); + } + ckfree((char *) oldArrayPtr); } /* - * Set up an array containing all of the tags that are associated - * with the current character. This array will be used to look - * for bindings. If there are no tags then there can't be any - * bindings. + * Reset the "current" mark (be careful to recompute its location, + * since it might have changed during an event binding). Then + * invoke the binding system with an EnterNotify event for all of + * the tags that have just appeared. */ - tagArrayPtr = TkBTreeGetTags(textPtr->tree, - textPtr->currentAnnotPtr->linePtr, textPtr->currentAnnotPtr->ch, - &numTags); - if (numTags == 0) { - return; + TkTextPixelIndex(textPtr, textPtr->pickEvent.xcrossing.x, + textPtr->pickEvent.xcrossing.y, &index); + TkTextSetMark(textPtr, "current", &index); + if (numNewTags != 0) { + if ((textPtr->bindingTable != NULL) && (textPtr->tkwin != NULL)) { + event = textPtr->pickEvent; + event.type = EnterNotify; + event.xcrossing.detail = NotifyAncestor; + Tk_BindEvent(textPtr->bindingTable, &event, textPtr->tkwin, + numNewTags, (ClientData *) copyArrayPtr); + } + ckfree((char *) copyArrayPtr); } - - /* - * Sort the array of tags. SortTags sorts it backwards, so after it - * returns we have to reverse the order in the array. - */ - - SortTags(numTags, tagArrayPtr); - for (p1 = tagArrayPtr, p2 = tagArrayPtr + numTags - 1; - p1 < p2; p1++, p2--) { - tmp = *p1; - *p1 = *p2; - *p2 = tmp; - } - - /* - * Invoke the binding system, then free up the tag array. - */ - - Tk_BindEvent(textPtr->bindingTable, eventPtr, textPtr->tkwin, - numTags, (ClientData *) tagArrayPtr); - ckfree((char *) tagArrayPtr); } diff --git a/tk4.2/generic/tkTextWind.c b/tk4.2/generic/tkTextWind.c new file mode 100644 index 0000000..0f9d4ba --- /dev/null +++ b/tk4.2/generic/tkTextWind.c @@ -0,0 +1,1178 @@ +/* + * tkTextWind.c -- + * + * This file contains code that allows arbitrary windows to be + * nested inside text widgets. It also implements the "window" + * widget command for texts. + * + * Copyright (c) 1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkTextWind.c 1.13 96/02/15 18:53:02 + */ + +#include "tk.h" +#include "tkText.h" +#include "tkPort.h" + +/* + * The following structure is the official type record for the + * embedded window geometry manager: + */ + +static void EmbWinRequestProc _ANSI_ARGS_((ClientData clientData, + Tk_Window tkwin)); +static void EmbWinLostSlaveProc _ANSI_ARGS_((ClientData clientData, + Tk_Window tkwin)); + +static Tk_GeomMgr textGeomType = { + "text", /* name */ + EmbWinRequestProc, /* requestProc */ + EmbWinLostSlaveProc, /* lostSlaveProc */ +}; + +/* + * Definitions for alignment values: + */ + +#define ALIGN_BOTTOM 0 +#define ALIGN_CENTER 1 +#define ALIGN_TOP 2 +#define ALIGN_BASELINE 3 + +/* + * Macro that determines the size of an embedded window segment: + */ + +#define EW_SEG_SIZE ((unsigned) (Tk_Offset(TkTextSegment, body) \ + + sizeof(TkTextEmbWindow))) + +/* + * Prototypes for procedures defined in this file: + */ + +static int AlignParseProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, Tk_Window tkwin, char *value, + char *widgRec, int offset)); +static char * AlignPrintProc _ANSI_ARGS_((ClientData clientData, + Tk_Window tkwin, char *widgRec, int offset, + Tcl_FreeProc **freeProcPtr)); +static TkTextSegment * EmbWinCleanupProc _ANSI_ARGS_((TkTextSegment *segPtr, + TkTextLine *linePtr)); +static void EmbWinCheckProc _ANSI_ARGS_((TkTextSegment *segPtr, + TkTextLine *linePtr)); +static void EmbWinBboxProc _ANSI_ARGS_((TkTextDispChunk *chunkPtr, + int index, int y, int lineHeight, int baseline, + int *xPtr, int *yPtr, int *widthPtr, + int *heightPtr)); +static int EmbWinConfigure _ANSI_ARGS_((TkText *textPtr, + TkTextSegment *ewPtr, int argc, char **argv)); +static void EmbWinDelayedUnmap _ANSI_ARGS_(( + ClientData clientData)); +static int EmbWinDeleteProc _ANSI_ARGS_((TkTextSegment *segPtr, + TkTextLine *linePtr, int treeGone)); +static void EmbWinDisplayProc _ANSI_ARGS_(( + TkTextDispChunk *chunkPtr, int x, int y, + int lineHeight, int baseline, Display *display, + Drawable dst, int screenY)); +static int EmbWinLayoutProc _ANSI_ARGS_((TkText *textPtr, + TkTextIndex *indexPtr, TkTextSegment *segPtr, + int offset, int maxX, int maxChars, + int noCharsYet, Tk_Uid wrapMode, + TkTextDispChunk *chunkPtr)); +static void EmbWinStructureProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +static void EmbWinUndisplayProc _ANSI_ARGS_((TkText *textPtr, + TkTextDispChunk *chunkPtr)); + +/* + * The following structure declares the "embedded window" segment type. + */ + +static Tk_SegType tkTextEmbWindowType = { + "window", /* name */ + 0, /* leftGravity */ + (Tk_SegSplitProc *) NULL, /* splitProc */ + EmbWinDeleteProc, /* deleteProc */ + EmbWinCleanupProc, /* cleanupProc */ + (Tk_SegLineChangeProc *) NULL, /* lineChangeProc */ + EmbWinLayoutProc, /* layoutProc */ + EmbWinCheckProc /* checkProc */ +}; + +/* + * Information used for parsing window configuration options: + */ + +static Tk_CustomOption alignOption = {AlignParseProc, AlignPrintProc, + (ClientData) NULL}; + +static Tk_ConfigSpec configSpecs[] = { + {TK_CONFIG_CUSTOM, "-align", (char *) NULL, (char *) NULL, + "center", 0, TK_CONFIG_DONT_SET_DEFAULT, &alignOption}, + {TK_CONFIG_STRING, "-create", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextEmbWindow, create), + TK_CONFIG_DONT_SET_DEFAULT|TK_CONFIG_NULL_OK}, + {TK_CONFIG_INT, "-padx", (char *) NULL, (char *) NULL, + "0", Tk_Offset(TkTextEmbWindow, padX), + TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_INT, "-pady", (char *) NULL, (char *) NULL, + "0", Tk_Offset(TkTextEmbWindow, padY), + TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_BOOLEAN, "-stretch", (char *) NULL, (char *) NULL, + "0", Tk_Offset(TkTextEmbWindow, stretch), + TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_WINDOW, "-window", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextEmbWindow, tkwin), + TK_CONFIG_DONT_SET_DEFAULT|TK_CONFIG_NULL_OK}, + {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, 0} +}; + +/* + *-------------------------------------------------------------- + * + * TkTextWindowCmd -- + * + * This procedure implements the "window" widget command + * for text widgets. See the user documentation for details + * on what it does. + * + * Results: + * A standard Tcl result or error. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +int +TkTextWindowCmd(textPtr, interp, argc, argv) + register TkText *textPtr; /* Information about text widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. Someone else has already + * parsed this command enough to know that + * argv[1] is "window". */ +{ + int c; + size_t length; + register TkTextSegment *ewPtr; + + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " window option ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + c = argv[2][0]; + length = strlen(argv[2]); + if ((strncmp(argv[2], "cget", length) == 0) && (length >= 2)) { + TkTextIndex index; + TkTextSegment *ewPtr; + + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " window cget index option\"", + (char *) NULL); + return TCL_ERROR; + } + if (TkTextGetIndex(interp, textPtr, argv[3], &index) != TCL_OK) { + return TCL_ERROR; + } + ewPtr = TkTextIndexToSeg(&index, (int *) NULL); + if (ewPtr->typePtr != &tkTextEmbWindowType) { + Tcl_AppendResult(interp, "no embedded window at index \"", + argv[3], "\"", (char *) NULL); + return TCL_ERROR; + } + return Tk_ConfigureValue(interp, textPtr->tkwin, configSpecs, + (char *) &ewPtr->body.ew, argv[4], 0); + } else if ((strncmp(argv[2], "configure", length) == 0) && (length >= 2)) { + TkTextIndex index; + TkTextSegment *ewPtr; + + if (argc < 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " window configure index ?option value ...?\"", + (char *) NULL); + return TCL_ERROR; + } + if (TkTextGetIndex(interp, textPtr, argv[3], &index) != TCL_OK) { + return TCL_ERROR; + } + ewPtr = TkTextIndexToSeg(&index, (int *) NULL); + if (ewPtr->typePtr != &tkTextEmbWindowType) { + Tcl_AppendResult(interp, "no embedded window at index \"", + argv[3], "\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 4) { + return Tk_ConfigureInfo(interp, textPtr->tkwin, configSpecs, + (char *) &ewPtr->body.ew, (char *) NULL, 0); + } else if (argc == 5) { + return Tk_ConfigureInfo(interp, textPtr->tkwin, configSpecs, + (char *) &ewPtr->body.ew, argv[4], 0); + } else { + TkTextChanged(textPtr, &index, &index); + return EmbWinConfigure(textPtr, ewPtr, argc-4, argv+4); + } + } else if ((strncmp(argv[2], "create", length) == 0) && (length >= 2)) { + TkTextIndex index; + int lineIndex; + + /* + * Add a new window. Find where to put the new window, and + * mark that position for redisplay. + */ + + if (argc < 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " window create index ?option value ...?\"", + (char *) NULL); + return TCL_ERROR; + } + if (TkTextGetIndex(interp, textPtr, argv[3], &index) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Don't allow insertions on the last (dummy) line of the text. + */ + + lineIndex = TkBTreeLineIndex(index.linePtr); + if (lineIndex == TkBTreeNumLines(textPtr->tree)) { + lineIndex--; + TkTextMakeIndex(textPtr->tree, lineIndex, 1000000, &index); + } + + /* + * Create the new window segment and initialize it. + */ + + ewPtr = (TkTextSegment *) ckalloc(EW_SEG_SIZE); + ewPtr->typePtr = &tkTextEmbWindowType; + ewPtr->size = 1; + ewPtr->body.ew.textPtr = textPtr; + ewPtr->body.ew.linePtr = NULL; + ewPtr->body.ew.tkwin = NULL; + ewPtr->body.ew.create = NULL; + ewPtr->body.ew.align = ALIGN_CENTER; + ewPtr->body.ew.padX = ewPtr->body.ew.padY = 0; + ewPtr->body.ew.stretch = 0; + ewPtr->body.ew.chunkCount = 0; + ewPtr->body.ew.displayed = 0; + + /* + * Link the segment into the text widget, then configure it (delete + * it again if the configuration fails). + */ + + TkTextChanged(textPtr, &index, &index); + TkBTreeLinkSegment(ewPtr, &index); + if (EmbWinConfigure(textPtr, ewPtr, argc-4, argv+4) != TCL_OK) { + TkTextIndex index2; + + TkTextIndexForwChars(&index, 1, &index2); + TkBTreeDeleteChars(&index, &index2); + return TCL_ERROR; + } + } else if (strncmp(argv[2], "names", length) == 0) { + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " window names\"", (char *) NULL); + return TCL_ERROR; + } + for (hPtr = Tcl_FirstHashEntry(&textPtr->windowTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + Tcl_AppendElement(interp, + Tcl_GetHashKey(&textPtr->markTable, hPtr)); + } + } else { + Tcl_AppendResult(interp, "bad window option \"", argv[2], + "\": must be cget, configure, create, or names", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * EmbWinConfigure -- + * + * This procedure is called to handle configuration options + * for an embedded window, using an argc/argv list. + * + * Results: + * The return value is a standard Tcl result. If TCL_ERROR is + * returned, then interp->result contains an error message.. + * + * Side effects: + * Configuration information for the embedded window changes, + * such as alignment, stretching, or name of the embedded + * window. + * + *-------------------------------------------------------------- + */ + +static int +EmbWinConfigure(textPtr, ewPtr, argc, argv) + TkText *textPtr; /* Information about text widget that + * contains embedded window. */ + TkTextSegment *ewPtr; /* Embedded window to be configured. */ + int argc; /* Number of strings in argv. */ + char **argv; /* Array of strings describing configuration + * options. */ +{ + Tk_Window oldWindow; + Tcl_HashEntry *hPtr; + int new; + + oldWindow = ewPtr->body.ew.tkwin; + if (Tk_ConfigureWidget(textPtr->interp, textPtr->tkwin, configSpecs, + argc, argv, (char *) &ewPtr->body.ew, TK_CONFIG_ARGV_ONLY) + != TCL_OK) { + return TCL_ERROR; + } + if (oldWindow != ewPtr->body.ew.tkwin) { + if (oldWindow != NULL) { + Tcl_DeleteHashEntry(Tcl_FindHashEntry(&textPtr->windowTable, + Tk_PathName(oldWindow))); + Tk_DeleteEventHandler(oldWindow, StructureNotifyMask, + EmbWinStructureProc, (ClientData) ewPtr); + Tk_ManageGeometry(oldWindow, (Tk_GeomMgr *) NULL, + (ClientData) NULL); + if (textPtr->tkwin != Tk_Parent(oldWindow)) { + Tk_UnmaintainGeometry(oldWindow, textPtr->tkwin); + } else { + Tk_UnmapWindow(oldWindow); + } + } + if (ewPtr->body.ew.tkwin != NULL) { + Tk_Window ancestor, parent; + + /* + * Make sure that the text is either the parent of the + * embedded window or a descendant of that parent. Also, + * don't allow a top-level window to be managed inside + * a text. + */ + + parent = Tk_Parent(ewPtr->body.ew.tkwin); + for (ancestor = textPtr->tkwin; ; + ancestor = Tk_Parent(ancestor)) { + if (ancestor == parent) { + break; + } + if (Tk_IsTopLevel(ancestor)) { + badMaster: + Tcl_AppendResult(textPtr->interp, "can't embed ", + Tk_PathName(ewPtr->body.ew.tkwin), " in ", + Tk_PathName(textPtr->tkwin), (char *) NULL); + ewPtr->body.ew.tkwin = NULL; + return TCL_ERROR; + } + } + if (Tk_IsTopLevel(ewPtr->body.ew.tkwin) + || (ewPtr->body.ew.tkwin == textPtr->tkwin)) { + goto badMaster; + } + + /* + * Take over geometry management for the window, plus create + * an event handler to find out when it is deleted. + */ + + Tk_ManageGeometry(ewPtr->body.ew.tkwin, &textGeomType, + (ClientData) ewPtr); + Tk_CreateEventHandler(ewPtr->body.ew.tkwin, StructureNotifyMask, + EmbWinStructureProc, (ClientData) ewPtr); + + /* + * Special trick! Must enter into the hash table *after* + * calling Tk_ManageGeometry: if the window was already managed + * elsewhere in this text, the Tk_ManageGeometry call will cause + * the entry to be removed, which could potentially lose the new + * entry. + */ + + hPtr = Tcl_CreateHashEntry(&textPtr->windowTable, + Tk_PathName(ewPtr->body.ew.tkwin), &new); + Tcl_SetHashValue(hPtr, ewPtr); + + } + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * AlignParseProc -- + * + * This procedure is invoked by Tk_ConfigureWidget during + * option processing to handle "-align" options for embedded + * windows. + * + * Results: + * A standard Tcl return value. + * + * Side effects: + * The alignment for the embedded window may change. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +AlignParseProc(clientData, interp, tkwin, value, widgRec, offset) + ClientData clientData; /* Not used.*/ + Tcl_Interp *interp; /* Used for reporting errors. */ + Tk_Window tkwin; /* Window for text widget. */ + char *value; /* Value of option. */ + char *widgRec; /* Pointer to TkTextEmbWindow + * structure. */ + int offset; /* Offset into item (ignored). */ +{ + register TkTextEmbWindow *embPtr = (TkTextEmbWindow *) widgRec; + + if (strcmp(value, "baseline") == 0) { + embPtr->align = ALIGN_BASELINE; + } else if (strcmp(value, "bottom") == 0) { + embPtr->align = ALIGN_BOTTOM; + } else if (strcmp(value, "center") == 0) { + embPtr->align = ALIGN_CENTER; + } else if (strcmp(value, "top") == 0) { + embPtr->align = ALIGN_TOP; + } else { + Tcl_AppendResult(interp, "bad alignment \"", value, + "\": must be baseline, bottom, center, or top", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * AlignPrintProc -- + * + * This procedure is invoked by the Tk configuration code + * to produce a printable string for the "-align" configuration + * option for embedded windows. + * + * Results: + * The return value is a string describing the embedded + * window's current alignment. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static char * +AlignPrintProc(clientData, tkwin, widgRec, offset, freeProcPtr) + ClientData clientData; /* Ignored. */ + Tk_Window tkwin; /* Window for text widget. */ + char *widgRec; /* Pointer to TkTextEmbWindow + * structure. */ + int offset; /* Ignored. */ + Tcl_FreeProc **freeProcPtr; /* Pointer to variable to fill in with + * information about how to reclaim + * storage for return string. */ +{ + switch (((TkTextEmbWindow *) widgRec)->align) { + case ALIGN_BASELINE: + return "baseline"; + case ALIGN_BOTTOM: + return "bottom"; + case ALIGN_CENTER: + return "center"; + case ALIGN_TOP: + return "top"; + default: + return "??"; + } +} + +/* + *-------------------------------------------------------------- + * + * EmbWinStructureProc -- + * + * This procedure is invoked by the Tk event loop whenever + * StructureNotify events occur for a window that's embedded + * in a text widget. This procedure's only purpose is to + * clean up when windows are deleted. + * + * Results: + * None. + * + * Side effects: + * The window is disassociated from the window segment, and + * the portion of the text is redisplayed. + * + *-------------------------------------------------------------- + */ + +static void +EmbWinStructureProc(clientData, eventPtr) + ClientData clientData; /* Pointer to record describing window item. */ + XEvent *eventPtr; /* Describes what just happened. */ +{ + register TkTextSegment *ewPtr = (TkTextSegment *) clientData; + TkTextIndex index; + + if (eventPtr->type != DestroyNotify) { + return; + } + + Tcl_DeleteHashEntry(Tcl_FindHashEntry(&ewPtr->body.ew.textPtr->windowTable, + Tk_PathName(ewPtr->body.ew.tkwin))); + ewPtr->body.ew.tkwin = NULL; + index.tree = ewPtr->body.ew.textPtr->tree; + index.linePtr = ewPtr->body.ew.linePtr; + index.charIndex = TkTextSegToOffset(ewPtr, ewPtr->body.ew.linePtr); + TkTextChanged(ewPtr->body.ew.textPtr, &index, &index); +} + +/* + *-------------------------------------------------------------- + * + * EmbWinRequestProc -- + * + * This procedure is invoked whenever a window that's associated + * with a window canvas item changes its requested dimensions. + * + * Results: + * None. + * + * Side effects: + * The size and location on the screen of the window may change, + * depending on the options specified for the window item. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +EmbWinRequestProc(clientData, tkwin) + ClientData clientData; /* Pointer to record for window item. */ + Tk_Window tkwin; /* Window that changed its desired + * size. */ +{ + TkTextSegment *ewPtr = (TkTextSegment *) clientData; + TkTextIndex index; + + index.tree = ewPtr->body.ew.textPtr->tree; + index.linePtr = ewPtr->body.ew.linePtr; + index.charIndex = TkTextSegToOffset(ewPtr, ewPtr->body.ew.linePtr); + TkTextChanged(ewPtr->body.ew.textPtr, &index, &index); +} + +/* + *-------------------------------------------------------------- + * + * EmbWinLostSlaveProc -- + * + * This procedure is invoked by the Tk geometry manager when + * a slave window managed by a text widget is claimed away + * by another geometry manager. + * + * Results: + * None. + * + * Side effects: + * The window is disassociated from the window segment, and + * the portion of the text is redisplayed. + * + *-------------------------------------------------------------- + */ + +static void +EmbWinLostSlaveProc(clientData, tkwin) + ClientData clientData; /* Pointer to record describing window item. */ + Tk_Window tkwin; /* Window that was claimed away by another + * geometry manager. */ +{ + register TkTextSegment *ewPtr = (TkTextSegment *) clientData; + TkTextIndex index; + + Tk_DeleteEventHandler(ewPtr->body.ew.tkwin, StructureNotifyMask, + EmbWinStructureProc, (ClientData) ewPtr); + Tcl_CancelIdleCall(EmbWinDelayedUnmap, (ClientData) ewPtr); + if (ewPtr->body.ew.textPtr->tkwin != Tk_Parent(tkwin)) { + Tk_UnmaintainGeometry(tkwin, ewPtr->body.ew.textPtr->tkwin); + } else { + Tk_UnmapWindow(tkwin); + } + Tcl_DeleteHashEntry(Tcl_FindHashEntry(&ewPtr->body.ew.textPtr->windowTable, + Tk_PathName(ewPtr->body.ew.tkwin))); + ewPtr->body.ew.tkwin = NULL; + index.tree = ewPtr->body.ew.textPtr->tree; + index.linePtr = ewPtr->body.ew.linePtr; + index.charIndex = TkTextSegToOffset(ewPtr, ewPtr->body.ew.linePtr); + TkTextChanged(ewPtr->body.ew.textPtr, &index, &index); +} + +/* + *-------------------------------------------------------------- + * + * EmbWinDeleteProc -- + * + * This procedure is invoked by the text B-tree code whenever + * an embedded window lies in a range of characters being deleted. + * + * Results: + * Returns 0 to indicate that the deletion has been accepted. + * + * Side effects: + * The embedded window is deleted, if it exists, and any resources + * associated with it are released. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +EmbWinDeleteProc(ewPtr, linePtr, treeGone) + TkTextSegment *ewPtr; /* Segment being deleted. */ + TkTextLine *linePtr; /* Line containing segment. */ + int treeGone; /* Non-zero means the entire tree is + * being deleted, so everything must + * get cleaned up. */ +{ + Tcl_HashEntry *hPtr; + + if (ewPtr->body.ew.tkwin != NULL) { + hPtr = Tcl_FindHashEntry(&ewPtr->body.ew.textPtr->windowTable, + Tk_PathName(ewPtr->body.ew.tkwin)); + if (hPtr != NULL) { + /* + * (It's possible for there to be no hash table entry for this + * window, if an error occurred while creating the window segment + * but before the window got added to the table) + */ + + Tcl_DeleteHashEntry(hPtr); + } + + /* + * Delete the event handler for the window before destroying + * the window, so that EmbWinStructureProc doesn't get called + * (we'll already do everything that it would have done, and + * it will just get confused). + */ + + Tk_DeleteEventHandler(ewPtr->body.ew.tkwin, StructureNotifyMask, + EmbWinStructureProc, (ClientData) ewPtr); + Tk_DestroyWindow(ewPtr->body.ew.tkwin); + } + Tcl_CancelIdleCall(EmbWinDelayedUnmap, (ClientData) ewPtr); + Tk_FreeOptions(configSpecs, (char *) &ewPtr->body.ew, + ewPtr->body.ew.textPtr->display, 0); + ckfree((char *) ewPtr); + return 0; +} + +/* + *-------------------------------------------------------------- + * + * EmbWinCleanupProc -- + * + * This procedure is invoked by the B-tree code whenever a + * segment containing an embedded window is moved from one + * line to another. + * + * Results: + * None. + * + * Side effects: + * The linePtr field of the segment gets updated. + * + *-------------------------------------------------------------- + */ + +static TkTextSegment * +EmbWinCleanupProc(ewPtr, linePtr) + TkTextSegment *ewPtr; /* Mark segment that's being moved. */ + TkTextLine *linePtr; /* Line that now contains segment. */ +{ + ewPtr->body.ew.linePtr = linePtr; + return ewPtr; +} + +/* + *-------------------------------------------------------------- + * + * EmbWinLayoutProc -- + * + * This procedure is the "layoutProc" for embedded window + * segments. + * + * Results: + * 1 is returned to indicate that the segment should be + * displayed. The chunkPtr structure is filled in. + * + * Side effects: + * None, except for filling in chunkPtr. + * + *-------------------------------------------------------------- + */ + + /*ARGSUSED*/ +static int +EmbWinLayoutProc(textPtr, indexPtr, ewPtr, offset, maxX, maxChars, + noCharsYet, wrapMode, chunkPtr) + TkText *textPtr; /* Text widget being layed out. */ + TkTextIndex *indexPtr; /* Identifies first character in chunk. */ + TkTextSegment *ewPtr; /* Segment corresponding to indexPtr. */ + int offset; /* Offset within segPtr corresponding to + * indexPtr (always 0). */ + int maxX; /* Chunk must not occupy pixels at this + * position or higher. */ + int maxChars; /* Chunk must not include more than this + * many characters. */ + int noCharsYet; /* Non-zero means no characters have been + * assigned to this line yet. */ + Tk_Uid wrapMode; /* Wrap mode to use for line: tkTextCharUid, + * tkTextNoneUid, or tkTextWordUid. */ + register TkTextDispChunk *chunkPtr; + /* Structure to fill in with information + * about this chunk. The x field has already + * been set by the caller. */ +{ + int width, height; + + if (offset != 0) { + panic("Non-zero offset in EmbWinLayoutProc"); + } + + if ((ewPtr->body.ew.tkwin == NULL) && (ewPtr->body.ew.create != NULL)) { + int code, new; + Tcl_DString name; + Tk_Window ancestor; + Tcl_HashEntry *hPtr; + + /* + * The window doesn't currently exist. Create it by evaluating + * the creation script. The script must return the window's + * path name: look up that name to get back to the window + * token. Then register ourselves as the geometry manager for + * the window. + */ + + code = Tcl_GlobalEval(textPtr->interp, ewPtr->body.ew.create); + if (code != TCL_OK) { + createError: + Tcl_BackgroundError(textPtr->interp); + goto gotWindow; + } + Tcl_DStringInit(&name); + Tcl_DStringAppend(&name, textPtr->interp->result, -1); + Tcl_ResetResult(textPtr->interp); + ewPtr->body.ew.tkwin = Tk_NameToWindow(textPtr->interp, + Tcl_DStringValue(&name), textPtr->tkwin); + if (ewPtr->body.ew.tkwin == NULL) { + goto createError; + } + for (ancestor = textPtr->tkwin; ; + ancestor = Tk_Parent(ancestor)) { + if (ancestor == Tk_Parent(ewPtr->body.ew.tkwin)) { + break; + } + if (Tk_IsTopLevel(ancestor)) { + badMaster: + Tcl_AppendResult(textPtr->interp, "can't embed ", + Tk_PathName(ewPtr->body.ew.tkwin), " relative to ", + Tk_PathName(textPtr->tkwin), (char *) NULL); + Tcl_BackgroundError(textPtr->interp); + ewPtr->body.ew.tkwin = NULL; + goto gotWindow; + } + } + if (Tk_IsTopLevel(ewPtr->body.ew.tkwin) + || (textPtr->tkwin == ewPtr->body.ew.tkwin)) { + goto badMaster; + } + Tk_ManageGeometry(ewPtr->body.ew.tkwin, &textGeomType, + (ClientData) ewPtr); + Tk_CreateEventHandler(ewPtr->body.ew.tkwin, StructureNotifyMask, + EmbWinStructureProc, (ClientData) ewPtr); + + /* + * Special trick! Must enter into the hash table *after* + * calling Tk_ManageGeometry: if the window was already managed + * elsewhere in this text, the Tk_ManageGeometry call will cause + * the entry to be removed, which could potentially lose the new + * entry. + */ + + hPtr = Tcl_CreateHashEntry(&textPtr->windowTable, + Tk_PathName(ewPtr->body.ew.tkwin), &new); + Tcl_SetHashValue(hPtr, ewPtr); + } + + /* + * See if there's room for this window on this line. + */ + + gotWindow: + if (ewPtr->body.ew.tkwin == NULL) { + width = 0; + height = 0; + } else { + width = Tk_ReqWidth(ewPtr->body.ew.tkwin) + 2*ewPtr->body.ew.padX; + height = Tk_ReqHeight(ewPtr->body.ew.tkwin) + 2*ewPtr->body.ew.padY; + } + if ((width > (maxX - chunkPtr->x)) + && !noCharsYet && (textPtr->wrapMode != tkTextNoneUid)) { + return 0; + } + + /* + * Fill in the chunk structure. + */ + + chunkPtr->displayProc = EmbWinDisplayProc; + chunkPtr->undisplayProc = EmbWinUndisplayProc; + chunkPtr->measureProc = (Tk_ChunkMeasureProc *) NULL; + chunkPtr->bboxProc = EmbWinBboxProc; + chunkPtr->numChars = 1; + if (ewPtr->body.ew.align == ALIGN_BASELINE) { + chunkPtr->minAscent = height - ewPtr->body.ew.padY; + chunkPtr->minDescent = ewPtr->body.ew.padY; + chunkPtr->minHeight = 0; + } else { + chunkPtr->minAscent = 0; + chunkPtr->minDescent = 0; + chunkPtr->minHeight = height; + } + chunkPtr->width = width; + chunkPtr->breakIndex = -1; + chunkPtr->breakIndex = 1; + chunkPtr->clientData = (ClientData) ewPtr; + ewPtr->body.ew.chunkCount += 1; + return 1; +} + +/* + *-------------------------------------------------------------- + * + * EmbWinCheckProc -- + * + * This procedure is invoked by the B-tree code to perform + * consistency checks on embedded windows. + * + * Results: + * None. + * + * Side effects: + * The procedure panics if it detects anything wrong with + * the embedded window. + * + *-------------------------------------------------------------- + */ + +static void +EmbWinCheckProc(ewPtr, linePtr) + TkTextSegment *ewPtr; /* Segment to check. */ + TkTextLine *linePtr; /* Line containing segment. */ +{ + if (ewPtr->nextPtr == NULL) { + panic("EmbWinCheckProc: embedded window is last segment in line"); + } + if (ewPtr->size != 1) { + panic("EmbWinCheckProc: embedded window has size %d", ewPtr->size); + } +} + +/* + *-------------------------------------------------------------- + * + * EmbWinDisplayProc -- + * + * This procedure is invoked by the text displaying code + * when it is time to actually draw an embedded window + * chunk on the screen. + * + * Results: + * None. + * + * Side effects: + * The embedded window gets moved to the correct location + * and mapped onto the screen. + * + *-------------------------------------------------------------- + */ + +static void +EmbWinDisplayProc(chunkPtr, x, y, lineHeight, baseline, display, dst, screenY) + TkTextDispChunk *chunkPtr; /* Chunk that is to be drawn. */ + int x; /* X-position in dst at which to + * draw this chunk (differs from + * the x-position in the chunk because + * of scrolling). */ + int y; /* Top of rectangular bounding box + * for line: tells where to draw this + * chunk in dst (x-position is in + * the chunk itself). */ + int lineHeight; /* Total height of line. */ + int baseline; /* Offset of baseline from y. */ + Display *display; /* Display to use for drawing. */ + Drawable dst; /* Pixmap or window in which to draw */ + int screenY; /* Y-coordinate in text window that + * corresponds to y. */ +{ + TkTextSegment *ewPtr = (TkTextSegment *) chunkPtr->clientData; + int lineX, windowX, windowY, width, height; + Tk_Window tkwin; + + tkwin = ewPtr->body.ew.tkwin; + if (tkwin == NULL) { + return; + } + if ((x + chunkPtr->width) <= 0) { + /* + * The window is off-screen; just unmap it. + */ + + if (ewPtr->body.ew.textPtr->tkwin != Tk_Parent(tkwin)) { + Tk_UnmaintainGeometry(tkwin, ewPtr->body.ew.textPtr->tkwin); + } else { + Tk_UnmapWindow(tkwin); + } + return; + } + + /* + * Compute the window's location and size in the text widget, taking + * into account the align and stretch values for the window. + */ + + EmbWinBboxProc(chunkPtr, 0, screenY, lineHeight, baseline, &lineX, + &windowY, &width, &height); + windowX = lineX - chunkPtr->x + x; + + if (ewPtr->body.ew.textPtr->tkwin == Tk_Parent(tkwin)) { + if ((windowX != Tk_X(tkwin)) || (windowY != Tk_Y(tkwin)) + || (Tk_ReqWidth(tkwin) != Tk_Width(tkwin)) + || (height != Tk_Height(tkwin))) { + Tk_MoveResizeWindow(tkwin, windowX, windowY, width, height); + } + Tk_MapWindow(tkwin); + } else { + Tk_MaintainGeometry(tkwin, ewPtr->body.ew.textPtr->tkwin, + windowX, windowY, width, height); + } + + /* + * Mark the window as displayed so that it won't get unmapped. + */ + + ewPtr->body.ew.displayed = 1; +} + +/* + *-------------------------------------------------------------- + * + * EmbWinUndisplayProc -- + * + * This procedure is called when the chunk for an embedded + * window is no longer going to be displayed. It arranges + * for the window associated with the chunk to be unmapped. + * + * Results: + * None. + * + * Side effects: + * The window is scheduled for unmapping. + * + *-------------------------------------------------------------- + */ + +static void +EmbWinUndisplayProc(textPtr, chunkPtr) + TkText *textPtr; /* Overall information about text + * widget. */ + TkTextDispChunk *chunkPtr; /* Chunk that is about to be freed. */ +{ + TkTextSegment *ewPtr = (TkTextSegment *) chunkPtr->clientData; + + ewPtr->body.ew.chunkCount--; + if (ewPtr->body.ew.chunkCount == 0) { + /* + * Don't unmap the window immediately, since there's a good chance + * that it will immediately be redisplayed, perhaps even in the + * same place. Instead, schedule the window to be unmapped later; + * the call to EmbWinDelayedUnmap will be cancelled in the likely + * event that the unmap becomes unnecessary. + */ + + ewPtr->body.ew.displayed = 0; + Tcl_DoWhenIdle(EmbWinDelayedUnmap, (ClientData) ewPtr); + } +} + +/* + *-------------------------------------------------------------- + * + * EmbWinBboxProc -- + * + * This procedure is called to compute the bounding box of + * the area occupied by an embedded window. + * + * Results: + * There is no return value. *xPtr and *yPtr are filled in + * with the coordinates of the upper left corner of the + * window, and *widthPtr and *heightPtr are filled in with + * the dimensions of the window in pixels. Note: not all + * of the returned bbox is necessarily visible on the screen + * (the rightmost part might be off-screen to the right, + * and the bottommost part might be off-screen to the bottom). + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static void +EmbWinBboxProc(chunkPtr, index, y, lineHeight, baseline, xPtr, yPtr, + widthPtr, heightPtr) + TkTextDispChunk *chunkPtr; /* Chunk containing desired char. */ + int index; /* Index of desired character within + * the chunk. */ + int y; /* Topmost pixel in area allocated + * for this line. */ + int lineHeight; /* Total height of line. */ + int baseline; /* Location of line's baseline, in + * pixels measured down from y. */ + int *xPtr, *yPtr; /* Gets filled in with coords of + * character's upper-left pixel. */ + int *widthPtr; /* Gets filled in with width of + * character, in pixels. */ + int *heightPtr; /* Gets filled in with height of + * character, in pixels. */ +{ + TkTextSegment *ewPtr = (TkTextSegment *) chunkPtr->clientData; + Tk_Window tkwin; + + tkwin = ewPtr->body.ew.tkwin; + if (tkwin != NULL) { + *widthPtr = Tk_ReqWidth(tkwin); + *heightPtr = Tk_ReqHeight(tkwin); + } else { + *widthPtr = 0; + *heightPtr = 0; + } + *xPtr = chunkPtr->x + ewPtr->body.ew.padX; + if (ewPtr->body.ew.stretch) { + if (ewPtr->body.ew.align == ALIGN_BASELINE) { + *heightPtr = baseline - ewPtr->body.ew.padY; + } else { + *heightPtr = lineHeight - 2*ewPtr->body.ew.padY; + } + } + switch (ewPtr->body.ew.align) { + case ALIGN_BOTTOM: + *yPtr = y + (lineHeight - *heightPtr - ewPtr->body.ew.padY); + break; + case ALIGN_CENTER: + *yPtr = y + (lineHeight - *heightPtr)/2; + break; + case ALIGN_TOP: + *yPtr = y + ewPtr->body.ew.padY; + break; + case ALIGN_BASELINE: + *yPtr = y + (baseline - *heightPtr); + break; + } +} + +/* + *-------------------------------------------------------------- + * + * EmbWinDelayedUnmap -- + * + * This procedure is an idle handler that does the actual + * work of unmapping an embedded window. See the comment + * in EmbWinUndisplayProc for details. + * + * Results: + * None. + * + * Side effects: + * The window gets unmapped, unless its chunk reference count + * has become non-zero again. + * + *-------------------------------------------------------------- + */ + +static void +EmbWinDelayedUnmap(clientData) + ClientData clientData; /* Token for the window to + * be unmapped. */ +{ + TkTextSegment *ewPtr = (TkTextSegment *) clientData; + + if (!ewPtr->body.ew.displayed && (ewPtr->body.ew.tkwin != NULL)) { + if (ewPtr->body.ew.textPtr->tkwin != Tk_Parent(ewPtr->body.ew.tkwin)) { + Tk_UnmaintainGeometry(ewPtr->body.ew.tkwin, + ewPtr->body.ew.textPtr->tkwin); + } else { + Tk_UnmapWindow(ewPtr->body.ew.tkwin); + } + } +} + +/* + *-------------------------------------------------------------- + * + * TkTextWindowIndex -- + * + * Given the name of an embedded window within a text widget, + * returns an index corresponding to the window's position + * in the text. + * + * Results: + * The return value is 1 if there is an embedded window by + * the given name in the text widget, 0 otherwise. If the + * window exists, *indexPtr is filled in with its index. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +TkTextWindowIndex(textPtr, name, indexPtr) + TkText *textPtr; /* Text widget containing window. */ + char *name; /* Name of window. */ + TkTextIndex *indexPtr; /* Index information gets stored here. */ +{ + Tcl_HashEntry *hPtr; + TkTextSegment *ewPtr; + + hPtr = Tcl_FindHashEntry(&textPtr->windowTable, name); + if (hPtr == NULL) { + return 0; + } + ewPtr = (TkTextSegment *) Tcl_GetHashValue(hPtr); + indexPtr->tree = textPtr->tree; + indexPtr->linePtr = ewPtr->body.ew.linePtr; + indexPtr->charIndex = TkTextSegToOffset(ewPtr, indexPtr->linePtr); + return 1; +} diff --git a/tk3.6/tkTrig.c b/tk4.2/generic/tkTrig.c similarity index 84% rename from tk3.6/tkTrig.c rename to tk4.2/generic/tkTrig.c index 1b14462..c1f2557 100644 --- a/tk3.6/tkTrig.c +++ b/tk4.2/generic/tkTrig.c @@ -6,34 +6,18 @@ * canvas code. It also has miscellaneous geometry functions * used by canvases. * - * Copyright (c) 1992-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1992-1994 The Regents of the University of California. + * Copyright (c) 1994 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tkTrig.c 1.23 96/02/15 18:53:05 */ -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkTrig.c,v 1.17 93/10/07 11:50:20 ouster Exp $ SPRITE (Berkeley)"; -#endif - #include #include "tkInt.h" -#include "tkConfig.h" +#include "tkPort.h" #include "tkCanvas.h" #undef MIN @@ -285,6 +269,157 @@ TkLineToArea(end1Ptr, end2Ptr, rectPtr) return -1; } +/* + *-------------------------------------------------------------- + * + * TkThickPolyLineToArea -- + * + * This procedure is called to determine whether a connected + * series of line segments lies entirely inside, entirely + * outside, or overlapping a given rectangular area. + * + * Results: + * -1 is returned if the lines are entirely outside the area, + * 0 if they overlap, and 1 if they are entirely inside the + * given area. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +TkThickPolyLineToArea(coordPtr, numPoints, width, capStyle, joinStyle, rectPtr) + double *coordPtr; /* Points to an array of coordinates for + * the polyline: x0, y0, x1, y1, ... */ + int numPoints; /* Total number of points at *coordPtr. */ + double width; /* Width of each line segment. */ + int capStyle; /* How are end-points of polyline drawn? + * CapRound, CapButt, or CapProjecting. */ + int joinStyle; /* How are joints in polyline drawn? + * JoinMiter, JoinRound, or JoinBevel. */ + double *rectPtr; /* Rectangular area to check against. */ +{ + double radius, poly[10]; + int count; + int changedMiterToBevel; /* Non-zero means that a mitered corner + * had to be treated as beveled after all + * because the angle was < 11 degrees. */ + int inside; /* Tentative guess about what to return, + * based on all points seen so far: one + * means everything seen so far was + * inside the area; -1 means everything + * was outside the area. 0 means overlap + * has been found. */ + + radius = width/2.0; + inside = -1; + + if ((coordPtr[0] >= rectPtr[0]) && (coordPtr[0] <= rectPtr[2]) + && (coordPtr[1] >= rectPtr[1]) && (coordPtr[1] <= rectPtr[3])) { + inside = 1; + } + + /* + * Iterate through all of the edges of the line, computing a polygon + * for each edge and testing the area against that polygon. In + * addition, there are additional tests to deal with rounded joints + * and caps. + */ + + changedMiterToBevel = 0; + for (count = numPoints; count >= 2; count--, coordPtr += 2) { + + /* + * If rounding is done around the first point of the edge + * then test a circular region around the point with the + * area. + */ + + if (((capStyle == CapRound) && (count == numPoints)) + || ((joinStyle == JoinRound) && (count != numPoints))) { + poly[0] = coordPtr[0] - radius; + poly[1] = coordPtr[1] - radius; + poly[2] = coordPtr[0] + radius; + poly[3] = coordPtr[1] + radius; + if (TkOvalToArea(poly, rectPtr) != inside) { + return 0; + } + } + + /* + * Compute the polygonal shape corresponding to this edge, + * consisting of two points for the first point of the edge + * and two points for the last point of the edge. + */ + + if (count == numPoints) { + TkGetButtPoints(coordPtr+2, coordPtr, width, + capStyle == CapProjecting, poly, poly+2); + } else if ((joinStyle == JoinMiter) && !changedMiterToBevel) { + poly[0] = poly[6]; + poly[1] = poly[7]; + poly[2] = poly[4]; + poly[3] = poly[5]; + } else { + TkGetButtPoints(coordPtr+2, coordPtr, width, 0, poly, poly+2); + + /* + * If the last joint was beveled, then also check a + * polygon comprising the last two points of the previous + * polygon and the first two from this polygon; this checks + * the wedges that fill the beveled joint. + */ + + if ((joinStyle == JoinBevel) || changedMiterToBevel) { + poly[8] = poly[0]; + poly[9] = poly[1]; + if (TkPolygonToArea(poly, 5, rectPtr) != inside) { + return 0; + } + changedMiterToBevel = 0; + } + } + if (count == 2) { + TkGetButtPoints(coordPtr, coordPtr+2, width, + capStyle == CapProjecting, poly+4, poly+6); + } else if (joinStyle == JoinMiter) { + if (TkGetMiterPoints(coordPtr, coordPtr+2, coordPtr+4, + (double) width, poly+4, poly+6) == 0) { + changedMiterToBevel = 1; + TkGetButtPoints(coordPtr, coordPtr+2, width, 0, poly+4, + poly+6); + } + } else { + TkGetButtPoints(coordPtr, coordPtr+2, width, 0, poly+4, poly+6); + } + poly[8] = poly[0]; + poly[9] = poly[1]; + if (TkPolygonToArea(poly, 5, rectPtr) != inside) { + return 0; + } + } + + /* + * If caps are rounded, check the cap around the final point + * of the line. + */ + + if (capStyle == CapRound) { + poly[0] = coordPtr[0] - radius; + poly[1] = coordPtr[1] - radius; + poly[2] = coordPtr[0] + radius; + poly[3] = coordPtr[1] + radius; + if (TkOvalToArea(poly, rectPtr) != inside) { + return 0; + } + } + + return inside; +} + /* *-------------------------------------------------------------- * @@ -330,7 +465,7 @@ TkPolygonToPoint(polyPtr, numPoints, pointPtr) * count it as two intersections. */ - bestDist = 1.0e40; + bestDist = 1.0e36; intersections = 0; for (count = numPoints, pPtr = polyPtr; count > 1; count--, pPtr += 2) { @@ -753,8 +888,7 @@ TkOvalToArea(ovalPtr, rectPtr) /* ARGSUSED */ void -TkIncludePoint(canvasPtr, itemPtr, pointPtr) - Tk_Canvas *canvasPtr; /* Canvas containing item. */ +TkIncludePoint(itemPtr, pointPtr) register Tk_Item *itemPtr; /* Item whose bounding box is * being calculated. */ double *pointPtr; /* Address of two doubles giving @@ -800,8 +934,8 @@ TkIncludePoint(canvasPtr, itemPtr, pointPtr) */ void -TkBezierScreenPoints(canvasPtr, control, numSteps, xPointPtr) - Tk_Canvas *canvasPtr; /* Canvas in which curve is to be +TkBezierScreenPoints(canvas, control, numSteps, xPointPtr) + Tk_Canvas canvas; /* Canvas in which curve is to be * drawn. */ double control[]; /* Array of coordinates for four * control points: x0, y0, x1, y1, @@ -820,10 +954,12 @@ TkBezierScreenPoints(canvasPtr, control, numSteps, xPointPtr) u = 1.0 - t; u2 = u*u; u3 = u2*u; - xPointPtr->x = SCREEN_X(canvasPtr, (control[0]*u3 - + 3.0 * (control[2]*t*u2 + control[4]*t2*u) + control[6]*t3)); - xPointPtr->y = SCREEN_Y(canvasPtr, (control[1]*u3 - + 3.0 * (control[3]*t*u2 + control[5]*t2*u) + control[7]*t3)); + Tk_CanvasDrawableCoords(canvas, + (control[0]*u3 + 3.0 * (control[2]*t*u2 + control[4]*t2*u) + + control[6]*t3), + (control[1]*u3 + 3.0 * (control[3]*t*u2 + control[5]*t2*u) + + control[7]*t3), + &xPointPtr->x, &xPointPtr->y); } } @@ -897,8 +1033,8 @@ TkBezierPoints(control, numSteps, coordPtr) */ int -TkMakeBezierCurve(canvasPtr, pointPtr, numPoints, numSteps, xPoints, dblPoints) - Tk_Canvas *canvasPtr; /* Canvas in which curve is to be +TkMakeBezierCurve(canvas, pointPtr, numPoints, numSteps, xPoints, dblPoints) + Tk_Canvas canvas; /* Canvas in which curve is to be * drawn. */ double *pointPtr; /* Array of input coordinates: x0, * y0, x1, y1, etc.. */ @@ -939,9 +1075,9 @@ TkMakeBezierCurve(canvasPtr, pointPtr, numPoints, numSteps, xPoints, dblPoints) control[6] = 0.5*pointPtr[0] + 0.5*pointPtr[2]; control[7] = 0.5*pointPtr[1] + 0.5*pointPtr[3]; if (xPoints != NULL) { - xPoints->x = SCREEN_X(canvasPtr, control[0]); - xPoints->y = SCREEN_Y(canvasPtr, control[1]); - TkBezierScreenPoints(canvasPtr, control, numSteps, xPoints+1); + Tk_CanvasDrawableCoords(canvas, control[0], control[1], + &xPoints->x, &xPoints->y); + TkBezierScreenPoints(canvas, control, numSteps, xPoints+1); xPoints += numSteps+1; } if (dblPoints != NULL) { @@ -954,8 +1090,8 @@ TkMakeBezierCurve(canvasPtr, pointPtr, numPoints, numSteps, xPoints, dblPoints) } else { closed = 0; if (xPoints != NULL) { - xPoints->x = SCREEN_X(canvasPtr, pointPtr[0]); - xPoints->y = SCREEN_Y(canvasPtr, pointPtr[1]); + Tk_CanvasDrawableCoords(canvas, pointPtr[0], pointPtr[1], + &xPoints->x, &xPoints->y); xPoints += 1; } if (dblPoints != NULL) { @@ -1014,8 +1150,8 @@ TkMakeBezierCurve(canvasPtr, pointPtr, numPoints, numSteps, xPoints, dblPoints) || ((pointPtr[2] == pointPtr[4]) && (pointPtr[3] == pointPtr[5]))) { if (xPoints != NULL) { - xPoints[0].x = SCREEN_X(canvasPtr, control[6]); - xPoints[0].y = SCREEN_Y(canvasPtr, control[7]); + Tk_CanvasDrawableCoords(canvas, control[6], control[7], + &xPoints[0].x, &xPoints[0].y); xPoints++; } if (dblPoints != NULL) { @@ -1033,7 +1169,7 @@ TkMakeBezierCurve(canvasPtr, pointPtr, numPoints, numSteps, xPoints, dblPoints) if (xPoints != NULL) { - TkBezierScreenPoints(canvasPtr, control, numSteps, xPoints); + TkBezierScreenPoints(canvas, control, numSteps, xPoints); xPoints += numSteps; } if (dblPoints != NULL) { @@ -1064,15 +1200,14 @@ TkMakeBezierCurve(canvasPtr, pointPtr, numPoints, numSteps, xPoints, dblPoints) */ void -TkMakeBezierPostscript(interp, pointPtr, numPoints, psInfoPtr) +TkMakeBezierPostscript(interp, canvas, pointPtr, numPoints) Tcl_Interp *interp; /* Interpreter in whose result the * Postscript is to be stored. */ + Tk_Canvas canvas; /* Canvas widget for which the + * Postscript is being generated. */ double *pointPtr; /* Array of input coordinates: x0, * y0, x1, y1, etc.. */ int numPoints; /* Number of points at pointPtr. */ - Tk_PostscriptInfo *psInfoPtr; /* Information about the Postscript; - * must be passed back to Postscript - * utility procedures. */ { int closed, i; int numCoords = numPoints*2; @@ -1097,16 +1232,16 @@ TkMakeBezierPostscript(interp, pointPtr, numPoints, psInfoPtr) control[6] = 0.5*pointPtr[0] + 0.5*pointPtr[2]; control[7] = 0.5*pointPtr[1] + 0.5*pointPtr[3]; sprintf(buffer, "%.15g %.15g moveto\n%.15g %.15g %.15g %.15g %.15g %.15g curveto\n", - control[0], TkCanvPsY(psInfoPtr, control[1]), - control[2], TkCanvPsY(psInfoPtr, control[3]), - control[4], TkCanvPsY(psInfoPtr, control[5]), - control[6], TkCanvPsY(psInfoPtr, control[7])); + control[0], Tk_CanvasPsY(canvas, control[1]), + control[2], Tk_CanvasPsY(canvas, control[3]), + control[4], Tk_CanvasPsY(canvas, control[5]), + control[6], Tk_CanvasPsY(canvas, control[7])); } else { closed = 0; control[6] = pointPtr[0]; control[7] = pointPtr[1]; sprintf(buffer, "%.15g %.15g moveto\n", - control[6], TkCanvPsY(psInfoPtr, control[7])); + control[6], Tk_CanvasPsY(canvas, control[7])); } Tcl_AppendResult(interp, buffer, (char *) NULL); @@ -1136,9 +1271,9 @@ TkMakeBezierPostscript(interp, pointPtr, numPoints, psInfoPtr) control[5] = 0.333*control[7] + 0.667*pointPtr[1]; sprintf(buffer, "%.15g %.15g %.15g %.15g %.15g %.15g curveto\n", - control[2], TkCanvPsY(psInfoPtr, control[3]), - control[4], TkCanvPsY(psInfoPtr, control[5]), - control[6], TkCanvPsY(psInfoPtr, control[7])); + control[2], Tk_CanvasPsY(canvas, control[3]), + control[4], Tk_CanvasPsY(canvas, control[5]), + control[6], Tk_CanvasPsY(canvas, control[7])); Tcl_AppendResult(interp, buffer, (char *) NULL); } } diff --git a/tk4.2/generic/tkUtil.c b/tk4.2/generic/tkUtil.c new file mode 100644 index 0000000..ab5fc68 --- /dev/null +++ b/tk4.2/generic/tkUtil.c @@ -0,0 +1,229 @@ +/* + * tkUtil.c -- + * + * This file contains miscellaneous utility procedures that + * are used by the rest of Tk, such as a procedure for drawing + * a focus highlight. + * + * Copyright (c) 1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkUtil.c 1.8 96/08/21 17:45:36 + */ + +#include "tkInt.h" +#include "tkPort.h" + +/* + *---------------------------------------------------------------------- + * + * Tk_DrawFocusHighlight -- + * + * This procedure draws a rectangular ring around the outside of + * a widget to indicate that it has received the input focus. + * + * Results: + * None. + * + * Side effects: + * A rectangle "width" pixels wide is drawn in "drawable", + * corresponding to the outer area of "tkwin". + * + *---------------------------------------------------------------------- + */ + +void +Tk_DrawFocusHighlight(tkwin, gc, width, drawable) + Tk_Window tkwin; /* Window whose focus highlight ring is + * to be drawn. */ + GC gc; /* Graphics context to use for drawing + * the highlight ring. */ + int width; /* Width of the highlight ring, in pixels. */ + Drawable drawable; /* Where to draw the ring (typically a + * pixmap for double buffering). */ +{ + XRectangle rects[4]; + + rects[0].x = 0; + rects[0].y = 0; + rects[0].width = Tk_Width(tkwin); + rects[0].height = width; + rects[1].x = 0; + rects[1].y = Tk_Height(tkwin) - width; + rects[1].width = Tk_Width(tkwin); + rects[1].height = width; + rects[2].x = 0; + rects[2].y = width; + rects[2].width = width; + rects[2].height = Tk_Height(tkwin) - 2*width; + rects[3].x = Tk_Width(tkwin) - width; + rects[3].y = width; + rects[3].width = width; + rects[3].height = rects[2].height; + XFillRectangles(Tk_Display(tkwin), drawable, gc, rects, 4); +} + +/* + *---------------------------------------------------------------------- + * + * Tk_GetScrollInfo -- + * + * This procedure is invoked to parse "xview" and "yview" + * scrolling commands for widgets using the new scrolling + * command syntax ("moveto" or "scroll" options). + * + * Results: + * The return value is either TK_SCROLL_MOVETO, TK_SCROLL_PAGES, + * TK_SCROLL_UNITS, or TK_SCROLL_ERROR. This indicates whether + * the command was successfully parsed and what form the command + * took. If TK_SCROLL_MOVETO, *dblPtr is filled in with the + * desired position; if TK_SCROLL_PAGES or TK_SCROLL_UNITS, + * *intPtr is filled in with the number of lines to move (may be + * negative); if TK_SCROLL_ERROR, interp->result contains an + * error message. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tk_GetScrollInfo(interp, argc, argv, dblPtr, intPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + int argc; /* # arguments for command. */ + char **argv; /* Arguments for command. */ + double *dblPtr; /* Filled in with argument "moveto" + * option, if any. */ + int *intPtr; /* Filled in with number of pages + * or lines to scroll, if any. */ +{ + int c; + size_t length; + + length = strlen(argv[2]); + c = argv[2][0]; + if ((c == 'm') && (strncmp(argv[2], "moveto", length) == 0)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " ", argv[1], " moveto fraction\"", + (char *) NULL); + return TK_SCROLL_ERROR; + } + if (Tcl_GetDouble(interp, argv[3], dblPtr) != TCL_OK) { + return TK_SCROLL_ERROR; + } + return TK_SCROLL_MOVETO; + } else if ((c == 's') + && (strncmp(argv[2], "scroll", length) == 0)) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " ", argv[1], " scroll number units|pages\"", + (char *) NULL); + return TK_SCROLL_ERROR; + } + if (Tcl_GetInt(interp, argv[3], intPtr) != TCL_OK) { + return TK_SCROLL_ERROR; + } + length = strlen(argv[4]); + c = argv[4][0]; + if ((c == 'p') && (strncmp(argv[4], "pages", length) == 0)) { + return TK_SCROLL_PAGES; + } else if ((c == 'u') + && (strncmp(argv[4], "units", length) == 0)) { + return TK_SCROLL_UNITS; + } else { + Tcl_AppendResult(interp, "bad argument \"", argv[4], + "\": must be units or pages", (char *) NULL); + return TK_SCROLL_ERROR; + } + } + Tcl_AppendResult(interp, "unknown option \"", argv[2], + "\": must be moveto or scroll", (char *) NULL); + return TK_SCROLL_ERROR; +} + +/* + *--------------------------------------------------------------------------- + * + * TkFindStateString -- + * + * Given a lookup table, map a number to a string in the table. + * + * Results: + * If numKey was equal to the numeric key of one of the elements + * in the table, returns the string key of that element. + * Returns NULL if numKey was not equal to any of the numeric keys + * in the table. + * + * Side effects. + * None. + * + *--------------------------------------------------------------------------- + */ + +char * +TkFindStateString(mapPtr, numKey) + CONST TkStateMap *mapPtr; /* The state table. */ + int numKey; /* The key to try to find in the table. */ +{ + for ( ; mapPtr->strKey != NULL; mapPtr++) { + if (numKey == mapPtr->numKey) { + return mapPtr->strKey; + } + } + return NULL; +} + +/* + *--------------------------------------------------------------------------- + * + * TkFindStateNum -- + * + * Given a lookup table, map a string to a number in the table. + * + * Results: + * If strKey was equal to the string keys of one of the elements + * in the table, returns the numeric key of that element. + * Returns the numKey associated with the last element (the NULL + * string one) in the table if strKey was not equal to any of the + * string keys in the table. In that case, an error message is + * also left in interp->result (if interp is not NULL). + * + * Side effects. + * None. + * + *--------------------------------------------------------------------------- + */ + +int +TkFindStateNum(interp, field, mapPtr, strKey) + Tcl_Interp *interp; /* Interp for error reporting. */ + CONST char *field; /* String to use when constructing error. */ + CONST TkStateMap *mapPtr; /* Lookup table. */ + CONST char *strKey; /* String to try to find in lookup table. */ +{ + CONST TkStateMap *mPtr; + + if (mapPtr->strKey == NULL) { + panic("TkFindStateNum: no choices in lookup table"); + } + + for (mPtr = mapPtr; mPtr->strKey != NULL; mPtr++) { + if (strcmp(strKey, mPtr->strKey) == 0) { + return mPtr->numKey; + } + } + if (interp != NULL) { + mPtr = mapPtr; + Tcl_AppendResult(interp, "bad ", field, " value \"", strKey, + "\": must be ", mPtr->strKey, (char *) NULL); + for (mPtr++; mPtr->strKey != NULL; mPtr++) { + Tcl_AppendResult(interp, ", ", mPtr->strKey, (char *) NULL); + } + } + return mPtr->numKey; +} diff --git a/tk4.2/generic/tkVisual.c b/tk4.2/generic/tkVisual.c new file mode 100644 index 0000000..6b9bb34 --- /dev/null +++ b/tk4.2/generic/tkVisual.c @@ -0,0 +1,540 @@ +/* + * tkVisual.c -- + * + * This file contains library procedures for allocating and + * freeing visuals and colormaps. This code is based on a + * prototype implementation by Paul Mackerras. + * + * Copyright (c) 1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkVisual.c 1.18 96/02/15 18:53:08 + */ + +#include "tkInt.h" +#include "tkPort.h" + +/* + * The table below maps from symbolic names for visual classes + * to the associated X class symbols. + */ + +typedef struct VisualDictionary { + char *name; /* Textual name of class. */ + int minLength; /* Minimum # characters that must be + * specified for an unambiguous match. */ + int class; /* X symbol for class. */ +} VisualDictionary; +static VisualDictionary visualNames[] = { + {"best", 1, 0}, + {"directcolor", 2, DirectColor}, + {"grayscale", 1, GrayScale}, + {"greyscale", 1, GrayScale}, + {"pseudocolor", 1, PseudoColor}, + {"staticcolor", 7, StaticColor}, + {"staticgray", 7, StaticGray}, + {"staticgrey", 7, StaticGray}, + {"truecolor", 1, TrueColor}, + {NULL, 0, 0}, +}; + +/* + * One of the following structures exists for each distinct non-default + * colormap allocated for a display by Tk_GetColormap. + */ + +struct TkColormap { + Colormap colormap; /* X's identifier for the colormap. */ + Visual *visual; /* Visual for which colormap was + * allocated. */ + int refCount; /* How many uses of the colormap are still + * outstanding (calls to Tk_GetColormap + * minus calls to Tk_FreeColormap). */ + int shareable; /* 0 means this colormap was allocated by + * a call to Tk_GetColormap with "new", + * implying that the window wants it all + * for itself. 1 means that the colormap + * was allocated as a default for a particular + * visual, so it can be shared. */ + struct TkColormap *nextPtr; /* Next in list of colormaps for this display, + * or NULL for end of list. */ +}; + +/* + *---------------------------------------------------------------------- + * + * Tk_GetVisual -- + * + * Given a string identifying a particular kind of visual, this + * procedure returns a visual and depth that matches the specification. + * + * Results: + * The return value is normally a pointer to a visual. If an + * error occurred in looking up the visual, NULL is returned and + * an error message is left in interp->result. The depth of the + * visual is returned to *depthPtr under normal returns. If + * colormapPtr is non-NULL, then this procedure also finds a + * suitable colormap for use with the visual in tkwin, and it + * returns that colormap in *colormapPtr unless an error occurs. + * + * Side effects: + * A new colormap may be allocated. + * + *---------------------------------------------------------------------- + */ + +Visual * +Tk_GetVisual(interp, tkwin, string, depthPtr, colormapPtr) + Tcl_Interp *interp; /* Interpreter to use for error + * reporting. */ + Tk_Window tkwin; /* Window in which visual will be + * used. */ + char *string; /* String describing visual. See + * manual entry for details. */ + int *depthPtr; /* The depth of the returned visual + * is stored here. */ + Colormap *colormapPtr; /* If non-NULL, then a suitable + * colormap for visual is placed here. + * This colormap must eventually be + * freed by calling Tk_FreeColormap. */ +{ + Tk_Window tkwin2; + XVisualInfo template, *visInfoList, *bestPtr; + long mask; + Visual *visual; + int length, c, numVisuals, prio, bestPrio, i; + char *p; + VisualDictionary *dictPtr; + TkColormap *cmapPtr; + TkDisplay *dispPtr = ((TkWindow *) tkwin)->dispPtr; + + /* + * Parse string and set up a template for use in searching for + * an appropriate visual. + */ + + c = string[0]; + if (c == '.') { + /* + * The string must be a window name. If the window is on the + * same screen as tkwin, then just use its visual. Otherwise + * use the information about the visual as a template for the + * search. + */ + + tkwin2 = Tk_NameToWindow(interp, string, tkwin); + if (tkwin2 == NULL) { + return NULL; + } + visual = Tk_Visual(tkwin2); + if (Tk_Screen(tkwin) == Tk_Screen(tkwin2)) { + *depthPtr = Tk_Depth(tkwin2); + if (colormapPtr != NULL) { + /* + * Use the colormap from the other window too (but be sure + * to increment its reference count if it's one of the ones + * allocated here). + */ + + *colormapPtr = Tk_Colormap(tkwin2); + for (cmapPtr = dispPtr->cmapPtr; cmapPtr != NULL; + cmapPtr = cmapPtr->nextPtr) { + if (cmapPtr->colormap == *colormapPtr) { + cmapPtr->refCount += 1; + break; + } + } + } + return visual; + } + template.depth = Tk_Depth(tkwin2); + template.class = visual->class; + template.red_mask = visual->red_mask; + template.green_mask = visual->green_mask; + template.blue_mask = visual->blue_mask; + template.colormap_size = visual->map_entries; + template.bits_per_rgb = visual->bits_per_rgb; + mask = VisualDepthMask|VisualClassMask|VisualRedMaskMask + |VisualGreenMaskMask|VisualBlueMaskMask|VisualColormapSizeMask + |VisualBitsPerRGBMask; + } else if ((c == 0) || ((c == 'd') && (string[1] != 0) + && (strncmp(string, "default", strlen(string)) == 0))) { + /* + * Use the default visual for the window's screen. + */ + + if (colormapPtr != NULL) { + *colormapPtr = DefaultColormapOfScreen(Tk_Screen(tkwin)); + } + *depthPtr = DefaultDepthOfScreen(Tk_Screen(tkwin)); + return DefaultVisualOfScreen(Tk_Screen(tkwin)); + } else if (isdigit(UCHAR(c))) { + int visualId; + + /* + * This is a visual ID. + */ + + if (Tcl_GetInt(interp, string, &visualId) == TCL_ERROR) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad X identifier for visual: ", + string, "\"", (char *) NULL); + return NULL; + } + template.visualid = visualId; + mask = VisualIDMask; + } else { + /* + * Parse the string into a class name (or "best") optionally + * followed by whitespace and a depth. + */ + + for (p = string; *p != 0; p++) { + if (isspace(UCHAR(*p)) || isdigit(UCHAR(*p))) { + break; + } + } + length = p - string; + template.class = -1; + for (dictPtr = visualNames; dictPtr->name != NULL; dictPtr++) { + if ((dictPtr->name[0] == c) && (length >= dictPtr->minLength) + && (strncmp(string, dictPtr->name, + (size_t) length) == 0)) { + template.class = dictPtr->class; + break; + } + } + if (template.class == -1) { + Tcl_AppendResult(interp, "unknown or ambiguous visual name \"", + string, "\": class must be ", (char *) NULL); + for (dictPtr = visualNames; dictPtr->name != NULL; dictPtr++) { + Tcl_AppendResult(interp, dictPtr->name, ", ", (char *) NULL); + } + Tcl_AppendResult(interp, "or default", (char *) NULL); + return NULL; + } + while (isspace(UCHAR(*p))) { + p++; + } + if (*p == 0) { + template.depth = 10000; + } else { + if (Tcl_GetInt(interp, p, &template.depth) != TCL_OK) { + return NULL; + } + } + if (c == 'b') { + mask = 0; + } else { + mask = VisualClassMask; + } + } + + /* + * Find all visuals that match the template we've just created, + * and return an error if there are none that match. + */ + + template.screen = Tk_ScreenNumber(tkwin); + mask |= VisualScreenMask; + visInfoList = XGetVisualInfo(Tk_Display(tkwin), mask, &template, + &numVisuals); + if (visInfoList == NULL) { + interp->result = "couldn't find an appropriate visual"; + return NULL; + } + + /* + * Search through the visuals that were returned to find the best + * one. The choice is based on the following criteria, in decreasing + * order of importance: + * + * 1. Depth: choose a visual with exactly the desired depth, + * else one with more bits than requested but as few bits + * as possible, else one with fewer bits but as many as + * possible. + * 2. Class: some visual classes are more desirable than others; + * pick the visual with the most desirable class. + * 3. Default: the default visual for the screen gets preference + * over other visuals, all else being equal. + */ + + bestPrio = 0; + bestPtr = NULL; + for (i = 0; i < numVisuals; i++) { + switch (visInfoList[i].class) { + case DirectColor: prio = 5; break; + case GrayScale: prio = 1; break; + case PseudoColor: prio = 7; break; + case StaticColor: prio = 3; break; + case StaticGray: prio = 1; break; + case TrueColor: prio = 5; break; + default: prio = 0; break; + } + if (visInfoList[i].visual + == DefaultVisualOfScreen(Tk_Screen(tkwin))) { + prio++; + } + if (bestPtr == NULL) { + goto newBest; + } + if (visInfoList[i].depth < bestPtr->depth) { + if (visInfoList[i].depth >= template.depth) { + goto newBest; + } + } else if (visInfoList[i].depth > bestPtr->depth) { + if (bestPtr->depth < template.depth) { + goto newBest; + } + } else { + if (prio > bestPrio) { + goto newBest; + } + } + continue; + + newBest: + bestPtr = &visInfoList[i]; + bestPrio = prio; + } + *depthPtr = bestPtr->depth; + visual = bestPtr->visual; + XFree((char *) visInfoList); + + /* + * If we need to find a colormap for this visual, do it now. + * If the visual is the default visual for the screen, then + * use the default colormap. Otherwise search for an existing + * colormap that's shareable. If all else fails, create a new + * colormap. + */ + + if (colormapPtr != NULL) { + if (visual == DefaultVisualOfScreen(Tk_Screen(tkwin))) { + *colormapPtr = DefaultColormapOfScreen(Tk_Screen(tkwin)); + } else { + for (cmapPtr = dispPtr->cmapPtr; cmapPtr != NULL; + cmapPtr = cmapPtr->nextPtr) { + if (cmapPtr->shareable && (cmapPtr->visual == visual)) { + *colormapPtr = cmapPtr->colormap; + cmapPtr->refCount += 1; + goto done; + } + } + cmapPtr = (TkColormap *) ckalloc(sizeof(TkColormap)); + cmapPtr->colormap = XCreateColormap(Tk_Display(tkwin), + RootWindowOfScreen(Tk_Screen(tkwin)), visual, + AllocNone); + cmapPtr->visual = visual; + cmapPtr->refCount = 1; + cmapPtr->shareable = 1; + cmapPtr->nextPtr = dispPtr->cmapPtr; + dispPtr->cmapPtr = cmapPtr; + *colormapPtr = cmapPtr->colormap; + } + } + + done: + return visual; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_GetColormap -- + * + * Given a string identifying a colormap, this procedure finds + * an appropriate colormap. + * + * Results: + * The return value is normally the X resource identifier for the + * colormap. If an error occurs, None is returned and an error + * message is placed in interp->result. + * + * Side effects: + * A reference count is incremented for the colormap, so + * Tk_FreeColormap must eventually be called exactly once for + * each call to Tk_GetColormap. + * + *---------------------------------------------------------------------- + */ + +Colormap +Tk_GetColormap(interp, tkwin, string) + Tcl_Interp *interp; /* Interpreter to use for error + * reporting. */ + Tk_Window tkwin; /* Window where colormap will be + * used. */ + char *string; /* String that identifies colormap: + * either "new" or the name of + * another window. */ +{ + Colormap colormap; + TkColormap *cmapPtr; + TkDisplay *dispPtr = ((TkWindow *) tkwin)->dispPtr; + Tk_Window other; + + /* + * Allocate a new colormap, if that's what is wanted. + */ + + if (strcmp(string, "new") == 0) { + cmapPtr = (TkColormap *) ckalloc(sizeof(TkColormap)); + cmapPtr->colormap = XCreateColormap(Tk_Display(tkwin), + RootWindowOfScreen(Tk_Screen(tkwin)), Tk_Visual(tkwin), + AllocNone); + cmapPtr->visual = Tk_Visual(tkwin); + cmapPtr->refCount = 1; + cmapPtr->shareable = 0; + cmapPtr->nextPtr = dispPtr->cmapPtr; + dispPtr->cmapPtr = cmapPtr; + return cmapPtr->colormap; + } + + /* + * Use a colormap from an existing window. It must have the same + * visual as tkwin (which means, among other things, that the + * other window must be on the same screen). + */ + + other = Tk_NameToWindow(interp, string, tkwin); + if (other == NULL) { + return None; + } + if (Tk_Screen(other) != Tk_Screen(tkwin)) { + Tcl_AppendResult(interp, "can't use colormap for ", string, + ": not on same screen", (char *) NULL); + return None; + } + if (Tk_Visual(other) != Tk_Visual(tkwin)) { + Tcl_AppendResult(interp, "can't use colormap for ", string, + ": incompatible visuals", (char *) NULL); + return None; + } + colormap = Tk_Colormap(other); + + /* + * If the colormap was a special one allocated by code in this file, + * increment its reference count. + */ + + for (cmapPtr = dispPtr->cmapPtr; cmapPtr != NULL; + cmapPtr = cmapPtr->nextPtr) { + if (cmapPtr->colormap == colormap) { + cmapPtr->refCount += 1; + } + } + return colormap; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_FreeColormap -- + * + * This procedure is called to release a colormap that was + * previously allocated by Tk_GetColormap. + * + * Results: + * None. + * + * Side effects: + * The colormap's reference count is decremented. If this was the + * last reference to the colormap, then the colormap is freed. + * + *---------------------------------------------------------------------- + */ + +void +Tk_FreeColormap(display, colormap) + Display *display; /* Display for which colormap was + * allocated. */ + Colormap colormap; /* Colormap that is no longer needed. + * Must have been returned by previous + * call to Tk_GetColormap, or + * preserved by a previous call to + * Tk_PreserveColormap. */ +{ + TkDisplay *dispPtr; + TkColormap *cmapPtr, *prevPtr; + + /* + * Find Tk's information about the display, then see if this + * colormap is a non-default one (if it's a default one, there + * won't be an entry for it in the display's list). + */ + + dispPtr = TkGetDisplay(display); + if (dispPtr == NULL) { + panic("unknown display passed to Tk_FreeColormap"); + } + for (prevPtr = NULL, cmapPtr = dispPtr->cmapPtr; cmapPtr != NULL; + prevPtr = cmapPtr, cmapPtr = cmapPtr->nextPtr) { + if (cmapPtr->colormap == colormap) { + cmapPtr->refCount -= 1; + if (cmapPtr->refCount == 0) { + XFreeColormap(display, colormap); + if (prevPtr == NULL) { + dispPtr->cmapPtr = cmapPtr->nextPtr; + } else { + prevPtr->nextPtr = cmapPtr->nextPtr; + } + ckfree((char *) cmapPtr); + } + return; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tk_PreserveColormap -- + * + * This procedure is called to indicate to Tk that the specified + * colormap is being referenced from another location and should + * not be freed until all extra references are eliminated. The + * colormap must have been returned by Tk_GetColormap. + * + * Results: + * None. + * + * Side effects: + * The colormap's reference count is incremented, so + * Tk_FreeColormap must eventually be called exactly once for + * each call to Tk_PreserveColormap. + * + *---------------------------------------------------------------------- + */ + +void +Tk_PreserveColormap(display, colormap) + Display *display; /* Display for which colormap was + * allocated. */ + Colormap colormap; /* Colormap that should be + * preserved. */ +{ + TkDisplay *dispPtr; + TkColormap *cmapPtr, *prevPtr; + + /* + * Find Tk's information about the display, then see if this + * colormap is a non-default one (if it's a default one, there + * won't be an entry for it in the display's list). + */ + + dispPtr = TkGetDisplay(display); + if (dispPtr == NULL) { + panic("unknown display passed to Tk_PreserveColormap"); + } + for (prevPtr = NULL, cmapPtr = dispPtr->cmapPtr; cmapPtr != NULL; + prevPtr = cmapPtr, cmapPtr = cmapPtr->nextPtr) { + if (cmapPtr->colormap == colormap) { + cmapPtr->refCount += 1; + return; + } + } +} diff --git a/tk3.6/tkWindow.c b/tk4.2/generic/tkWindow.c similarity index 66% rename from tk3.6/tkWindow.c rename to tk4.2/generic/tkWindow.c index 1551c05..b1e69df 100644 --- a/tk3.6/tkWindow.c +++ b/tk4.2/generic/tkWindow.c @@ -6,40 +6,24 @@ * invoke them) but also maintain the local Tk_Window * structure. * - * Copyright (c) 1989-1993 The Regents of the University of California. - * All rights reserved. + * Copyright (c) 1989-1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. * - * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * 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. + * SCCS: @(#) tkWindow.c 1.214 96/10/12 17:14:54 */ -#ifndef lint -static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkWindow.c,v 1.131 93/10/08 11:37:03 ouster Exp $ SPRITE (Berkeley)"; -#endif - -#include "tkConfig.h" +#include "tkPort.h" #include "tkInt.h" -#include "patchlevel.h" +#include "tkPatch.h" /* * Count of number of main windows currently open in this process. */ -int tk_NumMainWindows; +static int numMainWindows; /* * First in list of all main windows managed by this process. @@ -57,14 +41,7 @@ TkDisplay *tkDisplayList = NULL; * Have statics in this module been initialized? */ -static initialized = 0; - -/* - * Context information used to map from X window id's to - * TkWindow structures (during event handling, for example): - */ - -XContext tkWindowContext; +static int initialized = 0; /* * The variables below hold several uid's that are used in many places @@ -87,17 +64,16 @@ static XWindowChanges defChanges = { #define ALL_EVENTS_MASK \ KeyPressMask|KeyReleaseMask|ButtonPressMask|ButtonReleaseMask| \ EnterWindowMask|LeaveWindowMask|PointerMotionMask|ExposureMask| \ - VisibilityChangeMask|SubstructureNotifyMask| \ - FocusChangeMask|PropertyChangeMask|ColormapChangeMask + VisibilityChangeMask|FocusChangeMask|PropertyChangeMask|ColormapChangeMask static XSetWindowAttributes defAtts= { None, /* background_pixmap */ 0, /* background_pixel */ CopyFromParent, /* border_pixmap */ 0, /* border_pixel */ - ForgetGravity, /* bit_gravity */ + NorthWestGravity, /* bit_gravity */ NorthWestGravity, /* win_gravity */ NotUseful, /* backing_store */ - ~0, /* backing_planes */ + (unsigned) ~0, /* backing_planes */ 0, /* backing_pixel */ False, /* save_under */ ALL_EVENTS_MASK, /* event_mask */ @@ -119,17 +95,21 @@ typedef struct { /* Command procedure. */ } TkCmd; -TkCmd commands[] = { +static TkCmd commands[] = { /* * Commands that are part of the intrinsics: */ - {"after", Tk_AfterCmd}, + {"bell", Tk_BellCmd}, {"bind", Tk_BindCmd}, + {"bindtags", Tk_BindtagsCmd}, + {"clipboard", Tk_ClipboardCmd}, {"destroy", Tk_DestroyCmd}, - {"exit", Tk_ExitCmd}, + {"event", Tk_EventCmd}, {"focus", Tk_FocusCmd}, {"grab", Tk_GrabCmd}, + {"grid", Tk_GridCmd}, + {"image", Tk_ImageCmd}, {"lower", Tk_LowerCmd}, {"option", Tk_OptionCmd}, {"pack", Tk_PackCmd}, @@ -138,45 +118,91 @@ TkCmd commands[] = { {"selection", Tk_SelectionCmd}, {"tk", Tk_TkCmd}, {"tkwait", Tk_TkwaitCmd}, + {"tk_chooseColor", Tk_ChooseColorCmd}, + {"tk_getOpenFile", Tk_GetOpenFileCmd}, + {"tk_getSaveFile", Tk_GetSaveFileCmd}, + {"tk_messageBox", Tk_MessageBoxCmd}, {"update", Tk_UpdateCmd}, {"winfo", Tk_WinfoCmd}, {"wm", Tk_WmCmd}, /* - * Widget-creation commands. + * Widget class commands. */ {"button", Tk_ButtonCmd}, {"canvas", Tk_CanvasCmd}, - {"checkbutton", Tk_ButtonCmd}, + {"checkbutton", Tk_CheckbuttonCmd}, {"entry", Tk_EntryCmd}, {"frame", Tk_FrameCmd}, - {"label", Tk_ButtonCmd}, + {"label", Tk_LabelCmd}, {"listbox", Tk_ListboxCmd}, {"menu", Tk_MenuCmd}, {"menubutton", Tk_MenubuttonCmd}, {"message", Tk_MessageCmd}, - {"radiobutton", Tk_ButtonCmd}, + {"radiobutton", Tk_RadiobuttonCmd}, {"scale", Tk_ScaleCmd}, {"scrollbar", Tk_ScrollbarCmd}, {"text", Tk_TextCmd}, - {"toplevel", Tk_FrameCmd}, - {(char *) NULL, (int (*)()) NULL} + {"toplevel", Tk_ToplevelCmd}, + /* + * Native widget class commands. + */ +#ifdef MAC_TCL + {"macscrollbar", Tk_MacScrollbarCmd}, + {"unsupported1", TkUnsupported1Cmd}, +#endif + {(char *) NULL, (int (*) _ANSI_ARGS_((ClientData, Tcl_Interp *, int, char **))) NULL} +}; + +/* + * The variables and table below are used to parse arguments from + * the "argv" variable in Tk_Init. + */ + +static int synchronize; +static char *name; +static char *display; +static char *geometry; +static char *colormap; +static char *visual; +static int rest = 0; + +static Tk_ArgvInfo argTable[] = { + {"-colormap", TK_ARGV_STRING, (char *) NULL, (char *) &colormap, + "Colormap for main window"}, + {"-display", TK_ARGV_STRING, (char *) NULL, (char *) &display, + "Display to use"}, + {"-geometry", TK_ARGV_STRING, (char *) NULL, (char *) &geometry, + "Initial geometry for window"}, + {"-name", TK_ARGV_STRING, (char *) NULL, (char *) &name, + "Name to use for application"}, + {"-sync", TK_ARGV_CONSTANT, (char *) 1, (char *) &synchronize, + "Use synchronous mode for display server"}, + {"-visual", TK_ARGV_STRING, (char *) NULL, (char *) &visual, + "Visual for main window"}, + {"--", TK_ARGV_REST, (char *) 1, (char *) &rest, + "Pass all remaining arguments through to script"}, + {(char *) NULL, TK_ARGV_END, (char *) NULL, (char *) NULL, + (char *) NULL} }; /* * Forward declarations to procedures defined later in this file: */ +static TkWindow * AllocWindow _ANSI_ARGS_((TkDisplay *dispPtr, + int screenNum, TkWindow *parentPtr)); static Tk_Window CreateTopLevelWindow _ANSI_ARGS_((Tcl_Interp *interp, Tk_Window parent, char *name, char *screenName)); +static void DeleteWindowsExitProc _ANSI_ARGS_(( + ClientData clientData)); static void DoConfigureNotify _ANSI_ARGS_((TkWindow *winPtr)); static TkDisplay * GetScreen _ANSI_ARGS_((Tcl_Interp *interp, char *screenName, int *screenPtr)); static int NameWindow _ANSI_ARGS_((Tcl_Interp *interp, TkWindow *winPtr, TkWindow *parentPtr, char *name)); -static TkWindow * NewWindow _ANSI_ARGS_((TkDisplay *dispPtr, - int screenNum, TkWindow *parentPtr)); +static void OpenIM _ANSI_ARGS_((TkDisplay *dispPtr)); static void UnlinkWindow _ANSI_ARGS_((TkWindow *winPtr)); /* @@ -222,10 +248,30 @@ CreateTopLevelWindow(interp, parent, name, screenName) if (!initialized) { initialized = 1; - tkWindowContext = XUniqueContext(); tkActiveUid = Tk_GetUid("active"); tkDisabledUid = Tk_GetUid("disabled"); tkNormalUid = Tk_GetUid("normal"); + + /* + * Create built-in image types. + */ + + Tk_CreateImageType(&tkBitmapImageType); + Tk_CreateImageType(&tkPhotoImageType); + + /* + * Create built-in photo image formats. + */ + + Tk_CreatePhotoImageFormat(&tkImgFmtGIF); + Tk_CreatePhotoImageFormat(&tkImgFmtPPM); + + /* + * Create exit handler to delete all windows when the application + * exits. + */ + + Tcl_CreateExitHandler(DeleteWindowsExitProc, (ClientData) NULL); } if ((parent != NULL) && (screenName != NULL) && (screenName[0] == '\0')) { @@ -238,12 +284,22 @@ CreateTopLevelWindow(interp, parent, name, screenName) } } - winPtr = NewWindow(dispPtr, screenId, (TkWindow *) parent); + winPtr = AllocWindow(dispPtr, screenId, (TkWindow *) parent); + + /* + * Force the window to use a the border pixel instead of border + * pixmap. This is needed for the case where the window doesn't + * use the default visual. In this case, the default border is + * a pixmap inherited from the root window, which won't work because + * it will have the wrong visual. + */ + + winPtr->dirtyAtts |= CWBorderPixel; /* * Internal windows don't normally ask for StructureNotify events, * since we can generate them internally. However, for top-level - * windows we need to as for the events because the window could + * windows we need to ask for the events because the window could * be manipulated externally. */ @@ -299,7 +355,8 @@ GetScreen(interp, screenName, screenPtr) { register TkDisplay *dispPtr; char *p; - int length, screenId, i; + int screenId; + size_t length; /* * Separate the screen number from the rest of the display @@ -308,13 +365,11 @@ GetScreen(interp, screenName, screenPtr) * optional. */ - if ((screenName == NULL) || (screenName[0] == '\0')) { - screenName = getenv("DISPLAY"); - if (screenName == NULL) { - interp->result = - "no display name and no $DISPLAY environment variable"; - return (TkDisplay *) NULL; - } + screenName = TkGetDefaultScreenName(interp, screenName); + if (screenName == NULL) { + interp->result = + "no display name and no $DISPLAY environment variable"; + return (TkDisplay *) NULL; } length = strlen(screenName); screenId = 0; @@ -348,20 +403,19 @@ GetScreen(interp, screenName, screenPtr) dispPtr->name = (char *) ckalloc((unsigned) (length+1)); dispPtr->lastEventTime = CurrentTime; strncpy(dispPtr->name, screenName, length); - dispPtr->focusTopLevelPtr = NULL; - dispPtr->focussedOnEnter = 0; dispPtr->name[length] = '\0'; dispPtr->bindInfoStale = 1; dispPtr->numModKeyCodes = 0; dispPtr->modKeyCodes = NULL; + OpenIM(dispPtr); dispPtr->errorPtr = NULL; dispPtr->deleteCount = 0; - dispPtr->defaultHandler = NULL; - dispPtr->commWindow = NULL; - dispPtr->serverSecure = 0; - dispPtr->selectionOwner = NULL; - dispPtr->selectionSerial = 0; + dispPtr->commTkwin = NULL; + dispPtr->selectionInfoPtr = NULL; dispPtr->multipleAtom = None; + dispPtr->clipWindow = NULL; + dispPtr->clipboardActive = 0; + dispPtr->clipboardAppPtr = NULL; dispPtr->atomInit = 0; dispPtr->cursorFont = None; dispPtr->grabWinPtr = NULL; @@ -371,19 +425,18 @@ GetScreen(interp, screenName, screenPtr) dispPtr->firstGrabEventPtr = NULL; dispPtr->lastGrabEventPtr = NULL; dispPtr->grabFlags = 0; - dispPtr->colorModels = (Tk_ColorModel *) ckalloc((unsigned) - (ScreenCount(display)*sizeof(Tk_ColorModel))); - for (i = ScreenCount(display)-1; i >= 0; i--) { - if (DisplayPlanes(display, i) <= 4) { - dispPtr->colorModels[i] = TK_MONO; - } else { - dispPtr->colorModels[i] = TK_COLOR; - } - } + TkInitXId(dispPtr); + dispPtr->destroyCount = 0; + dispPtr->lastDestroyRequest = 0; + dispPtr->cmapPtr = NULL; + dispPtr->focusWinPtr = NULL; + dispPtr->implicitWinPtr = NULL; + dispPtr->focusOnMapPtr = NULL; + dispPtr->forceFocus = 0; + dispPtr->stressPtr = NULL; + dispPtr->delayedMotionPtr = NULL; + Tcl_InitHashTable(&dispPtr->winTable, TCL_ONE_WORD_KEYS); tkDisplayList = dispPtr; - Tk_CreateFileHandler(ConnectionNumber(display), - TK_READABLE|TK_IS_DISPLAY, (void (*)()) NULL, - (ClientData) display); break; } if ((strncmp(dispPtr->name, screenName, length) == 0) @@ -399,10 +452,43 @@ GetScreen(interp, screenName, screenPtr) return dispPtr; } +/* + *---------------------------------------------------------------------- + * + * TkGetDisplay -- + * + * Given an X display, TkGetDisplay returns the TkDisplay + * structure for the display. + * + * Results: + * The return value is a pointer to information about the display, + * or NULL if the display did not have a TkDisplay structure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +TkDisplay * +TkGetDisplay(display) + Display *display; /* X's display pointer */ +{ + TkDisplay *dispPtr; + + for (dispPtr = tkDisplayList; dispPtr != NULL; + dispPtr = dispPtr->nextPtr) { + if (dispPtr->display == display) { + break; + } + } + return dispPtr; +} + /* *-------------------------------------------------------------- * - * NewWindow -- + * AllocWindow -- * * This procedure creates and initializes a TkWindow structure. * @@ -417,7 +503,7 @@ GetScreen(interp, screenName, screenPtr) */ static TkWindow * -NewWindow(dispPtr, screenNum, parentPtr) +AllocWindow(dispPtr, screenNum, parentPtr) TkDisplay *dispPtr; /* Display associated with new window. */ int screenNum; /* Index of screen for new window. */ TkWindow *parentPtr; /* Parent from which this window should @@ -457,20 +543,22 @@ NewWindow(dispPtr, screenNum, parentPtr) } else { winPtr->atts.colormap = DefaultColormap(dispPtr->display, screenNum); } - winPtr->dirtyAtts = CWEventMask|CWColormap; + winPtr->dirtyAtts = CWEventMask|CWColormap|CWBitGravity; winPtr->flags = 0; winPtr->handlerList = NULL; - winPtr->focusProc = NULL; - winPtr->focusData = NULL; +#ifdef TK_USE_INPUT_METHODS + winPtr->inputContext = NULL; +#endif /* TK_USE_INPUT_METHODS */ + winPtr->tagPtr = NULL; + winPtr->numTags = 0; winPtr->optionLevel = -1; winPtr->selHandlerList = NULL; - winPtr->selClearProc = NULL; - winPtr->selClearData = NULL; - winPtr->geomProc = NULL; + winPtr->geomMgrPtr = NULL; winPtr->geomData = NULL; winPtr->reqWidth = winPtr->reqHeight = 1; winPtr->internalBorderWidth = 0; winPtr->wmInfoPtr = NULL; + winPtr->privatePtr = NULL; return winPtr; } @@ -524,6 +612,7 @@ NameWindow(interp, winPtr, parentPtr, name) } parentPtr->lastChildPtr = winPtr; winPtr->mainPtr = parentPtr->mainPtr; + winPtr->mainPtr->refCount++; winPtr->nameUid = Tk_GetUid(name); /* @@ -577,7 +666,7 @@ NameWindow(interp, winPtr, parentPtr, name) /* *---------------------------------------------------------------------- * - * Tk_CreateMainWindow -- + * TkCreateMainWindow -- * * Make a new main window. A main window is a special kind of * top-level window used as the outermost window in an @@ -594,32 +683,35 @@ NameWindow(interp, winPtr, parentPtr, name) * associated with the window and registered for "send" commands * under "baseName". BaseName may be extended with an instance * number in the form "#2" if necessary to make it globally - * unique. Tk-related commands are bound into interp. The main - * window becomes a "toplevel" widget and its X window will be - * created and mapped as an idle handler. + * unique. Tk-related commands are bound into interp. * *---------------------------------------------------------------------- */ Tk_Window -Tk_CreateMainWindow(interp, screenName, baseName, className) +TkCreateMainWindow(interp, screenName, baseName) Tcl_Interp *interp; /* Interpreter to use for error reporting. */ char *screenName; /* Name of screen on which to create * window. Empty or NULL string means * use DISPLAY environment variable. */ char *baseName; /* Base name for application; usually of the * form "prog instance". */ - char *className; /* Class to use for application (same as class - * for main window). */ { Tk_Window tkwin; - int result, dummy; + int dummy; Tcl_HashEntry *hPtr; register TkMainInfo *mainPtr; register TkWindow *winPtr; register TkCmd *cmdPtr; - char *libDir; - static char *argv[] = {"-width", "200", "-height", "200", (char *) NULL}; + + /* + * Panic if someone updated the TkWindow structure without + * also updating the Tk_FakeWin structure (or vice versa). + */ + + if (sizeof(TkWindow) != sizeof(Tk_FakeWin)) { + panic("TkWindow and Tk_FakeWin are not the same size"); + } /* * Create the basic TkWindow structure. @@ -639,12 +731,20 @@ Tk_CreateMainWindow(interp, screenName, baseName, className) winPtr = (TkWindow *) tkwin; mainPtr = (TkMainInfo *) ckalloc(sizeof(TkMainInfo)); mainPtr->winPtr = winPtr; + mainPtr->refCount = 1; mainPtr->interp = interp; Tcl_InitHashTable(&mainPtr->nameTable, TCL_STRING_KEYS); - mainPtr->bindingTable = Tk_CreateBindingTable(interp); - mainPtr->focusPtr = winPtr; - mainPtr->focusDefaultPtr = NULL; + TkBindInit(mainPtr); + mainPtr->focusPtr = NULL; + mainPtr->focusSerial = 0; + mainPtr->lastFocusPtr = NULL; mainPtr->optionRootPtr = NULL; + Tcl_InitHashTable(&mainPtr->imageTable, TCL_STRING_KEYS); + mainPtr->strictMotif = 0; + if (Tcl_LinkVar(interp, "tk_strictMotif", (char *) &mainPtr->strictMotif, + TCL_LINK_BOOLEAN) != TCL_OK) { + Tcl_ResetResult(interp); + } mainPtr->nextPtr = tkMainWindowList; tkMainWindowList = mainPtr; winPtr->mainPtr = mainPtr; @@ -653,34 +753,10 @@ Tk_CreateMainWindow(interp, screenName, baseName, className) winPtr->pathName = Tcl_GetHashKey(&mainPtr->nameTable, hPtr); /* - * Register the interpreter for "send" purposes. If baseName isn't - * already unique, find a unique suffix to add to it to make it - * unique. Change the window's name to contain the suffix. + * Register the interpreter for "send" purposes. */ - result = Tk_RegisterInterp(interp, baseName, tkwin); - if (result == TCL_OK) { - winPtr->nameUid = Tk_GetUid(baseName); - } else { - char newName[110]; - int i; - - for (i = 2; ; i++) { - sprintf(newName, "%.100s #%d", baseName, i); - Tcl_SetResult(interp, (char *) NULL, TCL_STATIC); - result = Tk_RegisterInterp(interp, newName, tkwin); - if (result == TCL_OK) { - break; - } - if (i >= 100) { - Tcl_SetResult(interp, - "couldn't generate unique name to register application", - TCL_STATIC); - Tk_DestroyWindow(tkwin); - } - } - winPtr->nameUid = Tk_GetUid(newName); - } + winPtr->nameUid = Tk_GetUid(Tk_SetAppName(tkwin, baseName)); /* * Bind in Tk's commands. @@ -688,71 +764,21 @@ Tk_CreateMainWindow(interp, screenName, baseName, className) for (cmdPtr = commands; cmdPtr->name != NULL; cmdPtr++) { Tcl_CreateCommand(interp, cmdPtr->name, cmdPtr->cmdProc, - (ClientData) tkwin, (void (*)()) NULL); + (ClientData) tkwin, + (void (*) _ANSI_ARGS_((ClientData))) NULL); } /* * Set variables for the intepreter. */ - libDir = getenv("TK_LIBRARY"); - if (libDir == NULL) { - libDir = TK_LIBRARY; - } - Tcl_SetVar(interp, "tk_library", libDir, TCL_GLOBAL_ONLY); Tcl_SetVar(interp, "tk_patchLevel", TK_PATCH_LEVEL, TCL_GLOBAL_ONLY); Tcl_SetVar(interp, "tk_version", TK_VERSION, TCL_GLOBAL_ONLY); - Tcl_SetVar(interp, "tkVersion", TK_VERSION, TCL_GLOBAL_ONLY); - /* - * Make the main window into a toplevel widget. - */ - - Tk_SetClass(tkwin, className); - if (TkInitFrame(interp, tkwin, 1, 4, argv) != TCL_OK) { - return NULL; - } - - tk_NumMainWindows++; + numMainWindows++; return tkwin; } -/* - *---------------------------------------------------------------------- - * - * Tk_Init -- - * - * This procedure is typically invoked by Tcl_AppInit procedures - * to perform additional Tk initialization for a Tcl interpreter, - * such as sourcing the "tk.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 tk.tcl script. - * - *---------------------------------------------------------------------- - */ - -int -Tk_Init(interp) - Tcl_Interp *interp; /* Interpreter to initialize. */ -{ - static char initCmd[] = - "if [file exists $tk_library/tk.tcl] {\n\ - source $tk_library/tk.tcl\n\ - } else {\n\ - set msg \"can't find $tk_library/tk.tcl; perhaps you \"\n\ - append msg \"need to\\ninstall Tk or set your TK_LIBRARY \"\n\ - append msg \"environment variable?\"\n\ - error $msg\n\ - }"; - - return Tcl_Eval(interp, initCmd); -} - /* *-------------------------------------------------------------- * @@ -793,8 +819,14 @@ Tk_CreateWindow(interp, parent, name, screenName) TkWindow *parentPtr = (TkWindow *) parent; TkWindow *winPtr; + if ((parentPtr != NULL) && (parentPtr->flags & TK_ALREADY_DEAD)) { + Tcl_AppendResult(interp, + "can't create window: parent has been destroyed", + (char *) NULL); + return NULL; + } if (screenName == NULL) { - winPtr = NewWindow(parentPtr->dispPtr, parentPtr->screenNum, + winPtr = AllocWindow(parentPtr->dispPtr, parentPtr->screenNum, parentPtr); if (NameWindow(interp, winPtr, parentPtr, name) != TCL_OK) { Tk_DestroyWindow((Tk_Window) winPtr); @@ -879,7 +911,7 @@ Tk_CreateWindowFromPath(interp, tkwin, pathName, screenName) *p = '.'; p[1] = '\0'; } else { - strncpy(p, pathName, numChars); + strncpy(p, pathName, (size_t) numChars); p[numChars] = '\0'; } @@ -894,6 +926,11 @@ Tk_CreateWindowFromPath(interp, tkwin, pathName, screenName) if (parent == NULL) { return NULL; } + if (((TkWindow *) parent)->flags & TK_ALREADY_DEAD) { + Tcl_AppendResult(interp, + "can't create window: parent has been destroyed", (char *) NULL); + return NULL; + } /* * Create the window. @@ -903,7 +940,7 @@ Tk_CreateWindowFromPath(interp, tkwin, pathName, screenName) TkWindow *parentPtr = (TkWindow *) parent; TkWindow *winPtr; - winPtr = NewWindow(parentPtr->dispPtr, parentPtr->screenNum, + winPtr = AllocWindow(parentPtr->dispPtr, parentPtr->screenNum, parentPtr); if (NameWindow(interp, winPtr, parentPtr, pathName+numChars+1) != TCL_OK) { @@ -940,12 +977,13 @@ void Tk_DestroyWindow(tkwin) Tk_Window tkwin; /* Window to destroy. */ { - register TkWindow *winPtr = (TkWindow *) tkwin; + TkWindow *winPtr = (TkWindow *) tkwin; + TkDisplay *dispPtr = winPtr->dispPtr; XEvent event; if (winPtr->flags & TK_ALREADY_DEAD) { /* - * An destroy event binding caused the window to be destroyed + * A destroy event binding caused the window to be destroyed * again. Ignore the request. */ @@ -954,16 +992,69 @@ Tk_DestroyWindow(tkwin) winPtr->flags |= TK_ALREADY_DEAD; /* - * Recursively destroy children. The TK_RECURSIVE_DESTROY - * flags means that the child's window needn't be explicitly - * destroyed (the destroy of the parent already did it), nor - * does it need to be removed from its parent's child list, - * since the parent is being destroyed too. + * Some cleanup needs to be done immediately, rather than later, + * because it needs information that will be destoyed before we + * get to the main cleanup point. For example, TkFocusDeadWindow + * needs to access the parentPtr field from a window, but if + * a Destroy event handler deletes the window's parent this + * field will be NULL before the main cleanup point is reached. */ + TkFocusDeadWindow(winPtr); + + /* + * If this is a main window, remove it from the list of main + * windows. This needs to be done now (rather than later with + * all the other main window cleanup) to handle situations where + * a destroy binding for a window calls "exit". In this case + * the child window cleanup isn't complete when exit is called, + * so the reference count of its application doesn't go to zero + * when exit calls Tk_DestroyWindow on ".", so the main window + * doesn't get removed from the list and exit loops infinitely. + * Even worse, if "destroy ." is called by the destroy binding + * before calling "exit", "exit" will attempt to destroy + * mainPtr->winPtr, which no longer exists, and there may be a + * core dump. + */ + + if (winPtr->mainPtr->winPtr == winPtr) { + if (tkMainWindowList == winPtr->mainPtr) { + tkMainWindowList = winPtr->mainPtr->nextPtr; + } else { + TkMainInfo *prevPtr; + + for (prevPtr = tkMainWindowList; + prevPtr->nextPtr != winPtr->mainPtr; + prevPtr = prevPtr->nextPtr) { + /* Empty loop body. */ + } + prevPtr->nextPtr = winPtr->mainPtr->nextPtr; + } + numMainWindows--; + } + + /* + * Recursively destroy children. + */ + + dispPtr->destroyCount++; while (winPtr->childList != NULL) { - winPtr->childList->flags |= TK_RECURSIVE_DESTROY; - Tk_DestroyWindow((Tk_Window) winPtr->childList); + TkWindow *childPtr; + + childPtr = winPtr->childList; + childPtr->flags |= TK_PARENT_DESTROYED; + Tk_DestroyWindow((Tk_Window) childPtr); + if (winPtr->childList == childPtr) { + /* + * The child didn't remove itself from the child list, so + * let's remove it here. This can happen in some strange + * conditions, such as when a Delete event handler for a + * window deletes the window's parent. + */ + + winPtr->childList = childPtr->nextPtr; + childPtr->parentPtr = NULL; + } } /* @@ -972,88 +1063,110 @@ Tk_DestroyWindow(tkwin) * exists. This is a bit of a kludge, and may be unnecessarily * expensive, but without it no event handlers will get called for * windows that don't exist yet. + * + * Note: if the window's pathName is NULL it means that the window + * was not successfully initialized in the first place, so we should + * not make the window exist or generate the event. */ - if (winPtr->window == None) { - Tk_MakeWindowExist(tkwin); + if (winPtr->pathName != NULL) { + if (winPtr->window == None) { + Tk_MakeWindowExist(tkwin); + } + event.type = DestroyNotify; + event.xdestroywindow.serial = + LastKnownRequestProcessed(winPtr->display); + event.xdestroywindow.send_event = False; + event.xdestroywindow.display = winPtr->display; + event.xdestroywindow.event = winPtr->window; + event.xdestroywindow.window = winPtr->window; + Tk_HandleEvent(&event); } - event.type = DestroyNotify; - event.xdestroywindow.serial = - LastKnownRequestProcessed(winPtr->display); - event.xdestroywindow.send_event = False; - event.xdestroywindow.display = winPtr->display; - event.xdestroywindow.event = winPtr->window; - event.xdestroywindow.window = winPtr->window; - Tk_HandleEvent(&event); /* * Cleanup the data structures associated with this window. - * No need to destroy windows during recursive destroys, since - * that will happen automatically when the parent window is - * destroyed (not true for top-level windows: must destroy - * them explicitly). */ - if (winPtr->window != None) { - if (!(winPtr->flags & TK_RECURSIVE_DESTROY) - || (winPtr->flags & TK_TOP_LEVEL)) { - XDestroyWindow(winPtr->display, winPtr->window); - } - XDeleteContext(winPtr->display, winPtr->window, tkWindowContext); - winPtr->window = None; - } - UnlinkWindow(winPtr); - TkEventDeadWindow(winPtr); - TkFocusDeadWindow(winPtr); - TkOptionDeadWindow(winPtr); - TkSelDeadWindow(winPtr); if (winPtr->flags & TK_TOP_LEVEL) { TkWmDeadWindow(winPtr); + } else if (winPtr->flags & TK_WM_COLORMAP_WINDOW) { + TkWmRemoveFromColormapWindows(winPtr); } + if (winPtr->window != None) { +#if defined(MAC_TCL) || defined(__WIN32__) + XDestroyWindow(winPtr->display, winPtr->window); +#else + if ((winPtr->flags & TK_TOP_LEVEL) + || !(winPtr->flags & TK_PARENT_DESTROYED)) { + /* + * The parent has already been destroyed and this isn't + * a top-level window, so this window will be destroyed + * implicitly when the parent's X window is destroyed; + * it's much faster not to do an explicit destroy of this + * X window. + */ + + dispPtr->lastDestroyRequest = NextRequest(winPtr->display); + XDestroyWindow(winPtr->display, winPtr->window); + } +#endif + TkFreeWindowId(dispPtr, winPtr->window); + Tcl_DeleteHashEntry(Tcl_FindHashEntry(&dispPtr->winTable, + (char *) winPtr->window)); + winPtr->window = None; + } + dispPtr->destroyCount--; + UnlinkWindow(winPtr); + TkEventDeadWindow(winPtr); +#ifdef TK_USE_INPUT_METHODS + if (winPtr->inputContext != NULL) { + XDestroyIC(winPtr->inputContext); + } +#endif /* TK_USE_INPUT_METHODS */ + if (winPtr->tagPtr != NULL) { + TkFreeBindingTags(winPtr); + } + TkOptionDeadWindow(winPtr); + TkSelDeadWindow(winPtr); TkGrabDeadWindow(winPtr); if (winPtr->mainPtr != NULL) { - Tk_DeleteAllBindings(winPtr->mainPtr->bindingTable, - (ClientData) winPtr->pathName); if (winPtr->pathName != NULL) { + Tk_DeleteAllBindings(winPtr->mainPtr->bindingTable, + (ClientData) winPtr->pathName); Tcl_DeleteHashEntry(Tcl_FindHashEntry(&winPtr->mainPtr->nameTable, winPtr->pathName)); } - if (winPtr->mainPtr->winPtr == winPtr) { + winPtr->mainPtr->refCount--; + if (winPtr->mainPtr->refCount == 0) { register TkCmd *cmdPtr; /* - * Deleting a main window. Delete the TkMainInfo structure too - * and replace all of Tk's commands with dummy commands that - * return errors (except don't replace the "exit" command, since - * it may be needed for the application to exit). Also delete - * the "send" command to unregister the interpreter. + * We just deleted the last window in the application. Delete + * the TkMainInfo structure too and replace all of Tk's commands + * with dummy commands that return errors. Also delete the + * "send" command to unregister the interpreter. + * + * NOTE: Only replace the commands it if the interpreter is + * not being deleted. If it *is*, the interpreter cleanup will + * do all the needed work. */ - for (cmdPtr = commands; cmdPtr->name != NULL; cmdPtr++) { - if (cmdPtr->cmdProc != Tk_ExitCmd) { - Tcl_CreateCommand(winPtr->mainPtr->interp, cmdPtr->name, - TkDeadAppCmd, (ClientData) NULL, - (void (*)()) NULL); - } - } - Tcl_CreateCommand(winPtr->mainPtr->interp, "send", - TkDeadAppCmd, (ClientData) NULL, (void (*)()) NULL); + if ((winPtr->mainPtr->interp != NULL) && + (!Tcl_InterpDeleted(winPtr->mainPtr->interp))) { + for (cmdPtr = commands; cmdPtr->name != NULL; cmdPtr++) { + Tcl_CreateCommand(winPtr->mainPtr->interp, cmdPtr->name, + TkDeadAppCmd, (ClientData) NULL, + (void (*) _ANSI_ARGS_((ClientData))) NULL); + } + Tcl_CreateCommand(winPtr->mainPtr->interp, "send", + TkDeadAppCmd, (ClientData) NULL, + (void (*) _ANSI_ARGS_((ClientData))) NULL); + Tcl_UnlinkVar(winPtr->mainPtr->interp, "tk_strictMotif"); + } Tcl_DeleteHashTable(&winPtr->mainPtr->nameTable); - Tk_DeleteBindingTable(winPtr->mainPtr->bindingTable); - if (tkMainWindowList == winPtr->mainPtr) { - tkMainWindowList = winPtr->mainPtr->nextPtr; - } else { - TkMainInfo *prevPtr; - - for (prevPtr = tkMainWindowList; - prevPtr->nextPtr != winPtr->mainPtr; - prevPtr = prevPtr->nextPtr) { - /* Empty loop body. */ - } - prevPtr->nextPtr = winPtr->mainPtr->nextPtr; - } + TkBindFree(winPtr->mainPtr); + TkDeleteAllImages(winPtr->mainPtr); ckfree((char *) winPtr->mainPtr); - tk_NumMainWindows--; } } ckfree((char *) winPtr); @@ -1139,12 +1252,14 @@ Tk_MakeWindowExist(tkwin) register TkWindow *winPtr = (TkWindow *) tkwin; TkWindow *winPtr2; Window parent; + Tcl_HashEntry *hPtr; + int new; if (winPtr->window != None) { return; } - if (winPtr->flags & TK_TOP_LEVEL) { + if ((winPtr->parentPtr == NULL) || (winPtr->flags & TK_TOP_LEVEL)) { parent = XRootWindow(winPtr->display, winPtr->screenNum); } else { if (winPtr->parentPtr->window == None) { @@ -1153,29 +1268,28 @@ Tk_MakeWindowExist(tkwin) parent = winPtr->parentPtr->window; } - winPtr->window = XCreateWindow(winPtr->display, parent, - winPtr->changes.x, winPtr->changes.y, - winPtr->changes.width, winPtr->changes.height, - winPtr->changes.border_width, winPtr->depth, - InputOutput, winPtr->visual, winPtr->dirtyAtts, - &winPtr->atts); - XSaveContext(winPtr->display, winPtr->window, tkWindowContext, - (caddr_t) winPtr); + winPtr->window = TkMakeWindow(winPtr, parent); + hPtr = Tcl_CreateHashEntry(&winPtr->dispPtr->winTable, + (char *) winPtr->window, &new); + Tcl_SetHashValue(hPtr, winPtr); winPtr->dirtyAtts = 0; winPtr->dirtyChanges = 0; - - /* - * If any siblings higher up in the stacking order have already - * been created then move this window to its rightful position - * in the stacking order. - * - * NOTE: this code ignores any changes anyone might have made - * to the sibling and stack_mode field of the window's attributes, - * so it really isn't safe for these to be manipulated except - * by calling Tk_RestackWindow. - */ +#ifdef TK_USE_INPUT_METHODS + winPtr->inputContext = NULL; +#endif /* TK_USE_INPUT_METHODS */ if (!(winPtr->flags & TK_TOP_LEVEL)) { + /* + * If any siblings higher up in the stacking order have already + * been created then move this window to its rightful position + * in the stacking order. + * + * NOTE: this code ignores any changes anyone might have made + * to the sibling and stack_mode field of the window's attributes, + * so it really isn't safe for these to be manipulated except + * by calling Tk_RestackWindow. + */ + for (winPtr2 = winPtr->nextPtr; winPtr2 != NULL; winPtr2 = winPtr2->nextPtr) { if ((winPtr2->window != None) && !(winPtr2->flags & TK_TOP_LEVEL)) { @@ -1187,14 +1301,28 @@ Tk_MakeWindowExist(tkwin) break; } } + + /* + * If this window has a different colormap than its parent, add + * the window to the WM_COLORMAP_WINDOWS property for its top-level. + */ + + if ((winPtr->parentPtr != NULL) && + (winPtr->atts.colormap != winPtr->parentPtr->atts.colormap)) { + TkWmAddToColormapWindows(winPtr); + winPtr->flags |= TK_WM_COLORMAP_WINDOW; + } } /* * Issue a ConfigureNotify event if there were deferred configuration - * changes. + * changes (but skip it if the window is being deleted; the + * ConfigureNotify event could cause problems if we're being called + * from Tk_DestroyWindow under some conditions). */ - if (winPtr->flags & TK_NEED_CONFIG_NOTIFY) { + if ((winPtr->flags & TK_NEED_CONFIG_NOTIFY) + && !(winPtr->flags & TK_ALREADY_DEAD)){ winPtr->flags &= ~TK_NEED_CONFIG_NOTIFY; DoConfigureNotify(winPtr); } @@ -1227,7 +1355,7 @@ Tk_UnmapWindow(tkwin) { register TkWindow *winPtr = (TkWindow *) tkwin; - if (!(winPtr->flags & TK_MAPPED)) { + if (!(winPtr->flags & TK_MAPPED) || (winPtr->flags & TK_ALREADY_DEAD)) { return; } if (winPtr->flags & TK_TOP_LEVEL) { @@ -1319,14 +1447,15 @@ Tk_MoveWindow(tkwin, x, y) void Tk_ResizeWindow(tkwin, width, height) Tk_Window tkwin; /* Window to resize. */ - unsigned int width, height; /* New dimensions for window. */ + int width, height; /* New dimensions for window. */ { register TkWindow *winPtr = (TkWindow *) tkwin; - winPtr->changes.width = width; - winPtr->changes.height = height; + winPtr->changes.width = (unsigned) width; + winPtr->changes.height = (unsigned) height; if (winPtr->window != None) { - XResizeWindow(winPtr->display, winPtr->window, width, height); + XResizeWindow(winPtr->display, winPtr->window, (unsigned) width, + (unsigned) height); if (!(winPtr->flags & TK_TOP_LEVEL)) { DoConfigureNotify(winPtr); } @@ -1341,17 +1470,17 @@ Tk_MoveResizeWindow(tkwin, x, y, width, height) Tk_Window tkwin; /* Window to move and resize. */ int x, y; /* New location for window (within * parent). */ - unsigned int width, height; /* New dimensions for window. */ + int width, height; /* New dimensions for window. */ { register TkWindow *winPtr = (TkWindow *) tkwin; winPtr->changes.x = x; winPtr->changes.y = y; - winPtr->changes.width = width; - winPtr->changes.height = height; + winPtr->changes.width = (unsigned) width; + winPtr->changes.height = (unsigned) height; if (winPtr->window != None) { - XMoveResizeWindow(winPtr->display, winPtr->window, - x, y, width, height); + XMoveResizeWindow(winPtr->display, winPtr->window, x, y, + (unsigned) width, (unsigned) height); if (!(winPtr->flags & TK_TOP_LEVEL)) { DoConfigureNotify(winPtr); } @@ -1370,7 +1499,8 @@ Tk_SetWindowBorderWidth(tkwin, width) winPtr->changes.border_width = width; if (winPtr->window != None) { - XSetWindowBorderWidth(winPtr->display, winPtr->window, width); + XSetWindowBorderWidth(winPtr->display, winPtr->window, + (unsigned) width); if (!(winPtr->flags & TK_TOP_LEVEL)) { DoConfigureNotify(winPtr); } @@ -1459,7 +1589,7 @@ Tk_SetWindowBackground(tkwin, pixel) if (winPtr->window != None) { XSetWindowBackground(winPtr->display, winPtr->window, pixel); } else { - winPtr->dirtyAtts = (winPtr->dirtyAtts & ~CWBackPixmap) + winPtr->dirtyAtts = (winPtr->dirtyAtts & (unsigned) ~CWBackPixmap) | CWBackPixel; } } @@ -1478,7 +1608,7 @@ Tk_SetWindowBackgroundPixmap(tkwin, pixmap) XSetWindowBackgroundPixmap(winPtr->display, winPtr->window, pixmap); } else { - winPtr->dirtyAtts = (winPtr->dirtyAtts & ~CWBackPixel) + winPtr->dirtyAtts = (winPtr->dirtyAtts & (unsigned) ~CWBackPixel) | CWBackPixmap; } } @@ -1496,7 +1626,7 @@ Tk_SetWindowBorder(tkwin, pixel) if (winPtr->window != None) { XSetWindowBorder(winPtr->display, winPtr->window, pixel); } else { - winPtr->dirtyAtts = (winPtr->dirtyAtts & ~CWBorderPixmap) + winPtr->dirtyAtts = (winPtr->dirtyAtts & (unsigned) ~CWBorderPixmap) | CWBorderPixel; } } @@ -1515,7 +1645,7 @@ Tk_SetWindowBorderPixmap(tkwin, pixmap) XSetWindowBorderPixmap(winPtr->display, winPtr->window, pixmap); } else { - winPtr->dirtyAtts = (winPtr->dirtyAtts & ~CWBorderPixel) + winPtr->dirtyAtts = (winPtr->dirtyAtts & (unsigned) ~CWBorderPixel) | CWBorderPixmap; } } @@ -1523,14 +1653,18 @@ Tk_SetWindowBorderPixmap(tkwin, pixmap) void Tk_DefineCursor(tkwin, cursor) Tk_Window tkwin; /* Window to manipulate. */ - Cursor cursor; /* Cursor to use for window (may be None). */ + Tk_Cursor cursor; /* Cursor to use for window (may be None). */ { register TkWindow *winPtr = (TkWindow *) tkwin; - winPtr->atts.cursor = cursor; - +#ifdef MAC_TCL + winPtr->atts.cursor = (XCursor) cursor; +#else + winPtr->atts.cursor = (Cursor) cursor; +#endif + if (winPtr->window != None) { - XDefineCursor(winPtr->display, winPtr->window, cursor); + XDefineCursor(winPtr->display, winPtr->window, winPtr->atts.cursor); } else { winPtr->dirtyAtts = winPtr->dirtyAtts | CWCursor; } @@ -1554,6 +1688,10 @@ Tk_SetWindowColormap(tkwin, colormap) if (winPtr->window != None) { XSetWindowColormap(winPtr->display, winPtr->window, colormap); + if (!(winPtr->flags & TK_TOP_LEVEL)) { + TkWmAddToColormapWindows(winPtr); + winPtr->flags |= TK_WM_COLORMAP_WINDOW; + } } else { winPtr->dirtyAtts |= CWColormap; } @@ -1583,7 +1721,7 @@ int Tk_SetWindowVisual(tkwin, visual, depth, colormap) Tk_Window tkwin; /* Window to manipulate. */ Visual *visual; /* New visual for window. */ - unsigned int depth; /* New depth for window. */ + int depth; /* New depth for window. */ Colormap colormap; /* An appropriate colormap for the visual. */ { register TkWindow *winPtr = (TkWindow *) tkwin; @@ -1681,6 +1819,7 @@ Tk_SetClass(tkwin, className) if (winPtr->flags & TK_TOP_LEVEL) { TkWmSetClass(winPtr); } + TkOptionClassChanged(winPtr); } /* @@ -1722,6 +1861,50 @@ Tk_NameToWindow(interp, pathName, tkwin) return (Tk_Window) Tcl_GetHashValue(hPtr); } +/* + *---------------------------------------------------------------------- + * + * Tk_IdToWindow -- + * + * Given an X display and window ID, this procedure returns the + * Tk token for the window, if there exists a Tk window corresponding + * to the given ID. + * + * Results: + * The return result is either a token for the window corresponding + * to the given X id, or else NULL to indicate that there is no such + * window. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tk_Window +Tk_IdToWindow(display, window) + Display *display; /* X display containing the window. */ + Window window; /* X window window id. */ +{ + TkDisplay *dispPtr; + Tcl_HashEntry *hPtr; + + for (dispPtr = tkDisplayList; ; dispPtr = dispPtr->nextPtr) { + if (dispPtr == NULL) { + return NULL; + } + if (dispPtr->display == display) { + break; + } + } + + hPtr = Tcl_FindHashEntry(&dispPtr->winTable, (char *) window); + if (hPtr == NULL) { + return NULL; + } + return (Tk_Window) Tcl_GetHashValue(hPtr); +} + /* *---------------------------------------------------------------------- * @@ -1746,59 +1929,6 @@ Tk_DisplayName(tkwin) return ((TkWindow *) tkwin)->dispPtr->name; } -/* - *---------------------------------------------------------------------- - * - * Tk_SetColorModel -- - * - * This procedure changes the current color model for a window - * (actually, for the window's screen). - * - * Results: - * None. - * - * Side effects: - * The color model for tkwin's screen is set to "model". - * - *---------------------------------------------------------------------- - */ - -void -Tk_SetColorModel(tkwin, model) - Tk_Window tkwin; /* Token for window; this selects a screen - * whose color model is to be modified. */ - Tk_ColorModel model; /* New model for tkwin's screen. */ -{ - TkWindow *winPtr = (TkWindow *) tkwin; - winPtr->dispPtr->colorModels[winPtr->screenNum] = model; -} - -/* - *---------------------------------------------------------------------- - * - * Tk_GetColorModel -- - * - * This procedure returns the current color model for a window - * (actually, for the window's screen). - * - * Results: - * A color model. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -Tk_ColorModel -Tk_GetColorModel(tkwin) - Tk_Window tkwin; /* Token for window; this selects a screen - * whose color model is returned. */ -{ - TkWindow *winPtr = (TkWindow *) tkwin; - return winPtr->dispPtr->colorModels[winPtr->screenNum]; -} - /* *---------------------------------------------------------------------- * @@ -1879,6 +2009,7 @@ Tk_RestackWindow(tkwin, aboveBelow, other) XWindowChanges changes; unsigned int mask; + /* * Special case: if winPtr is a top-level window then just find * the top-level ancestor of otherPtr and restack winPtr above @@ -1888,10 +2019,8 @@ Tk_RestackWindow(tkwin, aboveBelow, other) changes.stack_mode = aboveBelow; mask = CWStackMode; if (winPtr->flags & TK_TOP_LEVEL) { - if (otherPtr != NULL) { - while (!(otherPtr->flags & TK_TOP_LEVEL)) { - otherPtr = otherPtr->parentPtr; - } + while ((otherPtr != NULL) && !(otherPtr->flags & TK_TOP_LEVEL)) { + otherPtr = otherPtr->parentPtr; } TkWmRestackToplevel(winPtr, aboveBelow, otherPtr); return TCL_OK; @@ -1901,6 +2030,13 @@ Tk_RestackWindow(tkwin, aboveBelow, other) * Find an ancestor of otherPtr that is a sibling of winPtr. */ + if (winPtr->parentPtr == NULL) { + /* + * Window is going to be deleted shortly; don't do anything. + */ + + return TCL_OK; + } if (otherPtr == NULL) { if (aboveBelow == Above) { otherPtr = winPtr->parentPtr->lastChildPtr; @@ -1909,7 +2045,7 @@ Tk_RestackWindow(tkwin, aboveBelow, other) } } else { while (winPtr->parentPtr != otherPtr->parentPtr) { - if (otherPtr->flags & TK_TOP_LEVEL) { + if ((otherPtr == NULL) || (otherPtr->flags & TK_TOP_LEVEL)) { return TCL_ERROR; } otherPtr = otherPtr->parentPtr; @@ -1990,12 +2126,319 @@ Tk_RestackWindow(tkwin, aboveBelow, other) Tk_Window Tk_MainWindow(interp) Tcl_Interp *interp; /* Interpreter that embodies the - * application. */ + * application. Used for error + * reporting also. */ { - Tcl_CmdInfo info; - if (Tcl_GetCommandInfo(interp, "winfo", &info) == 0) { - interp->result = "this isn't a Tk application"; - return NULL; + TkMainInfo *mainPtr; + + for (mainPtr = tkMainWindowList; mainPtr != NULL; + mainPtr = mainPtr->nextPtr) { + if (mainPtr->interp == interp) { + return (Tk_Window) mainPtr->winPtr; + } } - return (Tk_Window) info.clientData; + interp->result = "this isn't a Tk application"; + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_StrictMotif -- + * + * Indicates whether strict Motif compliance has been specified + * for the given window. + * + * Results: + * The return value is 1 if strict Motif compliance has been + * requested for tkwin's application by setting the tk_strictMotif + * variable in its interpreter to a true value. 0 is returned + * if tk_strictMotif has a false value. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tk_StrictMotif(tkwin) + Tk_Window tkwin; /* Window whose application is + * to be checked. */ +{ + return ((TkWindow *) tkwin)->mainPtr->strictMotif; +} + +/* + *-------------------------------------------------------------- + * + * OpenIM -- + * + * Tries to open an X input method, associated with the + * given display. Right now we can only deal with a bare-bones + * input style: no preedit, and no status. + * + * Results: + * Stores the input method in dispPtr->inputMethod; if there isn't + * a suitable input method, then NULL is stored in dispPtr->inputMethod. + * + * Side effects: + * An input method gets opened. + * + *-------------------------------------------------------------- + */ + +static void +OpenIM(dispPtr) + TkDisplay *dispPtr; /* Tk's structure for the display. */ +{ +#ifndef TK_USE_INPUT_METHODS + return; +#else + unsigned short i; + XIMStyles *stylePtr; + + dispPtr->inputMethod = XOpenIM(dispPtr->display, NULL, NULL, NULL); + if (dispPtr->inputMethod == NULL) { + return; + } + + if ((XGetIMValues(dispPtr->inputMethod, XNQueryInputStyle, &stylePtr, + NULL) != NULL) || (stylePtr == NULL)) { + goto error; + } + for (i = 0; i < stylePtr->count_styles; i++) { + if (stylePtr->supported_styles[i] + == (XIMPreeditNothing|XIMStatusNothing)) { + XFree(stylePtr); + return; + } + } + XFree(stylePtr); + + error: + + /* + * Should close the input method, but this causes core dumps on some + * systems (e.g. Solaris 2.3 as of 1/6/95). + * XCloseIM(dispPtr->inputMethod); + */ + dispPtr->inputMethod = NULL; + return; +#endif /* TK_USE_INPUT_METHODS */ +} + +/* + *---------------------------------------------------------------------- + * + * Tk_GetNumMainWindows -- + * + * This procedure returns the number of main windows currently + * open in this process. + * + * Results: + * The number of main windows open in this process. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tk_GetNumMainWindows() +{ + return numMainWindows; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteWindowsExitProc -- + * + * This procedure is invoked as an exit handler. It deletes all + * of the main windows in the process. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteWindowsExitProc(clientData) + ClientData clientData; /* Not used. */ +{ + while (tkMainWindowList != NULL) { + Tk_DestroyWindow((Tk_Window) tkMainWindowList->winPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tk_Init -- + * + * This procedure is invoked to add Tk to an interpreter. It + * incorporates all of Tk's commands into the interpreter and + * creates the main window for a new Tk application. If the + * interpreter contains a variable "argv", this procedure + * extracts several arguments from that variable, uses them + * to configure the main window, and modifies argv to exclude + * the arguments (see the "wish" documentation for a list of + * the arguments that are extracted). + * + * Results: + * Returns a standard Tcl completion code and sets interp->result + * if there is an error. + * + * Side effects: + * Depends on various initialization scripts that get invoked. + * + *---------------------------------------------------------------------- + */ + +int +Tk_Init(interp) + Tcl_Interp *interp; /* Interpreter to initialize. */ +{ + char *p; + int argc, code; + char **argv, *args[20]; + Tcl_DString class; + char buffer[30]; + + /* + * If there is an "argv" variable, get its value, extract out + * relevant arguments from it, and rewrite the variable without + * the arguments that we used. + */ + + synchronize = 0; + name = display = geometry = colormap = visual = NULL; + p = Tcl_GetVar2(interp, "argv", (char *) NULL, TCL_GLOBAL_ONLY); + argv = NULL; + if (p != NULL) { + if (Tcl_SplitList(interp, p, &argc, &argv) != TCL_OK) { + argError: + Tcl_AddErrorInfo(interp, + "\n (processing arguments in argv variable)"); + return TCL_ERROR; + } + if (Tk_ParseArgv(interp, (Tk_Window) NULL, &argc, argv, + argTable, TK_ARGV_DONT_SKIP_FIRST_ARG|TK_ARGV_NO_DEFAULTS) + != TCL_OK) { + ckfree((char *) argv); + goto argError; + } + p = Tcl_Merge(argc, argv); + Tcl_SetVar2(interp, "argv", (char *) NULL, p, TCL_GLOBAL_ONLY); + sprintf(buffer, "%d", argc); + Tcl_SetVar2(interp, "argc", (char *) NULL, buffer, TCL_GLOBAL_ONLY); + ckfree(p); + } + + /* + * Figure out the application's name and class. + */ + + if (name == NULL) { + name = Tcl_GetVar(interp, "argv0", TCL_GLOBAL_ONLY); + if ((name == NULL) || (*name == 0)) { + name = "tk"; + } else { + p = strrchr(name, '/'); + if (p != NULL) { + name = p+1; + } + } + } + Tcl_DStringInit(&class); + Tcl_DStringAppend(&class, name, -1); + p = Tcl_DStringValue(&class); + if (islower(UCHAR(*p))) { + *p = toupper(UCHAR(*p)); + } + + /* + * Create an argument list for creating the top-level window, + * using the information parsed from argv, if any. + */ + + args[0] = "toplevel"; + args[1] = "."; + args[2] = "-class"; + args[3] = Tcl_DStringValue(&class); + argc = 4; + if (display != NULL) { + args[argc] = "-screen"; + args[argc+1] = display; + argc += 2; + + /* + * If this is the first application for this process, save + * the display name in the DISPLAY environment variable so + * that it will be available to subprocesses created by us. + */ + + if (numMainWindows == 0) { + Tcl_SetVar2(interp, "env", "DISPLAY", display, TCL_GLOBAL_ONLY); + } + } + if (colormap != NULL) { + args[argc] = "-colormap"; + args[argc+1] = colormap; + argc += 2; + } + if (visual != NULL) { + args[argc] = "-visual"; + args[argc+1] = visual; + argc += 2; + } + args[argc] = NULL; + code = TkCreateFrame((ClientData) NULL, interp, argc, args, 1, name); + Tcl_DStringFree(&class); + if (code != TCL_OK) { + goto done; + } + Tcl_ResetResult(interp); + if (synchronize) { + XSynchronize(Tk_Display(Tk_MainWindow(interp)), True); + } + + /* + * Set the geometry of the main window, if requested. Put the + * requested geometry into the "geometry" variable. + */ + + if (geometry != NULL) { + Tcl_SetVar(interp, "geometry", geometry, TCL_GLOBAL_ONLY); + code = Tcl_VarEval(interp, "wm geometry . ", geometry, (char *) NULL); + if (code != TCL_OK) { + goto done; + } + } + if (Tcl_PkgRequire(interp, "Tcl", TCL_VERSION, 1) == NULL) { + code = TCL_ERROR; + goto done; + } + code = Tcl_PkgProvide(interp, "Tk", TK_VERSION); + if (code != TCL_OK) { + goto done; + } + + /* + * Invoke platform-specific initialization. + */ + + code = TkPlatformInit(interp); + + done: + if (argv != NULL) { + ckfree((char *) argv); + } + return code; } diff --git a/tk4.2/library/bgerror.tcl b/tk4.2/library/bgerror.tcl new file mode 100644 index 0000000..6933025 --- /dev/null +++ b/tk4.2/library/bgerror.tcl @@ -0,0 +1,74 @@ +# bgerror.tcl -- +# +# This file contains a default version of the bgerror procedure. It +# posts a dialog box with the error message and gives the user a chance +# to see a more detailed stack trace. +# +# SCCS: @(#) bgerror.tcl 1.9 96/05/02 10:17:11 +# +# Copyright (c) 1992-1994 The Regents of the University of California. +# Copyright (c) 1994-1995 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +# The following declaration servers no purpose other than to generate +# a tclIndex entry for "tkerror". Since tkerror and bgerror are hard-wired +# by the Tcl interpreter to be synonyms, the definition of tkerror is +# immediately overridden when bgerror is defined. + +proc tkerror {} {} + +# bgerror -- +# This is the default version of bgerror. It posts a dialog box containing +# the error message and gives the user a chance to ask to see a stack +# trace. +# Arguments: +# err - The error message. + +proc bgerror err { + global errorInfo + set info $errorInfo + set button [tk_dialog .bgerrorDialog "Error in Tcl Script" \ + "Error: $err" error 0 OK "Skip Messages" "Stack Trace"] + if {$button == 0} { + return + } elseif {$button == 1} { + return -code break + } + + set w .bgerrorTrace + catch {destroy $w} + toplevel $w -class ErrorTrace + wm minsize $w 1 1 + wm title $w "Stack Trace for Error" + wm iconname $w "Stack Trace" + button $w.ok -text OK -command "destroy $w" + text $w.text -relief sunken -bd 2 -yscrollcommand "$w.scroll set" \ + -setgrid true -width 60 -height 20 + scrollbar $w.scroll -relief sunken -command "$w.text yview" + pack $w.ok -side bottom -padx 3m -pady 2m + pack $w.scroll -side right -fill y + pack $w.text -side left -expand yes -fill both + $w.text insert 0.0 $info + $w.text mark set insert 0.0 + + # Center the window on the screen. + + wm withdraw $w + update idletasks + set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \ + - [winfo vrootx [winfo parent $w]]] + set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \ + - [winfo vrooty [winfo parent $w]]] + wm geom $w +$x+$y + wm deiconify $w + + # Be sure to release any grabs that might be present on the + # screen, since they could make it impossible for the user + # to interact with the stack trace. + + if {[grab current .] != ""} { + grab release [grab current .] + } +} diff --git a/tk4.2/library/button.tcl b/tk4.2/library/button.tcl new file mode 100644 index 0000000..1969ba6 --- /dev/null +++ b/tk4.2/library/button.tcl @@ -0,0 +1,185 @@ +# button.tcl -- +# +# This file defines the default bindings for Tk label, button, +# checkbutton, and radiobutton widgets and provides procedures +# that help in implementing those bindings. +# +# SCCS: @(#) button.tcl 1.19 96/02/20 13:01:32 +# +# Copyright (c) 1992-1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +#------------------------------------------------------------------------- +# The code below creates the default class bindings for buttons. +#------------------------------------------------------------------------- + +bind Button {} +bind Button { + tkButtonEnter %W +} +bind Button { + tkButtonLeave %W +} +bind Button <1> { + tkButtonDown %W +} +bind Button { + tkButtonUp %W +} +bind Button { + tkButtonInvoke %W +} + +bind Checkbutton {} +bind Checkbutton { + tkButtonEnter %W +} +bind Checkbutton { + tkButtonLeave %W +} +bind Checkbutton <1> { + tkCheckRadioInvoke %W +} +bind Checkbutton { + tkCheckRadioInvoke %W +} +bind Checkbutton { + if !$tk_strictMotif { + tkCheckRadioInvoke %W + } +} + +bind Radiobutton {} +bind Radiobutton { + tkButtonEnter %W +} +bind Radiobutton { + tkButtonLeave %W +} +bind Radiobutton <1> { + tkCheckRadioInvoke %W +} +bind Radiobutton { + tkCheckRadioInvoke %W +} +bind Radiobutton { + if !$tk_strictMotif { + tkCheckRadioInvoke %W + } +} + +# tkButtonEnter -- +# The procedure below is invoked when the mouse pointer enters a +# button widget. It records the button we're in and changes the +# state of the button to active unless the button is disabled. +# +# Arguments: +# w - The name of the widget. + +proc tkButtonEnter {w} { + global tkPriv + if {[$w cget -state] != "disabled"} { + $w config -state active + if {$tkPriv(buttonWindow) == $w} { + $w configure -state active -relief sunken + } + } + set tkPriv(window) $w +} + +# tkButtonLeave -- +# The procedure below is invoked when the mouse pointer leaves a +# button widget. It changes the state of the button back to +# inactive. If we're leaving the button window with a mouse button +# pressed (tkPriv(buttonWindow) == $w), restore the relief of the +# button too. +# +# Arguments: +# w - The name of the widget. + +proc tkButtonLeave w { + global tkPriv + if {[$w cget -state] != "disabled"} { + $w config -state normal + } + if {$w == $tkPriv(buttonWindow)} { + $w configure -relief $tkPriv(relief) + } + set tkPriv(window) "" +} + +# tkButtonDown -- +# The procedure below is invoked when the mouse button is pressed in +# a button widget. It records the fact that the mouse is in the button, +# saves the button's relief so it can be restored later, and changes +# the relief to sunken. +# +# Arguments: +# w - The name of the widget. + +proc tkButtonDown w { + global tkPriv + set tkPriv(relief) [lindex [$w config -relief] 4] + if {[$w cget -state] != "disabled"} { + set tkPriv(buttonWindow) $w + $w config -relief sunken + } +} + +# tkButtonUp -- +# The procedure below is invoked when the mouse button is released +# in a button widget. It restores the button's relief and invokes +# the command as long as the mouse hasn't left the button. +# +# Arguments: +# w - The name of the widget. + +proc tkButtonUp w { + global tkPriv + if {$w == $tkPriv(buttonWindow)} { + set tkPriv(buttonWindow) "" + $w config -relief $tkPriv(relief) + if {($w == $tkPriv(window)) + && ([$w cget -state] != "disabled")} { + uplevel #0 [list $w invoke] + } + } +} + +# tkButtonInvoke -- +# The procedure below is called when a button is invoked through +# the keyboard. It simulate a press of the button via the mouse. +# +# Arguments: +# w - The name of the widget. + +proc tkButtonInvoke w { + if {[$w cget -state] != "disabled"} { + set oldRelief [$w cget -relief] + set oldState [$w cget -state] + $w configure -state active -relief sunken + update idletasks + after 100 + $w configure -state $oldState -relief $oldRelief + uplevel #0 [list $w invoke] + } +} + +# tkCheckRadioInvoke -- +# The procedure below is invoked when the mouse button is pressed in +# a checkbutton or radiobutton widget, or when the widget is invoked +# through the keyboard. It invokes the widget if it +# isn't disabled. +# +# Arguments: +# w - The name of the widget. + +proc tkCheckRadioInvoke w { + if {[$w cget -state] != "disabled"} { + uplevel #0 [list $w invoke] + } +} diff --git a/tk4.2/library/clrpick.tcl b/tk4.2/library/clrpick.tcl new file mode 100644 index 0000000..af5f980 --- /dev/null +++ b/tk4.2/library/clrpick.tcl @@ -0,0 +1,691 @@ +# clrpick.tcl -- +# +# Color selection dialog for platforms that do not support a +# standard color selection dialog. +# +# SCCS: @(#) clrpick.tcl 1.3 96/09/05 09:59:24 +# +# Copyright (c) 1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# ToDo: +# +# (1): Find out how many free colors are left in the colormap and +# don't allocate too many colors. +# (2): Implement HSV color selection. +# + +# tkColorDialog -- +# +# Create a color dialog and let the user choose a color. This function +# should not be called directly. It is called by the tk_chooseColor +# function when a native color selector widget does not exist +# +proc tkColorDialog {args} { + global tkPriv + set w .__tk__color + upvar #0 $w data + + # The lines variables track the start and end indices of the line + # elements in the colorbar canvases. + set data(lines,red,start) 0 + set data(lines,red,last) -1 + set data(lines,green,start) 0 + set data(lines,green,last) -1 + set data(lines,blue,start) 0 + set data(lines,blue,last) -1 + + # This is the actual number of lines that are drawn in each color strip. + # Note that the bars may be of any width. + # However, NUM_COLORBARS must be a number that evenly divides 256. + # Such as 256, 128, 64, etc. + set data(NUM_COLORBARS) 8 + + # BARS_WIDTH is the number of pixels wide the color bar portion of the + # canvas is. This number must be a multiple of NUM_COLORBARS + set data(BARS_WIDTH) 128 + + # PLGN_WIDTH is the number of pixels wide of the triangular selection + # polygon. This also results in the definition of the padding on the + # left and right sides which is half of PLGN_WIDTH. Make this number even. + set data(PLGN_HEIGHT) 10 + + # PLGN_HEIGHT is the height of the selection polygon and the height of the + # selection rectangle at the bottom of the color bar. No restrictions. + set data(PLGN_WIDTH) 10 + + tkColorDialog_Config $w $args + tkColorDialog_InitValues $w + + if ![winfo exists $w] { + toplevel $w -class tkColorDialog + tkColorDialog_BuildDialog $w + } + wm transient $w $data(-parent) + + + # 5. Withdraw the window, then update all the geometry information + # so we know how big it wants to be, then center the window in the + # display and de-iconify it. + + wm withdraw $w + update idletasks + set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \ + - [winfo vrootx [winfo parent $w]]] + set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \ + - [winfo vrooty [winfo parent $w]]] + wm geom $w +$x+$y + wm deiconify $w + wm title $w $data(-title) + + # 6. Set a grab and claim the focus too. + + set oldFocus [focus] + set oldGrab [grab current $w] + if {$oldGrab != ""} { + set grabStatus [grab status $oldGrab] + } + grab $w + focus $data(okBtn) + + # 7. Wait for the user to respond, then restore the focus and + # return the index of the selected button. Restore the focus + # before deleting the window, since otherwise the window manager + # may take the focus away so we can't redirect it. Finally, + # restore any grab that was in effect. + + tkwait variable tkPriv(selectColor) + catch {focus $oldFocus} + grab release $w + destroy $w + unset data + if {$oldGrab != ""} { + if {$grabStatus == "global"} { + grab -global $oldGrab + } else { + grab $oldGrab + } + } + return $tkPriv(selectColor) +} + +# tkColorDialog_InitValues -- +# +# Get called during initialization or when user resets NUM_COLORBARS +# +proc tkColorDialog_InitValues {w} { + upvar #0 $w data + + # IntensityIncr is the difference in color intensity between a colorbar + # and its neighbors. + set data(intensityIncr) [expr 256 / $data(NUM_COLORBARS)] + + # ColorbarWidth is the width of each colorbar + set data(colorbarWidth) \ + [expr $data(BARS_WIDTH) / $data(NUM_COLORBARS)] + + # Indent is the width of the space at the left and right side of the + # colorbar. It is always half the selector polygon width, because the + # polygon extends into the space. + set data(indent) [expr $data(PLGN_WIDTH) / 2] + + set data(colorPad) 2 + set data(selPad) [expr $data(PLGN_WIDTH) / 2] + + # + # minX is the x coordinate of the first colorbar + # + set data(minX) $data(indent) + + # + # maxX is the x coordinate of the last colorbar + # + set data(maxX) [expr $data(BARS_WIDTH) + $data(indent)-1] + + # + # canvasWidth is the width of the entire canvas, including the indents + # + set data(canvasWidth) [expr $data(BARS_WIDTH) + \ + $data(PLGN_WIDTH)] + + # Set the initial color, specified by -initialcolor, or the + # color chosen by the user the last time. + set data(selection) $data(-initialcolor) + set data(finalColor) $data(-initialcolor) + set rgb [winfo rgb . $data(selection)] + + set data(red,intensity) [expr [lindex $rgb 0]/0x100] + set data(green,intensity) [expr [lindex $rgb 1]/0x100] + set data(blue,intensity) [expr [lindex $rgb 2]/0x100] +} + +# tkColorDialog_Config -- +# +# Parses the command line arguments to tk_chooseColor +# +proc tkColorDialog_Config {w argList} { + global tkPriv + upvar #0 $w data + + # 1: the configuration specs + # + set specs { + {-initialcolor "" "" ""} + {-parent "" "" "."} + {-title "" "" "Color"} + } + + # 2: parse the arguments + # + tclParseConfigSpec $w $specs "" $argList + + if ![string compare $data(-title) ""] { + set data(-title) " " + } + if ![string compare $data(-initialcolor) ""] { + if {[info exists tkPriv(selectColor)] && \ + [string compare $tkPriv(selectColor) ""]} { + set data(-initialcolor) $tkPriv(selectColor) + } else { + set data(-initialcolor) [. cget -background] + } + } else { + if [catch {winfo rgb . $data(-initialcolor)} err] { + error $err + } + } + + if ![winfo exists $data(-parent)] { + error "bad window path name \"$data(-parent)\"" + } +} + +# tkColorDialog_BuildDialog -- +# +# Build the dialog. +# +proc tkColorDialog_BuildDialog {w} { + upvar #0 $w data + + # TopFrame contains the color strips and the color selection + # + set topFrame [frame $w.top -relief raised -bd 1] + + # StripsFrame contains the colorstrips and the individual RGB entries + set stripsFrame [frame $topFrame.colorStrip] + + foreach c { Red Green Blue } { + set color [string tolower $c] + + # each f frame contains an [R|G|B] entry and the equiv. color strip. + set f [frame $stripsFrame.$color] + + # The box frame contains the label and entry widget for an [R|G|B] + set box [frame $f.box] + + label $box.label -text $c: -width 6 -under 0 -anchor ne + entry $box.entry -textvariable [format %s $w]($color,intensity) \ + -width 4 + pack $box.label -side left -fill y -padx 2 -pady 3 + pack $box.entry -side left -anchor n -pady 0 + pack $box -side left -fill both + + set height [expr \ + [winfo reqheight $box.entry] - \ + 2*([$box.entry cget -highlightthickness] + [$box.entry cget -bd])] + + canvas $f.color -height $height\ + -width $data(BARS_WIDTH) -relief sunken -bd 2 + canvas $f.sel -height $data(PLGN_HEIGHT) \ + -width $data(canvasWidth) -highlightthickness 0 + pack $f.color -expand yes -fill both + pack $f.sel -expand yes -fill both + + pack $f -side top -fill x -padx 0 -pady 2 + + set data($color,entry) $box.entry + set data($color,col) $f.color + set data($color,sel) $f.sel + + bind $data($color,col) \ + "tkColorDialog_DrawColorScale $w $color 1" + bind $data($color,col) \ + "tkColorDialog_EnterColorBar $w $color" + bind $data($color,col) \ + "tkColorDialog_LeaveColorBar $w $color" + + bind $data($color,sel) \ + "tkColorDialog_EnterColorBar $w $color" + bind $data($color,sel) \ + "tkColorDialog_LeaveColorBar $w $color" + + bind $box.entry "tkColorDialog_HandleRGBEntry $w" + } + + pack $stripsFrame -side left -fill both -padx 4 -pady 10 + + # The selFrame contains a frame that demonstrates the currently + # selected color + # + set selFrame [frame $topFrame.sel] + set lab [label $selFrame.lab -text "Selection:" -under 0 -anchor sw] + set ent [entry $selFrame.ent -textvariable [format %s $w](selection) \ + -width 16] + set f1 [frame $selFrame.f1 -relief sunken -bd 2] + set data(finalCanvas) [frame $f1.demo -bd 0 -width 100 -height 70] + + pack $lab $ent -side top -fill x -padx 4 -pady 2 + pack $f1 -expand yes -anchor nw -fill both -padx 6 -pady 10 + pack $data(finalCanvas) -expand yes -fill both + + bind $ent "tkColorDialog_HandleSelEntry $w" + + pack $selFrame -side left -fill none -anchor nw + pack $topFrame -side top -expand yes -fill both -anchor nw + + # the botFrame frame contains the buttons + # + set botFrame [frame $w.bot -relief raised -bd 1] + button $botFrame.ok -text OK -width 8 -under 0 \ + -command "tkColorDialog_OkCmd $w" + button $botFrame.cancel -text Cancel -width 8 -under 0 \ + -command "tkColorDialog_CancelCmd $w" + + set data(okBtn) $botFrame.ok + set data(cancelBtn) $botFrame.cancel + + pack $botFrame.ok $botFrame.cancel \ + -padx 10 -pady 10 -expand yes -side left + pack $botFrame -side bottom -fill x + + + # Accelerator bindings + + bind $w "focus $data(red,entry)" + bind $w "focus $data(green,entry)" + bind $w "focus $data(blue,entry)" + bind $w "focus $ent" + bind $w "tkButtonInvoke $data(cancelBtn)" + bind $w "tkButtonInvoke $data(cancelBtn)" + bind $w "tkButtonInvoke $data(okBtn)" + + wm protocol $w WM_DELETE_WINDOW "tkColorDialog_CancelCmd $w" +} + +# tkColorDialog_SetRGBValue -- +# +# Sets the current selection of the dialog box +# +proc tkColorDialog_SetRGBValue {w color} { + upvar #0 $w data + + set data(red,intensity) [lindex $color 0] + set data(green,intensity) [lindex $color 1] + set data(blue,intensity) [lindex $color 2] + + tkColorDialog_RedrawColorBars $w all + + # Now compute the new x value of each colorbars pointer polygon + foreach color { red green blue } { + set x [tkColorDialog_RgbToX $w $data($color,intensity)] + tkColorDialog_MoveSelector $w $data($color,sel) $color $x 0 + } +} + +# tkColorDialog_XToRgb -- +# +# Converts a screen coordinate to intensity +# +proc tkColorDialog_XToRgb {w x} { + upvar #0 $w data + + return [expr ($x * $data(intensityIncr))/ $data(colorbarWidth)] +} + +# tkColorDialog_RgbToX +# +# Converts an intensity to screen coordinate. +# +proc tkColorDialog_RgbToX {w color} { + upvar #0 $w data + + return [expr ($color * $data(colorbarWidth)/ $data(intensityIncr))] +} + + +# tkColorDialog_DrawColorScale -- +# +# Draw color scale is called whenever the size of one of the color +# scale canvases is changed. +# +proc tkColorDialog_DrawColorScale {w c {create 0}} { + global lines + upvar #0 $w data + + # col: color bar canvas + # sel: selector canvas + set col $data($c,col) + set sel $data($c,sel) + + # First handle the case that we are creating everything for the first time. + if $create { + # First remove all the lines that already exist. + if { $data(lines,$c,last) > $data(lines,$c,start)} { + for {set i $data(lines,$c,start)} \ + {$i <= $data(lines,$c,last)} { incr i} { + $sel delete $i + } + } + # Delete the selector if it exists + if [info exists data($c,index)] { + $sel delete $data($c,index) + } + + # Draw the selection polygons + tkColorDialog_CreateSelector $w $sel $c + $sel bind $data($c,index) \ + "tkColorDialog_StartMove $w $sel $c %x $data(selPad) 1" + $sel bind $data($c,index) \ + "tkColorDialog_MoveSelector $w $sel $c %x $data(selPad)" + $sel bind $data($c,index) \ + "tkColorDialog_ReleaseMouse $w $sel $c %x $data(selPad)" + + set height [winfo height $col] + # Create an invisible region under the colorstrip to catch mouse clicks + # that aren't on the selector. + set data($c,clickRegion) [$sel create rectangle 0 0 \ + $data(canvasWidth) $height -fill {} -outline {}] + + bind $col \ + "tkColorDialog_StartMove $w $sel $c %x $data(colorPad)" + bind $col \ + "tkColorDialog_MoveSelector $w $sel $c %x $data(colorPad)" + bind $col \ + "tkColorDialog_ReleaseMouse $w $sel $c %x $data(colorPad)" + + $sel bind $data($c,clickRegion) \ + "tkColorDialog_StartMove $w $sel $c %x $data(selPad)" + $sel bind $data($c,clickRegion) \ + "tkColorDialog_MoveSelector $w $sel $c %x $data(selPad)" + $sel bind $data($c,clickRegion) \ + "tkColorDialog_ReleaseMouse $w $sel $c %x $data(selPad)" + } else { + # l is the canvas index of the first colorbar. + set l $data(lines,$c,start) + } + + # Draw the color bars. + set highlightW [expr \ + [$col cget -highlightthickness] + [$col cget -bd]] + for {set i 0} { $i < $data(NUM_COLORBARS)} { incr i} { + set intensity [expr $i * $data(intensityIncr)] + set startx [expr $i * $data(colorbarWidth) + $highlightW] + if { $c == "red" } { + set color [format "#%02x%02x%02x" \ + $intensity \ + $data(green,intensity) \ + $data(blue,intensity)] + } elseif { $c == "green" } { + set color [format "#%02x%02x%02x" \ + $data(red,intensity) \ + $intensity \ + $data(blue,intensity)] + } else { + set color [format "#%02x%02x%02x" \ + $data(red,intensity) \ + $data(green,intensity) \ + $intensity] + } + + if $create { + set index [$col create rect $startx $highlightW \ + [expr $startx +$data(colorbarWidth)] \ + [expr [winfo height $col] + $highlightW]\ + -fill $color -outline $color] + } else { + $col itemconf $l -fill $color -outline $color + incr l + } + } + $sel raise $data($c,index) + + if $create { + set data(lines,$c,last) $index + set data(lines,$c,start) [expr $index - $data(NUM_COLORBARS) + 1 ] + } + + tkColorDialog_RedrawFinalColor $w +} + +# tkColorDialog_CreateSelector -- +# +# Creates and draws the selector polygon at the position +# $data($c,intensity). +# +proc tkColorDialog_CreateSelector {w sel c } { + upvar #0 $w data + set data($c,index) [$sel create polygon \ + 0 $data(PLGN_HEIGHT) \ + $data(PLGN_WIDTH) $data(PLGN_HEIGHT) \ + $data(indent) 0] + set data($c,x) [tkColorDialog_RgbToX $w $data($c,intensity)] + $sel move $data($c,index) $data($c,x) 0 +} + +# tkColorDialog_RedrawFinalColor +# +# Combines the intensities of the three colors into the final color +# +proc tkColorDialog_RedrawFinalColor {w} { + upvar #0 $w data + + set color [format "#%02x%02x%02x" $data(red,intensity) \ + $data(green,intensity) $data(blue,intensity)] + + $data(finalCanvas) conf -bg $color + set data(finalColor) $color + set data(selection) $color + set data(finalRGB) [list \ + $data(red,intensity) \ + $data(green,intensity) \ + $data(blue,intensity)] +} + +# tkColorDialog_RedrawColorBars -- +# +# Only redraws the colors on the color strips that were not manipulated. +# Params: color of colorstrip that changed. If color is not [red|green|blue] +# Then all colorstrips will be updated +# +proc tkColorDialog_RedrawColorBars {w colorChanged} { + upvar #0 $w data + + switch $colorChanged { + red { + tkColorDialog_DrawColorScale $w green + tkColorDialog_DrawColorScale $w blue + } + green { + tkColorDialog_DrawColorScale $w red + tkColorDialog_DrawColorScale $w blue + } + blue { + tkColorDialog_DrawColorScale $w red + tkColorDialog_DrawColorScale $w green + } + default { + tkColorDialog_DrawColorScale $w red + tkColorDialog_DrawColorScale $w green + tkColorDialog_DrawColorScale $w blue + } + } + tkColorDialog_RedrawFinalColor $w +} + +#---------------------------------------------------------------------- +# Event handlers +#---------------------------------------------------------------------- + +# tkColorDialog_StartMove -- +# +# Handles a mousedown button event over the selector polygon. +# Adds the bindings for moving the mouse while the button is +# pressed. Sets the binding for the button-release event. +# +# Params: sel is the selector canvas window, color is the color of the strip. +# +proc tkColorDialog_StartMove {w sel color x delta {dontMove 0}} { + upvar #0 $w data + + if !$dontMove { + tkColorDialog_MoveSelector $w $sel $color $x $delta + } +} + +# tkColorDialog_MoveSelector -- +# +# Moves the polygon selector so that its middle point has the same +# x value as the specified x. If x is outside the bounds [0,255], +# the selector is set to the closest endpoint. +# +# Params: sel is the selector canvas, c is [red|green|blue] +# x is a x-coordinate. +# +proc tkColorDialog_MoveSelector {w sel color x delta} { + upvar #0 $w data + + incr x -$delta + + if { $x < 0 } { + set x 0 + } elseif { $x >= $data(BARS_WIDTH)} { + set x [expr $data(BARS_WIDTH) - 1] + } + set diff [expr $x - $data($color,x)] + $sel move $data($color,index) $diff 0 + set data($color,x) [expr $data($color,x) + $diff] + + # Return the x value that it was actually set at + return $x +} + +# tkColorDialog_ReleaseMouse +# +# Removes mouse tracking bindings, updates the colorbars. +# +# Params: sel is the selector canvas, color is the color of the strip, +# x is the x-coord of the mouse. +# +proc tkColorDialog_ReleaseMouse {w sel color x delta} { + upvar #0 $w data + + set x [tkColorDialog_MoveSelector $w $sel $color $x $delta] + + # Determine exactly what color we are looking at. + set data($color,intensity) [tkColorDialog_XToRgb $w $x] + + tkColorDialog_RedrawColorBars $w $color +} + +# tkColorDialog_ResizeColorbars -- +# +# Completely redraws the colorbars, including resizing the +# colorstrips +# +proc tkColorDialog_ResizeColorBars {w} { + upvar #0 $w data + + if { ($data(BARS_WIDTH) < $data(NUM_COLORBARS)) || + (($data(BARS_WIDTH) % $data(NUM_COLORBARS)) != 0)} { + set data(BARS_WIDTH) $data(NUM_COLORBARS) + } + tkColorDialog_InitValues $w + foreach color { red green blue } { + $data($color,col) conf -width $data(canvasWidth) + tkColorDialog_DrawColorScale $w $color 1 + } +} + +# tkColorDialog_HandleSelEntry -- +# +# Handles the return keypress event in the "Selection:" entry +# +proc tkColorDialog_HandleSelEntry {w} { + upvar #0 $w data + + set text [string trim $data(selection)] + # Check to make sure that the color is valid + if [catch {set color [winfo rgb . $text]} ] { + set data(selection) $data(finalColor) + return + } + + set R [expr [lindex $color 0]/0x100] + set G [expr [lindex $color 1]/0x100] + set B [expr [lindex $color 2]/0x100] + + tkColorDialog_SetRGBValue $w "$R $G $B" + set data(selection) $text +} + +# tkColorDialog_HandleRGBEntry -- +# +# Handles the return keypress event in the R, G or B entry +# +proc tkColorDialog_HandleRGBEntry {w} { + upvar #0 $w data + + foreach c {red green blue} { + if [catch { + set data($c,intensity) [expr int($data($c,intensity))] + }] { + set data($c,intensity) 0 + } + + if {$data($c,intensity) < 0} { + set data($c,intensity) 0 + } + if {$data($c,intensity) > 255} { + set data($c,intensity) 255 + } + } + + tkColorDialog_SetRGBValue $w "$data(red,intensity) $data(green,intensity) \ + $data(blue,intensity)" +} + +# mouse cursor enters a color bar +# +proc tkColorDialog_EnterColorBar {w color} { + upvar #0 $w data + + $data($color,sel) itemconfig $data($color,index) -fill red +} + +# mouse leaves enters a color bar +# +proc tkColorDialog_LeaveColorBar {w color} { + upvar #0 $w data + + $data($color,sel) itemconfig $data($color,index) -fill black +} + +# user hits OK button +# +proc tkColorDialog_OkCmd {w} { + global tkPriv + upvar #0 $w data + + set tkPriv(selectColor) $data(finalColor) +} + +# user hits Cancel button +# +proc tkColorDialog_CancelCmd {w} { + global tkPriv + + set tkPriv(selectColor) "" +} + diff --git a/tk4.2/library/comdlg.tcl b/tk4.2/library/comdlg.tcl new file mode 100644 index 0000000..4f00217 --- /dev/null +++ b/tk4.2/library/comdlg.tcl @@ -0,0 +1,308 @@ +# comdlg.tcl -- +# +# Some functions needed for the common dialog boxes. Probably need to go +# in a different file. +# +# SCCS: @(#) comdlg.tcl 1.4 96/09/05 09:07:54 +# +# Copyright (c) 1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +# tclParseConfigSpec -- +# +# Parses a list of "-option value" pairs. If all options and +# values are legal, the values are stored in +# $data($option). Otherwise an error message is returned. When +# an error happens, the data() array may have been partially +# modified, but all the modified members of the data(0 array are +# guaranteed to have valid values. This is different than +# Tk_ConfigureWidget() which does not modify the value of a +# widget record if any error occurs. +# +# Arguments: +# +# w = widget record to modify. Must be the pathname of a widget. +# +# specs = { +# {-commandlineswitch resourceName ResourceClass defaultValue verifier} +# {....} +# } +# +# flags = currently unused. +# +# argList = The list of "-option value" pairs. +# +proc tclParseConfigSpec {w specs flags argList} { + upvar #0 $w data + + # 1: Put the specs in associative arrays for faster access + # + foreach spec $specs { + if {[llength $spec] < 4} { + error "\"spec\" should contain 5 or 4 elements" + } + set cmdsw [lindex $spec 0] + set cmd($cmdsw) "" + set rname($cmdsw) [lindex $spec 1] + set rclass($cmdsw) [lindex $spec 2] + set def($cmdsw) [lindex $spec 3] + set verproc($cmdsw) [lindex $spec 4] + } + + if {[expr [llength $argList] %2] != 0} { + foreach {cmdsw value} $argList { + if ![info exists cmd($cmdsw)] { + error "unknown option \"$cmdsw\", must be [tclListValidFlags cmd]" + } + } + error "value for \"[lindex $argList end]\" missing" + } + + # 2: set the default values + # + foreach cmdsw [array names cmd] { + set data($cmdsw) $def($cmdsw) + } + + # 3: parse the argument list + # + foreach {cmdsw value} $argList { + if ![info exists cmd($cmdsw)] { + error "unknown option \"$cmdsw\", must be [tclListValidFlags cmd]" + } + set data($cmdsw) $value + } + + # Done! +} + +proc tclListValidFlags {v} { + upvar $v cmd + + set len [llength [array names cmd]] + set i 1 + set separator "" + set errormsg "" + foreach cmdsw [lsort [array names cmd]] { + append errormsg "$separator$cmdsw" + incr i + if {$i == $len} { + set separator " or " + } else { + set separator ", " + } + } + return $errormsg +} + +# This procedure is used to sort strings in a case-insenstive mode. +# +proc tclSortNoCase {str1 str2} { + return [string compare [string toupper $str1] [string toupper $str2]] +} + + +# Gives an error if the string does not contain a valid integer +# number +# +proc tclVerifyInteger {string} { + lindex {1 2 3} $string +} + + +#---------------------------------------------------------------------- +# +# Focus Group +# +# Focus groups are used to handle the user's focusing actions inside a +# toplevel. +# +# One example of using focus groups is: when the user focuses on an +# entry, the text in the entry is highlighted and the cursor is put to +# the end of the text. When the user changes focus to another widget, +# the text in the previously focused entry is validated. +# +#---------------------------------------------------------------------- + + +# tkFocusGroup_Create -- +# +# Create a focus group. All the widgets in a focus group must be +# within the same focus toplevel. Each toplevel can have only +# one focus group, which is identified by the name of the +# toplevel widget. +# +proc tkFocusGroup_Create {t} { + global tkPriv + if [string compare [winfo toplevel $t] $t] { + error "$t is not a toplevel window" + } + if ![info exists tkPriv(fg,$t)] { + set tkPriv(fg,$t) 1 + set tkPriv(focus,$t) "" + bind $t "tkFocusGroup_In $t %W %d" + bind $t "tkFocusGroup_Out $t %W %d" + bind $t "tkFocusGroup_Destroy $t %W" + } +} + +# tkFocusGroup_BindIn -- +# +# Add a widget into the "FocusIn" list of the focus group. The $cmd will be +# called when the widget is focused on by the user. +# +proc tkFocusGroup_BindIn {t w cmd} { + global tkFocusIn tkPriv + if ![info exists tkPriv(fg,$t)] { + error "focus group \"$t\" doesn't exist" + } + set tkFocusIn($t,$w) $cmd +} + + +# tkFocusGroup_BindOut -- +# +# Add a widget into the "FocusOut" list of the focus group. The +# $cmd will be called when the widget loses the focus (User +# types Tab or click on another widget). +# +proc tkFocusGroup_BindOut {t w cmd} { + global tkFocusOut tkPriv + if ![info exists tkPriv(fg,$t)] { + error "focus group \"$t\" doesn't exist" + } + set tkFocusOut($t,$w) $cmd +} + +# tkFocusGroup_Destroy -- +# +# Cleans up when members of the focus group is deleted, or when the +# toplevel itself gets deleted. +# +proc tkFocusGroup_Destroy {t w} { + global tkPriv tkFocusIn tkFocusOut + + if ![string compare $t $w] { + unset tkPriv(fg,$t) + unset tkPriv(focus,$t) + + foreach name [array names tkFocusIn $t,*] { + unset tkFocusIn($name) + } + foreach name [array names tkFocusOut $t,*] { + unset tkFocusOut($name) + } + } else { + if [info exists tkPriv(focus,$t)] { + if ![string compare $tkPriv(focus,$t) $w] { + set tkPriv(focus,$t) "" + } + } + catch { + unset tkFocusIn($t,$w) + } + catch { + unset tkFocusOut($t,$w) + } + } +} + +# tkFocusGroup_In -- +# +# Handles the event. Calls the FocusIn command for the newly +# focused widget in the focus group. +# +proc tkFocusGroup_In {t w detail} { + global tkPriv tkFocusIn + + if ![info exists tkFocusIn($t,$w)] { + set tkFocusIn($t,$w) "" + return + } + if ![info exists tkPriv(focus,$t)] { + return + } + if ![string compare $tkPriv(focus,$t) $w] { + # This is already in focus + # + return + } else { + set tkPriv(focus,$t) $w + eval $tkFocusIn($t,$w) + } +} + +# tkFocusGroup_Out -- +# +# Handles the event. Checks if this is really a lose +# focus event, not one generated by the mouse moving out of the +# toplevel window. Calls the FocusOut command for the widget +# who loses its focus. +# +proc tkFocusGroup_Out {t w detail} { + global tkPriv tkFocusOut + + if {[string compare $detail NotifyNonlinear] && + [string compare $detail NotifyNonlinearVirtual]} { + # This is caused by mouse moving out of the window + return + } + if ![info exists tkPriv(focus,$t)] { + return + } + if ![info exists tkFocusOut($t,$w)] { + return + } else { + eval $tkFocusOut($t,$w) + set tkPriv(focus,$t) "" + } +} + +# tkFDGetFileTypes -- +# +# Process the string given by the -filetypes option of the file +# dialogs. Similar to the C function TkGetFileFilters() on the Mac +# and Windows platform. +# +proc tkFDGetFileTypes {string} { + foreach t $string { + if {[llength $t] < 2 || [llength $t] > 3} { + error "bad file type \"$t\", should be \"typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?\"" + } + eval lappend [list fileTypes([lindex $t 0])] [lindex $t 1] + } + + set types {} + foreach t $string { + set label [lindex $t 0] + set exts {} + + if [info exists hasDoneType($label)] { + continue + } + + set name "$label (" + set sep "" + foreach ext $fileTypes($label) { + if ![string compare $ext ""] { + continue + } + regsub {^[.]} $ext "*." ext + if ![info exists hasGotExt($label,$ext)] { + append name $sep$ext + lappend exts $ext + set hasGotExt($label,$ext) 1 + } + set sep , + } + append name ")" + lappend types [list $name $exts] + + set hasDoneType($label) 1 + } + + return $types +} diff --git a/tk4.2/library/console.tcl b/tk4.2/library/console.tcl new file mode 100644 index 0000000..177f1ee --- /dev/null +++ b/tk4.2/library/console.tcl @@ -0,0 +1,417 @@ +# console.tcl -- +# +# This code constructs the console window for an application. It +# can be used by non-unix systems that do not have built-in support +# for shells. +# +# SCCS: @(#) console.tcl 1.34 96/08/26 20:14:30 +# +# Copyright (c) 1995-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +# TODO: history - remember partially written command + +# tkConsoleInit -- +# This procedure constructs and configures the console windows. +# +# Arguments: +# None. + +proc tkConsoleInit {} { + global tcl_platform + + if {[info commands macscrollbar] == "macscrollbar"} { + # Use the native scrollbar for the console + rename scrollbar "" + rename macscrollbar scrollbar + } + text .console -yscrollcommand ".sb set" -setgrid true + scrollbar .sb -command ".console yview" + pack .sb -side right -fill both + pack .console -fill both -expand 1 -side left + if {$tcl_platform(platform) == "macintosh"} { + after idle {.console configure -font {Monaco 9 normal}} + .sb configure -bg white + .console configure -bg white -bd 0 -highlightthickness 0 \ + -selectbackground black -selectforeground white \ + -selectborderwidth 0 -insertwidth 1 + .console tag configure sel -relief ridge + bind .console { .console tag configure sel -borderwidth 0 + .console configure -selectbackground black -selectforeground white } + bind .console { .console tag configure sel -borderwidth 2 + .console configure -selectbackground white -selectforeground black } + } + + tkConsoleBind .console + + .console tag configure stderr -foreground red + .console tag configure stdin -foreground blue + + focus .console + + wm protocol . WM_DELETE_WINDOW { wm withdraw . } + wm title . "Console" + flush stdout + .console mark set output [.console index "end - 1 char"] + tkTextSetCursor .console end + .console mark set promptEnd insert + .console mark gravity promptEnd left +} + +# tkConsoleInvoke -- +# Processes the command line input. If the command is complete it +# is evaled in the main interpreter. Otherwise, the continuation +# prompt is added and more input may be added. +# +# Arguments: +# None. + +proc tkConsoleInvoke {args} { + set ranges [.console tag ranges input] + set cmd "" + if {$ranges != ""} { + set pos 0 + while {[lindex $ranges $pos] != ""} { + set start [lindex $ranges $pos] + set end [lindex $ranges [incr pos]] + append cmd [.console get $start $end] + incr pos + } + } + if {$cmd == ""} { + tkConsolePrompt + } elseif [info complete $cmd] { + .console mark set output end + .console tag delete input + set result [interp record $cmd] + if {$result != ""} { + .console insert insert "$result\n" + } + tkConsoleHistory reset + tkConsolePrompt + } else { + tkConsolePrompt partial + } + .console yview -pickplace insert +} + +# tkConsoleHistory -- +# This procedure implements command line history for the +# console. In general is evals the history command in the +# main interpreter to obtain the history. The global variable +# histNum is used to store the current location in the history. +# +# Arguments: +# cmd - Which action to take: prev, next, reset. + +set histNum 1 +proc tkConsoleHistory {cmd} { + global histNum + + switch $cmd { + prev { + incr histNum -1 + if {$histNum == 0} { + set cmd {history event [expr [history nextid] -1]} + } else { + set cmd "history event $histNum" + } + if {[catch {interp eval $cmd} cmd]} { + incr histNum + return + } + .console delete promptEnd end + .console insert promptEnd $cmd {input stdin} + } + next { + incr histNum + if {$histNum == 0} { + set cmd {history event [expr [history nextid] -1]} + } elseif {$histNum > 0} { + set cmd "" + set histNum 1 + } else { + set cmd "history event $histNum" + } + if {$cmd != ""} { + catch {interp eval $cmd} cmd + } + .console delete promptEnd end + .console insert promptEnd $cmd {input stdin} + } + reset { + set histNum 1 + } + } +} + +# tkConsolePrompt -- +# This procedure draws the prompt. If tcl_prompt1 or tcl_prompt2 +# exists in the main interpreter it will be called to generate the +# prompt. Otherwise, a hard coded default prompt is printed. +# +# Arguments: +# partial - Flag to specify which prompt to print. + +proc tkConsolePrompt {{partial normal}} { + if {$partial == "normal"} { + set temp [.console index "end - 1 char"] + .console mark set output end + if [interp eval "info exists tcl_prompt1"] { + interp eval "eval \[set tcl_prompt1\]" + } else { + puts -nonewline "% " + } + } else { + set temp [.console index output] + .console mark set output end + if [interp eval "info exists tcl_prompt2"] { + interp eval "eval \[set tcl_prompt2\]" + } else { + puts -nonewline "> " + } + } + flush stdout + .console mark set output $temp + tkTextSetCursor .console end + .console mark set promptEnd insert + .console mark gravity promptEnd left +} + +# tkConsoleBind -- +# This procedure first ensures that the default bindings for the Text +# class have been defined. Then certain bindings are overridden for +# the class. +# +# Arguments: +# None. + +proc tkConsoleBind {win} { + bindtags $win "$win Text . all" + + # Ignore all Alt, Meta, and Control keypresses unless explicitly bound. + # Otherwise, if a widget binding for one of these is defined, the + # class binding will also fire and insert the character, + # which is wrong. Ditto for . + + bind $win {# nothing } + bind $win {# nothing} + bind $win {# nothing} + bind $win {# nothing} + bind $win {# nothing} + + bind $win { + tkConsoleInsert %W \t + focus %W + break + } + bind $win { + %W mark set insert {end - 1c} + tkConsoleInsert %W "\n" + tkConsoleInvoke + break + } + bind $win { + if {[%W tag nextrange sel 1.0 end] != ""} { + %W tag remove sel sel.first promptEnd + } else { + if [%W compare insert < promptEnd] { + break + } + } + } + bind $win { + if {[%W tag nextrange sel 1.0 end] != ""} { + %W tag remove sel sel.first promptEnd + } else { + if [%W compare insert <= promptEnd] { + break + } + } + } + foreach left {Control-a Home} { + bind $win <$left> { + if [%W compare insert < promptEnd] { + tkTextSetCursor %W {insert linestart} + } else { + tkTextSetCursor %W promptEnd + } + break + } + } + foreach right {Control-e End} { + bind $win <$right> { + tkTextSetCursor %W {insert lineend} + break + } + } + bind $win { + if [%W compare insert < promptEnd] { + break + } + } + bind $win { + if [%W compare insert < promptEnd] { + %W mark set insert promptEnd + } + } + bind $win { + if [%W compare insert < promptEnd] { + break + } + } + bind $win { + if [%W compare insert < promptEnd] { + break + } + } + bind $win { + if [%W compare insert <= promptEnd] { + break + } + } + bind $win { + if [%W compare insert <= promptEnd] { + break + } + } + foreach prev {Control-p Up} { + bind $win <$prev> { + tkConsoleHistory prev + break + } + } + foreach prev {Control-n Down} { + bind $win <$prev> { + tkConsoleHistory next + break + } + } + bind $win { + if [%W compare insert > promptEnd] { + catch { + %W insert insert [selection get -displayof %W] {input stdin} + %W see insert + } + } + break + } + bind $win { + catch {tkConsoleInsert %W [selection get -displayof %W]} + break + } + bind $win { + tkConsoleInsert %W %A + break + } + foreach left {Control-b Left} { + bind $win <$left> { + if [%W compare insert == promptEnd] { + break + } + tkTextSetCursor %W insert-1c + break + } + } + foreach right {Control-f Right} { + bind $win <$right> { + tkTextSetCursor %W insert+1c + break + } + } + bind $win { + eval destroy [winfo child .] + if {$tcl_platform(platform) == "macintosh"} { + source -rsrc Console + } else { + source [file join $tk_library console.tcl] + } + } + bind $win <> { + continue + } + bind $win <> { + if {[selection own -displayof %W] == "%W"} { + clipboard clear -displayof %W + catch { + clipboard append -displayof %W [selection get -displayof %W] + } + } + break + } + bind $win <> { + catch { + set clip [selection get -displayof %W -selection CLIPBOARD] + set list [split $clip \n\r] + tkConsoleInsert %W [lindex $list 0] + foreach x [lrange $list 1 end] { + %W mark set insert {end - 1c} + tkConsoleInsert %W "\n" + tkConsoleInvoke + tkConsoleInsert %W $x + } + } + break + } +} + +# tkConsoleInsert -- +# Insert a string into a text at the point of the insertion cursor. +# If there is a selection in the text, and it covers the point of the +# insertion cursor, then delete the selection before inserting. Insertion +# is restricted to the prompt area. +# +# Arguments: +# w - The text window in which to insert the string +# s - The string to insert (usually just a single character) + +proc tkConsoleInsert {w s} { + if {$s == ""} { + return + } + catch { + if {[$w compare sel.first <= insert] + && [$w compare sel.last >= insert]} { + $w tag remove sel sel.first promptEnd + $w delete sel.first sel.last + } + } + if {[$w compare insert < promptEnd]} { + $w mark set insert end + } + $w insert insert $s {input stdin} + $w see insert +} + +# tkConsoleOutput -- +# +# This routine is called directly by ConsolePutsCmd to cause a string +# to be displayed in the console. +# +# Arguments: +# dest - The output tag to be used: either "stderr" or "stdout". +# string - The string to be displayed. + +proc tkConsoleOutput {dest string} { + .console insert output $string $dest + .console see insert +} + +# tkConsoleExit -- +# +# This routine is called by ConsoleEventProc when the main window of +# the application is destroyed. +# +# Arguments: +# None. + +proc tkConsoleExit {} { + exit +} + +# now initialize the console + +tkConsoleInit diff --git a/tk3.6/library/demos/README b/tk4.2/library/demos/README similarity index 72% rename from tk3.6/library/demos/README rename to tk4.2/library/demos/README index b1766ea..c71f977 100644 --- a/tk3.6/library/demos/README +++ b/tk4.2/library/demos/README @@ -3,7 +3,7 @@ the features of the Tk toolkit. The programs are all scripts for "wish", a windowing shell. If wish has been installed in /usr/local then you can invoke any of the programs in this directory just by typing its file name to your command shell. Otherwise invoke -wish on the file using the "-f" switch to wish, e.g. "wish -f hello". +wish with the file as its first argument, e.g., "wish hello". The rest of this file contains a brief description of each program. Files with names ending in ".tcl" are procedure packages used by one or more of the demo programs; they can't be used as programs by @@ -43,19 +43,4 @@ browse - A simple directory browser. Invoke it with and argument Double-click on files or subdirectories to browse them. Control-c and control-q cause the program to exit. -dialog - Displays a simple dialog. Click on any button and the - application exits. - -size - Takes three arguments: the name of an application, the - name of a widget in that application, and the name of an - integer-valued option for that widget. Allows you to - interactively resize the given option. For example, - start up the dialog demo, then type - "size dialog .bot.middle -pady" for an example. - -color - Similar to "size", but modifies a color option. Try - "color dialog .bot.middle -bg" for an example. - -tkSquare.c - A very simple widget to provide an example of how to - implement a new widget. When building a new widget you - may find it useful to start from this code. +sccs id = SCCS: @(#) README 1.3 96/02/16 10:49:14 diff --git a/tk4.2/library/demos/arrow.tcl b/tk4.2/library/demos/arrow.tcl new file mode 100644 index 0000000..56230c8 --- /dev/null +++ b/tk4.2/library/demos/arrow.tcl @@ -0,0 +1,234 @@ +# arrow.tcl -- +# +# This demonstration script creates a canvas widget that displays a +# large line with an arrowhead whose shape can be edited interactively. +# +# SCCS: @(#) arrow.tcl 1.6 96/04/12 12:08:30 + +# arrowSetup -- +# This procedure regenerates all the text and graphics in the canvas +# window. It's called when the canvas is initially created, and also +# whenever any of the parameters of the arrow head are changed +# interactively. +# +# Arguments: +# c - Name of the canvas widget. + +proc arrowSetup c { + upvar #0 demo_arrowInfo v + + # Remember the current box, if there is one. + + set tags [$c gettags current] + if {$tags != ""} { + set cur [lindex $tags [lsearch -glob $tags box?]] + } else { + set cur "" + } + + # Create the arrow and outline. + + $c delete all + eval "$c create line $v(x1) $v(y) $v(x2) $v(y) -width [expr 10*$v(width)] \ + -arrowshape {[expr 10*$v(a)] [expr 10*$v(b)] [expr 10*$v(c)]} \ + -arrow last $v(bigLineStyle)" + set xtip [expr $v(x2)-10*$v(b)] + set deltaY [expr 10*$v(c)+5*$v(width)] + $c create line $v(x2) $v(y) $xtip [expr $v(y)+$deltaY] \ + [expr $v(x2)-10*$v(a)] $v(y) $xtip [expr $v(y)-$deltaY] \ + $v(x2) $v(y) -width 2 -capstyle round -joinstyle round + + # Create the boxes for reshaping the line and arrowhead. + + eval "$c create rect [expr $v(x2)-10*$v(a)-5] [expr $v(y)-5] \ + [expr $v(x2)-10*$v(a)+5] [expr $v(y)+5] $v(boxStyle) \ + -tags {box1 box}" + eval "$c create rect [expr $xtip-5] [expr $v(y)-$deltaY-5] \ + [expr $xtip+5] [expr $v(y)-$deltaY+5] $v(boxStyle) \ + -tags {box2 box}" + eval "$c create rect [expr $v(x1)-5] [expr $v(y)-5*$v(width)-5] \ + [expr $v(x1)+5] [expr $v(y)-5*$v(width)+5] $v(boxStyle) \ + -tags {box3 box}" + if {$cur != ""} { + eval $c itemconfigure $cur $v(activeStyle) + } + + # Create three arrows in actual size with the same parameters + + $c create line [expr $v(x2)+50] 0 [expr $v(x2)+50] 1000 \ + -width 2 + set tmp [expr $v(x2)+100] + $c create line $tmp [expr $v(y)-125] $tmp [expr $v(y)-75] \ + -width $v(width) \ + -arrow both -arrowshape "$v(a) $v(b) $v(c)" + $c create line [expr $tmp-25] $v(y) [expr $tmp+25] $v(y) \ + -width $v(width) \ + -arrow both -arrowshape "$v(a) $v(b) $v(c)" + $c create line [expr $tmp-25] [expr $v(y)+75] [expr $tmp+25] \ + [expr $v(y)+125] -width $v(width) \ + -arrow both -arrowshape "$v(a) $v(b) $v(c)" + + # Create a bunch of other arrows and text items showing the + # current dimensions. + + set tmp [expr $v(x2)+10] + $c create line $tmp [expr $v(y)-5*$v(width)] \ + $tmp [expr $v(y)-$deltaY] \ + -arrow both -arrowshape $v(smallTips) + $c create text [expr $v(x2)+15] [expr $v(y)-$deltaY+5*$v(c)] \ + -text $v(c) -anchor w + set tmp [expr $v(x1)-10] + $c create line $tmp [expr $v(y)-5*$v(width)] \ + $tmp [expr $v(y)+5*$v(width)] \ + -arrow both -arrowshape $v(smallTips) + $c create text [expr $v(x1)-15] $v(y) -text $v(width) -anchor e + set tmp [expr $v(y)+5*$v(width)+10*$v(c)+10] + $c create line [expr $v(x2)-10*$v(a)] $tmp $v(x2) $tmp \ + -arrow both -arrowshape $v(smallTips) + $c create text [expr $v(x2)-5*$v(a)] [expr $tmp+5] \ + -text $v(a) -anchor n + set tmp [expr $tmp+25] + $c create line [expr $v(x2)-10*$v(b)] $tmp $v(x2) $tmp \ + -arrow both -arrowshape $v(smallTips) + $c create text [expr $v(x2)-5*$v(b)] [expr $tmp+5] \ + -text $v(b) -anchor n + + $c create text $v(x1) 310 -text "-width $v(width)" \ + -anchor w -font -*-Helvetica-Medium-R-Normal--*-180-*-*-*-*-*-* + $c create text $v(x1) 330 -text "-arrowshape {$v(a) $v(b) $v(c)}" \ + -anchor w -font -*-Helvetica-Medium-R-Normal--*-180-*-*-*-*-*-* + + incr v(count) +} + +set w .arrow +global tk_library +catch {destroy $w} +toplevel $w +wm title $w "Arrowhead Editor Demonstration" +wm iconname $w "arrow" +positionWindow $w +set c $w.c + +label $w.msg -font $font -wraplength 5i -justify left -text "This widget allows you to experiment with different widths and arrowhead shapes for lines in canvases. To change the line width or the shape of the arrowhead, drag any of the three boxes attached to the oversized arrow. The arrows on the right give examples at normal scale. The text at the bottom shows the configuration options as you'd enter them for a canvas line item." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +canvas $c -width 500 -height 350 -relief sunken -borderwidth 2 +pack $c -expand yes -fill both + +set demo_arrowInfo(a) 8 +set demo_arrowInfo(b) 10 +set demo_arrowInfo(c) 3 +set demo_arrowInfo(width) 2 +set demo_arrowInfo(motionProc) arrowMoveNull +set demo_arrowInfo(x1) 40 +set demo_arrowInfo(x2) 350 +set demo_arrowInfo(y) 150 +set demo_arrowInfo(smallTips) {5 5 2} +set demo_arrowInfo(count) 0 +if {[winfo depth $c] > 1} { + set demo_arrowInfo(bigLineStyle) "-fill SkyBlue1" + set demo_arrowInfo(boxStyle) "-fill {} -outline black -width 1" + set demo_arrowInfo(activeStyle) "-fill red -outline black -width 1" +} else { + set demo_arrowInfo(bigLineStyle) "-fill black \ + -stipple @[file join $tk_library demos images grey.25]" + set demo_arrowInfo(boxStyle) "-fill {} -outline black -width 1" + set demo_arrowInfo(activeStyle) "-fill black -outline black -width 1" +} +arrowSetup $c +$c bind box "$c itemconfigure current $demo_arrowInfo(activeStyle)" +$c bind box "$c itemconfigure current $demo_arrowInfo(boxStyle)" +$c bind box " " +$c bind box " " +$c bind box1 <1> {set demo_arrowInfo(motionProc) arrowMove1} +$c bind box2 <1> {set demo_arrowInfo(motionProc) arrowMove2} +$c bind box3 <1> {set demo_arrowInfo(motionProc) arrowMove3} +$c bind box "\$demo_arrowInfo(motionProc) $c %x %y" +bind $c "arrowSetup $c" + +# arrowMove1 -- +# This procedure is called for each mouse motion event on box1 (the +# one at the vertex of the arrow). It updates the controlling parameters +# for the line and arrowhead. +# +# Arguments: +# c - The name of the canvas window. +# x, y - The coordinates of the mouse. + +proc arrowMove1 {c x y} { + upvar #0 demo_arrowInfo v + set newA [expr ($v(x2)+5-round([$c canvasx $x]))/10] + if {$newA < 0} { + set newA 0 + } + if {$newA > 25} { + set newA 25 + } + if {$newA != $v(a)} { + $c move box1 [expr 10*($v(a)-$newA)] 0 + set v(a) $newA + } +} + +# arrowMove2 -- +# This procedure is called for each mouse motion event on box2 (the +# one at the trailing tip of the arrowhead). It updates the controlling +# parameters for the line and arrowhead. +# +# Arguments: +# c - The name of the canvas window. +# x, y - The coordinates of the mouse. + +proc arrowMove2 {c x y} { + upvar #0 demo_arrowInfo v + set newB [expr ($v(x2)+5-round([$c canvasx $x]))/10] + if {$newB < 0} { + set newB 0 + } + if {$newB > 25} { + set newB 25 + } + set newC [expr ($v(y)+5-round([$c canvasy $y])-5*$v(width))/10] + if {$newC < 0} { + set newC 0 + } + if {$newC > 20} { + set newC 20 + } + if {($newB != $v(b)) || ($newC != $v(c))} { + $c move box2 [expr 10*($v(b)-$newB)] [expr 10*($v(c)-$newC)] + set v(b) $newB + set v(c) $newC + } +} + +# arrowMove3 -- +# This procedure is called for each mouse motion event on box3 (the +# one that controls the thickness of the line). It updates the +# controlling parameters for the line and arrowhead. +# +# Arguments: +# c - The name of the canvas window. +# x, y - The coordinates of the mouse. + +proc arrowMove3 {c x y} { + upvar #0 demo_arrowInfo v + set newWidth [expr ($v(y)+2-round([$c canvasy $y]))/5] + if {$newWidth < 0} { + set newWidth 0 + } + if {$newWidth > 20} { + set newWidth 20 + } + if {$newWidth != $v(width)} { + $c move box3 0 [expr 5*($v(width)-$newWidth)] + set v(width) $newWidth + } +} diff --git a/tk4.2/library/demos/bind.tcl b/tk4.2/library/demos/bind.tcl new file mode 100644 index 0000000..5dfa0a0 --- /dev/null +++ b/tk4.2/library/demos/bind.tcl @@ -0,0 +1,75 @@ +# bind.tcl -- +# +# This demonstration script creates a text widget with bindings set +# up for hypertext-like effects. +# +# SCCS: @(#) bind.tcl 1.5 96/04/12 11:48:26 + +set w .bind +catch {destroy $w} +toplevel $w +wm title $w "Text Demonstration - Tag Bindings" +wm iconname $w "bind" +positionWindow $w + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +text $w.text -yscrollcommand "$w.scroll set" -setgrid true \ + -width 60 -height 24 -font $font -wrap word +scrollbar $w.scroll -command "$w.text yview" +pack $w.scroll -side right -fill y +pack $w.text -expand yes -fill both + +# Set up display styles. + +if {[winfo depth $w] > 1} { + set bold "-background #43ce80 -relief raised -borderwidth 1" + set normal "-background {} -relief flat" +} else { + set bold "-foreground white -background black" + set normal "-foreground {} -background {}" +} + +# Add text to widget. + +$w.text insert 0.0 {\ +The same tag mechanism that controls display styles in text widgets can also be used to associate Tcl commands with regions of text, so that mouse or keyboard actions on the text cause particular Tcl commands to be invoked. For example, in the text below the descriptions of the canvas demonstrations have been tagged. When you move the mouse over a demo description the description lights up, and when you press button 1 over a description then that particular demonstration is invoked. + +} +$w.text insert end \ +{1. Samples of all the different types of items that can be created in canvas widgets.} d1 +$w.text insert end \n\n +$w.text insert end \ +{2. A simple two-dimensional plot that allows you to adjust the positions of the data points.} d2 +$w.text insert end \n\n +$w.text insert end \ +{3. Anchoring and justification modes for text items.} d3 +$w.text insert end \n\n +$w.text insert end \ +{4. An editor for arrow-head shapes for line items.} d4 +$w.text insert end \n\n +$w.text insert end \ +{5. A ruler with facilities for editing tab stops.} d5 +$w.text insert end \n\n +$w.text insert end \ +{6. A grid that demonstrates how canvases can be scrolled.} d6 + +# Create bindings for tags. + +foreach tag {d1 d2 d3 d4 d5 d6} { + $w.text tag bind $tag "$w.text tag configure $tag $bold" + $w.text tag bind $tag "$w.text tag configure $tag $normal" +} +$w.text tag bind d1 <1> {source [file join $tk_library demos items.tcl]} +$w.text tag bind d2 <1> {source [file join $tk_library demos plot.tcl]} +$w.text tag bind d3 <1> {source [file join $tk_library demos ctext.tcl]} +$w.text tag bind d4 <1> {source [file join $tk_library demos arrow.tcl]} +$w.text tag bind d5 <1> {source [file join $tk_library demos ruler.tcl]} +$w.text tag bind d6 <1> {source [file join $tk_library demos cscroll.tcl]} + +$w.text mark set insert 0.0 +$w.text configure -state disabled diff --git a/tk4.2/library/demos/bitmap.tcl b/tk4.2/library/demos/bitmap.tcl new file mode 100644 index 0000000..6b75784 --- /dev/null +++ b/tk4.2/library/demos/bitmap.tcl @@ -0,0 +1,51 @@ +# bitmap.tcl -- +# +# This demonstration script creates a toplevel window that displays +# all of Tk's built-in bitmaps. +# +# SCCS: @(#) bitmap.tcl 1.4 96/02/16 10:49:27 + +# bitmapRow -- +# Create a row of bitmap items in a window. +# +# Arguments: +# w - The window that is to contain the row. +# args - The names of one or more bitmaps, which will be displayed +# in a new row across the bottom of w along with their +# names. + +proc bitmapRow {w args} { + frame $w + pack $w -side top -fill both + set i 0 + foreach bitmap $args { + frame $w.$i + pack $w.$i -side left -fill both -pady .25c -padx .25c + label $w.$i.bitmap -bitmap $bitmap + label $w.$i.label -text $bitmap -width 9 + pack $w.$i.label $w.$i.bitmap -side bottom + incr i + } +} + +set w .bitmap +global tk_library +catch {destroy $w} +toplevel $w +wm title $w "Bitmap Demonstration" +wm iconname $w "bitmap" +positionWindow $w + +label $w.msg -font $font -wraplength 4i -justify left -text "This window displays all of Tk's built-in bitmaps, along with the names you can use for them in Tcl scripts." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +frame $w.frame +bitmapRow $w.frame.0 error gray12 gray50 hourglass +bitmapRow $w.frame.1 info question questhead warning +pack $w.frame -side top -expand yes -fill both diff --git a/tk3.6/library/demos/browse b/tk4.2/library/demos/browse similarity index 85% rename from tk3.6/library/demos/browse rename to tk4.2/library/demos/browse index 47c6a75..46f6532 100644 --- a/tk3.6/library/demos/browse +++ b/tk4.2/library/demos/browse @@ -1,15 +1,20 @@ -#!/usr/local/bin/wish -f -# +#!/bin/sh +# the next line restarts using wish \ +exec wish "$0" "$@" + +# browse -- # This script generates a directory browser, which lists the working # directory and allows you to open files or subdirectories by # double-clicking. +# +# SCCS: @(#) browse 1.8 96/02/16 10:49:18 # Create a scrollbar on the right side of the main window and a listbox # on the left side. scrollbar .scroll -command ".list yview" pack .scroll -side right -fill y -listbox .list -yscroll ".scroll set" -relief raised -geometry 20x20 \ +listbox .list -yscroll ".scroll set" -relief sunken -width 20 -height 20 \ -setgrid yes pack .list -side left -fill both -expand yes wm minsize . 1 1 @@ -47,7 +52,5 @@ foreach i [exec ls -a $dir] { # Set up bindings for the browser. -bind .list {destroy .} -bind .list {destroy .} -focus .list +bind all {destroy .} bind .list {foreach i [selection get] {browse $dir $i}} diff --git a/tk4.2/library/demos/button.tcl b/tk4.2/library/demos/button.tcl new file mode 100644 index 0000000..8145cf7 --- /dev/null +++ b/tk4.2/library/demos/button.tcl @@ -0,0 +1,32 @@ +# button.tcl -- +# +# This demonstration script creates a toplevel window containing +# several button widgets. +# +# SCCS: @(#) button.tcl 1.4 96/08/20 15:50:22 + +set w .button +catch {destroy $w} +toplevel $w +wm title $w "Button Demonstration" +wm iconname $w "button" +positionWindow $w + +label $w.msg -font $font -wraplength 4i -justify left -text "If you click on any of the four buttons below, the background of the button area will change to the color indicated in the button. You can press Tab to move among the buttons, then press Space to invoke the current button." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +button $w.b1 -text "Peach Puff" -width 10 \ + -command "$w config -bg PeachPuff1; $w.buttons config -bg PeachPuff1" +button $w.b2 -text "Light Blue" -width 10 \ + -command "$w config -bg LightBlue1; $w.buttons config -bg LightBlue1" +button $w.b3 -text "Sea Green" -width 10 \ + -command "$w config -bg SeaGreen2; $w.buttons config -bg SeaGreen2" +button $w.b4 -text "Yellow" -width 10 \ + -command "$w config -bg Yellow1; $w.buttons config -bg Yellow1" +pack $w.b1 $w.b2 $w.b3 $w.b4 -side top -expand yes -pady 2 diff --git a/tk4.2/library/demos/check.tcl b/tk4.2/library/demos/check.tcl new file mode 100644 index 0000000..ec1b6d9 --- /dev/null +++ b/tk4.2/library/demos/check.tcl @@ -0,0 +1,29 @@ +# check.tcl -- +# +# This demonstration script creates a toplevel window containing +# several checkbuttons. +# +# SCCS: @(#) check.tcl 1.3 96/02/16 10:49:37 + +set w .check +catch {destroy $w} +toplevel $w +wm title $w "Checkbutton Demonstration" +wm iconname $w "check" +positionWindow $w + +label $w.msg -font $font -wraplength 4i -justify left -text "Three checkbuttons are displayed below. If you click on a button, it will toggle the button's selection state and set a Tcl variable to a value indicating the state of the checkbutton. Click the \"See Variables\" button to see the current values of the variables." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +button $w.buttons.vars -text "See Variables" \ + -command "showVars $w.dialog wipers brakes sober" +pack $w.buttons.dismiss $w.buttons.code $w.buttons.vars -side left -expand 1 + +checkbutton $w.b1 -text "Wipers OK" -variable wipers -relief flat +checkbutton $w.b2 -text "Brakes OK" -variable brakes -relief flat +checkbutton $w.b3 -text "Driver Sober" -variable sober -relief flat +pack $w.b1 $w.b2 $w.b3 -side top -pady 2 -anchor w diff --git a/tk4.2/library/demos/clrpick.tcl b/tk4.2/library/demos/clrpick.tcl new file mode 100644 index 0000000..96d4765 --- /dev/null +++ b/tk4.2/library/demos/clrpick.tcl @@ -0,0 +1,52 @@ +# clrpick.tcl -- +# +# This demonstration script prompts the user to select a color. +# +# SCCS: @(#) clrpick.tcl 1.1 96/08/23 11:36:42 + +set w .clrpick +catch {destroy $w} +toplevel $w +wm title $w "File Selection Dialogs" +wm iconname $w "colors" +positionWindow $w + +label $w.msg -font $font -wraplength 4i -justify left -text "Press the buttons below to choose the foreground and background colors for the widgets in this window." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +button $w.back -text "Set background color ..." \ + -command \ + "setColor $w $w.back background {-background -highlightbackground}" +button $w.fore -text "Set foreground color ..." \ + -command \ + "setColor $w $w.back foreground -foreground" + +pack $w.back $w.fore -side top -anchor c -pady 2m + +proc setColor {w button name options} { + grab $w + set initialColor [$button cget -$name] + set color [tk_chooseColor -title "Choose a $name color" -parent $w \ + -initialcolor $initialColor] + if [string compare $color ""] { + setColor_helper $w $options $color + } + grab release $w +} + +proc setColor_helper {w options color} { + foreach option $options { + catch { + $w config $option $color + } + } + foreach child [winfo children $w] { + setColor_helper $child $options $color + } +} diff --git a/tk4.2/library/demos/colors.tcl b/tk4.2/library/demos/colors.tcl new file mode 100644 index 0000000..395e6e1 --- /dev/null +++ b/tk4.2/library/demos/colors.tcl @@ -0,0 +1,97 @@ +# colors.tcl -- +# +# This demonstration script creates a listbox widget that displays +# many of the colors from the X color database. You can click on +# a color to change the application's palette. +# +# SCCS: @(#) colors.tcl 1.3 96/02/16 10:49:41 + +set w .colors +catch {destroy $w} +toplevel $w +wm title $w "Listbox Demonstration (colors)" +wm iconname $w "Listbox" +positionWindow $w + +label $w.msg -font $font -wraplength 4i -justify left -text "A listbox containing several color names is displayed below, along with a scrollbar. You can scan the list either using the scrollbar or by dragging in the listbox window with button 2 pressed. If you double-click button 1 on a color, then the application's color palette will be set to match that color" +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +frame $w.frame -borderwidth 10 +pack $w.frame -side top -expand yes -fill y + +scrollbar $w.frame.scroll -command "$w.frame.list yview" +listbox $w.frame.list -yscroll "$w.frame.scroll set" \ + -width 20 -height 16 -setgrid 1 +pack $w.frame.list $w.frame.scroll -side left -fill y -expand 1 + +bind $w.frame.list { + tk_setPalette [selection get] +} +$w.frame.list insert 0 gray60 gray70 gray80 gray85 gray90 gray95 \ + snow1 snow2 snow3 snow4 seashell1 seashell2 \ + seashell3 seashell4 AntiqueWhite1 AntiqueWhite2 AntiqueWhite3 \ + AntiqueWhite4 bisque1 bisque2 bisque3 bisque4 PeachPuff1 \ + PeachPuff2 PeachPuff3 PeachPuff4 NavajoWhite1 NavajoWhite2 \ + NavajoWhite3 NavajoWhite4 LemonChiffon1 LemonChiffon2 \ + LemonChiffon3 LemonChiffon4 cornsilk1 cornsilk2 cornsilk3 \ + cornsilk4 ivory1 ivory2 ivory3 ivory4 honeydew1 honeydew2 \ + honeydew3 honeydew4 LavenderBlush1 LavenderBlush2 \ + LavenderBlush3 LavenderBlush4 MistyRose1 MistyRose2 \ + MistyRose3 MistyRose4 azure1 azure2 azure3 azure4 \ + SlateBlue1 SlateBlue2 SlateBlue3 SlateBlue4 RoyalBlue1 \ + RoyalBlue2 RoyalBlue3 RoyalBlue4 blue1 blue2 blue3 blue4 \ + DodgerBlue1 DodgerBlue2 DodgerBlue3 DodgerBlue4 SteelBlue1 \ + SteelBlue2 SteelBlue3 SteelBlue4 DeepSkyBlue1 DeepSkyBlue2 \ + DeepSkyBlue3 DeepSkyBlue4 SkyBlue1 SkyBlue2 SkyBlue3 \ + SkyBlue4 LightSkyBlue1 LightSkyBlue2 LightSkyBlue3 \ + LightSkyBlue4 SlateGray1 SlateGray2 SlateGray3 SlateGray4 \ + LightSteelBlue1 LightSteelBlue2 LightSteelBlue3 \ + LightSteelBlue4 LightBlue1 LightBlue2 LightBlue3 \ + LightBlue4 LightCyan1 LightCyan2 LightCyan3 LightCyan4 \ + PaleTurquoise1 PaleTurquoise2 PaleTurquoise3 PaleTurquoise4 \ + CadetBlue1 CadetBlue2 CadetBlue3 CadetBlue4 turquoise1 \ + turquoise2 turquoise3 turquoise4 cyan1 cyan2 cyan3 cyan4 \ + DarkSlateGray1 DarkSlateGray2 DarkSlateGray3 \ + DarkSlateGray4 aquamarine1 aquamarine2 aquamarine3 \ + aquamarine4 DarkSeaGreen1 DarkSeaGreen2 DarkSeaGreen3 \ + DarkSeaGreen4 SeaGreen1 SeaGreen2 SeaGreen3 SeaGreen4 \ + PaleGreen1 PaleGreen2 PaleGreen3 PaleGreen4 SpringGreen1 \ + SpringGreen2 SpringGreen3 SpringGreen4 green1 green2 \ + green3 green4 chartreuse1 chartreuse2 chartreuse3 \ + chartreuse4 OliveDrab1 OliveDrab2 OliveDrab3 OliveDrab4 \ + DarkOliveGreen1 DarkOliveGreen2 DarkOliveGreen3 \ + DarkOliveGreen4 khaki1 khaki2 khaki3 khaki4 \ + LightGoldenrod1 LightGoldenrod2 LightGoldenrod3 \ + LightGoldenrod4 LightYellow1 LightYellow2 LightYellow3 \ + LightYellow4 yellow1 yellow2 yellow3 yellow4 gold1 gold2 \ + gold3 gold4 goldenrod1 goldenrod2 goldenrod3 goldenrod4 \ + DarkGoldenrod1 DarkGoldenrod2 DarkGoldenrod3 DarkGoldenrod4 \ + RosyBrown1 RosyBrown2 RosyBrown3 RosyBrown4 IndianRed1 \ + IndianRed2 IndianRed3 IndianRed4 sienna1 sienna2 sienna3 \ + sienna4 burlywood1 burlywood2 burlywood3 burlywood4 wheat1 \ + wheat2 wheat3 wheat4 tan1 tan2 tan3 tan4 chocolate1 \ + chocolate2 chocolate3 chocolate4 firebrick1 firebrick2 \ + firebrick3 firebrick4 brown1 brown2 brown3 brown4 salmon1 \ + salmon2 salmon3 salmon4 LightSalmon1 LightSalmon2 \ + LightSalmon3 LightSalmon4 orange1 orange2 orange3 orange4 \ + DarkOrange1 DarkOrange2 DarkOrange3 DarkOrange4 coral1 \ + coral2 coral3 coral4 tomato1 tomato2 tomato3 tomato4 \ + OrangeRed1 OrangeRed2 OrangeRed3 OrangeRed4 red1 red2 red3 \ + red4 DeepPink1 DeepPink2 DeepPink3 DeepPink4 HotPink1 \ + HotPink2 HotPink3 HotPink4 pink1 pink2 pink3 pink4 \ + LightPink1 LightPink2 LightPink3 LightPink4 PaleVioletRed1 \ + PaleVioletRed2 PaleVioletRed3 PaleVioletRed4 maroon1 \ + maroon2 maroon3 maroon4 VioletRed1 VioletRed2 VioletRed3 \ + VioletRed4 magenta1 magenta2 magenta3 magenta4 orchid1 \ + orchid2 orchid3 orchid4 plum1 plum2 plum3 plum4 \ + MediumOrchid1 MediumOrchid2 MediumOrchid3 MediumOrchid4 \ + DarkOrchid1 DarkOrchid2 DarkOrchid3 DarkOrchid4 purple1 \ + purple2 purple3 purple4 MediumPurple1 MediumPurple2 \ + MediumPurple3 MediumPurple4 thistle1 thistle2 thistle3 \ + thistle4 diff --git a/tk4.2/library/demos/cscroll.tcl b/tk4.2/library/demos/cscroll.tcl new file mode 100644 index 0000000..f6c7ddb --- /dev/null +++ b/tk4.2/library/demos/cscroll.tcl @@ -0,0 +1,92 @@ +# cscroll.tcl -- +# +# This demonstration script creates a simple canvas that can be +# scrolled in two dimensions. +# +# SCCS: @(#) cscroll.tcl 1.5 96/10/04 17:09:36 + +set w .cscroll +catch {destroy $w} +toplevel $w +wm title $w "Scrollable Canvas Demonstration" +wm iconname $w "cscroll" +positionWindow $w +set c $w.c + +label $w.msg -font $font -wraplength 4i -justify left -text "This window displays a canvas widget that can be scrolled either using the scrollbars or by dragging with button 2 in the canvas. If you click button 1 on one of the rectangles, its indices will be printed on stdout." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +frame $w.grid +scrollbar $w.hscroll -orient horiz -command "$c xview" +scrollbar $w.vscroll -command "$c yview" +canvas $c -relief sunken -borderwidth 2 -scrollregion {-11c -11c 50c 20c} \ + -xscrollcommand "$w.hscroll set" \ + -yscrollcommand "$w.vscroll set" +pack $w.grid -expand yes -fill both -padx 1 -pady 1 +grid rowconfig $w.grid 0 -weight 1 -minsize 0 +grid columnconfig $w.grid 0 -weight 1 -minsize 0 + +grid $c -padx 1 -in $w.grid -pady 1 \ + -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news +grid $w.vscroll -in $w.grid -padx 1 -pady 1 \ + -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news +grid $w.hscroll -in $w.grid -padx 1 -pady 1 \ + -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news + + +set bg [lindex [$c config -bg] 4] +for {set i 0} {$i < 20} {incr i} { + set x [expr {-10 + 3*$i}] + for {set j 0; set y -10} {$j < 10} {incr j; incr y 3} { + $c create rect ${x}c ${y}c [expr $x+2]c [expr $y+2]c \ + -outline black -fill $bg -tags rect + $c create text [expr $x+1]c [expr $y+1]c -text "$i,$j" \ + -anchor center -tags text + } +} + +$c bind all "scrollEnter $c" +$c bind all "scrollLeave $c" +$c bind all <1> "scrollButton $c" +bind $c <2> "$c scan mark %x %y" +bind $c "$c scan dragto %x %y" + +proc scrollEnter canvas { + global oldFill + set id [$canvas find withtag current] + if {[lsearch [$canvas gettags current] text] >= 0} { + set id [expr $id-1] + } + set oldFill [lindex [$canvas itemconfig $id -fill] 4] + if {[winfo depth $canvas] > 1} { + $canvas itemconfigure $id -fill SeaGreen1 + } else { + $canvas itemconfigure $id -fill black + $canvas itemconfigure [expr $id+1] -fill white + } +} + +proc scrollLeave canvas { + global oldFill + set id [$canvas find withtag current] + if {[lsearch [$canvas gettags current] text] >= 0} { + set id [expr $id-1] + } + $canvas itemconfigure $id -fill $oldFill + $canvas itemconfigure [expr $id+1] -fill black +} + +proc scrollButton canvas { + global oldFill + set id [$canvas find withtag current] + if {[lsearch [$canvas gettags current] text] < 0} { + set id [expr $id+1] + } + puts stdout "You buttoned at [lindex [$canvas itemconf $id -text] 4]" +} diff --git a/tk4.2/library/demos/ctext.tcl b/tk4.2/library/demos/ctext.tcl new file mode 100644 index 0000000..66fad39 --- /dev/null +++ b/tk4.2/library/demos/ctext.tcl @@ -0,0 +1,142 @@ +# ctext.tcl -- +# +# This demonstration script creates a canvas widget with a text +# item that can be edited and reconfigured in various ways. +# +# SCCS: @(#) ctext.tcl 1.4 96/02/16 10:49:16 + +set w .ctext +catch {destroy $w} +toplevel $w +wm title $w "Canvas Text Demonstration" +wm iconname $w "Text" +positionWindow $w +set c $w.c + +label $w.msg -font $font -wraplength 5i -justify left -text "This window displays a string of text to demonstrate the text facilities of canvas widgets. You can click in the boxes to adjust the position of the text relative to its positioning point or change its justification. The text also supports the following simple bindings for editing: + 1. You can point, click, and type. + 2. You can also select with button 1. + 3. You can copy the selection to the mouse position with button 2. + 4. Backspace and Control+h delete the selection if there is one; + otherwise they delete the character just before the insertion cursor. + 5. Delete deletes the selection if there is one; otherwise it deletes + the character just after the insertion cursor." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +canvas $c -relief flat -borderwidth 0 -width 500 -height 350 +pack $w.c -side top -expand yes -fill both + +set textFont -*-Helvetica-Medium-R-Normal--*-240-*-*-*-*-*-* + +$c create rectangle 245 195 255 205 -outline black -fill red + +# First, create the text item and give it bindings so it can be edited. + +$c addtag text withtag [$c create text 250 200 -text "This is just a string of text to demonstrate the text facilities of canvas widgets. Bindings have been been defined to support editing (see above)." -width 440 -anchor n -font -*-Helvetica-Medium-R-Normal--*-240-*-*-*-*-*-* -justify left] +$c bind text <1> "textB1Press $c %x %y" +$c bind text "textB1Move $c %x %y" +$c bind text "$c select adjust current @%x,%y" +$c bind text "textB1Move $c %x %y" +$c bind text "textInsert $c %A" +$c bind text "textInsert $c \\n" +$c bind text "textBs $c" +$c bind text "textBs $c" +$c bind text "textDel $c" +$c bind text <2> "textPaste $c @%x,%y" + +# Next, create some items that allow the text's anchor position +# to be edited. + +proc mkTextConfig {w x y option value color} { + set item [$w create rect [expr $x] [expr $y] [expr $x+30] [expr $y+30] \ + -outline black -fill $color -width 1] + $w bind $item <1> "$w itemconf text $option $value" + $w addtag config withtag $item +} + +set x 50 +set y 50 +set color LightSkyBlue1 +mkTextConfig $c $x $y -anchor se $color +mkTextConfig $c [expr $x+30] [expr $y] -anchor s $color +mkTextConfig $c [expr $x+60] [expr $y] -anchor sw $color +mkTextConfig $c [expr $x] [expr $y+30] -anchor e $color +mkTextConfig $c [expr $x+30] [expr $y+30] -anchor center $color +mkTextConfig $c [expr $x+60] [expr $y+30] -anchor w $color +mkTextConfig $c [expr $x] [expr $y+60] -anchor ne $color +mkTextConfig $c [expr $x+30] [expr $y+60] -anchor n $color +mkTextConfig $c [expr $x+60] [expr $y+60] -anchor nw $color +set item [$c create rect [expr $x+40] [expr $y+40] [expr $x+50] [expr $y+50] \ + -outline black -fill red] +$c bind $item <1> "$c itemconf text -anchor center" +$c create text [expr $x+45] [expr $y-5] -text {Text Position} -anchor s \ + -font -*-times-medium-r-normal--*-240-*-*-*-*-*-* -fill brown + +# Lastly, create some items that allow the text's justification to be +# changed. + +set x 350 +set y 50 +set color SeaGreen2 +mkTextConfig $c $x $y -justify left $color +mkTextConfig $c [expr $x+30] [expr $y] -justify center $color +mkTextConfig $c [expr $x+60] [expr $y] -justify right $color +$c create text [expr $x+45] [expr $y-5] -text {Justification} -anchor s \ + -font -*-times-medium-r-normal--*-240-*-*-*-*-*-* -fill brown + +$c bind config "textEnter $c" +$c bind config "$c itemconf current -fill \$textConfigFill" + +set textConfigFill {} + +proc textEnter {w} { + global textConfigFill + set textConfigFill [lindex [$w itemconfig current -fill] 4] + $w itemconfig current -fill black +} + +proc textInsert {w string} { + if {$string == ""} { + return + } + catch {$w dchars text sel.first sel.last} + $w insert text insert $string +} + +proc textPaste {w pos} { + catch { + $w insert text $pos [selection get] + } +} + +proc textB1Press {w x y} { + $w icursor current @$x,$y + $w focus current + focus $w + $w select from current @$x,$y +} + +proc textB1Move {w x y} { + $w select to current @$x,$y +} + +proc textBs {w} { + if ![catch {$w dchars text sel.first sel.last}] { + return + } + set char [expr {[$w index text insert] - 1}] + if {$char >= 0} {$w dchar text $char} +} + +proc textDel {w} { + if ![catch {$w dchars text sel.first sel.last}] { + return + } + $w dchars text insert +} diff --git a/tk4.2/library/demos/dialog1.tcl b/tk4.2/library/demos/dialog1.tcl new file mode 100644 index 0000000..e221beb --- /dev/null +++ b/tk4.2/library/demos/dialog1.tcl @@ -0,0 +1,15 @@ +# dialog1.tcl -- +# +# This demonstration script creates a dialog box with a local grab. +# +# SCCS: @(#) dialog1.tcl 1.2 96/02/16 10:49:52 + +after idle {.dialog1.msg configure -wraplength 4i} +set i [tk_dialog .dialog1 "Dialog with local grab" {This is a modal dialog box. It uses Tk's "grab" command to create a "local grab" on the dialog box. The grab prevents any pointer-related events from getting to any other windows in the application until you have answered the dialog by invoking one of the buttons below. However, you can still interact with other applications.} \ +info 0 OK Cancel {Show Code}] + +switch $i { + 0 {puts "You pressed OK"} + 1 {puts "You pressed Cancel"} + 2 {showCode .dialog1} +} diff --git a/tk4.2/library/demos/dialog2.tcl b/tk4.2/library/demos/dialog2.tcl new file mode 100644 index 0000000..0cc3bb6 --- /dev/null +++ b/tk4.2/library/demos/dialog2.tcl @@ -0,0 +1,19 @@ +# dialog2.tcl -- +# +# This demonstration script creates a dialog box with a global grab. +# +# SCCS: @(#) dialog2.tcl 1.2 96/02/16 10:49:53 + +after idle { + .dialog2.msg configure -wraplength 4i +} +after 100 { + grab -global .dialog2 +} +set i [tk_dialog .dialog2 "Dialog with local grab" {This dialog box uses a global grab, so it prevents you from interacting with anything on your display until you invoke one of the buttons below. Global grabs are almost always a bad idea; don't use them unless you're truly desperate.} warning 0 OK Cancel {Show Code}] + +switch $i { + 0 {puts "You pressed OK"} + 1 {puts "You pressed Cancel"} + 2 {showCode .dialog2} +} diff --git a/tk4.2/library/demos/entry1.tcl b/tk4.2/library/demos/entry1.tcl new file mode 100644 index 0000000..5d49e9f --- /dev/null +++ b/tk4.2/library/demos/entry1.tcl @@ -0,0 +1,32 @@ +# entry1.tcl -- +# +# This demonstration script creates several entry widgets without +# scrollbars. +# +# SCCS: @(#) entry1.tcl 1.3 96/02/16 10:49:44 + +set w .entry1 +catch {destroy $w} +toplevel $w +wm title $w "Entry Demonstration (no scrollbars)" +wm iconname $w "entry1" +positionWindow $w + +label $w.msg -font $font -wraplength 5i -justify left -text "Three different entries are displayed below. You can add characters by pointing, clicking and typing. The normal Motif editing characters are supported, along with many Emacs bindings. For example, Backspace and Control-h delete the character to the left of the insertion cursor and Delete and Control-d delete the chararacter to the right of the insertion cursor. For entries that are too large to fit in the window all at once, you can scan through the entries by dragging with mouse button2 pressed." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +entry $w.e1 -relief sunken +entry $w.e2 -relief sunken +entry $w.e3 -relief sunken +pack $w.e1 $w.e2 $w.e3 -side top -pady 5 -padx 10 -fill x + +$w.e1 insert 0 "Initial value" +$w.e2 insert end "This entry contains a long value, much too long " +$w.e2 insert end "to fit in the window at one time, so long in fact " +$w.e2 insert end "that you'll have to scan or scroll to see the end." diff --git a/tk4.2/library/demos/entry2.tcl b/tk4.2/library/demos/entry2.tcl new file mode 100644 index 0000000..a6c5014 --- /dev/null +++ b/tk4.2/library/demos/entry2.tcl @@ -0,0 +1,44 @@ +# entry2.tcl -- +# +# This demonstration script is the same as the entry1.tcl script +# except that it creates scrollbars for the entries. +# +# SCCS: @(#) entry2.tcl 1.3 96/02/16 10:49:45 + +set w .entry2 +catch {destroy $w} +toplevel $w +wm title $w "Entry Demonstration (with scrollbars)" +wm iconname $w "entry2" +positionWindow $w + +label $w.msg -font $font -wraplength 5i -justify left -text "Three different entries are displayed below, with a scrollbar for each entry. You can add characters by pointing, clicking and typing. The normal Motif editing characters are supported, along with many Emacs bindings. For example, Backspace and Control-h delete the character to the left of the insertion cursor and Delete and Control-d delete the chararacter to the right of the insertion cursor. For entries that are too large to fit in the window all at once, you can scan through the entries with the scrollbars, or by dragging with mouse button2 pressed." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +frame $w.frame -borderwidth 10 +pack $w.frame -side top -fill x -expand 1 + +entry $w.frame.e1 -relief sunken -xscrollcommand "$w.frame.s1 set" +scrollbar $w.frame.s1 -relief sunken -orient horiz -command \ + "$w.frame.e1 xview" +frame $w.frame.spacer1 -width 20 -height 10 +entry $w.frame.e2 -relief sunken -xscrollcommand "$w.frame.s2 set" +scrollbar $w.frame.s2 -relief sunken -orient horiz -command \ + "$w.frame.e2 xview" +frame $w.frame.spacer2 -width 20 -height 10 +entry $w.frame.e3 -relief sunken -xscrollcommand "$w.frame.s3 set" +scrollbar $w.frame.s3 -relief sunken -orient horiz -command \ + "$w.frame.e3 xview" +pack $w.frame.e1 $w.frame.s1 $w.frame.spacer1 $w.frame.e2 $w.frame.s2 \ + $w.frame.spacer2 $w.frame.e3 $w.frame.s3 -side top -fill x + +$w.frame.e1 insert 0 "Initial value" +$w.frame.e2 insert end "This entry contains a long value, much too long " +$w.frame.e2 insert end "to fit in the window at one time, so long in fact " +$w.frame.e2 insert end "that you'll have to scan or scroll to see the end." diff --git a/tk4.2/library/demos/filebox.tcl b/tk4.2/library/demos/filebox.tcl new file mode 100644 index 0000000..548ad0c --- /dev/null +++ b/tk4.2/library/demos/filebox.tcl @@ -0,0 +1,66 @@ +# filebox.tcl -- +# +# This demonstration script prompts the user to select a file. +# +# SCCS: @(#) filebox.tcl 1.2 96/08/27 15:03:26 + +set w .filebox +catch {destroy $w} +toplevel $w +wm title $w "File Selection Dialogs" +wm iconname $w "filebox" +positionWindow $w + +label $w.msg -font $font -wraplength 4i -justify left -text "Enter a file name in the entry box or click on the \"Browse\" buttons to select a file name using the file selection dialog." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +foreach i {open save} { + set f [frame $w.$i] + label $f.lab -text "Select a file to $i: " -anchor e + entry $f.ent -width 20 + button $f.but -text "Browse ..." -command "fileDialog $w $f.ent $i" + pack $f.lab -side left + pack $f.ent -side left -expand yes -fill x + pack $f.but -side left + pack $f -fill x -padx 1c -pady 3 +} + +if ![string compare $tcl_platform(platform) unix] { + checkbutton $w.strict -text "Use Motif Style Dialog" \ + -variable tk_strictMotif -onvalue 1 -offvalue 0 + pack $w.strict -anchor c +} + +proc fileDialog {w ent operation} { + # Type names Extension(s) Mac File Type(s) + # + #--------------------------------------------------------- + set types { + {"Text files" {.txt .doc} } + {"Text files" {} TEXT} + {"Tcl Scripts" {.tcl} TEXT} + {"C Source Files" {.c .h} } + {"All Source Files" {.tcl .c .h} } + {"Image Files" {.gif} } + {"Image Files" {.jpeg .jpg} } + {"Image Files" "" {GIFF JPEG}} + {"All files" *} + } + if {$operation == "open"} { + set file [tk_getOpenFile -filetypes $types -parent $w] + } else { + set file [tk_getSaveFile -filetypes $types -parent $w \ + -initialfile Untitled -defaultextension .txt] + } + if [string compare $file ""] { + $ent delete 0 end + $ent insert 0 $file + $ent xview end + } +} diff --git a/tk3.6/library/demos/mkFloor.tcl b/tk4.2/library/demos/floor.tcl similarity index 92% rename from tk3.6/library/demos/mkFloor.tcl rename to tk4.2/library/demos/floor.tcl index f083ae3..672ab46 100644 --- a/tk3.6/library/demos/mkFloor.tcl +++ b/tk4.2/library/demos/floor.tcl @@ -1,86 +1,18 @@ -# mkFloor w +# floor.tcl -- # -# Create a top-level window containing a canvas that displays the +# This demonstration script creates a canvas widet that displays the # floorplan for DEC's Western Research Laboratory. # +# SCCS: @(#) floor.tcl 1.5 96/10/04 17:09:37 + +# floorDisplay -- +# Recreate the floorplan display in the canvas given by "w". The +# floor given by "active" is displayed on top with its office structure +# visible. +# # Arguments: -# w - Name to use for new top-level window. - -proc mkFloor {{w .cfloor}} { - global c tk_library currentRoom colors - catch {destroy $w} - toplevel $w -# dpos $w - wm title $w "Floorplan Canvas Demonstration" - wm iconname $w "Floorplan" - wm minsize $w 100 100 - set c $w.frame2.c - - message $w.msg -font *-Times-Medium-R-Normal-*-180-* -width 800 \ - -relief raised -bd 2 -text "This window contains a canvas widget showing the floorplan of Digital Equipment Corporation's Western Research Laboratory. It has three levels. At any given time one of the levels is active, meaning that you can see its room structure. To activate a level, click the left mouse button anywhere on it. As the mouse moves over the active level, the room under the mouse lights up and its room number appears in the \"Room:\" entry. You can also type a room number in the entry and the room will light up." - frame $w.frame2 -relief raised -bd 2 - button $w.ok -text "OK" -command "destroy $w" - pack $w.msg -side top -fill both - pack $w.frame2 -side top -fill both -expand yes - pack $w.ok -side bottom -pady 5 - - scrollbar $w.frame2.vscroll -relief sunken -command "$c yview" - scrollbar $w.frame2.hscroll -orient horiz -relief sunken -command "$c xview" - canvas $c -width 900 -height 500 -xscroll "$w.frame2.hscroll set" \ - -yscroll "$w.frame2.vscroll set" - pack $w.frame2.hscroll -side bottom -fill x - pack $w.frame2.vscroll -side right -fill y - pack $c -in $w.frame2 -expand yes -fill both - - # Create an entry for displaying and typing in current room. - - entry $c.entry -width 10 -relief sunken -bd 2 -textvariable currentRoom - - # Choose colors, then fill in the floorplan. - - if {[tk colormodel $c] == "color"} { - set colors(bg1) #c0a3db55dc28 - set colors(outline1) #70207f868000 - set colors(bg2) #aeb8c6eec7ad - set colors(outline2) #59b466056666 - set colors(bg3) #9cfab288b333 - set colors(outline3) #43474c834ccd - set colors(offices) Black - set colors(active) #dae0f278f332 - } else { - set colors(bg1) white - set colors(outline1) black - set colors(bg2) white - set colors(outline2) black - set colors(bg3) white - set colors(outline3) black - set colors(offices) Black - set colors(active) black - } - floorDisplay $c 3 - - # Set up event bindings for canvas: - - $c bind floor1 <1> "floorDisplay $c 1" - $c bind floor2 <1> "floorDisplay $c 2" - $c bind floor3 <1> "floorDisplay $c 3" - $c bind room \ - "set currentRoom \$floorLabels(\[$c find withtag current\]) - update idletasks" - $c bind room {set currentRoom ""} - bind $c <2> "$c scan mark %x %y" - bind $c "$c scan dragto %x %y" - bind $c "unset currentRoom" - bind $c "focus $c.entry" - set currentRoom "" - trace variable currentRoom w "roomChanged $c" -} - -set activeFloor "" - -# The following procedure recreates the floorplan display in the canvas -# given by "w". The floor given by "active" (1, 2, or 3) is displayed -# on top, with office structure visible. +# w - Name of the canvas window. +# active - Number of active floor (1, 2, or 3). proc floorDisplay {w active} { global floorLabels floorItems colors activeFloor @@ -129,8 +61,31 @@ proc floorDisplay {w active} { $w config -scrollregion [$w bbox all] } +# newRoom -- +# This procedure is invoked whenever the mouse enters a room +# in the floorplan. It changes tags so that the current room is +# highlighted. +# +# Arguments: +# w - The name of the canvas window. + +proc newRoom w { + global currentRoom floorLabels + + set id [$w find withtag current] + if {$id != ""} { + set currentRoom $floorLabels($id) + } + update idletasks +} + +# roomChanged -- # This procedure is invoked whenever the currentRoom variable changes. # It highlights the current room and unhighlights any previous room. +# +# Arguments: +# w - The canvas window displaying the floorplan. +# args - Not used. proc roomChanged {w args} { global currentRoom floorItems colors @@ -144,9 +99,15 @@ proc roomChanged {w args} { $w raise $new marker } -# The following procedures are invoked to instantiate various portions -# of the building floorplan. The bodies of these procedures were -# generated automatically from database files describing the building. +# bg1 -- +# This procedure represents part of the floorplan database. When +# invoked, it instantiates the background information for the first +# floor. +# +# Arguments: +# w - The canvas window. +# fill - Fill color to use for the floor's background. +# outline - Color to use for the floor's outline. proc bg1 {w fill outline} { $w create poly 347 80 349 82 351 84 353 85 363 92 375 99 386 104 \ @@ -263,6 +224,16 @@ proc bg1 {w fill outline} { $w create line 353 85 351 84 -fill $outline -tags {floor1 bg} } +# bg2 -- +# This procedure represents part of the floorplan database. When +# invoked, it instantiates the background information for the second +# floor. +# +# Arguments: +# w - The canvas window. +# fill - Fill color to use for the floor's background. +# outline - Color to use for the floor's outline. + proc bg2 {w fill outline} { $w create poly 559 129 484 129 484 162 398 162 398 129 315 129 \ 315 133 176 133 176 129 96 129 96 133 3 133 3 339 0 339 0 391 \ @@ -308,6 +279,16 @@ proc bg2 {w fill outline} { $w create line 96 133 96 129 -fill $outline -tags {floor2 bg} } +# bg3 -- +# This procedure represents part of the floorplan database. When +# invoked, it instantiates the background information for the third +# floor. +# +# Arguments: +# w - The canvas window. +# fill - Fill color to use for the floor's background. +# outline - Color to use for the floor's outline. + proc bg3 {w fill outline} { $w create poly 159 300 107 300 107 248 159 248 159 129 96 129 96 \ 133 21 133 21 331 0 331 0 391 60 391 60 370 159 370 159 300 \ @@ -337,6 +318,15 @@ proc bg3 {w fill outline} { -fill $outline -tags {floor3 bg} } +# fg1 -- +# This procedure represents part of the floorplan database. When +# invoked, it instantiates the foreground information for the first +# floor (office outlines and numbers). +# +# Arguments: +# w - The canvas window. +# color - Color to use for drawing foreground information. + proc fg1 {w color} { global floorLabels floorItems set i [$w create polygon 375 246 375 172 341 172 341 246 -fill {} -tags {floor1 room}] @@ -691,6 +681,15 @@ proc fg1 {w color} { $w create line 113 152 113 129 -fill $color -tags {floor1 wall} } +# fg2 -- +# This procedure represents part of the floorplan database. When +# invoked, it instantiates the foreground information for the second +# floor (office outlines and numbers). +# +# Arguments: +# w - The canvas window. +# color - Color to use for drawing foreground information. + proc fg2 {w color} { global floorLabels floorItems set i [$w create polygon 748 188 755 188 755 205 758 205 758 222 800 222 800 168 748 168 -fill {} -tags {floor2 room}] @@ -1052,6 +1051,15 @@ proc fg2 {w color} { $w create line 341 275 341 283 -fill $color -tags {floor2 wall} } +# fg3 -- +# This procedure represents part of the floorplan database. When +# invoked, it instantiates the foreground information for the third +# floor (office outlines and numbers). +# +# Arguments: +# w - The canvas window. +# color - Color to use for drawing foreground information. + proc fg3 {w color} { global floorLabels floorItems set i [$w create polygon 89 228 89 180 70 180 70 228 -fill {} -tags {floor3 room}] @@ -1274,3 +1282,85 @@ proc fg3 {w color} { $w create line 273 250 307 250 -fill $color -tags {floor3 wall} $w create line 258 250 243 250 -fill $color -tags {floor3 wall} } + +# Below is the "main program" that creates the floorplan demonstration. + +set w .floor +global c tk_library currentRoom colors activeFloor +catch {destroy $w} +toplevel $w +wm title $w "Floorplan Canvas Demonstration" +wm iconname $w "Floorplan" +wm geometry $w +20+20 +wm minsize $w 100 100 + +label $w.msg -font $font -wraplength 8i -justify left -text "This window contains a canvas widget showing the floorplan of Digital Equipment Corporation's Western Research Laboratory. It has three levels. At any given time one of the levels is active, meaning that you can see its room structure. To activate a level, click the left mouse button anywhere on it. As the mouse moves over the active level, the room under the mouse lights up and its room number appears in the \"Room:\" entry. You can also type a room number in the entry and the room will light up." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +set f [frame $w.frame] +pack $f -side top -fill both -expand yes +set h [scrollbar $f.hscroll -highlightthickness 0 -orient horizontal] +set v [scrollbar $f.vscroll -highlightthickness 0 -orient vertical] +set f1 [frame $f.f1 -bd 2 -relief sunken] +set c [canvas $f1.c -width 900 -height 500 -borderwidth 0 \ + -highlightthickness 0 -xscrollcommand "$h set" -yscrollcommand "$v set"] +pack $c -expand yes -fill both +grid $f1 -padx 1 -pady 1 \ + -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news +grid $v -padx 1 -pady 1 \ + -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news +grid $h -padx 1 -pady 1 \ + -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news +grid rowconfig $f 0 -weight 1 -minsize 0 +grid columnconfig $f 0 -weight 1 -minsize 0 +pack $f -expand yes -fill both -padx 1 -pady 1 + +$v config -command "$c yview" +$h config -command "$c xview" + +# Create an entry for displaying and typing in current room. + +entry $c.entry -width 10 -relief sunken -bd 2 -textvariable currentRoom + +# Choose colors, then fill in the floorplan. + +if {[winfo depth $c] > 1} { + set colors(bg1) #a9c1da + set colors(outline1) #77889a + set colors(bg2) #9ab0c6 + set colors(outline2) #687786 + set colors(bg3) #8ba0b3 + set colors(outline3) #596673 + set colors(offices) Black + set colors(active) #c4d1df +} else { + set colors(bg1) white + set colors(outline1) black + set colors(bg2) white + set colors(outline2) black + set colors(bg3) white + set colors(outline3) black + set colors(offices) Black + set colors(active) black +} +set activeFloor "" +floorDisplay $c 3 + +# Set up event bindings for canvas: + +$c bind floor1 <1> "floorDisplay $c 1" +$c bind floor2 <1> "floorDisplay $c 2" +$c bind floor3 <1> "floorDisplay $c 3" +$c bind room "newRoom $c" +$c bind room {set currentRoom ""} +bind $c <2> "$c scan mark %x %y" +bind $c "$c scan dragto %x %y" +bind $c "unset currentRoom" +set currentRoom "" +trace variable currentRoom w "roomChanged $c" diff --git a/tk4.2/library/demos/form.tcl b/tk4.2/library/demos/form.tcl new file mode 100644 index 0000000..3eef962 --- /dev/null +++ b/tk4.2/library/demos/form.tcl @@ -0,0 +1,36 @@ +# form.tcl -- +# +# This demonstration script creates a simple form with a bunch +# of entry widgets. +# +# SCCS: @(#) form.tcl 1.4 96/02/16 10:49:30 + +set w .form +catch {destroy $w} +toplevel $w +wm title $w "Form Demonstration" +wm iconname $w "form" +positionWindow $w + +label $w.msg -font $font -wraplength 4i -justify left -text "This window contains a simple form where you can type in the various entries and use tabs to move circularly between the entries." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +foreach i {f1 f2 f3 f4 f5} { + frame $w.$i -bd 2 + entry $w.$i.entry -relief sunken -width 40 + label $w.$i.label + pack $w.$i.entry -side right + pack $w.$i.label -side left +} +$w.f1.label config -text Name: +$w.f2.label config -text Address: +$w.f5.label config -text Phone: +pack $w.msg $w.f1 $w.f2 $w.f3 $w.f4 $w.f5 -side top -fill x +bind $w "destroy $w" +focus $w.f1.entry diff --git a/tk3.6/library/demos/hello b/tk4.2/library/demos/hello similarity index 74% rename from tk3.6/library/demos/hello rename to tk4.2/library/demos/hello index 1c93275..0fa5d05 100644 --- a/tk3.6/library/demos/hello +++ b/tk4.2/library/demos/hello @@ -1,6 +1,12 @@ -#!/usr/local/bin/wish -f +#!/bin/sh +# the next line restarts using wish \ +exec wish "$0" "$@" + +# hello -- # Simple Tk script to create a button that prints "Hello, world". # Click on the button to terminate the program. +# +# SCCS: @(#) hello 1.6 96/02/16 10:49:18 # # The first line below creates the button, and the second line # asks the packer to shrink-wrap the application's main window diff --git a/tk4.2/library/demos/hscale.tcl b/tk4.2/library/demos/hscale.tcl new file mode 100644 index 0000000..483a26f --- /dev/null +++ b/tk4.2/library/demos/hscale.tcl @@ -0,0 +1,43 @@ +# hscale.tcl -- +# +# This demonstration script shows an example with a horizontal scale. +# +# SCCS: @(#) hscale.tcl 1.3 96/02/16 10:49:47 + +set w .hscale +catch {destroy $w} +toplevel $w +wm title $w "Horizontal Scale Demonstration" +wm iconname $w "hscale" +positionWindow $w + +label $w.msg -font $font -wraplength 3.5i -justify left -text "An arrow and a horizontal scale are displayed below. If you click or drag mouse button 1 in the scale, you can change the length of the arrow." +pack $w.msg -side top -padx .5c + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +frame $w.frame -borderwidth 10 +pack $w.frame -side top -fill x + +canvas $w.frame.canvas -width 50 -height 50 -bd 0 -highlightthickness 0 +$w.frame.canvas create polygon 0 0 1 1 2 2 -fill DeepSkyBlue3 -tags poly +$w.frame.canvas create line 0 0 1 1 2 2 0 0 -fill black -tags line +scale $w.frame.scale -orient horizontal -length 284 -from 0 -to 250 \ + -command "setWidth $w.frame.canvas" -tickinterval 50 +pack $w.frame.canvas -side top -expand yes -anchor s -fill x -padx 15 +pack $w.frame.scale -side bottom -expand yes -anchor n +$w.frame.scale set 75 + +proc setWidth {w width} { + incr width 21 + set x2 [expr $width - 30] + if {$x2 < 21} { + set x2 21 + } + $w coords poly 20 15 20 35 $x2 35 $x2 45 $width 25 $x2 5 $x2 15 20 15 + $w coords line 20 15 20 35 $x2 35 $x2 45 $width 25 $x2 5 $x2 15 20 15 +} diff --git a/tk4.2/library/demos/icon.tcl b/tk4.2/library/demos/icon.tcl new file mode 100644 index 0000000..9cfc539 --- /dev/null +++ b/tk4.2/library/demos/icon.tcl @@ -0,0 +1,48 @@ +# icon.tcl -- +# +# This demonstration script creates a toplevel window containing +# buttons that display bitmaps instead of text. +# +# SCCS: @(#) icon.tcl 1.7 96/04/12 11:54:38 + +set w .icon +catch {destroy $w} +toplevel $w +wm title $w "Iconic Button Demonstration" +wm iconname $w "icon" +positionWindow $w + +label $w.msg -font $font -wraplength 5i -justify left -text "This window shows three ways of using bitmaps or images in radiobuttons and checkbuttons. On the left are two radiobuttons, each of which displays a bitmap and an indicator. In the middle is a checkbutton that displays a different image depending on whether it is selected or not. On the right is a checkbutton that displays a single bitmap but changes its background color to indicate whether or not it is selected." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +image create bitmap flagup \ + -file [file join $tk_library demos images flagup.bmp] \ + -maskfile [file join $tk_library demos images flagup.bmp] +image create bitmap flagdown \ + -file [file join $tk_library demos images flagdown.bmp] \ + -maskfile [file join $tk_library demos images flagdown.bmp] +frame $w.frame -borderwidth 10 +pack $w.frame -side top + +checkbutton $w.frame.b1 -image flagdown -selectimage flagup \ + -indicatoron 0 +$w.frame.b1 configure -selectcolor [$w.frame.b1 cget -background] +checkbutton $w.frame.b2 \ + -bitmap @[file join $tk_library demos images letters.bmp] \ + -indicatoron 0 -selectcolor SeaGreen1 +frame $w.frame.left +pack $w.frame.left $w.frame.b1 $w.frame.b2 -side left -expand yes -padx 5m + +radiobutton $w.frame.left.b3 \ + -bitmap @[file join $tk_library demos images letters.bmp] \ + -variable letters -value full +radiobutton $w.frame.left.b4 \ + -bitmap @[file join $tk_library demos images noletter.bmp] \ + -variable letters -value empty +pack $w.frame.left.b3 $w.frame.left.b4 -side top -expand yes diff --git a/tk4.2/library/demos/image1.tcl b/tk4.2/library/demos/image1.tcl new file mode 100644 index 0000000..55662e6 --- /dev/null +++ b/tk4.2/library/demos/image1.tcl @@ -0,0 +1,32 @@ +# image1.tcl -- +# +# This demonstration script displays two image widgets. +# +# SCCS: @(#) image1.tcl 1.5 96/08/20 15:50:44 + +set w .image1 +catch {destroy $w} +toplevel $w +wm title $w "Image Demonstration #1" +wm iconname $w "Image1" +positionWindow $w + +label $w.msg -font $font -wraplength 4i -justify left -text "This demonstration displays two images, each in a separate label widget." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +catch {image delete image1a} +image create photo image1a -file [file join $tk_library demos images earth.gif] +label $w.l1 -image image1a -bd 1 -relief sunken + +catch {image delete image1b} +image create photo image1b \ + -file [file join $tk_library demos images earthris.gif] +label $w.l2 -image image1b -bd 1 -relief sunken + +pack $w.l1 $w.l2 -side top -padx .5m -pady .5m diff --git a/tk4.2/library/demos/image2.tcl b/tk4.2/library/demos/image2.tcl new file mode 100644 index 0000000..58ac94c --- /dev/null +++ b/tk4.2/library/demos/image2.tcl @@ -0,0 +1,76 @@ +# image2.tcl -- +# +# This demonstration script creates a simple collection of widgets +# that allow you to select and view images in a Tk label. +# +# SCCS: @(#) image2.tcl 1.8 96/08/20 16:53:29 + +# loadDir -- +# This procedure reloads the directory listbox from the directory +# named in the demo's entry. +# +# Arguments: +# w - Name of the toplevel window of the demo. + +proc loadDir w { + global dirName + + $w.f.list delete 0 end + foreach i [lsort [glob [file join $dirName *]]] { + $w.f.list insert end [file tail $i] + } +} + +# loadImage -- +# Given the name of the toplevel window of the demo and the mouse +# position, extracts the directory entry under the mouse and loads +# that file into a photo image for display. +# +# Arguments: +# w - Name of the toplevel window of the demo. +# x, y- Mouse position within the listbox. + +proc loadImage {w x y} { + global dirName + + set file [file join $dirName [$w.f.list get @$x,$y]] + image2a configure -file $file +} + +set w .image2 +catch {destroy $w} +toplevel $w +wm title $w "Image Demonstration #2" +wm iconname $w "Image2" +positionWindow $w + +label $w.msg -font $font -wraplength 4i -justify left -text "This demonstration allows you to view images using a Tk \"photo\" image. First type a directory name in the listbox, then type Return to load the directory into the listbox. Then double-click on a file name in the listbox to see that image." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +label $w.dirLabel -text "Directory:" +set dirName [file join $tk_library demos images] +entry $w.dirName -width 30 -textvariable dirName +bind $w.dirName "loadDir $w" +frame $w.spacer1 -height 3m -width 20 +label $w.fileLabel -text "File:" +frame $w.f +pack $w.dirLabel $w.dirName $w.spacer1 $w.fileLabel $w.f -side top -anchor w + +listbox $w.f.list -width 20 -height 10 -yscrollcommand "$w.f.scroll set" +scrollbar $w.f.scroll -command "$w.f.list yview" +pack $w.f.list $w.f.scroll -side left -fill y -expand 1 +$w.f.list insert 0 earth.gif earthris.gif teapot.ppm +bind $w.f.list "loadImage $w %x %y" + +catch {image delete image2a} +image create photo image2a +frame $w.spacer2 -height 3m -width 20 +label $w.imageLabel -text "Image:" +label $w.image -image image2a +pack $w.spacer2 $w.imageLabel $w.image -side top -anchor w diff --git a/tk4.2/library/demos/images/earth.gif b/tk4.2/library/demos/images/earth.gif new file mode 100644 index 0000000..2c229eb Binary files /dev/null and b/tk4.2/library/demos/images/earth.gif differ diff --git a/tk4.2/library/demos/images/earthris.gif b/tk4.2/library/demos/images/earthris.gif new file mode 100644 index 0000000..c4ee473 Binary files /dev/null and b/tk4.2/library/demos/images/earthris.gif differ diff --git a/tk3.6/library/demos/bitmaps/face b/tk4.2/library/demos/images/face.bmp similarity index 99% rename from tk3.6/library/demos/bitmaps/face rename to tk4.2/library/demos/images/face.bmp index 8e09419..03d829f 100644 --- a/tk3.6/library/demos/bitmaps/face +++ b/tk4.2/library/demos/images/face.bmp @@ -1,5 +1,7 @@ #define face_width 108 #define face_height 144 +#define face_x_hot 48 +#define face_y_hot 80 static char face_bits[] = { 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x20, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x08, 0x09, diff --git a/tk3.6/library/demos/bitmaps/flagdown b/tk4.2/library/demos/images/flagdown.bmp similarity index 100% rename from tk3.6/library/demos/bitmaps/flagdown rename to tk4.2/library/demos/images/flagdown.bmp diff --git a/tk3.6/library/demos/bitmaps/flagup b/tk4.2/library/demos/images/flagup.bmp similarity index 100% rename from tk3.6/library/demos/bitmaps/flagup rename to tk4.2/library/demos/images/flagup.bmp diff --git a/tk3.6/library/demos/bitmaps/grey.25 b/tk4.2/library/demos/images/gray25.bmp similarity index 100% rename from tk3.6/library/demos/bitmaps/grey.25 rename to tk4.2/library/demos/images/gray25.bmp diff --git a/tk3.6/library/demos/bitmaps/letters b/tk4.2/library/demos/images/letters.bmp similarity index 100% rename from tk3.6/library/demos/bitmaps/letters rename to tk4.2/library/demos/images/letters.bmp diff --git a/tk3.6/library/demos/bitmaps/noletters b/tk4.2/library/demos/images/noletter.bmp similarity index 100% rename from tk3.6/library/demos/bitmaps/noletters rename to tk4.2/library/demos/images/noletter.bmp diff --git a/tk3.6/library/demos/bitmaps/pattern b/tk4.2/library/demos/images/pattern.bmp similarity index 100% rename from tk3.6/library/demos/bitmaps/pattern rename to tk4.2/library/demos/images/pattern.bmp diff --git a/tk4.2/library/demos/images/tcllogo.gif b/tk4.2/library/demos/images/tcllogo.gif new file mode 100644 index 0000000..4603d4f Binary files /dev/null and b/tk4.2/library/demos/images/tcllogo.gif differ diff --git a/tk4.2/library/demos/images/teapot.ppm b/tk4.2/library/demos/images/teapot.ppm new file mode 100644 index 0000000..b8ab85f --- /dev/null +++ b/tk4.2/library/demos/images/teapot.ppm @@ -0,0 +1,31 @@ +P6 +256 256 +255 +\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À[7 eOLjQLmSMoTMnSMlRMhPL_9 \À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀnSMtVMzYN~[N~[N\N\O€\O€]O€]O€]O€]O€\O€\O}[NyYNtVM\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀG-wXN}[N€]O„^O†_O†`O‡`Oˆ`Oˆ`OˆaO‰aO‰aO‰aO‰aO‰aO‰aOˆaOˆ`O†_Oƒ^O\N \À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀaMLyYN…_O‰aP‹bPcPŽcPŽdPŽdPdPdPdPdPdPdPdPeP‘eP’eP’eP‘ePdPcP…_OpUM\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀwXN…_OdP“fP•gQ–hQ˜hQ˜iQ™iQ™iQšiQšiQšjQ›jQ›jQœjQœjQœjQœjQœjQ›jQœjQ™iQ“fP‡`O\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀNCJiQL‹bP—hQkQ¡mR¤nR¥oR¥oR¥oR¥oR¥oR¥oR¦oR¦oR¦pR¨pS©qSªqS«rS¬rS«rS©qS¤oRœjQ€]O\KK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀfOLrUMcPŸlR©qS¯tS²uTµwT·xT¸xT¹yTºyT»zT»zU¼zU¼zU¼zU»zUºyT¸xT¶wT¯tS¡mR‰aOhPL\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\Àa0 cNLqUM€\O”fQ¦pS²wVºzV¿|VÂ}VÄVÆVÇ€VÉ‚WÌ…[Õeæ w÷³‹êª…Ĉg§qT“fQ{ZNYIK9\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀO1{G#‘JkRMqUMtVN–iS¨v\·€d¹bµzZ±vU°uT®sSªqS¤nRœjQ’eP„^OrUMHh>!T4\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀG-V5wE"~I#†M%U+¥e7²l:°g2®b*­a(­`(©^(¥])¡^-›]1ŠS,qC$`9 R3G-\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À@)J/i>!pA"tD"wF$yH&xH&tE$wE#yG%}M+ƒT4S5mE*Z7!K/B*;'\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À‰aO¦oR½{UÇ€VÏ…X<(F-a: e!j@#k@$h>"dµf-¨^(¡Z'šW&–T&œN>)F-J/b; g>#nD(jB&c y< u: r9 o7 l6 +j5 +h4 +g3 +5$D,K/b; h>"wM1tK.e="a<#cA,U8&E-<(9&.!a0 b1 c1     + ++3#@)46G<:HMCIXHK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀU*´vT¿~X¸{YÃk+›W&‰N$|> u: p8 k5 +f3 +a0 _/ ]. [- I¡\*ª_(‘LkRMmSMmSMnSMnSMD,R3W5mA"|O0|P1j?"c!a: X/K%&4$+2F=;HPEJL&\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀŸlR¶xT­sTµd)ŠO$w; m6 +g3 +a0 Z- \/ T*Q(ŠHµm8kRMmSMnTMoTMpTMpUM15G15G05G04G04GpUMpTM5^9 d!Y0W+]. s=‡M$dPŸlR\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀoTM¥oRdPvE"V+K%A 99†F¤['qUMtVM99H:9H:9H:9H:9H:9H:9H:9H:9H:9H99H99H99H99H99H99H:9H;:H>;HB=HPDJ\JKmSMwXN|ZN°y[ᦆ֘uº{W¹yU¿€]Á„b­tU£nR—hQˆaO{ZNvWNtVMvXNwXNyYNzYN{ZN|ZN}[N}[N~[N~[N~[N~[N~[N~[N~[N}[N}[N{ZNzYNxXN…L$f3 +I$L&P(U*\. €J#\O›jQ\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀžkR‰aOo9 L&C!:4f3 +X&pUMuWMwXNxXN<:H<:H<:H<:H<;H<;H<;H<;H=;H=;H=;H=;H>;H>;H?HG@ILBIREJ[JKcNLjQL§pR±uTºzUÃ~VÈWË‚XÖŽcäsÒŽe¼{V²vT¨pSžkR•gQŒbP†_O‚^O]O€\O€\O€\O€\O€]O]O]O]O]O]O]O]O]O]O]O€\O€\O~\N}[N|ZNxXN•T%H$G#K%Q(W+zG#nTM˜iQ\À\À\À\À\À\À\À\À\À\À\À\ÀdOLrUMuWNwXNyYN{ZN}[N{ZNwXNsVM \À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\Àˆ`OcPnA"M&@ 8F#m6 +›W&rVMvWNyYNzYN|ZN}[N}[N>HE?IG@IIAIKBIODJSFJWHK—hQŸlR§pR°b(¾i*Én+Ù|7Û|6Ïr,Íq+Êp-Ãl+»g)±b(®sS§pS lRšiQ•gQePcPŠaPˆaO‡`O‡`O†_O†_O…_O…_O…_O…_O…_O…_O…_O„_O„^O„^Oƒ^Oƒ^O‚]O]O€\O~[N{ZN•T%F#B!Y,L&U*~I#„^O†`O\À\À\À\ÀcNLrUMzYN\O„^Oˆ`OŠbPŒcPdPeP’fP“fP“fQ“fQ”fQ‘ePcP‰aP~[N\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À’fPsVM^/ C!7 ŽQ%tVMwXNzYN|ZN}[N\N\O€\O]O]O‚]O‚]OA=HB=HB=HB>HC>HC>ID?IE?IF@IG@IIAIKBIŒcPdP’eP–gQšiQŸlR£nR¤\'´d)¿i*Æm+Îs/Ïs/Êo+Én+Ål*¾i*ºg)³c(ª_(ªqS¦oR¡mRkQ™iQ•gQ“fP‘ePŽdPcPŒbP‹bPŠbPŠaP‰aP‰aO‰aOˆaOˆ`Oˆ`O‡`O‡`O‡`O†`O†_O…_O„^Oƒ^O‚]O\O}[N›QD"?D"K%_/ kRL’fPODJSFJ†_OŠbPŽcP‘eP“fQ–gQ™iQœjQžkR lR¡mR£nR¤nR¥oR¥oR¥oR¤nR¢mRŸlRšiQ‘eP…_O\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀB+‘ePI#L&90y< šPxXN{ZN}[N\N€\O]O‚]Oƒ^Oƒ^O„^O„_O…_O…_O†_O†`O‡`O‡`Oˆ`O‰aOŠaP‹bPŒbPcPŽdP‘eP“fP•gQ˜hQšiQžkR¢mR¡Z'«_(¶e)½h)Âk*Çn,Çn,Æm*Æl*Áj*ºf)¶e)²c(«_(¦]'§pR¤nR¡mRžkR›jQ™iQ–gQ”gQ“fP‘ePdPdPŽdPŽcPcPŒcPŒbP‹bP‹bP‹bPŠbPŠaP‰aP‰aO‰aOˆ`O‡`O†_O…_Oƒ^O]Oª_(@ B!I$B!N'w=‘eP`LKbNLeOLkR mR£nR¥oR§pSªqS¬rS®sS¯tS°tS°tS±uS±uS°tS¯tS­sSªrS§pS¢mRšjQŒbPjQL\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À‹bPpTME"5‡M$tVM{ZN}[N\O]O‚^Oƒ^O„_O…_O†_O†`O‡`Oˆ`Oˆ`O‰aO‰aPŠaPŠbP‹bPŒbPcPŽcPdPdP’eP“fP•gQ—hQ™iQ›jQkR lR¢mR¡Z'¬`(µd)ºg)ÇgÀj*Àj*¾i*¿i*»g)µd)²c(¯a(ª_(¤\'§pR¥oR¢nR mRžkRœjQšiQ˜iQ—hQ•gQ”gQ“fP’eP‘eP‘ePdPdPdPŽcPŽcPcPcPŒcPŒbP‹bP‹bPŠbPŠaP‰aOˆ`O†_O„^O\NœQ@ <G#_LKŽcPlSMnTMpUMsVM°tS²uT³vTµwT¶wT¶xT¶xT¶wTµwT´vT²uT¯tS¬sSªqS§pS¤oR¢nRžkR˜hQ‹bPeOL\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀwXN\NJ%01ŽJvWN}[N\O]Oƒ^O…_O†_O†`O‡`Oˆ`O‰aO‰aPŠaPŠbP‹bPŒbPŒbPcPŽcPŽdPdPdP‘eP’eP”fQ•gQ–gQ˜hQ™iQ›jQkQŸlR¡mRžY&¦]'­`(³c(·e)Àc¸\¸\¹\º]»]¶^®a(¬`(©^'£['¢['¥oR£nR¡mR lRžkRœkQ›jQšiQ˜iQ—hQ–gQ•gQ”gQ”fQ“fP’eP’eP‘eP‘ePdPdPdPdPŽdPŽcPcPcPŒbP‹bPŠaPˆaO†`O]O˜OG#7F#uWMƒ^OwXNxXNzYN{ZN|ZN¹yT¸yT·xT´wT±uT­sS¨pS¡mRœjQ•gQdPŒbP‰aP‰aPŒbPŽcP‘ePcP|ZN\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À[JKŠbP^/ 1 01|> wXN}[N]Oƒ^O…_O‡`O‡`OˆaO‰aPŠaP‹bP‹bPŒbPŒcPcPŽcPŽcPdPdPdP‘eP’eP“fP”fQ•gQ–gQ—hQ˜hQ™iQ›jQœkQžkRŸlR mRžY&¦]'­`(±b(·[ÇgÉiÉhÅfÂdÃe¿c«Uª_(§]'£[' Z'¤nR£nR¡mR mRŸlRžkRkQœjQšjQšiQ™iQ˜hQ—hQ–gQ•gQ•gQ”fQ”fQ“fP“fP’eP’eP‘eP‘ePePdPdPdPŽcPcPŒbPŠbPˆ`Oƒ^O‰D 4M&dPnSM|[N|[O|[OzZOxXNªrS¢nR˜hQŽcPƒ^OvXNiQL^KKRFJMCJJAIKBISFJ\JKnSMxYN†_O€\OaMK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀB!qUMŠaPC!/00a0 uWN}[N‚]O…_O†`Oˆ`O‰aPŠaP‹bPŒbPŒcPcPŽcPŽcPdPdPdP‘eP‘eP’eP“fP“fQ”fQ•gQ–gQ—hQ˜hQ™iQ™iQ›jQœjQkRžlRŸlRœX&¢['¨^'¬`(´ZÂdÄfÈiÆgÂd¿c¿c¼a¸_©T¥\'£[' Z'ŸY&£nR¢mR¡mR lRŸlRžkRkQœjQ›jQšjQšiQ™iQ˜hQ—hQ—hQ–hQ–gQ•gQ•gQ”gQ”fQ”fQ“fQ“fP’fP’eP‘eP‘ePdPdPŽcPŒbP‰aOƒ^Ox< :ŠaP]Oj8sVMmSMfOL^KKUGJIAIQEJ?IeZY638*  B\À\À\À\À\À,  4 .G1!\TU¡ƒrsVM{ZN`MK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À[JKyYNŒbP/0ˆN$]O…_Oˆ`O‹bPŒbPcPŽcPdPdPdP‘eP‘eP’eP’fP“fP“fQ”fQ”gQ•gQ–gQ–gQ—hQ—hQ˜hQ™iQ™iQšiQ›jQœjQœkQkRžkRŸlRœO¡Z'¥\'©^'­V¼a¾bÁeÆi!Ãf¾b»a¹`·_³]²\µZ¢[' Z'ŸY&œQ¡mR¡mR mR lRŸlRŸlRžkRkRkQœkQœjQ›jQ›jQšjQšiQšiQ™iQ™iQ˜iQ˜hQ˜hQ—hQ—hQ—hQ–hQ–gQ–gQ•gQ•gQ”fQ’fPdPcPšW&dPŠaPrUM + B\À\À\À\À\À\À\À\À\À\À%7!!C*F#P) {dYœze»p€\OgPL\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀSFJ`LKvWNŠaPm6 + X,uWM‚]O‡`OŠbPcPŽdPdPdP‘eP’eP’fP“fP“fQ”fQ”gQ•gQ•gQ–gQ–gQ—hQ—hQ˜hQ˜iQ™iQ™iQšiQ›jQ›jQœjQœkQkQžkRžlRŸlR¢Z'¤\'§]'·_¹`¼a½bÁeÅi"Áe¼aº`·_¶_²]²\±\«Y¡Z' Z'¡Z'¡mR¡mR mR lR lRŸlRŸlRžlRžkRžkRkRkQœkQœjQœjQ›jQ›jQ›jQšjQšiQšiQšiQ™iQ™iQ™iQ˜iQ˜hQ˜hQ—hQ–gQ•gQ“fQdP†_Oq8 –gQˆ`OuWM”T%\À\À\À\À\À\À\À\À\À\À B B!!T,c5ƒF‚T3È›~Æ“qƒ^OfOL\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀXHK_LKsVM‡`OcP ’S%]OŠbPcPdP‘eP’eP“fP“fQ”fQ”gQ•gQ•gQ–gQ–gQ—hQ—hQ—hQ˜hQ˜iQ™iQ™iQšiQšiQ›jQ›jQœjQœjQkQkRžkRžlRŸlRŸlR¥\'¦]'¨^'­Vº`»a½bÁfÄi"Àe»a¹`·_¶_³]±\±\¤R¢Z'¢Z'£['¡mR¡mR¡mR¡mR mR lR lRŸlRŸlRŸlRžlRžkRžkRkRkRkQkQœjQœjQœjQœjQœjQ›jQ›jQ›jQ›jQšjQšiQ™iQ™iQ˜hQ–gQ‘eP§Sq8 ‰aO•gQ‡`OtVMœX&\À\À\À\À\À\À\À\À\À\À B B B l@!{A…L$›Y'½†a“fPˆaO]KK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀODJ[JKaMKqUM\OcPƒ^OvE"‚]OŠaPdP‘eP“fP”fQ•gQ•gQ–gQ–hQ—hQ—hQ˜hQ˜hQ˜iQ™iQ™iQ™iQšiQšjQ›jQ›jQœjQœjQœkQkQkRžkRžkRŸlRŸlRŸlR lR©^'©^'ª_(®W»a¼a¾cÂg Äi"¿e»a¹`·_¶_³^±\±\¤R£['£['§]'¢mR¢mR¡mR¡mR¡mR¡mR mR lR lR lR lRŸlRŸlRŸlRŸlRžlRžlRžkRžkRžkRžkRkRkRkRkRkQkQkQœjQœjQšiQ˜hQ’ePšW&M&oTMšiQ‘eP…_OtVMmSMdOL\À\À\À\À\À\À\À\À\À B B B ‘J Z'ª_(œkQ™iQ‡`OSFJ\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀTFJ\JKcNLlRMzYN‡`O’ePzZN \Nˆ`OdP“fQ•gQ–gQ—hQ˜hQ˜hQ™iQ™iQ™iQšiQšiQšiQ›jQ›jQ›jQœjQœjQœjQœkQkQkRžkRžkRžlRŸlRŸlRŸlR lR lR mR®a(­`(¬`(¶[½a½b¿dÃh!Äi"¿d»a¹`¸_¶_µ^²]³]¦S¤\'§]'«_(¢nR¢mR¢mR¢mR¢mR¢mR¢mR¡mR¡mR¡mR¡mR¡mR mR mR mR mR lR lR lR lR lR lR lR lR lRŸlRŸlR lRŸlRžkRœkQ™iQePt: kQ˜hQcP€]OtVMlSMa2 \À\À\À\À\À\À\À\À\À B B +$5 ¬`(¶e)£nRœjQƒ^OJAI\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀXIK^KKdNLhPLuWM‚]OŒbP”fQeP m6 +†`OŽcP“fQ—hQ˜hQ™iQšiQšjQ›jQ›jQ›jQœjQœjQœjQœkQkQkQkRžkRžkRžkRžlRŸlRŸlRŸlR lR lR lR¡mR¡mR¡mR¡mRºg)³c(²c(±b(­V¿cÂeÅi!Åi!Àd¼bº`¹`·_·_¶^¢Q§]'ª_(­`(¹f)£nR£nR£nR£nR£nR£nR£nR¢nR¢nR¢nR¢nR¢nR¢nR¢mR¢mR¢mR¢mR¢mR¢mR¢mR¢mR¢mR¢nR¢mR¢mR£nR¢mR¢mR¡mR mRkR—hQˆGa0 ŠbP mRœjQ“fQ‰aP}[NrUMmSM…L$\À\À\À\À\À\À\À\À B B #C, 8&H.Z7 §pR›jQ{ZN\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀQEJ[JK`LKdNLhQLqUM{ZN…_OŽcP–gQ—hQ +‹bP‘eP–hQšiQ›jQœjQkQkQkRžkRžkRžlRžlRŸlRŸlRŸlRŸlRŸlR lR lR lR mR¡mR¡mR¡mR¡mR¡mR¢mR¢mR¢mR¢nR£nRÀj*ºg)·e)¶d)Âd°XÅgÅhÂe¿c½b½b¾bªU­`(®a(¯a(³c(¾i*¤oR¤oR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤oR¤oR¥oR¥oR¥oR¥oR¥oR¥oR¦oR¦oR¥oR¥oR¤nR¡mR›jQŽQ%Z- œjQ£nRŸlR—hQŽdP…_OuWMpTMnSMkRLa: \À\À\À\À\À\À\À B B&D2 @*S6#G@IPDJ˜hQmSM\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀVGJ]KKbMLeOLiQLlRMvWN\OˆaO‘eP—hQœjQ•gQoTM•gQ™iQkQŸlRŸlR lR mR¡mR¡mR¡mR¡mR¡mR¡mR¡mR¢mR¢mR¢mR¢mR¢mR¢mR¢nR£nR£nR£nR£nR£nR¤nR¤nR¤nR¤nR¤nR¤nRÆl*Ãl+¾j+¹g)¸f)¶e)µd)¶e)¶e)·e)·e)¸f)¾i*Ìs0Ðs.¦oR¦oR¦oR¦oR¦oR¦oR¦oR¦oR¦oR¦oR¦oR¦oR¦oR¦oR¦oR¦oR¦pR§pR§pR§pR§pR§pS§pS¨pS¨qS©qS©qS©qS¨pS©qS§pS¤nRŸlR‘I˜hQ§pR¥oR¡mRšiQ’ePŠaP€\OsVMpTMnTMlRM–X)\À\À\À\À\À\À\À B%C)D$;J/[8"LBITGJYIKWHK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀNCJYIK_LKcNLgPLjQLlRMpUMzYNƒ^O‹bP‘eP˜hQkQŸlR”fQ- —hQ›jQŸlR¢mR£nR£nR£nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤oR¤oR¥oR¥oR¥oR¥oR¥oR¥oR¥oR¥oR¥oR¥oR¥oR¦oR¦oR¦oR¦oR¦oR¦pR¦pR§pRàpßy-Ûw-Ûw-Þy.â{-ãu§pS§pS§pS§pS§pS¨pS¨pS¨pS¨pS¨pS¨pS¨pS¨pS¨pS¨pS¨qS©qS©qS©qS©qS©qS©qS©qSªqSªrS«rS«rS¬rS¬rS¬rS¬rS¬sS«rSªqS¦oRšiQ™iQ©qSªqS§pR¡mRœjQ•gQcP„_O{ZNtVMpUMoTMmSMjQL_9 \À\À\À\À\À B "C(D#*A$[<)dI\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀSFJ[JKaMKeOLhPLkRLmSMoTMuWM}[N…_O‹bP’eP˜hQžkR¢mR£nRžkR!-EkR¡mR¤nR¥oR¦pR§pR§pS§pS§pS§pS§pS§pS§pS§pR§pS§pS§pS§pS¨pS¨pS¨pS¨pS¨pS¨pS¨pS¨pS¨pS¨pS¨pS¨pS¨pS¨pS¨qS¨qS¨qS©qS©qS©qS©qS©qS©qS©qS©qS©qS©qS©qSªqSªqSªqSªqSªrS«rS«rS«rS«rS«rS«rS¬rS¬rS¬rS¬sS­sS®sS®sS¯tS¯tS¯tS¯tS°tS°uS°tS®sS«rS£nR¦oR®sS­sS«rS§pR¢mRœjQ–gQdPˆaO\OyYNuWMqUMoTMnSMkRLo8 \À\À\À\À\À B'D+E$(1 J/jH1NCJUGJYIKUGJ\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀXHK]KKbNLfOLiQLkRMmSMoTMqUMxXN\N†_OŒbP’fP˜hQkQ¡mR¥oR§pS¦pR˜hQ¢mR¥oR¨pSªqS«rS«rS«rS«rS«rS«rS«rS«rS«rS«rS«rSªrSªrSªrS«rS«rS«rS«rS«rS«rS«rS«rS«rS«rS«rS«rS«rS«rS«rS«rS¬rS¬rS¬rS¬rS¬rS¬rS¬rS¬sS¬sS­sS­sS­sS­sS­sS­sS®sS®sS®sS®sS®tS¯tS°tS°uS±uS±uT±uT²uT²uT²uT´vTµwT´vT³vT²uT¯tS¢mR¯tS±uT±uS®tS«rS§pR¢mRkQ—hQ‘ePŠaPƒ^O\N{ZNvXNqUMpTMnSMlRMP%\À\À\À\À B#C*E$.E- .!G$Y:%d<"SFJYIKZIKNCJ\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀPDJZIK_LKdNLgPLjQLlRMnSMpTMqUMuWMyYN€\O†`OcP’fP—hQœjQ¡mR¥oR¨qS«rS«rSªrS mR«rS­sS¯tS°tS°tS°tS¯tS¯tS¯tS¯tS¯tS¯tS¯tS¯tS¯tS¯tS®tS®sS®sS®sS®sS®sS®sS®sS®sS®sS®tS®tS®tS¯tS¯tS¯tS¯tS¯tS¯tS¯tS¯tS¯tS¯tS°tS°tS°tS±uS±uS±uT²uT²vT³vT³vT´vT´vT´wTµwTµwTµwT·xT·xT¸xT¸yT¸yU·xU¥\'©qS³vTµwTµwT´vT±uT®tTªrS¦oR¡mRkQ˜hQ’eP‹bP‡`Oƒ^O€\O|ZNxXNtVMpTMoTMmSMjQLh7\À\À\À B(D"-E*1F, 4#K)pL5PEJWHK[JKXHK:9H\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀUGJ\JKaMLeOLhPLkRLmSMoTMpUMrVMvWNyYN|ZN]O‡`OŒcP‘eP—hQ›jQ lR¤nR§pSªqS­sS¯tS°uS¯tS­sS mR^/ ²vT³vT´vT´wTµwT´wT´vT³vT´vT´vT´vT³vT³vT³vT³vT³vT³vT³vT³vT³vT³vT³vT³vT³vT³vT³vT³vT³vT´vT´vT´vT´vT´wTµwTµwTµwTµwT¶wT¶wT¶xT·xT·xT·xT¸xT¸xT¸xT¹yTºyT»zU¼zU½{U½{V½|V•gQ¬rSµwT¸xT¹yU¹yU¹zV·yVµxV±vU­tT©qS¥oS mRœjQ—hQ’ePcPŠbP‡`O„_O]O}[NyYNuWMpUMoTMmSMkRL}H#\À\À &D -E(1F/!2#8 W7"iA&UGJ[JK\JKREJ\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀMCIXIK^KKcNLfOLiQLkRMmSMoTMqUMsVMwXNzYN}[N€\Oƒ^O‡`OŒbP‘eP–gQšjQžkR¢mR¥oR©qS¬rS¯tS±uS³vT´vTµwT´wT²uT­sS lR«_(¹yT¹yTºyTºyTºyTºyTºyT¹yT¹yT¸yT¸xT¸xT¸xT¸xT¸xT¸xT¸yT¸yT¸yT¸yT¹yT¹yT¹yT¹yT¹yT¹yT¹yTºyTºyTºyTºyTºzT»zT¼zU¼{U½{U¾{U¾|U¿|UÀ}VÁ~VÂWÀY™iQ«rSµwT¹yT¼zU½|V¿}XÁ€ZÂ]Á]¾€]»~[¶zY±wW¬tU¨qS¤nSŸlR›jQ–gQ“fPePŽcP‹bPˆ`O…_O‚]O~\NzZNvXNqUMoTMnSMlRMiQLg=!\À +!C+E'0F.4F7%8%U/lG.SFJZIK]KKZIKB=H\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀREJZJK`LKdNLgPLjQLlRMnSMpTMqUMtWMxXN{ZN~[N]O„^O†`O‰aO‹bPdP•gQ™iQœkQ lR¤nR§pSªrS­sS¯tT²uT´vT¶wT·xT¹yT¹yTºyTºyT¹yT¶xT´vT¬rS¢nR—hQ¿|U¿|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ}UÀ}UÁ}UÁ}UÁ}UÁ}UÂ}UÂ~UÃ~UÃ~VÃ~VÄVÅ€WÆX®a(ŸlRªrS´vT¸yT¼zU¾|UÁ~VÃXÆ‚[Ɇ_΋dÓ‘jÔ“mÔ“nБlÊŒhĆd½_¶{[°vWªsU¦pS¢nRžkRšiQ˜hQ•gQ“fQ‘ePdPŒbP‰aO†_Oƒ^O€\O|ZNxXNsVMpTMnTMmSMjQL€C B)D&/F-3F47G6%>" Y7 kA$YIK]KK^KKSFJ\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀVGJ\KKbMLeOLhPLkRLmSMnTMpTMrUMuWNyYN|ZN\N‚]O„_O‡`OŠaPŒbPŽcPeP“fP—hQ›jQžlR¢nR¥oS©qT¬sT¯uU²vU´wV¶xV¸yV¹yUºzU»zU¼{U½{U¾{U¾|U¿|U¿|U¿|U¿|U¾{U½{U¼{U¼zU»zTºyT¹yT¸xTµwT³vT´vT´vT´vT´wT´wTµwT·xT¹yTºzT¼zU½{U¾{U¿|UÀ|UÂ}UÄVÅ€WÇ‚YÉ„\͈_ÑŒdÙ”láuç£|쩂ſt명æ¦ÞŸ{Õ—sËŽl†d¹^³yZ­uW¨qU¤oSŸlRžkRœjQšiQ˜hQ–gQ”fQ‘ePdPcPŠaP‡`O„^O]O}[NyYNuWMpTMoTMmSMkRLgPL&D#.E,3F46G;'<(D"iB(VGJ]KK`LK[JKB>H\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀNCJYIK^LKcNLfOLiQLkRMmSMoTMqUMsVMvXNzYN}[N€\O‚^O…_Oˆ`OŠaPŒcPdP‘eP“fQ•gQ—hQ™iQkR mS¤oT¨rU¬tW°wY´zZ¸}\»]¾€^À^Á‚^‚^Â\Á€ZÁYÁXÁ~WÁ~WÂ~VÂ~VÂ~VÃ~VÃ~UÃ~UÄ~UÄ~UÄUÄUÅVÅVÅVÅVÆVÆ€VÆ€VÇ€WÇWÈ‚XɃZË…[͇^ЊaÓdØ’iÜ—nâtè£zî©ó¯‡ø´û¸‘üº“û¹“÷¶ñ±Œé©…à¡~Ö˜vËmÇf»€`´z[®vX©rU¥pT£oS¢nS lRžkRœkRšjQ˜iQ–hQ”fQ’ePdPcP‹bPˆ`O…_O‚]O~[NzYNvWNpTMoTMnSMkRMhQLo7 ,2F36G99HC+@ ]8 nA"\JK`ML_LKSFJ\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀSFJ[JK`LKdNLgPLjQLlRMnSMpTMqUMtVMwXNzZN}[N€]Oƒ^O†_OˆaO‹bPcPdP‘eP“fQ•gQ—hQ™iQ›jRžlR mS£oU§rW¬vZ²{]¹€a¿…fÅŠjËnГqÓ•sÕ–sÕ–rÕ–qÕ”oÓ’mÑjÏgÍŠcˈaɆ^È„\Ç‚[ÆYÅ€XÅ€WÅWÅWÅVÅVÅWÅ€WÆ€WÇXÈ‚YɃ[Ê…\͇_ÏŠaÒeÕ‘hÙ•mÝ™qávä¡zç¤}꧀멃몄騃奀ߠ|Ù›wÓ•rÌmƉh¿„c¸~^²yZ®vX¬tWªsV¨qU¦pT¤oS¢nS mRžlRœkR›jQ™iQ—hQ•gQ“fPePŽcP‹bPˆaO…_O‚^O\N{ZNwXNsVMoTMnSMlRMiQL~I#26G99G?IQ2P+XHK_LLfQOcNLXIK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À©qSºyTÃ~VΈ`遲ޜv¾€]ªqS–LŽG|> g3 +S)?*%.—hQ—hQ‘eP‡`OuWM\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀSFJ[JK`LKdNLgPLjQLlRMnSMoTMqUMsVMwXNzYN}[N€\O‚^O…_O‡`OŠaPŒbPŽdP‘eP“fP•gQ—hQ˜iQšjRœkRŸlS¡nT¤pV§sX«vZ°z^¶b¼…gËmÊ’sјzØŸ€Þ¤…ã©Šè­ê¯ë°ê¯Žè¬‹å¨‡à¤‚Ûž|Ö™wÑ“qÌŽlljgÃ…bÀ‚_½\»}Zº{X¹zW¸yV·yU·xU·xU·xT·xT·xU·xU·xU·yV·yV·yW¸zW¸{X¹{Y¹|Zº}[º}[º}\º~\¹~]¹~]¸}]·|\µ{\´z[²yZ°wY®vX¬tWªsV¨rU¦pT¤oS¢nS¡mRŸlRkRœjQšiQ˜hQ–gQ”fQ’ePdPcPŠbP‡`O…_O‚]O~[NzZNvWNrUMoTMmSMlRMiQLeOLJAIJ(h>!]KKfQOgQN_LKD>I\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À™iQ°tS¸yT¼{UÂYÎŒeï­ˆô´Õ—u¶|\ Z'™LˆD |> ’eP¦oR¨qS¦oR¡mRšjQ‘eP„^OhPL\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀWHJ\KKaMLeOLhPLjQLlRMnSMpTMqUMtVMwXNzZN}[N€]Oƒ^O†_Oˆ`OŠbPcPdP‘eP“fQ•gQ—hQ™iQ›jRkRŸmS¢nT¤qV¨sX¬w[±{_¶€c½†hÄŒnË’tÒ™zØŸ€Þ¥…㩉ç­ê¯Žê¯Žê®ç«Šä§†ß£Ûž|Õ˜vГpËŽkljfÃ…bÀ‚_½\»}Yº{X¸zW¸yV·xU·xU·xT¶xT¶xT¶xU¶xU·xU·xU·yV·yV·zW¸zX¸{Y¹|Y¹|Z¹}[¹}[¹}\¹}\¸}\·}\¶|\µ{[³zZ²yZ°wY®vX¬tWªsV¨rU¦pT¤oS£nS¡mRŸlRžkRœjQšiQ˜hQ–gQ”fQ’ePdPŽcP‹bPˆ`O…_O‚^O\N{ZNwXNsVMoTMnSMlRMiQLfOLJ(V.]KKePNkUQcNLQEJ\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À‚]O¡mR©qS¬rS°tS³vTµwT·xUº{WĆbÒ“qךxÊo +K«rS´vT¶wT´vT²uT®sSªqS¤nRkQ•gQˆ`OuWNY,\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀNCJYIK^KKbNLfOLhQLkRLmSMoTMpUMrUMuWMxXN{ZN~[N]O„^O†_O‰aO‹bPcPdP‘eP“fQ•gQ—hQ™iQ›jRkRŸmS¢oT¥qV¨tX­w[±|_·d½†iÄŒnË“tÒ™zØŸ€Þ¥…㩉笌鮎ꮎ魌檉㧅ߢ€Ú{Õ—uÏ’pËjƈfÂ…b¿^½\»|Y¹{X¸zV·yV·xU·xU¶xT¶xT¶xT¶xU¶xU¶xU¶xU·yV·yV·yW¸zW¸{X¸{Y¸|Z¹|Z¹|[¹}[¸}\¸}\·|\¶|[µ{[³zZ±xY°wX®vX¬tWªsV¨rU¦pT¥oS£nS¡mRŸlRžkRœjQšjQ˜iQ—hQ”gQ’fPdPŽcP‹bP‰aO†_Oƒ^O€\O|ZNxXNtVMoTMnSMlRMjQLgPLzG#\JKcOMoXUgPMZIK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À’fP”gQ•gQ—hQ™iQkQ lR¤nR§pRªqS¬sS¯tS:"r<zYN­sS¹yT¾|UÁ~WÆ„^ËŠeË‹gƈe¾‚aµz[­tV¦pS¢mRkQ–gQŠbPzYNkRL\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀRFJZJK`LKcNLfPLiQLkRMmSMoTMqUMrVMvWNyYN|ZN\N]O„^O‡`O‰aO‹bPcPdP’eP”fQ–gQ—hQ™iQ›jRlR mS¢oU¥qV©tY­x\²|`¸d¾‡iÅoË“uÒ™{ÙŸ€Þ¥…㩉笌é®é®è¬‹å©ˆâ¦„Þ¡ÙœzÔ—tÏ‘oÊŒjƈe„a¿^½~[»|Y¹{X¸zV·yV·xU¶xU¶xT¶xT¶xT¶xT¶xU¶xU¶xU¶xV·yV·yW·zW·zX¸{Y¸{Y¸|Z¸|Z¸|[¸|[·|[·|[¶{[´z[³yZ±xY°wX®vW¬tWªsV¨rU¦pT¥oS£nS¡mRŸlRžkRœkRšjQ™iQ—hQ•gQ“fP‘ePŽdPŒbP‰aP†`Oƒ^O€]O}[NyYNuWNqUMnSMlSMkRLhPLcNLbNLpYVlUP`LK>;H\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À›jQ‡`O{ZN©^'¨^'­`(·e)½h)Ãk*Êo+±b(£nRºyTÃ~UÇXÒdãŸwò°‰ñ°‹è©…ÝŸ}Ô˜vÈm¾„eµ}_®x[°y\®x[«tW§qT¡mRœjQ–gQ‹bP}[NlRM\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀVGJ\JKaMKdNLgPLjQLlRMnSMpTMqUMsVMvXNzYN|[N\O‚]O…_O‡`O‰aPŒbPŽcPdP’eP”fQ–gQ˜hQšiQœjRžlS mS£oU¦rW©uY®x\³|`¸d¾‡jÅoÌ“uÒš{Ù €Þ¥…㩉欋è­è­Œç«Šå©‡á¥ƒÝ ~Ø›yÓ–tΑoÊŒjňe„a¿^¼~[º|Y¹{W¸zV·yV·xU¶xU¶xT¶xT¶xT¶xT¶xU¶xU¶xU¶xU¶xV·yV·yW·zX·zX¸{Y¸{Z¸{Z·|Z·|[·|[¶{[µ{[´zZ³yZ±xY¯wX®uW¬tVªsV¨rU¦pT¥oS£nS¡mR lRžkRœkR›jQ™iQ—hQ•gQ“fQ‘ePdPŒcPŠaP‡`O„^O]O~[NzYNvWNrUMnSMmSMkRLiQLeOLoXUu]XdOLKBI\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À:9H\N–hQ¸}\¯uU­sT¯tT¯tS¨qS¤nR£nR¢nRŸlR›jQšiQ˜hQ—hQ–gQ”fQ’eP‘eP—hQœkR mS¥pUªtX«uY¨sW¦qU mS›jQ•gQƒB’S%jQL\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀLBIXHK^KKbMLeOLhPLjRLlSMnSMpTMqUMtVMwXNzYN}[N€\O‚^O…_O‡`OŠaPŒbPŽcPeP’fP”fQ–gQ˜hQšiRœkRžlS nT£pU¦rWªuY®y]³}`¹‚e¿ˆjÅŽpÌ”vÓš{Ù Þ¤…⨉櫋笌笋櫊䨆ंܟ~ךxÒ•sÎnÉŒiŇeÁ„a¾€^¼~[º|Y¹{W¸yV·yV·xU¶xU¶xT¶wT¶wT¶wT¶xT¶xU¶xU¶xU¶xV¶yV¶yW·zW·zX·zY·{Y·{Z·{Z·{Z¶{Z¶{ZµzZ³yZ²yY±xY¯vX­uW¬tVªsU¨rU¦pT¥oS£nS¡mR lRžlRkR›jQ™iQ—hQ•gQ“fQ‘ePdPcPŠaP‡`O…_O‚]O\N{ZNwXNsVMnSMmSMkRMiQLfOL_LKhQMUGJ\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À (6BFP>=DKHMqjk€trwf`~kc„ndŠqesete¯Ž{w`¡v[\N†_OcP“fP˜iQœjRŸlS£oT¦qV¥qV£oTžlR™iQº^‡`OQ%hPL\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀQEJZIK_LKcNLfOLiQLkRLmSMoTMpUMrUMuWMxXN{ZN~[N€]Oƒ^O…_Oˆ`OŠaPŒcPŽdP‘eP“fP”gQ–hQ˜iQšjRœkRžlS¡nT£pU¦rWªuZ®y]³}a¹‚e¿ˆkÆŽpÌ”vÓš{ÙŸ€Þ¤…⨈媊櫋櫊婈⦅ߣ۞}ÖšxÑ•rÍmÈ‹ićdÁƒa¾€]¼~[º|Y¹zW¸yV·yU¶xU¶xU¶wT¶wT¶wT¶wT¶wT¶xU¶xU¶xU¶xU¶xV¶yV¶yW¶zX·zX·zY¶zY¶{Y¶{Z¶{ZµzZ´zZ³yY²xY°wX¯vX­uW«tVªsU¨rU¦pT¥oS£nS¡mS mRžlRkR›jQ™iQ˜hQ–gQ”fQ‘ePdPcP‹bPˆ`O…_O‚]O\O|ZNxXNtVMoTMmSMlRMjQLgPLbML[JK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À%5 (6$/79CEEKjgkrc_›…{‘uf±{Ÿw_ºq]Oˆ`OŽcP”fQ˜hQ›jRžlR¡nT¢oT¡nTkR˜hQŽdP¦]'ŽQ%\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀUGJ[JK`MKdNLgPLiQLkRMmSMoTMqUMrUMuWNxXN{ZN~[N]Oƒ^O†_Oˆ`OŠbPcPdP£['µd)•gQ—hQ˜iQšjRœkRžlS¡nT£pU§rWªvZ¯y]´~aºƒfÀˆkÆŽpÌ”vÓš{ØŸ€Ý¤„ᧇ䩉媊媉䨇᥄ޡ€Ú|Õ˜wДrÌmÈŠhĆdÀƒ`¾€]»}[º|Y¸zW·yV·xU¶xU¶xU¶wTµwTµwTµwTµwTµwUµwUµxUµxUµxV¶xV¶yW¶yW¶yX¶zX¶zY¶zYµzYµzY´zY´yY²yY±xY°wX®vW­uW«tVªsU¨qU¦pT¥oS£nS¢mS mRžlRkR›jQ™iQ˜hQ–gQ”fQ’ePdPcP‹bPˆaO†_Oƒ^O€\O|[NxYNtWMpUMmSMlRMjQLgPLcNLA;=\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À#*6+.8;:AHEJmgjd\]‡pe«}œxc w^»pƒ^OŠaP‘eP–gQšiQžlR mS¢nT mS›jR•gQ»h*œX&ˆM$\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀC+WHJ]KKaMLdOLgPLjQLlRMnSMoTMqUMrVMvWNyYN|ZN\N]O„^O†_OˆaO‹bPcPžY&«_(³c(•gQ—hQ™iQšjRœkRŸlS¡nT¤pV§sX«vZ¯z^´~bºƒfÀ‰kÆŽpÌ”vÒš{ØŸ€Ý£„ই㩉䩉䩈⧆ःܠØœ{Ô—vÏ“qËŽlljgÆcÀ‚`½]»}Z¹{Y¸zW·yV¶xU¶xU¶wUµwTµwTµwTµwTµwTµwTµwUµwUµxUµxVµxVµxVµyWµyWµyXµyXµyYµzY´yY´yY³yY²xY±wX°wX®vW­uV«tVªrU¨qU¦pT¥oS£nS¢mS mRžlRkR›jQ™iQ˜hQ–gQ”fQ’ePdPŽcP‹bP‰aO†_Oƒ^O€\O}[NyYNuWNqUMmSMlRMjQLhPLdNL\1\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À+.775;ICFphhŠztŠre¯}Ÿya¢vZ]OŠaP‘eP–gQšiQkRŸlS¡nTžlS™iQÌq.¯b*“S%zG#\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀMCJXHK^KKbMLeOLhPLjRLlSMnSMpTMqUMsVMvWNyYN|ZN\N‚]O„^O†`O‰aO‹bP—U&¥\'¯a(»g)Ìr/—hQ™iQ›jRkRŸmS¡nT¤pV§sX«v[¯z^´~bºƒfÀ‰kÆŽpÌ”vÒ™{מÜ£ƒà¦†â¨ˆã¨ˆã¨‡á¦…Þ£‚ÛŸ~×›yÓ–uÎ’pÊkƉgÂ…c¿‚_½]»}Z¹{X¸zW·yV¶xU¶xUµwTµwTµwTµwTµwTµwTµwTµwUµwUµwUµxUµxVµxVµxWµyWµyWµyXµyX´yX´yY³yY³xX²xX°wX¯vW®uW¬tV«sV©rU¨qT¦pT¥oS£nS¡mR mRžlRkR›jQšiQ˜hQ–gQ”fQ’ePdPŽcPŒbP‰aO†`Oƒ^O€]O}[NzYNvWNrUMmSMlRMjQLhQLeOL_LK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À,)/ZTVXON„uq‡od®}Ÿyb»s]OŠaPeP•gQšiQkRžlRŸlSœkR–hQ»g*¤\(ŽQ%`LK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À B B_LKcNLfOLiQLkRLmSMoTMpTMrUMtVMwXNzYN}[N\O‚]O„_O‡`O‰aOQ%ŸY&©^'±b(¾i*Õ{8—hQ™iQ›jRkRŸmS¡nT¤qV§sX«v[°z^µ~bºƒfÀ‰kÆŽpÌ”vÒ™{מÛ¢ƒß¥…ᧇ⧇ᦆऄݢڞ}ÖšxÒ•tÍ‘oÉŒjňfÂ…b¿_¼\º}Z¹{X·zW·yV¶xU¶xUµwTµwTµwTµwTµwTµwTµwTµwT´wU´wU´wU´xVµxVµxVµxW´xW´yW´yX´yX³xX³xX²xX±wX°wW¯vW­uW¬tV«sU©rU§qT¦pT¤oS£nS¡mR mRžlRkR›jQšiQ˜hQ–gQ”gQ’fPdPŽcPŒbP‰aP‡`O„^O]O~[N{ZNvXNrVMnSMlRMjRLhQLeOLaML+O+O\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀHFLXQRTJH~pm‚la¬Ž}Ÿzc»t¤tT‰aPdP•gQšiQœjRžlRžlS›jRÖ|:´e*˜V&ˆN$\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À B B`LKdNLgPLiQLkRMmSMoTMpUMrUMtVMwXNzYN}[N€\O‚]O…_O‡`O‰aPšW&£['«_(´d)Âl,݃@Òt.™iQ›jRkRŸmS¡oU¤qV¨sX«w[°z^µbºƒgÀ‰kÆŽpÌ”uÑ™zÖ~Ú¡‚Þ¤„ॆআॅޣ‚Ü Ø{Õ™wÑ”sÌnÈŒjňfÁ„b¾_¼~\º|Z¸{X·yW¶yV¶xUµwUµwTµwTµwTµwT´wT´wT´wT´wT´wU´wU´wU´wU´wV´xV´xV´xW´xW³xW³xW³xX²xX±wX°wW¯vW®uW­uV¬tVªsU©rU§qT¦pT¤oS£nS¡mR lRžlRkR›jQšiQ˜hQ–hQ”gQ’fPdPŽcPŒbPŠaP‡`O„^O]O~[N{ZNwXNsVMoTMlRMjRLiQLfOLbML+O+O‚+O‚+O‚\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À6./fZXeVRHAIZIKiQLuWM¤tU‰aOdP–gQšjQkRžlRkR˜iQÄn/¬b,‘R%rC"\À\À\À\À\À\À\À\À\À\À\À\À"Fx"Fx!Fx!Fx B B BdNLgPLjQLlRMmSMoTMqUMrUMtWMwXNzZN}[N€\O‚^O…_O‡`O“S%X&¥\'®a(·g+Ês2Ó{9Àj*™iQ›jRkSŸmS¢oU¤qV¨sX«w[°z^µbº„gÀ‰kÆŽpË“uИyÕœ}٠ܢƒÞ¤„ߤ„Þ£ƒÝ¡ÚŸ~×›zÓ—vÏ“rËmÇ‹ićeÀƒa¾€^»~\¹|Z¸zX·yW¶xVµxUµwUµwTµwT´wT´wT´wT´wT´wT´wT´wT´wU´wU´wU´wU´wV³wV³xV³xW³xW²wW²wW±wW±wW°vW¯vW®uV¬tV«sUªsU¨rT§qT¦pT¤oS£nS¡mR lRžlRkR›jQšiQ˜hQ–gQ”gQ’fPePŽcPŒbPŠaP‡`O„_O]O~\N{ZNxXNsVMoTMlRMjRLiQLfPLbNL +O‚+O‚+P‚+P‚+P‚\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À@89dWT@IIAI\JKlRMyYN„^OcP”gQ™iQkRžlRžkR™iRÍt3±d-’S%I#\À\À\À:^‘:^‘:^‘:^‘:^:^:^:^:^"Fx"Fx B B B BeOLhPLjRLlSMnSMpTMqUMrVMuWMxXN{ZN~[N€]Oƒ^O…_O“S%›W&¢['©^(¹k2½i+Ó{:•gQ—hQ™iQ›jRkSŸmT¢oU¤qV¨tY¬w[°{_µbºƒf¿ˆkÄoÊ’tÏ–xÓš|×~Ù €Û¡Û¡Û €Ùž~×›{Ô˜wДsÌoÉŒkʼngÂ…c¿‚`¼]º}[¸{Y·zX¶yVµxVµwU´wU´wT´wT´vT´vT´vT´vT³vT³vT³vT³vT³vU³vU³vU³wU²wU²wV²wV²wV±wV±vV°vV°vV¯uV®uV­tV¬tUªsU©rU¨qT§pT¥pS¤oS¢nS¡mR lRžlRkR›jQ™iQ˜hQ–gQ”gQ’fPePŽdPŒbPŠaPˆ`O…_O‚]O\N|ZNxYNtWMpTMlRMjRLiQLgPLcNL_LK+P‚+P‚+P‚,P‚,P‚,P‚,P‚,P‚Nr¤\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À]QNl\VG@IMCI_LKoTM|ZN†`OdP–gQšjQkRžlRœkR—hQºh*¤^,ŒP%X3:_‘:_‘:_‘:_‘:_‘:_‘:_‘:_‘:^‘:^‘:^‘:^‘"Fx B B B BfOLiQLkRLmSMnTMpTMqUMrVMuWNxYN{ZN~[N€]Oƒ^OŽP%—U&X&£['¬`)½n4Ãn/Àj*•gQ—hQ™iQ›jRkSŸmT¢oU¤qW¨tY«w[°z^´~b¹ƒf¿ˆjÄŒoÉ‘sΕwÒ™{Õœ}ØžÙŸ€ÚŸ€Ùž~ל|ÕšyÒ—vÏ“rËnÇ‹jĈfÁ„c¾`¼]¹}[¸{Y·zW¶xVµxU´wU´wT´wT´vT´vT³vT³vT³vT³vT³vT³vT³vT³vT²vU²vU²vU²vU²vU±vV±vV±vV°vV°vV¯uV®uV­uV¬tU«sUªrU©rT¨qT¦pT¥oS£oS¢nS¡mRŸlRžkRœkR›jQ™iQ˜hQ–gQ”gQ“fPePŽdPŒbPŠaPˆ`O…_O‚]O\N|ZNyYNuWMpUMlRMjQLiQLgPLdNL_LK,P‚,P‚,P‚,P‚,P‚Nr¤Nr¤Nr¤Nr¤Nr¥Nr¥\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀaSOD>IJAIQEJbNLrUM~[NˆaO‘eP—hQœjQžkRŸlR›jRÌs0²e,“T&ƒK$;_‘;_‘;_‘;_‘;_‘;_‘;_‘:_‘:_‘:_‘:_‘:_‘:_‘ B B B BgPLiQLkRLmSMoTMpTMqUMsVMuWNxYN{ZN~[N]O‡M$“S%™V&ŸY&¥\'±e-¹j/Ñz:”fQ•gQ—hQ™iR›jRkSŸmT¢oU¤qW¨tY«w[¯z^´~b¹ƒf¾‡jÃŒnÈrÍ”vјyÔ›|Ö~מ~Øž~×}Õ›{Ó˜xЕtÍ’qÊŽmÆŠiÇeÀ„b½_»~\¹|Z·{Y¶yWµxVµxU´wU´wT´vT³vT³vT³vT³vT³vT³vT³vT³vT²vT²vT²vT²vU²vU²vU±vU±vU±vU°vV°vV¯uV®uV®uV­tU¬sU«sUªrU¨qT§qT¦pS¥oS£nS¢nR¡mRŸlRžkRœkR›jQ™iQ˜hQ–gQ”gQ’fPePŽdPŒbPŠaPˆ`O…_O‚]O\O|ZNyYNuWMqUMlSMjQLhQLfPLdNL_LK,P‚,P‚Nr¤Nr¤Nr¤Nr¤Nr¥Nr¥Nr¥Ns¥Ns¥Ns¥Ns¥\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀdUOG@IMCITFJeOLtWM€]O‹bP“fP™iQkRŸlRkR™iQ¾j,©c/P%[JK;_‘;_‘;_‘;_‘;_‘;_‘;_‘;_‘;_‘;_‘;_‘;_‘ B B B BgPLiQLkRMmSMoTMpTMqUMsVMvWNyYN{ZN~[N|H#ŽQ%•T%›W& Z'¦]'ºm5¸f*Ív5”fQ•gQ—hQ™iR›jRkSŸmT¡oU¤qW§sY«v[¯z^³~b¸‚e½‡i‹nÇqË“uÏ–xÒ™zÔ›|Öœ}Öœ|Õ›{Ô™yÑ–vÏ“sÌoÈlʼnh†e¿ƒa¼€_º~\¸|Z·zX¶yWµxV´wU´wU³vT³vT³vT³vT³vT³vT³vT²vT²vT²vT²vT²vT²vT±vT±vU±vU±vU°uU°uU°uU¯uU®uU®tU­tU¬tU«sUªrU©rT¨qT§pT¥pS¤oS£nS¢mR mRŸlRžkRœjR›jQ™iQ—hQ–gQ”fQ’fPePŽcPŒbPŠaPˆ`O…_O‚^O\O|ZNyYNuWNqUMmSMjQLhQLfPLdNL`LKNr¤Nr¤Nr¥Nr¥Nr¥Ns¥Ns¥Ns¥Ns¥Os¥Os¥Os¥Os¥Os¥Os¥\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À2#TB3REJVGJ`LKpTM}[N‰aO’ePšiQžkR lRžlR˜hQ·e)¢^.P%^8 #Gy#Gy#Gy#Gy#Gy#Gy#Gy#Gy * B B B B BjQLlRMnSMoTMpUMrUMsVMxF#‡M$ŽQ%’S%–U&šW&žY&¢['ªa+¿s;¹g+dP‘eP“fQ”gQ–hQ˜iQšjRœkSžlS nU£pV¦rX©uZ¬x]°{_´~b¸‚e¼…iÀ‰kÃŒnÆŽpÈrÊ‘sË’sË‘rÊqÉoÇmÅ‹kÈhÀ…e¾ƒb¼€`º~^¸|[¶{ZµyX´xW³wV²vU²vU²vT±uT±uT±uT±uT±uT±uT±uT±uT°uT°uT°tT°tT¯tT¯tT¯tT¯tT®tT®tT­sT­sT¬sT¬sT«rTªrT©rT©qT¨qS§pS¦pS¥oS£nS¢nR¡mR lRŸlRkRœjQ›jQ™iQ˜hQ–gQ•gQ“fP‘ePdPcP‹bP‰aO‡`O„^O‚]O\N|ZNxXNuWMqUMmSMhPLgPLeOLcNL`LKZIK,Pƒ,Pƒ,QƒOs¦Os¦Ot¦Ot¦Ot¦Ot¦Pt¦Pt¦Pt¦Pt¦Pt¦-Qƒ-Qƒ-Qƒ-Qƒ-Qƒ-Qƒ-Qƒ-Qƒ-Qƒ-Qƒ\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀvšÍvšÍv›Ív›Ív›Ív›Ív›Íw›Íw›Í=a“=a“=a“#Gy#Gy#Gy#Gy#Gy#Gy#Gy#GymYPODJUGJXIKeOLtWM‚]OcP•gQœjQ lR mRkRÈp.´g0”T&ˆN$]8 #Gy#Gy#Gy#Gy#Gy#Gy#Gy * B B B B BjQLlRMnSMoTMpUMrUMv>„L$ŒP%‘R%•T%˜V&œX& Z'¤\'°f0¹m5Äq3dP‘eP“fQ”gQ–gQ˜hQ™jR›kSlS nT¢pV¥rX¨tZ«w\¯z_³}a·dº„g¾‡jÁŠlÄŒnÆŽpÇqÈqÈpÇŽoÆmÅ‹kÉiÁ‡g¿„d½‚aº_¸}]·|[µzY´yX³xW³wV²vU²vU±uT±uT±uT±uT±uT±uT°uS°uS°tS°tS°tS¯tS¯tT¯tT¯tT®tT®tT®sT­sT­sT¬sT¬sT«rTªrTªrT©qT¨qS§pS¦pS¥oS¤oS£nS¢mR¡mRŸlRžlRkRœjQšjQ™iQ—hQ–gQ”fQ’fP‘ePdPcP‹bP‰aO†`O„^O]O~\N{ZNxXNuWMqUMiQLgPLfOLeOLbNL_LKZIK,Qƒ,Qƒ,Qƒ,Qƒ,QƒOt¦Pt¦Pt¦Pt¦Pt¦Pt¦-Qƒ-Qƒ-Qƒ-Qƒ-Qƒ-Qƒ-Qƒ-Qƒ-Qƒ-Qƒ-Qƒ-Qƒ-Qƒ-Qƒ-Qƒ\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\Àv›Ív›Ív›Ív›Íw›Íw›Íw›Íw›Íw›Íw›Íw›Íw›Í=a“=a“=a“=a“=a“#Gz#Gz#Gz#Gz#Gz#Gz#GzgUOS=2RFJWHJ[JKlRMzYN†`OeP˜iQžkR mRŸlR™iQ¼h*°h4‘R%ˆN$^9 [JK#Gy#Gy#Gy#Gy#Gy * B B B B BjQLlRMnSMoTMpUMI#†L$‹O$Q%“S%—U&šW&X&¡Z'¦](·l5´f,Èt5dPeP’fP”fQ–gQ—hQ™iR›kRlSŸmT¢oV¤qW§tY«v[®y^±|aµc¸‚f¼…h¿ˆkÁŠlÃŒnÅnÅoÅnÅŒmÄ‹k‰iÁ‡g¿…e½ƒc»€`¹~^·|\¶{Z´yY³xW²wV²vU±vU±uT±uT±uT°uT°uT°tS°tS°tS°tS°tS¯tS¯tS¯tS¯tS®tS®tS®sS­sT­sT­sT¬sT¬rT«rTªrTªrS©qS¨qS§pS¦pS¦oS¥oS¤nS¢nR¡mR mRŸlRžkRkR›jQšiQ˜iQ—hQ•gQ”fQ’ePePdPcPŠbPˆ`O†_Oƒ^O]O~[N{ZNxXNtVMqUMhPLgPLfOLdNLbML_LKbE6,Qƒ,Qƒ,Qƒ,Qƒ-Qƒ-Qƒ-QƒPt¦-Qƒ-Qƒ-Qƒ-Qƒ-Qƒ-Qƒ-Qƒ-Qƒ-Qƒ-Qƒ-Qƒ-Qƒ-Qƒ-Qƒ-Qƒ-Qƒ-Qƒ-Q„-Q„-Q„\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À@d–w›Íw›Íw›Íw›Íw›Íw›Íw›Íw›Íw›Íw›Íw›Íw›Îw›Îw›Î=a”=a”=a”=a”=a”=a”=a“#Hz#Gz#Gz#Gz#Gz#Gz#GzmYPPDJUGJYIKbMLqUM\NŠbP”fQ›jQŸlR¡mRžlRËp,µe+ \+R%ˆN$b; ]8 [7 XHKO+N1L/L/L/K/K/ eb”>b”>b”>b”>b”>b”>b”>b”=b”=b”=b”=b”=b”=b”=b”=b”YEUGJYIK_LKnSM|ZNˆ`O’ePšiQŸlR¡mR mR™iQºg*´j4šW'‘R%ŽQ%h>!g=!f=!db”>b”>b”>b”>b”>b”>b”$Hz$Hz$Hz$Hz$Hz>b”>b”>b”>b”>b”gVOS=2RFJWHK[JKeOLsVM€]OŒbP•gQœjQ lR¡mRžlRÌr/¹g*²h2–U&“S%‘R%Q%ŽQ%ŒP%£['¨]'¬`(°b(´d)¸f)»g)¾i*Áj*I#¡Z'¡Z' Z' Z'¡Z'£['¤['¥\'¦]'ª_)±d,³d)Äq3‹bPcPdP‘eP’fQ”fQ–gQ—hQ™iR›kSlSŸmU¡oV¤qW¦sY©u[¬x]¯z^±|`´~b¶€d¸‚eºƒf»„f»„f¼„f»ƒe»‚dºb¹€a·~_¶}^µ{\´zZ³yY²wX±wW°vV°uU¯uU¯tT¯tT¯tT®tS®tS®tS®sS®sS®sS®sS®sS­sS­sS­sS­sS¬sS¬rS¬rS«rS«rSªrSªqS©qS©qS¨pS§pS¦pS¦oS¥oS¤oR£nR¢nR¡mR mRŸlRžkRkRœjQšjQ™iQ˜hQ–hQ•gQ“fQ’ePdPŽcPŒcPŠbPˆ`O†_O„^O]O\N|ZNyYNuWNrUMnSMjQLdNLcNLaMK_LK[JK`D6Pt¦Pt¦Pt§Pt§Pt§Pu§Pu§Pu§Pu§Qu§Qu§Qu§Qu§Qu§Qu§-Q„-Q„-Q„-R„-R„-R„-R„-R„-R„-R„-R„-R„.R„.R„Rv¨Rv¨Rv¨~¢Ô~¢Ô~¢Ô~¢Ô\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À@e—@e—@e—@e—Ae—Ae—Ae—Ae—Ae—Ae—Ae—Ae—Ae—Ae—Ae—xœÏxœÏxœÏxÏxÏxÏxÏyÏyÏ>b•>b”>b”$Hz$Hz$Hz$Hz$Hz$Hz$Hz$Hz$Hz$Hz>b”>b”>b”>b”>b”YDb”>b”>b”>b”Q@:R<2fL@WHJZJKaMKoTM|ZNˆ`O‘eP™iQŸlR¡mR¡mRœjRÇo-»i-´h0«`)§]'¨]'¬`(°b(´d)¸f)¼h)Àj*Ãk*Æm*Én+Ìp+Ïq+Òr,§]'§]'§]'¨^'ª_(«_(¬`(­`(¯b)²c)ºi.ˆ`OŠaPŒbPŽcPdP‘eP“fQ”gQ–hQ˜iRšjR›kSlTŸnU¢oV¤qW¦sY©uZ«w\­y]°{_²|`³}aµ~b¶b¶b¶b¶a¶~`µ}_µ|^´{]³z[²yZ±xY°wX¯vW¯uV®uU®tU®tT­tT­sT­sS­sS­sS­sS­sS­sS­sS­sS¬sS¬rS¬rS¬rS«rS«rS«rSªrSªqS©qS©qS¨qS¨pS§pS¦pS¦oS¥oR¤oR¤nR£nR¢mR¡mR lRŸlRžkRkRœjQšjQ™iQ˜hQ–hQ•gQ“fQ’ePdPdPcP‹bP‰aO‡`O…_O‚]O\O}[NzYNwXNtVMpTMlRMhPLcNLaMK_LK]KKbR]C5Pu§Pu§Pu§Qu§Qu§Qu§Qu§Qu§Qu§Qu§Qu§Qu§Qu§Qu¨Qu¨Qu¨Qv¨Qv¨Qv¨-R„-R„.R„.R„.R„Rv¨Rv¨Rv¨Rv¨Rv¨Rv¨Rv¨£Õ£Õ£Õ£Õ£Õ£Õ£Õ£Õ£Õ£Õ\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀAe—Ae—Ae—Ae—Ae—Ae—Ae—Ae—Ae—Ae—Ae—Ae—Ae—Ae˜Ae˜Ae˜Ae˜yÏyÏyÏAf˜Af˜Af˜$Hz$Hz$Hz$Hz$Hz$Hz$Hz$Hz$Hz$Hz$Hz$Hz$Hz$Hz$Hz$Hz>b•>b•>b”>b”WD3TFJXHK[JKfOLsVM€]O‹bP”gQœjQ lR¡mR mRœkRÅm,½i,ºj/²d+±c)²c(¶e)ºf)¾h*Áj*Ål*Én+Ëo+Îq+Ñr+Ós,Õt,ƒK$ª^(ª_(«_(¬`(®a(¯a)°b)³d*¶f+¾m1‡`O‰aP‹bPcPdPeP’fQ”fQ•gQ—hR™iR›kSlTŸmT¡oV£pW¥rX§tY©v[¬w\®y]¯z^±{_²|`³}`´}`´}`´}_´|^³{^³{\²z[±yZ°xY°wX¯vW®uV®tU­tU­tT­sT­sT­sS­sS¬sS¬sS¬sS¬rS¬rS¬rS¬rS¬rS«rS«rS«rS«rSªrSªqSªqS©qS©qS¨qS¨pS§pS¦pS¦oS¥oR¤oR¤nR£nR¢mR¡mR mRŸlRžlRkRœjQ›jQšiQ˜iQ—hQ–gQ”fQ“fP‘ePdPŽcPŒbPŠaPˆ`O†_O„^O]O\N|ZNyYNvWNsVMoTMkRLgPLbML`LK^KK\JK~aR[B5Pu§Qu§Qu§Qu§Qu§Qu§Qu§Qu§Qu§Qu§Qu§Qu¨Qu¨Qu¨Qv¨Qv¨Qv¨Rv¨Rv¨Rv¨Rv¨Rv¨Rv¨Rv¨Rv¨Rv¨Rv¨Rv¨Rv©Rv©£Õ£Õ£Õ£Õ£Õ£Õ£Õ£Õ£Õ£Õ£Õ£Õ£Õ\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀAe—Ae—Ae—Ae—Ae—Ae—Ae˜Ae˜Ae˜Ae˜Ae˜Ae˜Ae˜Af˜Af˜Af˜yÐAf˜Af˜Af˜Af˜Af˜Bf˜$H{$Hz$Hz$Hz$Hz$Hz$Hz$Hz$Hz$Hz$Hz$Hz$Hz$Hz$Hz$Hz>c•>c•>b•>b•O?:[E|aRZA5-QƒQu§Qu§Qu§Qu§Qu§Qu§Qu§Qu¨Qu¨Qu¨Qv¨Qv¨Qv¨Qv¨Rv¨Rv¨Rv¨Rv¨.R„.R„.R„.R„Rv¨Rv¨Rv©Rv©Rv©Rw©£Ö£Ö£Ö£Ö£Ö£Ö£Ö£Ö£Ö£Ö£Ö£Ö£Ö£Ö£Ö£Ö\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀAe˜Ae˜Ae˜Ae˜Ae˜Ae˜Ae˜Af˜Af˜Af˜Af˜Af˜yžÐyžÐyžÐzžÐzžÐzžÐBf˜Bf˜Bf˜Bf˜Bf˜$H{$H{$H{$H{$H{$H{$H{$H{$H{$Hz$Hz$Hz$Hz$Hz$Hz$Hz$Hz>c•>c•>c•>c•VC^C6W@5-Q„-Q„Qu§Qu§Qu§Qu§Qu¨Qu¨Qv¨Qv¨Qv¨Qv¨Rv¨Rv¨Rv¨Rv¨.R„.R„.R„.R„.R„.R„.R„.R„.R„Rv©Rw©Rw©Rw©¤Ö¤Ö¤Ö¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö¤Ö¤Ö¤Ö\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀAf˜Af˜Af˜Af˜Af˜Af˜Af˜Af˜zžÐzžÐzžÐzžÐzžÐzžÐzžÐzžÐzžÐzžÐzžÐBf˜Bf˜Bf˜Bf˜$I{$I{$I{$H{$H{$H{$H{$H{$H{$H{$H{$H{$H{$H{$H{$H{$Hz$Hz$Hz$Hz$Hz YE\C6T>4-Q„-Q„-Q„-R„Qu¨Qu¨Qv¨Qv¨Qv¨Qv¨Rv¨Rv¨Rv¨.R„.R„.R„.R„.R„.R„.R„.R„.R„.R„.R„.R„.R„Rw©Sw©€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤ÖEi›Ei›Ei›\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀAf˜Af˜Bf˜Bf˜Bf˜zžÐzžÐzžÐzžÐzžÐzžÐzžÐzžÐzžÑzžÑzžÑzŸÑzŸÑzŸÑzŸÑBf˜Bf˜Bf˜$I{$I{$I{$I{$I{$I{$I{$I{$I{$I{$I{$H{$H{$H{$H{?c•?c•?c•?c•$H{$H{$H{SB;R<2zbVUGJXIK[JK[JKuWN€\OŠaP’fP™iQŸlR¡mR£nS£nS¥pTà€9Þ9Õw2Öw0Öv/Öv.Ùx/Üz0Þz0á|1ã~2æ€3è5éƒ6ë…8ë…8ºm4¼o7¾q8Äu;Ãs9Ãs8ºj0‚]O„^O†_Oˆ`OŠaPŒbPcPdP‘eP’fQ”fQ•gQ—hR™iRšjSœkSlTŸnU¡oV¢pV¤qW¦rX§sY¨tY©uYªuZ«uZ«vZ«vY«uY«uX«uX«tW«tV«sVªsUªsUªrTªrTªrTªrSªqSªqSªqSªqSªqS©qS©qS©qS©qS©qS©qS©qS©qS¨qS¨pS¨pS§pS§pR§pR¦oR¦oR¥oR¥oR¤nR£nR£nR¢mR¡mR mR lRŸlRžkRkRœjQ›jQšiQ™iQ—hQ–gQ•gQ”fQ’eP‘ePdPcPŒbPŠaPˆ`O†_O„^O‚]O\O}[NzYNwXNtVMqUMnSMiQLeOL`LK]KKmP?kN?|aSZA5P<4-R„-R„-R„-R„-R„-R„Qv¨Rv¨Rv¨Rv¨Rv¨.R„.R„.R„.R„.R„.R„.R„.R„.R„.R„.R„.R„.R„.R„.R„.R„.R„€¤×€¤×€¤×€¤×€¤×€¤×€¤×€¤×€¤×€¤×€¤×€¤×€¤×€¤×€¤×€¤×Ei›Ei›Ei›Ei›Ei›Ei›Ei›\À\À\À\À\À\À\À\À\À\À\À\ÀBf˜zžÐzžÐzžÐzžÐzžÐzžÐzžÑzžÑzžÑzŸÑzŸÑzŸÑzŸÑ{ŸÑ{ŸÑ{ŸÑ{ŸÑ{ŸÑ{ŸÑBf™Bf™Bf™%I{$I{$I{$I{$I{$I{$I{$I{$I{$I{$I{?c–?c–?c–?c–?c–?c•?c•?c•?c•$H{$H{$H{jXP^H=}dXUGJXHKZIKkRLwXN‚]O‹bP”fQšiQžkR mR£nS¥pT¨qU¨rUç…;ç†>ì‰?è†<å‚9ê†;î‰=ðŠ=ðŠ>ôŽAø‘Dü•Hÿ˜Kù’E¿r:Àt;Àt;Át<Ãt:½n4´f,]Oƒ^O…_O‡`O‰aO‹bPŒcPŽcPdP‘eP“fQ”gQ–hQ˜iR™jR›kSœlSžmTŸnU¡oV¢pV¤qW¥rW¦rX§sX¨tX©tX©tX©tX©tXªtWªsW©sV©sV©rU©rU©rT©qT©qT©qS©qS©qS©qS©qS©qS©qS©qS©qS¨qS¨qS¨pS¨pS¨pS¨pS§pS§pS§pR¦pR¦oR¦oR¥oR¥oR¤nR¤nR£nR¢nR¢mR¡mR mR lRŸlRžkRkRœjQ›jQšiQ™iQ˜hQ–hQ•gQ”fQ’fP‘ePdPŽcPŒcP‹bP‰aO‡`O…_Oƒ^O]O~[N{ZNyYNvWNsVMpTMlRMgPLcNL†gUƒeUlO?~bT{`SW@5-R„-R„-R„-R„-R„-R„.R„.R„.R„.R„.R„.R„.R„.R„.R„.R„.R„.R„.R„.R„.R„.R„.R„.R„.R„.R„.R….R…Ei›Ei›Ei›€¥×€¥×€¥×€¥×€¥×€¥×€¥×€¥×€¥×€¥×€¥×€¥×Ei›Ei›Ei›Ei›Ei›Ei›Ei›Ei›Ei›Ei›Ei›\À\À\À\À\À\À\À\À\À\ÀzžÑzžÑzžÑzžÑzŸÑzŸÑzŸÑzŸÑ{ŸÑ{ŸÑ{ŸÑ{ŸÑ{ŸÑ{ŸÑ{ŸÑ{ŸÑ{ŸÑ{ŸÑ{ŸÑ{ŸÑ{ŸÒBg™Bg™Bg™%I{%I{%I{%I{%I{%I{%I{@d–?d–?d–?d–?d–?d–?d–?d–?d–?c–?c–?c–?c–$I{$I{L=:WD`KA-R„-R„-R„.R„.R„.R„.R„Rv¨Rv¨Rv¨Rv¨.R„.R„.R„.R„.R„.R„.R„.R„.R„.R„.R„.R„.R….R….R….R…EiœEiœEiœEiœEiœEiœ¥×¥×¥×¥×¥×¥×¥×EiœEiœEiœEiœEiœEiœEiœEiœEiœEiœEiœEiœEiœEiœEiœEiœ\À\À\À\À\À\À\À\ÀzŸÑzŸÑ{ŸÑ{ŸÑ{ŸÑ{ŸÑ{ŸÑ{ŸÑ{ŸÑ{ŸÑ{ŸÑ{ŸÑ{ŸÑ{ŸÒ{ŸÒ{ŸÒ{ŸÒ{ Ò{ Ò{ Ò{ Ò| ÒCg™Cg™%I{%I{%I{@d–@d–@d–@d–@d–@d–@d–@d–@d–@d–@d–@d–?d–?d–?d–?d–?d–?d–$I{$I{dUPYEXG@-R„.R„.R„.R„Rv¨Rv¨Rv¨Rv¨Rv¨Rv¨Rv¨Rv©.R„.R„.R„.R„.R„.R„.R„.R„.R….R….R….R….R….R….S…EiœEiœEiœEjœEjœEjœEjœEjœ¥×¥×¥×EjœEjœEjœEjœEjœEjœEjœEjœEjœEjœEjœEjœEjœEjœEjœEjœEjœEiœEiœEiœ\À\À\À\À\À\À{ŸÑ{ŸÑ{ŸÑ{ŸÑ{ŸÑ{ŸÑ{ŸÑ{ŸÒ{ŸÒ{ŸÒ{ Ò{ Ò{ Ò{ Ò| Ò| Ò| Ò| Ò| Ò| Ò| Ò| Ò| ÒCg™@d–@d–@d–@d–@d–@d–@d–@d–@d–@d–@d–@d–@d–@d–@d–@d–@d–@d–@d–@d–@d–?d–$I{$I{RA;P<3zcXnVIuh™~pdNLpUMÁ”w¬zZ«vS‘eP–gQœjQžlR¡mR¤oS§pT­uV¯vW±xY¶|\¼€_ÆdƉgÈŠhÊŒiÌŽkÎlÿRñF¶k4²g1¯d-­b+ª_(¢Z'}[N€\O‚]O„^O†_Oˆ`O‰aP‹bPcPŽcPdP‘eQ’fQ”gQ•gQ—hR˜iR™jR›kSœkSlTžmT nT¡nU¡oU¢oU£pU¤pU¤pU¤pU¥pU¥pT¥pT¥pT¥pT¥pS¥pS¥oS¦oS¦oS¦oS¦oS¦oS¦oR¦oR¦oR¦oR¦oR¦oR¦oR¦oR¥oR¥oR¥oR¥oR¤oR¤nR¤nR£nR£nR¢nR¢mR¡mR¡mR lRŸlRŸlRžkRkRœkQœjQ›jQšiQ™iQ˜hQ—hQ•gQ”gQ“fP’ePePdPcPŒbPŠbP‰aO‡`O…_Oƒ^O]O~\N|[NzYNwXNtVMpUM—pY”oXzWBuUB…gVlP@jO@|bUx`TcMB3!.R„Rv¨Rv¨Rv¨Rv¨Rv¨Rv¨Rv¨Rv©Rv©Rv©Rw©Rw©Rw©.R„.R„.R„.R„.R….R….R….R….R….S….S….S…EjœEjœEjœEjœEjœEjœEjœEjœEjœ¦Ø¦ØEjœEjœEjœEjœEjœEjœEjœEjœEjœEjœEjœEjœEjœEjœEjœEjœEjœEjœEjœEjœEjœEjœEjœ\À\À\À\ÀBg™{ŸÒ{ŸÒ{ŸÒ{ Ò{ Ò{ Ò{ Ò| Ò| Ò| Ò| Ò| Ò| Ò| Ò| Ò| Ò| Ò| Ò| ÒCg™Cg™Cg™Cg™|¡Ó@d—@d—@d—@d—@d—@d—@d–@d–@d–@d–@d–@d–@d–@d–@d–@d–@d–@d–@d–@d–@d–@d–%I{;0/SB;R=4fODpXL‘xkš€r˜vbº“zÀ”x«{[ÃldP•gQ™iQ›jQŸlR£nR¦pS¨qTªrT¬tU°wWµ{Z¸}\¸|\¸}\¹~]»]å}+Ý~6­d.ªa+¨_)§^(¤\'zYN|ZN~\N€]Oƒ^O„_O†_Oˆ`OŠaP‹bPcPŽdPdP‘eQ“fQ”gQ•gQ—hR˜iR™jRšjSœkSlSžlTŸmT mT nT¡nT¢nT¢oT£oT£oT£oT£oT¤oS¤oS¤oS¤oS¤oS¤oS¤oS¥oR¥oR¥oR¥oR¥oR¥oR¥oR¥oR¥oR¥oR¤oR¤oR¤nR¤nR¤nR£nR£nR£nR¢mR¢mR¡mR¡mR lR lRŸlRžlRžkRkQœjQ›jQšjQ™iQ™iQ˜hQ—hQ•gQ”gQ“fQ’ePePdPŽcPŒbPŠbP‰aO‡`O…_Oƒ^O]O\N}[NzZNxXNuWMrUM™rZ–pY|XCxVCsTBmQAkOA~cVzaU`I>\IARv¨Rv¨Rv¨Rv¨Rv¨Rv¨Rv¨Rv©Rv©Rv©Rw©Rw©Rw©Sw©Sw©Sw©Sw©.R….R….R….R….R….S….S….S….S…FjœFjœFjœFjœFjœFjœFjœFjœ‚¦Ø‚¦Ø‚¦Ø‚¦Ø‚¦Ø‚¦ØFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœ\À\ÀBg™{ Ò| Ò| Ò| Ò| Ò| Ò| Ò| Ò| Ò| Ò| Ò| Ò| Ò| Ó| ÓCg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™}¡Ó@e—@e—@e—@e—@e—@e—@d—@d—@d—@d—@d—@d—@d–@d–@d–@d–@d–@d–@d–@d–@d–@d–@d–%I{<1/J82^I@gQFqYN‘xl™€s—vc¢{d¿”yª{\«wUÄi‘eP•gQ˜hQkQ mR¢mR¤nR¥oS§pSªrT¬tU¬tU¬tU¬tU­tU®tUÒt.ƒL&¤](¢['¡Z'žY&xYN{ZN}[N\N]Oƒ^O…_O‡`OˆaOŠaPŒbPcPdPeP‘eQ“fQ”gQ•gQ—hR˜iR™iRšjR›kSœkSlSžlSŸmSŸmS mS nS¡nS¡nS¢nS¢nS¢nS¢nS£nS£nS£nR£nR£nR£nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR£nR£nR£nR£nR£nR¢nR¢mR¢mR¡mR¡mR¡mR lR lRŸlRžlRžkRkRœkQœjQ›jQšiQ™iQ˜iQ—hQ–hQ•gQ”fQ“fP’ePePdPŽcPŒbP‹bP‰aO‡`O†_O„^O‚]O\O}[N{ZNxYNvWNsVM›s[˜rZ~ZDnYŒkYqSBkPAiOA|cVbK?\G>NB?Rv¨Rv¨Rv¨Rv¨Rv¨Rv©Rv©Rv©Rw©Rw©Rw©Sw©Sw©Sw©Sw©Sw©Sw©Sw©Sw©.S….S….S….S….S….S…FjœFjœFjœFjœFjœFjœ‚¦Ø‚¦Ø‚¦Ø‚¦Ø‚¦Ø‚¦Ø‚¦Ø‚¦Ø‚¦Ø‚¦Ø‚¦ØFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœCg™Cg™| Ò| Ò| Ò| Ò| Ò| Ó| Ó| Ó| Ó|¡Ó|¡ÓCg™Cg™Cg™Cg™Cg™Cg™Cg™CgšCgšCgšCgšCgš}¡ÓAe—Ae—Ae—@e—@e—@e—@e—@e—@e—@e—@e—@d—@d—@d—@d—@d—@d—@d–@d–@d–@d–%I{@d–@d–<1/H72\I@ePGpYNxm˜€t–vc¡{e¾”zÁ“u‘p«wU¬uQ‘eP•gQ™iQšjQœjQžlR¡mR£nR¤nR¤oR¤oR¤oR¤oR¤oRÇgb;  Z'žY&›W&“S%vXNyYN{ZN~[N€\O‚]Oƒ^O…_O‡`O‰aOŠaPŒbPcPdPdP‘eQ“fQ”gQ•gQ–hQ˜iR™iRšjR›jR›kSœkSlSžlSžlSŸlSŸmS mS mS¡mS¡mS¡mR¡mR¢mR¢mR¢mR¢mR¢nR¢nR¢nR£nR£nR£nR£nR£nR¢nR¢nR¢mR¢mR¢mR¢mR¡mR¡mR¡mR mR lRŸlRŸlRžlRžkRkRkQœjQ›jQ›jQšiQ™iQ˜hQ—hQ–gQ•gQ”fQ“fP‘ePdPdPcPŒbP‹bP‰aO‡`O†_O„^O‚]O€\O}[N{ZNyYNvXNtVMu\„]E€[E’oZŽmZŠkYnRBjOB}cVdL@`I?XGARv¨Rv¨Rv¨Rv¨Rv©Rv©Rw©Rw©Rw©Rw©Sw©Sw©Sw©Sw©Sw©Sw©Sw©Sw©Sw©SwªSwª.S….S….S….S…/S…FjœFjœFjœFjœ‚¦Ù‚¦Ù‚¦Ù‚¦Ù‚¦Ù‚¦Ù‚¦Ù‚¦Ù‚¦Ù‚¦Ù‚¦Ù‚¦Ù‚¦Ù‚¦Ù‚¦ÙFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœ‚¦Ù‚¦ÙCg™Cg™| Ó| Ó|¡Ó|¡Ó|¡Ó|¡Ó|¡ÓCg™Cg™Cg™Cg™CgšCgšCgšCgšCgšCgšCgšCgšChšChšChšChšChš}¢ÔAe—Ae—Ae—Ae—Ae—Ae—Ae—Ae—Ae—@e—@e—@e—@e—@e—@e—@e—@d—%I{%I{%I{%I{%I{@d–@d–<10F61o]Vye]„oeŽxmœ‚u”udŸ{e¥}d¨|aÀ’tÁpÃl¬uQdP’eP”fQ–gQ˜iQ›jQœjQœjQœjQœjQœkQœkQkQ_9 œX&™V&•T%rUMuWMwXNzYN|ZN~[N€\O‚]O„^O…_O‡`O‰aOŠbPŒbPcPŽdPdP‘eQ’fQ”fQ•gQ–hQ—hR˜iR™iRšjR›jRœkRœkRkRlRžlRžlRŸlRŸlRŸlR lR mR mR mR¡mR¡mR¡mR¡mR¡mR¡mR¡mR¡mR¡mR¡mR¡mR¡mR¡mR¡mR¡mR mR lR lRŸlRŸlRŸlRžkRžkRkRkQœjQ›jQ›jQšiQ™iQ˜iQ—hQ–hQ•gQ”gQ“fQ’fP‘ePdPdPcPŒbPŠbP‰aO‡`O†_O„^O‚]O€\O~[N{ZNyYNwXNtVMrUM†^F‚]F”q\o[ŒlZqTD€fX}dWeMAbK@O=6NB@Rv¨Rv©Rv©Rv©Rw©Rw©Rw©Rw©Sw©Sw©Sw©Sw©Sw©Sw©Sw©Sw©Sw©SwªSwªSwªSxªSxªSxª/S…/S…FjœFjœFjœƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§ÙFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœFjœƒ§Ùƒ§Ùƒ§Ùƒ§ÙCg™Cg™Cg™}¡Ó}¡Ó}¡ÓCg™CgšCgšCgšCgšCgšCgšCgšChšChšChšChšChšChšChšChšChšChšDhšDhšDhš~¢ÔAe—Ae—Ae—Ae—Ae—Ae—Ae—Ae—Ae—Ae—Ae—Ae—Ae—%I{%I{%I{%I{%I{%I{%I{%I{%I{@d—@d—E:9D61m\Vwe]lXOuaX„k_¨‹z±|¡|e¥|c§|`©z]ªyXÂnÃlÄŽkÄŽidP’eP“fP“fP“fP’fP“fP“fP“fP[7 —U&”T%P%pTMsVMuWMxXNzYN|ZN~[N€\O‚]O„^O†_O‡`O‰aOŠbPŒbPcPŽdPdP‘eP’eQ“fQ”gQ•gQ–hQ—hQ˜iR™iRšjR›jR›jRœkRœkRkRkRžkRžlRžlRŸlRŸlRŸlRŸlR lR lR lR lR lR lR lR lR lR lR lR lR lRŸlRŸlRŸlRŸlRžkRžkRkRkQœkQœjQ›jQ›jQšiQ™iQ˜iQ˜hQ—hQ–gQ•gQ”fQ“fP’eP‘ePdPŽdPcPŒbPŠbP‰aO‡`O…_O„^O‚]O€\O~[N|ZNyYNwXNuWMrUM‡`G„^G–r]|ZFxXFtVEgY~eY{cXbLA[H?REA.R„.R„Rv©Rw©Rw©Rw©Sw©Sw©Sw©Sw©Sw©Sw©Sw©Sw©Sw©Sw©SwªSwªSxªSxªSxªSxªTxªTxªTxªƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§ÙFjFjFjFjFjFjFjFjFjFjFjƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§Ùƒ§ÙCg™Cgš}¡Ó}¡ÓCgšCgšCgšCgšChšChšChšChšChšChšChšChšChšDhšDhšDhšDhšDhšDhšDhšDhšDhšDhš~¢ÔAe—Ae—Ae—Ae—Ae—Ae—Ae—Ae—Ae—%I|%I|%I|%I{%I{%I{%I{%I{%I{%I{%I{%I{%I{%I{@e—@e—B99B51k[Vud]iWPr_Wye] †yªŒ|²}¡|e¤|c¾’w¨{^¨z\©yZÁp«xW«wU«wU«wU«wUÃŽlÃŽlÂŽlÂŽlkD(’S%ŒP%nSMoTMqUMsVMvWNxXNzYN|ZN~[N€\O‚]O„^O†_O‡`O‰aOŠaP‹bPcPŽcPdPeP’eQ“fQ”fQ•gQ–gQ–hQ—hQ˜iQ™iR™iRšjR›jR›jRœjRœkRœkRkRkRkRžkRžkRžlRžlRŸlRŸlRŸlRŸlRŸlRŸlRŸlRŸlRŸlRžlRžkRžkRžkRkRkQkQœkQœjQ›jQ›jQšjQšiQ™iQ˜iQ˜hQ—hQ–gQ•gQ”gQ“fQ’fP‘ePePdPŽcPcP‹bPŠaPˆaO‡`O…_Oƒ^O‚]O€\O~[N|ZNyYNwXNuWMrUMŸw_œv_˜t^~\GzYGvWF†j[fZ|dYybX\I@VGB5/2.R„.R„.R„.R„Sw©Sw©Sw©Sw©Sw©Sw©Sw©Sw©Sw©SwªSwªSwªSxªSxªSxªSxªTxªTxªTxªTxªFkFkFkFkƒ§Úƒ§Úƒ§Úƒ§Úƒ§Úƒ§Úƒ§Úƒ§Úƒ§Úƒ§Úƒ§Úƒ§Úƒ§Úƒ§Úƒ§Úƒ§Úƒ§Úƒ§Úƒ§Úƒ§Úƒ§Úƒ§Úƒ§ÚFkFkFkFkFkFkFkFkƒ§Úƒ§Úƒ§Úƒ§Úƒ§Úƒ§Úƒ§Úƒ§Ú}¡Ó}¡Ó}¡Ô}¡ÔChšChšChšChšChšChšChšDhšDhšDhšDhšDhšDhšDhšDhšDhšDhšDhšDhšDhšDhšDhšDhšDhš~£ÕAe˜Ae˜Ae˜Ae˜Ae˜%J|%I|%I|%I|%I|%I|%I|%I|%I|%I|%I|%I|%I{%I{%I{%I{%I{%I{@e—@e—<68?31gYVpa\bRMjYTq`Z€j`¡‡z«}²‘}¶’|¸’{º’z»’x¼’w§z^¿‘t¿‘s¿‘s¿s¿r¿r¾r¾r°h2‹O$„L$mSMnSMnTMoTMtVMvWNxXNzYN|ZN~[N€\O‚]O„^O…_O‡`OˆaOŠaP‹bPŒcPŽcPdPdP‘eP’eQ“fQ”fQ•gQ–gQ–hQ—hQ˜hQ˜iQ™iQšiQšiQšjQ›jQ›jQœjQœjQœkQœkQkQkRkRkRkRkRkRkRkRkRkQkQkQœkQœjQœjQœjQ›jQ›jQšjQšiQ™iQ™iQ˜hQ—hQ—hQ–gQ•gQ•gQ”fQ“fP’eP‘ePdPdPcPŒbP‹bP‰aPˆ`O†`O…_Oƒ^O]O€\O~[N|ZNyYNwXNtWM£z` y`w`šu_€]I|[HwXGˆl\ƒi[}eZycYr_WjZU;23.R„.R„.R„.R„.R….R….R…Sw©Sw©Sw©Sw©Sw©SwªSwªSwªSxªSxªSxªTxªTxªTxªTxª/S…/S…GkGkGkGkGkGkGkƒ¨Úƒ¨Úƒ¨Úƒ¨Úƒ¨Úƒ¨Úƒ¨Úƒ¨Úƒ¨Úƒ¨Úƒ¨Úƒ¨Úƒ¨Úƒ¨Úƒ¨Úƒ¨Úƒ¨Úƒ¨Úƒ¨Úƒ¨Úƒ¨Úƒ¨Úƒ¨ÚGkGkGkƒ¨Úƒ¨Úƒ¨Úƒ¨Úƒ¨Úƒ¨Úƒ¨Úƒ¨Úƒ¨Úƒ¨Úƒ¨Ú}¢Ô}¢Ô}¢Ô}¢Ô~¢ÔDhšDhšDhšDhšDhšDhšDhšDhšDhšDhšDhšDhšDhšDhšDhšDhšDhšDhšDhšDhšDhšDhšDhšDhš£ÕAf˜%J|%J|%J|%J|%J|%J|%J|%J|%J|%I|%I|%I|%I|%I|%I|%I|%I|%I|%I|%I|%I{%I{Ae—Ae—Ae—?89H=:?YUY`QGfVLudXjeitlm{po|qp}rp~rpsqsq€tqŒr_=1+xJ)’o[~[F€\G‚^H„_I…`IkRLlRMnSMpTMrVMuWMwXNyYN{ZN}[N~\N€\O‚]Oƒ^O„_O†_O‡`Oˆ`O‰aPŠbP‹bPŒcPcPŽcPdPdPeP‘eP’eP’fP“fQ“fQ”fQ”gQ•gQ•gQ•gQ–gQ–gQ–gQ–hQ–hQ—hQ—hQ—hQ—hQ—hQ–hQ–hQ–gQ–gQ–gQ•gQ•gQ•gQ”fQ”fQ“fQ“fP’eP‘eP‘ePdPdPŽdPŽcPcPŒbP‹bPŠaP‰aO‡`O†_O…_Oƒ^O‚]O€\O~\N}[N{ZNyYNwXNuWM“iOhOŽgO‹eOžze›yd—wd”tcrbtYKjTIaOG[KFj]Y^UU?;@.R….R….S….S….S….S….S….S…/S…/S…/S…/S…/S…/S…/S…/S…/S…/S…/S…/S…/S…/S…/S…GkžGkžGkžGkžGkžGkžGkžGkžGkžGkžGkžGkžGkžGkžGkžGkžGkžGkž…©Û…©Û…©Û…©Û…©Û…©Û…©Û…©Û…©Û…©Û…©ÛGlžGlžGlžGlžGlžGlžGlžGlžGlžGlžGlžGlžGlž…©Û…©Û…©Û…©Û…©Û…©Û£Õ£Õ£Õ£Õ£Õ£Õ£Õ£ÕDh›Dh›Dh›Dh›Di›Di›Di›Di›Di›¤Ö¤Ö¤Ö¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤ÖEi›Ei›&J|&J|&J|&J|&J|&J|&J|&J|&J|&J|&J|&J|&J|%J|%J|%J|%J|%J|%J|Af˜Ae˜Ae˜%J|%J|%J|%I|%I|%I|%I|#-#%.()1MEAQIEUMI]SL]TM=4.1+(=.#6,&5( 1%"ŒlYn[“p\•r]]Hƒ_I…`JœwažybkRLmSMpTMrUMtVMvWNxXNzYN|ZN}[N\N€]O‚]Oƒ^O…_O†_O‡`OˆaO‰aPŠaP‹bPŒbPcPŽcPŽdPdPdPeP‘eP‘eP’eP’fP“fP“fQ“fQ”fQ”fQ”fQ”gQ”gQ•gQ•gQ•gQ•gQ•gQ”gQ”fQ”fQ”fQ”fQ“fQ“fP“fP’eP’eP‘eP‘ePdPdPdPŽcPcPŒcPŒbP‹bPŠaP‰aO‡`O†_O…_Oƒ^O‚]O]O\O}[N|ZNzYNxXNvWN¬‚gªg¨€ghPŒfPŸ|fœzf˜xe”vdscsYLiTK_NHYKFh\Z]UV=;@.R….S….S….S….S….S….S…/S…/S…/S…/S…/S…/S…/S…TxªTxªTxªTxªTxª/S…/S…/S…/S…GlžGlžGlžGlžGlžGlžGlžGlžGlžGlžGlžGlžGlžGlžGlžGlžGlžGlžGlžGlž…©Û…©Û…©Û…©Û…©Û…©Û…©ÛGlžGlžGlžGlžGlžGlžGlžGlžGlžGlžGlžGlžGlžGlžGlžGlžGlžGlž…©Û…©Û…©Û…©Û£Õ£Õ£Õ£Õ£Õ£Õ£Ö£ÖDi›Di›Di›Di›Di›Di›¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤×€¤×€¤×€¤×Ei›&J|&J|&J|&J|&J|&J|&J|&J|&J|&J|&J|&J|&J|&J|&J|&J|Bf˜Bf˜Af˜Af˜Af˜Af˜Af˜%J|%J|%J|%J|%J|%J|%I|%I|%I|, +,!.! "`E6†iYŒlZo\“q]•s^^J™va›wbycŸzd {e¤}foTMqUMsVMuWNwXNyYN{ZN|ZN~[N\O]O‚]Oƒ^O…_O†_O‡`Oˆ`O‰aOŠaP‹bPŒbPŒcPcPŽcPŽdPdPdPdPeP‘eP‘eP‘eP’eP’eP’eP’eP’fP’fP’fP“fP’fP’fP’fP’eP’eP’eP‘eP‘eP‘ePePdPdPdPŽdPŽcPcPŒcPŒbP‹bPŠaP‰aOˆ`O‡`O†_O…_Oƒ^O‚]O]O\O~[N|[N{ZNyYNwXN®ƒi¬ƒiª‚i¨i¦€hŒhR‰fQ†dQ‚bP•wfx]Oˆpdkbtd_m`]OEDG?A;:@.S….S….S….S….S…/S…/S…/S…/S…/S…/S…/S…/S…TxªTxªTxªTxªTxªTx«Tx«Tx«Ty«/S†GlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlž…ªÜ…ªÜ…ªÜHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlž…ªÜ…ªÜ£Ö£Ö£Ö£Ö¤Ö¤Ö¤Ö¤Ö¤ÖEi›€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤×€¤×€¤×€¤×€¥×€¥×€¥×Bg™Bg™Bg™Bg™Bg™&J|&J|&J|&J|&J|&J|&J|&J|&J|&J|&J|&J|&J|Bf˜Bf˜Bf˜Bf˜Bf˜Bf˜Bf˜Bf˜Bf˜Af˜Af˜%J|%J|%J|%J|%J|%J|%J|%J|%J|%J|%I|%I|%I|%I|%I|%I| +,YA5jPBpSD‹l[o]’q^–t`‚_Kšwbœycžze {f¡}g¤h¨i”lSrVMtWMvWNxXNyYN{ZN|[N~[N\O]O‚]Oƒ^O„_O…_O†`O‡`Oˆ`O‰aPŠaP‹bP‹bPŒbPcPcPŽcPŽcPdPdPdPdPdPdPdPdPePePePePePdPdPdPdPdPdPdPŽcPŽcPcPcPŒbP‹bP‹bPŠaP‰aOˆ`O‡`O†`O…_O„^Oƒ^O‚]O€]O\O~[N|[N{ZNyYNxXN°…j®„j¬„jªƒj¨‚j¦€jŒhSŠgS†eRƒcR|`QŒsf…oe}jcrd`k_]LCDC=@,,3(4F(4F.S….S…/S…/S…/S…/S…/S…/S…/S…TxªTxªTxªTxªTxªTxªTx«Tx«Tx«Ty«Ty«Ty«…ªÜHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlž†ªÜHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžChšChš¤Ö€¤Ö€¤Ö€¤Ö€¤ÖEi›Ei›Ei›€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤Ö€¤×€¤×€¤×€¤×Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Bg™Bg™&J|&J|&J|&J|&J|&J|&J|&J|&J|&J|Bf˜Bf˜Bf˜Bf˜Bf˜Bf˜Bf˜Bf˜Bf˜Bf˜Bf˜Bf˜Bf˜Bf˜Bf˜&J|%J|%J|%J|%J|%J|%J|%J|%J|%J|%J|%J|%I|%I|%I|%I|%I|#5H71O;3V?4iOBoSDsVFo]{[I^Kƒ`L…bN‡dOŸ{f }g¢~h¥€j’kT•mU˜oVšqWrWwXNxXNzYN{ZN}[N~[N\O€]O‚]Oƒ^O„^O…_O…_O†`O‡`Oˆ`O‰aO‰aPŠaP‹bP‹bPŒbPŒbPŒcPcPcPcPŽcPŽcPŽcPŽcPŽcPŽcPŽcPŽcPŽcPŽcPcPcPcPŒcPŒbP‹bP‹bP‹bPŠaP‰aP‰aOˆ`O‡`O†_O…_O„_O„^Oƒ^O]O€\O\N~[N|ZN{ZNyYN›oTšoT™oT—nT¬„lªƒl¨‚ljUŒiTŠhT†fT€cSvi‰rgnfyidqdah^^HBD?<@)+3OZkMYk(5F(5F(5F/S…/S…/S…/S…/S…TxªTxªTxªTxªTxªTxªTx«Tx«Ty«Ty«Ty«Ty«Uy«†ªÜ†ªÜ†ªÜ†ªÜHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlž†ªÜ†ªÜ†ªÜ†ªÜ†ªÜHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžDhšDhšDhšChš&K}&K}&K}&K}&K}&K}ChšChšCgšCgšCgšCgšCgšCgšCg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™&J|&J|&J|&J|&J|&J|Bg™Bg™Bg™Bf™Bf™Bf™Bf™Bf™Bf˜Bf˜Bf˜Bf˜Bf˜Bf˜Bf˜Bf˜Bf˜Bf˜Bf˜&J|&J|&J|&J|%J|%J|%J|%J|%J|%J|%J|%J|%J|%J|%J|%I|%I|A99N?;L:2T>4gNBlRD‡k\‹n^z[J~^LaN…cO‡dP‰fQŠgRŒhTjU’lV•nW˜pXšrXsY¶‹q¸qºŽr¼r½r¿s©z[©z[ªz[«{[¬{[¬{ZÅ“rÅ’qÅ’qÅ’pÅ’pÅ‘o­yV­xV¬xU¬wT¬wTŠaPŠbP‹bP‹bP‹bP‹bP‹bP‹bP‹bP‹bP‹bP‹bP‹bP‹bPŠaPŠaPŠaP‰aP‰aOˆaOˆ`O‡`O‡`O†_O…_O„^Oƒ^O‚^O‚]O]O€\O~\N}[N|ZNzYNpTœpU›pUšpU˜oV—oV•nV“mV‘lVkVŒjVˆhVƒfU~cUuj†qh~mfugdkaad\^E@D98?$(2minffm^blV^lMYk(5F(5F/S…TxªTxªTxªTxªTxªTxªTxªTx«Tx«Ty«Ty«Ty«Uy«Uy«†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜHlžHlžHlžHlžHlŸHlŸHlŸHlŸHlŸHlŸHlŸHlŸHlŸHlŸHlŸ†ªÝ†ªÝ†ªÝ†ªÝ†ªÝ†ªÝ†ªÝ†ªÝ†ªÝ†ªÝHlŸHlŸHlŸHlŸHlŸHlŸHlŸHlŸHlŸHlŸHlŸHlŸHlŸHlŸHlŸHlŸHlŸHlŸHlŸHlŸHlŸ'K}'K}'K}'K}'K}'K}'K}'K}'K}&K}&K}ChšChšChšChšChšChšChšCgšCgšCgšCgšCgšCgšCg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™&J|Cg™Cg™Cg™Cg™Cg™Bg™Bg™Bg™Bg™Bg™Bg™Bf™Bf™Bf™Bf™Bf™Bf˜Bf˜Bf˜Bf˜Bf˜Bf˜Bf˜Bf˜&J|&J|&J|&J|&J|&J|&J|%J|%J|%J|%J|%J|%J|%J|Ae˜Ae˜;GY<68I=:I82Q=4XA6~fZ„j\‰m^p`|]L€`NƒcP†eQˆgS¡j£€l¦‚m©„n•oX˜qYšrZt[¶Œr¸sºs¼t½t¾‘t¨z]©{]ª{]«{\«{\¬{\¬{[Ä“sÄ“rÄ’rÄ’qÄ’pÄ‘p¬yWÄoÃnÃmÃlÂŽlÂŽkÁkˆaOˆaOˆaOˆaOˆaOˆaOˆaOˆ`Oˆ`O‡`O‡`O‡`O†`O†_O…_O…_O„_O„^Oƒ^O‚]O]O€]O\O~\N}[N|ZN¶‰l¶‰lµˆmœqV›qVšqV™pW˜pW–oW¬…nª…n§„n¤‚nŸ€n›~n€eW‘xlŠtk‚piykfodcf_`JDG@>C*,5$1MYktr~tstmolinadmX_lNZkMZkTxªTxªTxªTxªTx«Tx«Tx«Ty«Ty«Ty«Uy«Uy«Uy«†ªÝ†ªÝ†ªÝ†ªÝ†ªÝ†ªÝ†«Ý†«Ý†«Ý†«ÝHlŸHlŸHmŸHmŸHmŸHmŸHmŸHmŸHmŸHmŸHmŸHmŸ†«Ý†«Ý†«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«ÝHmŸHmŸHmŸHmŸHmŸHmŸHmŸHmŸHmŸHmŸHmŸHmŸHmŸHmŸHmŸHmŸHmŸHmŸHmŸHmŸ'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}DhšDhšDhšDhšChšChšChšChšChšChšChšCgšCgšCgšCgšCgšCgšCg™Cg™Cg™Cg™Cg™&J}&J}&J}Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Bg™Bg™Bg™Bg™Bg™Bg™Bf™Bf™Bf™Bf™Bf˜Bf˜Bf˜Bf˜Bf˜&J|&J|&J|&J|&J|&J|&J|&J|&J|&J|Af˜Af˜Af˜Af˜;GY;GY;GY1'!D:9N?;N;3]I?zdY€h[†l^‹oasc“ue€bQ„dR‡fT l¢m¦ƒn©…o«‡p®ˆq±Šr³‹sžv] w]¹u»u¼‘u¾‘u¿’v¨{^©{^ª|^«|]«|]«{\¬{\¬{[¬{[¬zZ«zZ«yY«yX«xXÂoÂnÂnÁŽmÁŽm¨uT¨uS§tS§tS§tR¦sR¦sQ…_O…_O…_O„^O„^Oƒ^Oƒ^O‚^O‚]O]O€]O¢rS¡rS¡rS¸‰k·‰l·‰l¶‰m¶‰mµ‰m´‰n³‰n›qWšqX™qX®‡o­‡o«†p¨…p¤ƒp pœp—}o{cXv`Vp]U}nishfhaba\_DAF::B$)4MYkMYkMYkŒtctq\QPPIKFDI;>H/8GMZkTxªTx«Tx«Tx«Ty«Ty«Ty«Uy«Uy«Uy«†«Ý†«Ý†«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«ÝHmŸHmŸHmŸImŸImŸImŸImŸImŸ‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«ÝImŸImŸImŸImŸImŸImŸImŸImŸImŸImŸImŸImŸImŸImŸImŸImŸImŸImŸ'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}DhšDhšDhšDhšDhšDhšDhšDhšDhšChšChšChšChšChšChšChšChšCgšCgš&K}&K}&K}&K}&J}&J}Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Bg™Bg™Bg™Bg™Bg™Bg™Bf™Bf™Bf™Bf™Bf˜Bf˜&J|&J|&J|&J|&J|&J|Bf˜Bf˜Bf˜Bf˜Bf˜Bf˜;HY;HY;GY;GY;GY;GY;,#I=:H82YF?^JA|e[‚j]ˆn`Œqcte”wg—yiš|k~l €n£‚o¤ƒp¦…q­‰s°Šs›u]žv^Ÿw^¡x_£y_¤z_¥z_¦{_¿“w¿“wÀ“vÁ“vÁ“v“u“u“tª{\ª{\ªz[ªzZªyZªyY©xXÁpÀo¨wW¨vV§vV§uU¦uU¦uT¥tT½Œl¼‹k¼‹k¼‹k»‹k»‹kºŠk¢sT¢rT¢rT¡rT¡rT¡rU rU rV·Šn¶ŠnµŠnµŠo´Šo³‰o²‰p±‰p™qY®ˆq¬‡qª†r§…r¤„r ‚rœ€q€gZ{dYvaXp^WiYU`TRVNOb]aEBH<+[NL^SQWNNKFJ?AI2:HTx«Ty«Ty«Ty«Uy«Uy«Uy«Uy«Uy«‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«ÝImŸImŸImŸImŸ‡«Ý‡«Ý‡«Ý‡«Ý‡«Þ‡«Þ‡«Þ‡«Þ‡«Þ‡«Þ‡«Þ‡«Þ‡«Þ‡«Þ‡«Þ‡«Þ‡«Þ‡«Þ‡«Þ‡«Þ‡«ÞImŸImŸImŸImŸImŸImŸImŸImŸImŸImŸImŸImŸImŸImŸImŸImŸ'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}DhšDhšDhšDhšDhšDhšDhšDhšDhšDhšDhšDhšDhšDhšChš&K}&K}&K}&K}&K}&K}&K}&K}&K}&K}CgšCg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Bg™Bg™Bg™Bg™Bg™Bg™Bf™Bf™Bf™&J|&J|Bf˜Bf˜Bf˜Bf˜Bf˜Bf˜Bf˜Bf˜Bf˜;HY;HY;HY;HY;HY;HY;GY3("D::B41RB=YG@wcZ}g\ƒk_‡nbŒrdug}aRdT„gV‡iX‰kY¢ƒq¤„r¥…s§†t‘p^’q^Ÿw` x`¢y`£z`¤za¥{a½“x¾“x¿“w¿“wÀ“wÀ“vÀ“vÀ“vÀ“uÀ’uÀ’tÀ‘sÀ‘sÀ‘r¿r¿q¿q¾p¾Žp¾Žo½Žo¥vW¼n¼Œn»Œn»Œn»ŒnºŒnº‹m¢tV¡sV¡sV¡sV sV sWŸsWŸsXžsXµŠpµŠp´ŠpœsY›sYšrZ˜r[–r\”q\‘p]¦†t£„tŸƒsœs€h\{e[vbYo^XhZV`USXPQNJMECJRS[47A+((MYkMYkMYkMZk(5F(5F(5FOHJT=+YML_SRZQQMGJABI2:H/T†Uy«Uy«Uy«Uy«Uy«Uy«‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Þ‡«Þ‡«Þ‡«Þ‡«Þ‡«Þ‡«Þ‡«Þ‡«Þ‡«Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬ÞImŸImŸImŸImŸImŸImŸImŸImŸImŸImŸImŸImŸˆ¬Þˆ¬Þ'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}DhšDhšDhšDhšDhšDhšDhšDhšDhšDhšDhšDhš'K}'K}'K}'K}'K}'K}&K}&K}&K}&K}&K}&K}&K}&K}CgšCgšCgšCgšCg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Bg™Bg™Bg™Bg™&J|&J|Bf™Bf™Bf™Bf™Bf˜Bf˜Bf˜Bf˜Bf˜;HY;HY;HY;HY;HY;HY>DM>DM;HY89<:+#9&B52I94ZHAxd[}g^k`†nc‹rey_R}bTeVƒgX…iYˆk[Šl\Œn]o^¥‡v§ˆvšvaœwažxa yb¢zb¤{b¤{a¼“x½“x¦|a§|a§|`§{`§{_§{_§{^§z^¾‘u¾‘t¾‘t¾s½s½r½r¥wZ¤wZ¤vY¤vY£vY£uX¢uX¢uX¢uX¹Œp¸Œp¸Œp·Œp·‹p¶‹p¶‹pµ‹qµ‹qtZ›t[šs\™s\˜s]–r]”r^’q^p^o^Šn^‡l^ƒj^h]{f\ub[n^YgZW_UTWPQOKOEEKST]JNY>=?JJIMYkMYk(5F(5F(5F(5F(5F)5G)5GK=4S<*XMLbWVYPPLGJ@AI/T†/T†Uy«Uy«Uy«‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬ÞImŸImŸImŸIm ˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬ÞIm Im Im Im Im Im Im Im ˆ¬Þˆ¬Þˆ¬Þˆ¬Þ'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}Dh›Dh›Dh›Dh›DhšDhšDhšDhš'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}&K}&K}&K}&K}ChšChšCgšCgšCgšCgšCgšCg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™Cg™&J|&J|&J|&J|&J|Bg™Bg™Bg™Bf™Bf™Bf™Bf™Bf˜Bf˜;HY;HY;HY;HY;HY;HYCIR>DMCIR;HYCIR.$0"8&?*G/V=+w[F{g^€kanXMs\Px_S{bU~dWfYƒhZ†j\ˆl]Šm^¢…v§ˆwªŠx­Œy¯y±Žz´zµz·‘z¹’z£{b£{b¤{b¥{b¥{a¥{a¥{`¥{`¥z_¥z_¥z^¼‘u¥y]¤y]¤x]¤x\£w\£w[¢w[¢v[¢v[¡v[¡v[¸r·r¶r¶ŒsµŒs´Œs´Œs²Œt±‹u°‹u˜t^–s_•s_“r_’r`q`p`¡…wž„v›‚v—€u“~twd]sb[l^ZeYW]TUUORLJOYYaRU^JOZ>>@!$)RXaMYk39B-3<-3<(5F)5G)5G)5G)5G)5GFDJK9*^K=YONg\\TLMIFJ:>I0T†0T†ImŸˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬ÞIm Im In In In In In In ˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬ßˆ¬ßˆ¬ßˆ¬ßˆ¬ßˆ¬ßˆ¬ßˆ¬ßˆ¬ßˆ¬ßˆ¬ßˆ¬ßˆ¬ßˆ¬ßˆ¬ßˆ¬ßIn In In In In ˆ¬ßˆ¬ßˆ¬ßˆ¬ßˆ¬ßˆ¬ß'K~'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}Di›Di›Dh›'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}&K}ChšChšChšChšChšCgšCgšCgšCgšCgšCg™Cg™Cg™Cg™Cg™Cg™&J}&J}&J}&J}&J|&J|&J|&J|&J|Bg™Bg™Bg™Bg™Bg™Bf™Bf™EM>EMCIR;HY;HYCIRCIR)6&8&@*H0I1!\B0}_JhTKjM8q[Pt]Sw`U{cW~eYg[ƒi\…k^‡m_Ÿ…v¢†w¥ˆx¨Šyª‹z­z¯Ž{±{²{³{´{žzdŸzd zc zc¡zc¸‘y¸‘y¸‘y¸‘x¸x¸x·w·w·w·wŸw_Ÿw_žw_µŽv´Žv³v²v²w±w°Œw¯Œw®Œw­‹w«‹xªŠx¨‰x¦‰x¥ˆx£‡x¡†xž…x›ƒw—v’~vŽ|t‰ys„vrh\YcXX[TUSNRIHOUXaNS^JFE>>A')+"%(4:C(5F(5F3:B3:B-3<-3<)5G)5G)5G)5G)5G)5GE:4O:*TKLbXWcZZPIKDCJIm Im Im Im ˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬ßˆ¬ßˆ¬ßˆ¬ßIn In In In In In Jn Jn Jn Jn Jn ˆ­ßˆ­ßˆ­ßˆ­ßˆ­ßˆ­ßˆ­ßˆ­ßˆ­ßˆ­ßˆ­ßˆ­ßˆ­ßˆ­ßˆ­ßˆ­ßˆ­ßˆ­ßˆ­ßˆ­ßˆ­ß‰­ß‰­ß‰­ß‰­ß‰­ßJn ‰­ß‰­ß‰­ß‰­ßˆ­ßˆ­ßˆ­ßˆ­ß'K~'K~'K~'K~'K~'K~'K~'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}DhšDhšDhšChšChšChšChšChšChšCgšCgšCgšCgš&K}&K}&J}&J}&J}&J}&J}&J}&J}&J}&J|&J|&J|Cg™Cg™Cg™Bg™Bg™Bg™EMCIRCIRCIR888DGNCJRCIRBBB(0 8&<)G0M5"X@0z^K†bFŠkUlXPp[Rs^TvaVzcX}fZg\i]™u›‚v„wŸ†x¢‡y¥‰z§Šz©‹{ªŒ{•ve–ve—we˜we°|°|±{²{²{²{²{²{±z±z±Žz±Žz±Žz°Žy™vb˜vb—vb–ub•ub•uc”tc“tc’sbscrcqc¢‡y †y…y›„x˜‚x•w’w|uˆytƒvs~sqyooslmVQTOLR[\dQU`KHHAAD:<@68; &Z`i-4<%');AJ4:C4:C4:C-4<)5G)5G)5G)5G)6G)6G@84H8-N?5YPQmccoghd`dIn In In In In In ˆ¬ßˆ¬ßˆ­ßˆ­ßˆ­ßˆ­ßˆ­ßˆ­ßˆ­ßˆ­ßJn Jn Jn Jn Jn Jn Jn Jn Jn Jn Jn Jn Jn Jn Jn Jn ‰­ß‰­ß‰­ß‰­ß‰­ß‰­ß‰­ß‰­ß‰­ß‰­ß‰­ß‰­ß‰­ß‰­ß‰­ß‰­ß‰­ß‰­ß‰­ß‰­ß‰­ß‰­ß‰­ßJn Jn Jn ‰­ß‰­ß‰­ß‰­ß‰­ß‰­ß‰­ß'K~'K~'K~'K~'K~'K~'K~'K~'K~'K~'K~'K~Ei›Ei›Ei›Ei›'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}DhšDhšDhšDhšDhšDhšChšChšChš&K}&K}&K}&K}&K}&K}&K}&K}&J}&J}&J}&J}&J}&J}&J}&J}&J}Cg™Cg™Cg™Cg™B9;>68;Z`iZ`iMZk)5G4:C-4<4:C4:C-4<;BJ)5G)6G)6G)6G)6G)6GC6-L;.leg„{{ypqhbeVYcJn Jn Jn Jn Jn Jn Jn ‰­ß‰­ß‰­ß‰­ß‰­ß‰­ßJn Jn Jn Jn Jn Jn Jn Jn Jn Jn Jn Jn Jn Jn Jn Jn Jn Jn Jn Jn ‰­ß‰­ß‰­ß‰­ß‰­ß‰­ß‰­à‰­à‰­à‰­à‰­à‰­à‰­à‰­à‰­à‰­à‰­à‰­à‰­àJn¡Jn¡Jn¡Jn¡Jn¡Jn¡Jn¡‰­à‰­à‰­à‰­à‰­à'L~'L~'L~'L~'L~'L~'K~'K~'K~Ei›Ei›Ei›Ei›Ei›Ei›Ei›Ei›'K~'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}DhšDhšDhšDhšDhš'K}'K}'K}'K}&K}&K}&K}&K}&K}&K}&K}&K}&K}&K}&K}&J}&J}&J}&J}&J}&J}Cg™Cg™Cg™<535=AG=?D?AD==1(B3)B2&F4'E4)gTGlXJs^OzcTzaPqfethgvjhbVTcWUdXVeYWfZXg[Yh\Zi]Zi][j^\€us€ususts~tt~tt}tt|st{stut~tt|sszrsyqrwpquoqsmpqloXTXTQWPOULLSSJEA<:=99757335./2113)+.'),)+.8:="(3@QJMPV\eT[cNZlNZlZ`iZ`iZ`iZ`iSYbY`h4;C.4=)6GCPaCPaCPaCPaCPaEQbZOGa_emhkŠƒ„nfgeaeJn¡Jn¡Jn¡Jn¡Jn¡Jn¡Š®àŠ®àŠ®àŠ®àŠ®àJo¡Jo¡Jo¡Jo¡Jo¡Jo¡Jo¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Š®àŠ®áŠ®áŠ®áŠ®áŠ®áŠ®áŠ®áKo¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡ƒ§Úƒ§Úƒ§Úƒ¨Úƒ¨Úƒ¨Úƒ¨Úƒ¨Ú„¨Ú„¨Ú„¨Ú„¨Ú„¨Ú„¨ÚEjœEiœEiœEiœEiœ'L~'L~'K~'K~'K~'K~'K~'K~'K~'K~'K~'K~'K~'K}'K}'K}'K}'K}'K}'K}Di›Di›Di›Di›Dh›Dh›'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}&K}&K}&K}&K}&K}&K}&K}&K}&K}$.>=I[=I[2)>0&A2'C3(I8-^OFbRHfUJjXMq^RwcVzfYfRDfQCdN@zdTqijrjksklrklrklrklqjmpjmpjmojmojmnimmimkhliflscYm`Xg\VbYT^VRE>;A<:>98:77645:873220/0,-/)+.*,/#%( &15;5BSKKKJMP]dlU[dNZlNZlZ`iTZcZaiZaiZ`iZ`iSZbŽ”LS[V]eDPbDPbDPbDPbDPbDPbWMF^^diei®”†…rkeaeJo¡Jo¡Jo¡Jo¡Š®àŠ®àŠ®àŠ®àŠ®àŠ®àŠ®àŠ®àŠ®àKo¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Š¯áŠ¯áŠ¯áŠ¯áKo¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡ƒ¨Úƒ¨Ú„¨Ú„¨Ú„¨Ú„¨Ú„¨Ú„¨Ú„¨Ú„¨Ú„¨Ú„¨Ú„¨Ú„¨Ú„¨Ú„¨Ú„¨Ú„¨Û„¨ÛGk'L~'L~'L~'L~'L~'L~'K~'K~'K~'K~'K~'K~'K~'K~'K~'K~Ei›Ei›Ei›Ei›Ei›Di›Di›Di›Di›Di›'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}&K}&K}&K}&K}&K}%/> ,>=I[=I[ ,> ,>#)2(.7#)2(.7#)2#)2#)2#)2(.7(.7(.767@D>A214$+3#%("$'###""""""&&&888888cB*}\I@!%+%!5*$:/(;0)<1*>3+@4+>1(bUKN@6OA6L=3QB8M?4_RKaTLbUMcVNcVNcVObVOaVOaUO`UO_UO^UO^TO\SOYRNWPNUOMWPKYSOWRN;63953:76755333,/2'),%(+"%(!' "&,KXi04:JMP]_b^emU[dNZlNZlT[cU[dU[dU[d[aj•ž•ž•žˆŽ—–¥W]fDPbDPbDPbDPbDPbDPb‘nSž…w—|m¨‚ƒqjKo¡Ko¡Ko¡Š®àŠ®àŠ®àŠ®áŠ®áŠ®áŠ®áŠ®áŠ®áŠ¯áŠ¯áŠ¯áKo¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¡Ko¢Ko¢Ko¢Ko¢Ko¢Ko¢Ko¢Ko¢Ko¢Ko¢Ko¢Ko¢Ko¢Ko¢Ko¢Kp¢Kp¢Kp¢Kp¢Kp¢Kp¢Kp¢Kp¢Kp¢Kp¢Kp¢Kp¢Kp¢Kp¢Kp¢Kp¢Kp¢Kp¢Kp¢Kp¢Kp¢Kp¢„¨Ú„¨Ú„¨Ú„¨Ú„¨Ú„¨Ú„¨Ú„¨Ú„¨Ú„¨Ú„¨Ú„¨Û„¨Û„¨Û„¨Û„¨Û„©Û„©Û„©Û„©ÛGkGkGkGkGkGk'L~'L~'L~'L~'K~'K~'K~Ei›Ei›Ei›Ei›Ei›Ei›Ei›Ei›Ei›Ei›Ei›Ei›Di›Di›'K}'K}'K}'K}HlžHlžHlžHlžHlžHlžHlžHlž'K}'K}'K}'K}'K}'K}'K}'K}'K}'K}&K}*2? ->=I[=I[ ,> ,> ,>#)2#)2#)2(.7(.7#)2#)2(.7(.7(.7(.7/28:79G@A<89',4#%(#%(######""""""8888888887'vS:‹jW;) + &3#.$-% .% .& /&!,#,#@70A71XNHXNHWNHWNHZRLYQLYQLXQLWQLWPLUOLSNLQMKOLJMJJ0//.-.,,-&(+"(!' 15;6CT37=MMMKMP^ad_enY`hNZlNZlU\dV\eŠ‘™Š™Š™–Ÿ–Ÿ–ž•ž“œ—¦Œ’›ƒ¡DQbDQbDQbDQbDQbMUc¤ƒ‘ylŸ‡|€oiKo¡Š¯áŠ¯áŠ¯áŠ¯áŠ¯áŠ¯áŠ¯á‹¯á‹¯á‹¯á‹¯á‹¯á‹¯á‹¯á‹¯á‹¯áKo¢Ko¢Ko¢Ko¢Ko¢Ko¢Ko¢Kp¢Kp¢Kp¢Kp¢Kp¢Kp¢Kp¢Kp¢Kp¢Kp¢Kp¢Kp¢Kp¢Kp¢Kp¢Kp¢‹¯â‹¯â‹¯â‹¯âLp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢„¨Ú„¨Ú„¨Ú„¨Ú„¨Ú„¨Û„¨Û„¨Û„¨Û„©Û„©Û„©Û„©Û„©Û„©Û…©Û…©Û…©Û…©Û…©Û…©ÛGkžGkžGkžGkžGkžGkžGkžGkžGkž…©Û…©Ü…©Ü…©Ü…©Ü…©Ü…©Ü…ªÜ…ªÜ…ªÜ…ªÜ…ªÜ…ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlž'K}'K}'K}'K}'K}'K}'K}'K}'K}HO\=J[=J[=J[ -> ,> ,>(.7#)2#)2(.7(.7(.7#)2(.7(.7(/7(/7)/8/28114H7,99@.05&,5$&)$$$######"""(((8888888888888884"nO9„gXˆjZE/ (-" + %' %$#" ! !$ 48>7CU:GX JJJLLLKMPagp_enNZlLPV˜Ÿ§Œ’›Œ’›Œ’›‹’š‹‘šŠ‘™‘— –Ÿ–Ÿ–Ÿ“œ“œ—¦„¢„¢DQbDQbDQbDQbNVc…uo‡rjѼ³º«§‹¯á‹¯á‹¯á‹¯á‹¯á‹¯á‹¯á‹¯á‹¯á‹¯á‹¯á‹¯á‹¯á‹¯á‹¯á‹¯á‹¯á‹¯áKp¢Kp¢Kp¢Kp¢Kp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢‹°â‹°â‹°â‹°âŒ°âŒ°âŒ°âLp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢„¨Û„¨Û„¨Û„©Û„©Û„©Û„©Û„©Û„©Û…©Û…©Û…©Û…©Û…©Û…©Û…©Û…©Û…©Û…©Û…©Û…©ÛGkžGkžGkžGlžGlžGlž…©Ü…©Ü…©Ü…ªÜ…ªÜ…ªÜ…ªÜ…ªÜ…ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlž'K}'K}'K}'K}DhšDhšDhšIP\=J[=J[=J[=J[ -> ->(.7#)2#)2(.7(.7(.7#)2(.7(/7(/7)/8)/8)/803966:E?AC>A856,07%'*%')$$$######(((DDDBBB8888888880 cF1w]OcS{`QS;+57'   *      ;?E7CU;HY=I[ JJJMMMKMPacfbhq‘— ƒ¡ƒ¡‘— “œ“œ“œŒ“›Œ’›Œ’›‹‘š‘— ‘— —Ÿ™Ÿ¨”œ“œ“œ„‘¢„‘¢„‘¢„‘¢EQcHScNVd´¨§¿®¨Èµ®¯‘‹¯á‹¯á‹¯á‹¯á‹¯á‹¯á‹¯á‹¯â‹¯â‹¯â‹¯â‹¯â‹¯â‹°â‹°â‹°â‹°â‹°â‹°â‹°âLp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Œ°âŒ°âŒ°âŒ°âŒ°âŒ°âŒ°âŒ°âŒ°âŒ°âŒ°âLp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp¢Lp£Lp£Lp£Lp£Lp£Lp£Lp£Lp£Lp£Lp£Lp£„©Û„©Û„©Û…©Û…©Û…©Û…©Û…©Û…©Û…©Û…©Û…©Û…©Û…©Û…©Û…©Û…©Û…©Û…©Û…©Ü…©Ü…©ÜGlžGlž…ªÜ…ªÜ…ªÜ…ªÜ…ªÜ…ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÝHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlž‡«Ý‡«ÝDhšDhšDhšDhš=J[=J[=J[=J[=J[=J[ ->(/7#)2#)2(.7(.7(.7#*2(/7)/8)/8)/8)/8)08*0903:56:88@KBB=;@348*08&(+'(*%%%$$$(((EEE(((&&&">-"bF3oXMs[Ow]Py^PqbpXMdH5R<,Q;, &%%#'-"'-&3DS_qP\nR_p>J\?K]AG@B::@66:-29'),)'%BBBFFFEEE)))))))))&&& @@@FFFACFZ\_[ajagp„¢„¢„¢ž¥­Ÿ¦®—¦–¥–ž•žŽ•Ž””œ“œ‘— —Ÿ›¡ªš ©™ ¨Ž•Ž”Ž”…‘£…‘£…‘£EQcGRcKTdPWd­¥§¿¯ª‹°âŒ°âŒ°âŒ°âŒ°âŒ°âŒ°âŒ°âŒ°âŒ°âŒ°âŒ°âŒ°âŒ°âŒ°âŒ°âŒ°âŒ°âŒ°âŒ°âŒ°ãŒ°ãŒ°ãŒ°ãŒ°ãLp£Lp£Lq£Lq£Lq£Lq£Lq£Lq£Lq£Œ±ãŒ±ãŒ±ãŒ±ãŒ±ãŒ±ã±ã±ã±ã±ã±ã±ã±ã±ã±ã±ã±ã±ãMq£Mq£Mq£Mq£Mq£Mq£Mq£Mq£Mq£Mq£Mq£Mq£Mq£Mq£Mq£…©Û…©Û…©Û…©Û…©Û…©Û…©Ü…©Ü…©Ü…©Ü…©Ü…ªÜ…ªÜ…ªÜ…ªÜ…ªÜ…ªÜ†ªÜHlžHlžHlžHlžHlž†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÝ†ªÝ†ªÝ†ªÝ†ªÝ†«Ý†«Ý†«Ý†«Ý†«Ý†«Ý†«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«ÝHlžHlžHlŸHlŸHlŸHlŸHlŸ‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Þ‡«Þ‡«Þ‡«ÞŸ>J\>J\=J[=J[=J[=J[FLU39B#*2(/7)/7)/8$*3$*3$*3)/8)08*09*09*19',5(-5*.6.17338@<=G@BH@BXW]UUXLPWFHKDFHKKKHHH+++%%%%%%$$$###!!!!!!777777777777777777777AAAFFFACFACF\^aeltbhqDQbDQbDQbŸ¥®¡§°¡§°¡§°¡§°—¦–Ÿ”š£”š£“™¢’™¡’˜¡‘˜ ‘— ›¡ª›¡ªš ©•ž™Ÿ¨Ž”ERcERcERcERcHScLUdRXd|njŒ°âŒ°âŒ°âŒ°âŒ°âŒ°âŒ°âŒ°âŒ°âŒ°âŒ°ãŒ°ãŒ°ãŒ°ãŒ°ãŒ±ãŒ±ãŒ±ãŒ±ãŒ±ãŒ±ãŒ±ãŒ±ã±ã±ã±ã±ãMq£Mq£Mq£Mq£Mq£Mq£±ã±ã±ã±ã±ã±ã±ã±ã±ã±ã±ã±ã±ã±ã±ã±ã±ã±ã±ã±ã±ã±ãMq£Mq£Mq£Mq£Mq£Mq£Mq£Mq£Mq£Mq£Mq£Mq£Mq£…©Ü…©Ü…©Ü…©Ü…©Ü…ªÜ…ªÜ…ªÜ…ªÜ…ªÜ…ªÜ†ªÜ†ªÜ†ªÜ†ªÜHlžHlžHlžHlžHlžHlžHlžHlžHlž†ªÜ†ªÜ†ªÜ†ªÝ†ªÝ†ªÝ†ªÝ†ªÝ†ªÝ†«Ý†«Ý†«Ý†«Ý†«Ý†«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«ÝHlŸHlŸHlŸHlŸHlŸ‡«Ý‡«Ý‡«Ý‡«Þ‡«Þ‡«Þ‡«Þ‡«Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬ÞŽŸŽŸŽŸŽŸ>J\=J[=J[FLUFLU(/7(/7*08*08%+3$*3$+3$+3*09*09*19&,5&,5'-6).6*/7-18NPURRVXUVc]^f^_[X]\XYTUZLQYKMPFHJ)))(((&&&%%%%%%$$$$$$###!!!!!!!!!777777777BBBEEEACGADGFIL\ckZ`iTZcDQbDQbDQbagpbiqcircir¢©±¢¨±¡¨°¡§°•œ¤•›¤”›£”š£“™¢’™¡’˜¡œ¢«œ¢«›¡ªš¡©•žY`hY_hERcERcERcGSdJTdNVdTYeLp¢Lp¢Œ°ãŒ°ãŒ°ãŒ°ãŒ±ãŒ±ãŒ±ãŒ±ãŒ±ãŒ±ãŒ±ã±ã±ã±ã±ã±ã±ã±ã±ã±ã±ã±ã±ã±ã±ã±ã±ã±ãMq£Mq£±ã±ã±ã±ä±ä±ä±ä±ä±ä±ä±ä±ä±ä²ä²ä²ä²ä²ä²ä²ä²ä²ä²ä²ä²ä²äMq¤Mq¤Mq¤Mq¤Mq¤Mq¤Mq¤Mq¤Mq¤Mq¤Mq¤…ªÜ…ªÜ…ªÜ…ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlž†ªÝ†ªÝ†«Ý†«Ý†«Ý†«Ý†«Ý†«Ý†«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«ÝHmŸ‡«Þ‡«Þ‡«Þ‡«Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬ÞŽŸŽŸŽŸŽŸŽŸŽŸŽŸFLUFLUFLU)/8+08+08&+3&+3%+4%+4%+4*19+1:&,5'-5'-6(.6FLTHMTINUKOVOQWSTXYWX`[^lbac]_f_\a_aY\aRX_,.1*,.*+-***((('''&&&%%%%%%$$$$$$$$$###!!!!!!!!!!!!!!!%%%%%%%%%%%%"""""""""KKKJJJFFFGIL]_b^dm\bkV]eDQbEQcEQcEQccirdjsdksektdjsdjscir£©²¢¨±¢¨±–œ¥•œ¤•›¤”›£”š£“™¢’™¡£¬œ¢«›¢ª[ajZ`iOU^ERcERcFRdFRdITdLUdPWeVZeLp£Lq£Lq£Lq£±ã±ã±ã±ã±ã±ã±ã±ã±ã±ã±ã±ã±ã±ã±ã±ã±ã±ä±ä±ä±ä±ä±ä²ä²ä²äMq£²ä²ä²ä²ä²ä²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äMr¤Mr¤Mr¤Mr¤Mr¤Mr¤Mr¤Mr¤Mr¤Mr¤†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlž†«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Þ‡«Þ‡«Þ‡«Þ‡«ÞHmŸHmŸHmŸ‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬ÞŽŸŽŸŽŸŽŸ‚Ž ‚Ž ‚Ž ‚Ž ”›£Š™ŠŽ•-18,18',3',4',4&,4%,4+1:,2:'-5DJSEKSEKTFLTFLUHMUINVKOWLPWQSYTUZWWZpjje^`offb\_h`]eaaCCG8;A27?-/2+-/.+)******)))((('''&&&&&&%%%%%%$$$$$$$$$$$$$$$$$$######???EEEEEEEEE((((((###&&&%%%HJMHJMHJMHJM_en]dlZ`i_enEQcEQcEQcEQcbhqektflufluflufluektektdksdjscjr£©²¢©±¢¨±–œ¥•œ¤•›¤”›£”š£“™¢£¬\ckQW`[ajZaiOU^FRdFRdFRdHSdKUdNVeRXeX\fLq£Mq£Mq£Mq£Mq£±ã±ã±ã±ã±ã±ä±ä±ä±ä±ä²ä²ä²ä²ä²ä²ä²ä²äŽ²äŽ²äŽ²äŽ²äŽ²äMr¤Mr¤Mr¤Mr¤Mr¤Ž²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²åŽ²åŽ²åŽ²åŽ²åŽ²åŽ²åŽ²åŽ²åNr¤Nr¤Nr¤Nr¤Nr¤Nr¤Nr¤Nr¤†ªÜ†ªÜ†ªÜ†ªÜ†ªÜ†ªÜHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlž‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Þ‡«Þ‡«Þ‡«Þ‡«Þ‡«Þ‡¬Þ‡¬Þ‡¬ÞHmŸHmŸHmŸHmŸImŸImŸImŸˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þ‚Ž ‚Ž ‚Ž ‚Ž ‚Ž ‚Ž ‚Ž ‚Ž ”›£Š‘™‹•‹•PT[KOVJOV(-4(-4'-5'-5JOXEKSEKSEKTFLTFLTGMUGMUHNVIOWKPWLQXMRYPTZTV[\]a_^asljd^azporjkE@CLEBIEFEDG29A28A17@135,.1+-0+,/./1..0'),)))++++++++++++***FFFFFFACFACFEEEACFACFŠŒJLOJLOKQZ_en]clY_hU[dEQcEQcEQcEQcEQcagp[aj\bk\bkgnvgnvgmvgmvfluflueltektdksdjscjrcir¢©±—¦–œ¥•œ¤•›¤TZcSYbRYaRXaQW`[bj[ajZ`iFSdFSdGSdJTdLVePXeTZfZ]fMq£Mq£Mq£Mq£Mq£Mq£Mq£²ä²ä²ä²ä²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äŽ²äNr¤Nr¤Nr¤Nr¤Nr¤Nr¤Nr¤Nr¤Nr¤Ž²åŽ²åŽ²åŽ²åŽ³åŽ³åŽ³åŽ³åŽ³åŽ³åŽ³åŽ³åŽ³åŽ³åŽ³åŽ³åŽ³åŽ³åŽ³åŽ³å³å³å³å³å³å³å³åNr¤Nr¤Nr¤Nr¤Nr¤³å³å†ªÜ†ªÜ†ªÝHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlžHlŸHlŸHlŸHlŸHlŸHlŸ‡«Ý‡«Ý‡«Ý‡«Ý‡«Ý‡«Þ‡«Þ‡«Þ‡«Þ‡«Þ‡«Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬Þ‡¬ÞImŸImŸImŸImŸImŸImŸImŸImŸImŸImŸˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬Þˆ¬ßˆ¬ßˆ¬ßˆ¬ßˆ¬ßˆ¬ßˆ­ß‚Ž ‚Ž ‚Ž ‚Ž ‚ ‚ ‚ ‚ ‚ …Œ”’•šŒ•‘”›LPVLPWKPW‹—‹—‹˜•‹‘™FLTFLTFLUGMUGMUHMVHNVINWIOWKPXLQYMRYNSZTX`X[a[]b]^c__ccacib`JDGi__aYYPJLD@C=;AKEDTQR@?A>>A;/5>.4=-4 1} { + set blue DeepSkyBlue3 + set red red + set bisque bisque3 + set green SeaGreen3 +} else { + set blue black + set red black + set bisque black + set green black +} + +# Set up demos within each of the areas of the grid. + +$c create text 5c .2c -text Lines -anchor n +$c create line 1c 1c 3c 1c 1c 4c 3c 4c -width 2m -fill $blue \ + -cap butt -join miter -tags item +$c create line 4.67c 1c 4.67c 4c -arrow last -tags item +$c create line 6.33c 1c 6.33c 4c -arrow both -tags item +$c create line 5c 6c 9c 6c 9c 1c 8c 1c 8c 4.8c 8.8c 4.8c 8.8c 1.2c \ + 8.2c 1.2c 8.2c 4.6c 8.6c 4.6c 8.6c 1.4c 8.4c 1.4c 8.4c 4.4c \ + -width 3 -fill $red -tags item +$c create line 1c 5c 7c 5c 7c 7c 9c 7c -width .5c \ + -stipple @[file join $tk_library demos images gray25.bmp] \ + -arrow both -arrowshape {15 15 7} -tags item +$c create line 1c 7c 1.75c 5.8c 2.5c 7c 3.25c 5.8c 4c 7c -width .5c \ + -cap round -join round -tags item + +$c create text 15c .2c -text "Curves (smoothed lines)" -anchor n +$c create line 11c 4c 11.5c 1c 13.5c 1c 14c 4c -smooth on \ + -fill $blue -tags item +$c create line 15.5c 1c 19.5c 1.5c 15.5c 4.5c 19.5c 4c -smooth on \ + -arrow both -width 3 -tags item +$c create line 12c 6c 13.5c 4.5c 16.5c 7.5c 18c 6c \ + 16.5c 4.5c 13.5c 7.5c 12c 6c -smooth on -width 3m -cap round \ + -stipple @[file join $tk_library demos images gray25.bmp] \ + -fill $red -tags item + +$c create text 25c .2c -text Polygons -anchor n +$c create polygon 21c 1.0c 22.5c 1.75c 24c 1.0c 23.25c 2.5c \ + 24c 4.0c 22.5c 3.25c 21c 4.0c 21.75c 2.5c -fill $green \ + -outline black -width 4 -tags item +$c create polygon 25c 4c 25c 4c 25c 1c 26c 1c 27c 4c 28c 1c \ + 29c 1c 29c 4c 29c 4c -fill $red -smooth on -tags item +$c create polygon 22c 4.5c 25c 4.5c 25c 6.75c 28c 6.75c \ + 28c 5.25c 24c 5.25c 24c 6.0c 26c 6c 26c 7.5c 22c 7.5c \ + -stipple @[file join $tk_library demos images gray25.bmp] \ + -outline black -tags item + +$c create text 5c 8.2c -text Rectangles -anchor n +$c create rectangle 1c 9.5c 4c 12.5c -outline $red -width 3m -tags item +$c create rectangle 0.5c 13.5c 4.5c 15.5c -fill $green -tags item +$c create rectangle 6c 10c 9c 15c -outline {} \ + -stipple @[file join $tk_library demos images gray25.bmp] \ + -fill $blue -tags item + +$c create text 15c 8.2c -text Ovals -anchor n +$c create oval 11c 9.5c 14c 12.5c -outline $red -width 3m -tags item +$c create oval 10.5c 13.5c 14.5c 15.5c -fill $green -tags item +$c create oval 16c 10c 19c 15c -outline {} \ + -stipple @[file join $tk_library demos images gray25.bmp] \ + -fill $blue -tags item + +$c create text 25c 8.2c -text Text -anchor n +$c create rectangle 22.4c 8.9c 22.6c 9.1c +$c create text 22.5c 9c -anchor n -font $font1 -width 4c \ + -text "A short string of text, word-wrapped, justified left, and anchored north (at the top). The rectangles show the anchor points for each piece of text." -tags item +$c create rectangle 25.4c 10.9c 25.6c 11.1c +$c create text 25.5c 11c -anchor w -font $font1 -fill $blue \ + -text "Several lines,\n each centered\nindividually,\nand all anchored\nat the left edge." \ + -justify center -tags item +$c create rectangle 24.9c 13.9c 25.1c 14.1c +$c create text 25c 14c -font $font2 -anchor c -fill $red -stipple gray50 \ + -text "Stippled characters" -tags item + +$c create text 5c 16.2c -text Arcs -anchor n +$c create arc 0.5c 17c 7c 20c -fill $green -outline black \ + -start 45 -extent 270 -style pieslice -tags item +$c create arc 6.5c 17c 9.5c 20c -width 4m -style arc \ + -outline $blue -start -135 -extent 270 -tags item \ + -outlinestipple @[file join $tk_library demos images gray25.bmp] +$c create arc 0.5c 20c 9.5c 24c -width 4m -style pieslice \ + -fill {} -outline $red -start 225 -extent -90 -tags item +$c create arc 5.5c 20.5c 9.5c 23.5c -width 4m -style chord \ + -fill $blue -outline {} -start 45 -extent 270 -tags item + +$c create text 15c 16.2c -text Bitmaps -anchor n +$c create bitmap 13c 20c -tags item \ + -bitmap @[file join $tk_library demos images face.bmp] +$c create bitmap 17c 18.5c -tags item \ + -bitmap @[file join $tk_library demos images noletter.bmp] +$c create bitmap 17c 21.5c -tags item \ + -bitmap @[file join $tk_library demos images letters.bmp] + +$c create text 25c 16.2c -text Windows -anchor n +button $c.button -text "Press Me" -command "butPress $c $red" +$c create window 21c 18c -window $c.button -anchor nw -tags item +entry $c.entry -width 20 -relief sunken +$c.entry insert end "Edit this text" +$c create window 21c 21c -window $c.entry -anchor nw -tags item +scale $c.scale -from 0 -to 100 -length 6c -sliderlength .4c \ + -width .5c -tickinterval 0 +$c create window 28.5c 17.5c -window $c.scale -anchor n -tags item +$c create text 21c 17.9c -text Button: -anchor sw +$c create text 21c 20.9c -text Entry: -anchor sw +$c create text 28.5c 17.4c -text Scale: -anchor s + +# Set up event bindings for canvas: + +$c bind item "itemEnter $c" +$c bind item "itemLeave $c" +bind $c <2> "$c scan mark %x %y" +bind $c "$c scan dragto %x %y" +bind $c <3> "itemMark $c %x %y" +bind $c "itemStroke $c %x %y" +bind $c "itemsUnderArea $c" +bind $c <1> "itemStartDrag $c %x %y" +bind $c "itemDrag $c %x %y" + +# Utility procedures for highlighting the item under the pointer: + +proc itemEnter {c} { + global restoreCmd + + if {[winfo depth $c] == 1} { + set restoreCmd {} + return + } + set type [$c type current] + if {$type == "window"} { + set restoreCmd {} + return + } + if {$type == "bitmap"} { + set bg [lindex [$c itemconf current -background] 4] + set restoreCmd [list $c itemconfig current -background $bg] + $c itemconfig current -background SteelBlue2 + return + } + set fill [lindex [$c itemconfig current -fill] 4] + if {(($type == "rectangle") || ($type == "oval") || ($type == "arc")) + && ($fill == "")} { + set outline [lindex [$c itemconfig current -outline] 4] + set restoreCmd "$c itemconfig current -outline $outline" + $c itemconfig current -outline SteelBlue2 + } else { + set restoreCmd "$c itemconfig current -fill $fill" + $c itemconfig current -fill SteelBlue2 + } +} + +proc itemLeave {c} { + global restoreCmd + + eval $restoreCmd +} + +# Utility procedures for stroking out a rectangle and printing what's +# underneath the rectangle's area. + +proc itemMark {c x y} { + global areaX1 areaY1 + set areaX1 [$c canvasx $x] + set areaY1 [$c canvasy $y] + $c delete area +} + +proc itemStroke {c x y} { + global areaX1 areaY1 areaX2 areaY2 + set x [$c canvasx $x] + set y [$c canvasy $y] + if {($areaX1 != $x) && ($areaY1 != $y)} { + $c delete area + $c addtag area withtag [$c create rect $areaX1 $areaY1 $x $y \ + -outline black] + set areaX2 $x + set areaY2 $y + } +} + +proc itemsUnderArea {c} { + global areaX1 areaY1 areaX2 areaY2 + set area [$c find withtag area] + set items "" + foreach i [$c find enclosed $areaX1 $areaY1 $areaX2 $areaY2] { + if {[lsearch [$c gettags $i] item] != -1} { + lappend items $i + } + } + puts stdout "Items enclosed by area: $items" + set items "" + foreach i [$c find overlapping $areaX1 $areaY1 $areaX2 $areaY2] { + if {[lsearch [$c gettags $i] item] != -1} { + lappend items $i + } + } + puts stdout "Items overlapping area: $items" +} + +set areaX1 0 +set areaY1 0 +set areaX2 0 +set areaY2 0 + +# Utility procedures to support dragging of items. + +proc itemStartDrag {c x y} { + global lastX lastY + set lastX [$c canvasx $x] + set lastY [$c canvasy $y] +} + +proc itemDrag {c x y} { + global lastX lastY + set x [$c canvasx $x] + set y [$c canvasy $y] + $c move current [expr $x-$lastX] [expr $y-$lastY] + set lastX $x + set lastY $y +} + +# Procedure that's invoked when the button embedded in the canvas +# is invoked. + +proc butPress {w color} { + set i [$w create text 25c 18.1c -text "Ouch!!" -fill $color -anchor n] + after 500 "$w delete $i" +} diff --git a/tk3.6/library/demos/ixset b/tk4.2/library/demos/ixset similarity index 94% rename from tk3.6/library/demos/ixset rename to tk4.2/library/demos/ixset index 9896007..dcde75d 100644 --- a/tk3.6/library/demos/ixset +++ b/tk4.2/library/demos/ixset @@ -1,12 +1,15 @@ -#!/usr/local/bin/wish -f +#!/bin/sh +# the next line restarts using wish \ +exec wish "$0" "$@" -# +# ixset -- # A nice interface to "xset" to change X server settings # # History : # 91/11/23 : pda@masi.ibp.fr, jt@ratp.fr : design # 92/08/01 : pda@masi.ibp.fr : cleaning # +# SCCS: @(#) ixset 1.7 96/02/16 10:49:19 # # Button actions @@ -195,8 +198,7 @@ proc createwindows {} { label .bell.label -text "Bell Settings" scale .bell.vol \ -from 0 -to 100 -length 200 -tickinterval 20 \ - -label "Volume (%)" -orient horizontal \ - -bg Bisque1 -activeforeground Gray + -label "Volume (%)" -orient horizontal frame .bell.val labelentry .bell.val.pit "Pitch (Hz)" 6 @@ -217,12 +219,10 @@ proc createwindows {} { checkbutton .kbd.val.onoff \ -text "On" \ -onvalue "on" -offvalue "off" -variable kbdrep \ - -relief flat \ - -activebackground Bisque1 + -relief flat scale .kbd.val.cli \ -from 0 -to 100 -length 200 -tickinterval 20 \ - -label "Click Volume (%)" -orient horizontal \ - -bg Bisque1 -activeforeground Gray + -label "Click Volume (%)" -orient horizontal pack .kbd.val.onoff -side left -expand yes -fill both pack .kbd.val.cli -side left -expand yes @@ -258,12 +258,10 @@ proc createwindows {} { frame .screen.val.rb radiobutton .screen.val.rb.blank \ -variable screenblank -text "Blank" -relief flat \ - -value "blank" -variable screenbla \ - -activebackground Bisque1 + -value "blank" -variable screenbla radiobutton .screen.val.rb.pat \ -variable screenblank -text "Pattern" -relief flat \ - -value "noblank" -variable screenbla \ - -activebackground Bisque1 + -value "noblank" -variable screenbla pack .screen.val.rb.blank .screen.val.rb.pat -side top -pady 2 -anchor w frame .screen.val.le labelentry .screen.val.le.tim "Timeout (s)" 5 diff --git a/tk4.2/library/demos/label.tcl b/tk4.2/library/demos/label.tcl new file mode 100644 index 0000000..6100265 --- /dev/null +++ b/tk4.2/library/demos/label.tcl @@ -0,0 +1,36 @@ +# label.tcl -- +# +# This demonstration script creates a toplevel window containing +# several label widgets. +# +# SCCS: @(#) label.tcl 1.6 96/04/12 12:06:20 + +set w .label +catch {destroy $w} +toplevel $w +wm title $w "Label Demonstration" +wm iconname $w "label" +positionWindow $w + +label $w.msg -font $font -wraplength 4i -justify left -text "Five labels are displayed below: three textual ones on the left, and a bitmap label and a text label on the right. Labels are pretty boring because you can't do anything with them." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +frame $w.left +frame $w.right +pack $w.left $w.right -side left -expand yes -padx 10 -pady 10 -fill both + +label $w.left.l1 -text "First label" +label $w.left.l2 -text "Second label, raised" -relief raised +label $w.left.l3 -text "Third label, sunken" -relief sunken +pack $w.left.l1 $w.left.l2 $w.left.l3 -side top -expand yes -pady 2 -anchor w + +label $w.right.bitmap -borderwidth 2 -relief sunken \ + -bitmap @[file join $tk_library demos images face.bmp] +label $w.right.caption -text "Tcl/Tk Proprietor" +pack $w.right.bitmap $w.right.caption -side top diff --git a/tk4.2/library/demos/license.terms b/tk4.2/library/demos/license.terms new file mode 100644 index 0000000..03ca6fc --- /dev/null +++ b/tk4.2/library/demos/license.terms @@ -0,0 +1,39 @@ +This software is copyrighted by the Regents of the University of +California, Sun Microsystems, Inc., and other parties. The following +terms apply to all files associated with the software unless explicitly +disclaimed in individual files. + +The authors hereby grant permission to use, copy, modify, distribute, +and license this software and its documentation for any purpose, provided +that existing copyright notices are retained in all copies and that this +notice is included verbatim in any distributions. No written agreement, +license, or royalty fee is required for any of the authorized uses. +Modifications to this software may be copyrighted by their authors +and need not follow the licensing terms described here, provided that +the new terms are clearly indicated on the first page of each file where +they apply. + +IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY +FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES +ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY +DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + +THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE +IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE +NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR +MODIFICATIONS. + +GOVERNMENT USE: If you are acquiring this software on behalf of the +U.S. government, the Government shall have only "Restricted Rights" +in the software and related documentation as defined in the Federal +Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you +are acquiring the software on behalf of the Department of Defense, the +software shall be classified as "Commercial Computer Software" and the +Government shall have only "Restricted Rights" as defined in Clause +252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the +authors grant the U.S. Government and others acting in its behalf +permission to use and distribute the software in accordance with the +terms specified in this license. diff --git a/tk4.2/library/demos/menu.tcl b/tk4.2/library/demos/menu.tcl new file mode 100644 index 0000000..75bd562 --- /dev/null +++ b/tk4.2/library/demos/menu.tcl @@ -0,0 +1,121 @@ +# menu.tcl -- +# +# This demonstration script creates a window with a bunch of menus +# and cascaded menus. +# +# SCCS: @(#) menu.tcl 1.7 96/04/12 11:57:35 + +set w .menu +catch {destroy $w} +toplevel $w +wm title $w "Menu Demonstration" +wm iconname $w "menu" +positionWindow $w + +frame $w.menu -relief raised -bd 2 +pack $w.menu -side top -fill x + +label $w.msg -font $font -wraplength 4i -justify left -text "This window contains a collection of menus and cascaded menus. You can post a menu from the keyboard by typing Alt+x, where \"x\" is the character underlined on the menu. You can then traverse among the menus using the arrow keys. When a menu is posted, you can invoke the current entry by typing space, or you can invoke any entry by typing its underlined character. If a menu entry has an accelerator, you can invoke the entry without posting the menu just by typing the accelerator." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +set m $w.menu.file.m +menubutton $w.menu.file -text "File" -menu $m -underline 0 +menu $m +$m add command -label "Open ..." -command {error "this is just a demo: no action has been defined for the \"Open ...\" entry"} +$m add command -label "New" -command {error "this is just a demo: no action has been defined for the \"New\" entry"} +$m add command -label "Save" -command {error "this is just a demo: no action has been defined for the \"Save\" entry"} +$m add command -label "Save As ..." -command {error "this is just a demo: no action has been defined for the \"Save As ...\" entry"} +$m add separator +$m add command -label "Print Setup ..." -command {error "this is just a demo: no action has been defined for the \"Print Setup ...\" entry"} +$m add command -label "Print ..." -command {error "this is just a demo: no action has been defined for the \"Print ...\" entry"} +$m add separator +$m add command -label "Quit" -command "destroy $w" + +set m $w.menu.basic.m +menubutton $w.menu.basic -text "Basic" -menu $m -underline 0 +menu $m +$m add command -label "Long entry that does nothing" +foreach i {a b c d e f g} { + $m add command -label "Print letter \"$i\"" -underline 14 \ + -accelerator Meta+$i -command "puts $i" + bind $w "puts $i" +} + +set m $w.menu.cascade.m +menubutton $w.menu.cascade -text "Cascades" -menu $m -underline 0 +menu $m +$m add command -label "Print hello" \ + -command {puts stdout "Hello"} -accelerator Control+a -underline 6 +bind . {puts stdout "Hello"} +$m add command -label "Print goodbye" -command {\ + puts stdout "Goodbye"} -accelerator Control+b -underline 6 +bind . {puts stdout "Goodbye"} +$m add cascade -label "Check buttons" \ + -menu $w.menu.cascade.m.check -underline 0 +$m add cascade -label "Radio buttons" \ + -menu $w.menu.cascade.m.radio -underline 0 + +set m $w.menu.cascade.m.check +menu $m +$m add check -label "Oil checked" -variable oil +$m add check -label "Transmission checked" -variable trans +$m add check -label "Brakes checked" -variable brakes +$m add check -label "Lights checked" -variable lights +$m add separator +$m add command -label "Show current values" \ + -command "showVars $w.menu.cascade.dialog oil trans brakes lights" +$m invoke 1 +$m invoke 3 + +set m $w.menu.cascade.m.radio +menu $m +$m add radio -label "10 point" -variable pointSize -value 10 +$m add radio -label "14 point" -variable pointSize -value 14 +$m add radio -label "18 point" -variable pointSize -value 18 +$m add radio -label "24 point" -variable pointSize -value 24 +$m add radio -label "32 point" -variable pointSize -value 32 +$m add sep +$m add radio -label "Roman" -variable style -value roman +$m add radio -label "Bold" -variable style -value bold +$m add radio -label "Italic" -variable style -value italic +$m add sep +$m add command -label "Show current values" \ + -command "showVars $w.menu.cascade.dialog pointSize style" +$m invoke 1 +$m invoke 7 + +set m $w.menu.icon.m +menubutton $w.menu.icon -text "Icons" -menu $m -underline 0 +menu $m +$m add command \ + -bitmap @[file join $tk_library demos images pattern.bmp] \ + -command { + tk_dialog .pattern {Bitmap Menu Entry} {The menu entry you invoked displays a bitmap rather than a text string. Other than this, it is just like any other menu entry.} {} 0 OK +} +foreach i {info questhead error} { + $m add command -bitmap $i -command "puts {You invoked the $i bitmap}" +} + +set m $w.menu.more.m +menubutton $w.menu.more -text "More" -menu $m -underline 0 +menu $m +foreach i {{An entry} {Another entry} {Does nothing} {Does almost nothing} {Make life meaningful}} { + $m add command -label $i -command [list puts "You invoked \"$i\""] +} + +set m $w.menu.colors.m +menubutton $w.menu.colors -text "Colors" -menu $m -underline 1 +menu $m +foreach i {red orange yellow green blue} { + $m add command -label $i -background $i \ + -command [list puts "You invoked \"$i\""] +} + +pack $w.menu.file $w.menu.basic $w.menu.cascade $w.menu.icon $w.menu.more \ + $w.menu.colors -side left diff --git a/tk4.2/library/demos/msgbox.tcl b/tk4.2/library/demos/msgbox.tcl new file mode 100644 index 0000000..0ceed11 --- /dev/null +++ b/tk4.2/library/demos/msgbox.tcl @@ -0,0 +1,61 @@ +# msgbox.tcl -- +# +# This demonstration script creates message boxes of various type +# +# SCCS: @(#) msgbox.tcl 1.2 96/08/27 14:42:23 + +set w .msgbox +catch {destroy $w} +toplevel $w +wm title $w "Message Box Demonstration" +wm iconname $w "messagebox" +positionWindow $w + +label $w.msg -font $font -wraplength 4i -justify left -text "Choose the icon and type option of the message box. Then press the \"Message Box\" button to see the message box." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +button $w.buttons.vars -text "Message Box" \ + -command "showMessageBox $w" +pack $w.buttons.dismiss $w.buttons.code $w.buttons.vars -side left -expand 1 + +frame $w.left +frame $w.right +pack $w.left $w.right -side left -expand yes -fill y -pady .5c -padx .5c + +label $w.left.label -text "Icon" +frame $w.left.sep -relief ridge -bd 1 -height 2 +pack $w.left.label -side top +pack $w.left.sep -side top -fill x -expand no + +set msgboxIcon info +foreach i {error info question warning} { + radiobutton $w.left.b$i -text $i -variable msgboxIcon \ + -relief flat -value $i -width 16 -anchor w + pack $w.left.b$i -side top -pady 2 -anchor w -fill x +} + +label $w.right.label -text "Type" +frame $w.right.sep -relief ridge -bd 1 -height 2 +pack $w.right.label -side top +pack $w.right.sep -side top -fill x -expand no + +set msgboxType ok +foreach t {abortretryignore ok okcancel retrycancel yesno yesnocancel} { + radiobutton $w.right.$t -text $t -variable msgboxType \ + -relief flat -value $t -width 16 -anchor w + pack $w.right.$t -side top -pady 2 -anchor w -fill x +} + +proc showMessageBox {w} { + global msgboxIcon msgboxType + set button [tk_messageBox -icon $msgboxIcon -type $msgboxType \ + -title Message -parent $w\ + -message "This is a \"$msgboxType\" type messagebox with the \"$msgboxIcon\" icon"] + + tk_messageBox -icon info -message "You have selected \"$button\"" -type ok\ + -parent $w +} diff --git a/tk4.2/library/demos/plot.tcl b/tk4.2/library/demos/plot.tcl new file mode 100644 index 0000000..907d43d --- /dev/null +++ b/tk4.2/library/demos/plot.tcl @@ -0,0 +1,94 @@ +# plot.tcl -- +# +# This demonstration script creates a canvas widget showing a 2-D +# plot with data points that can be dragged with the mouse. +# +# SCCS: @(#) plot.tcl 1.3 96/02/16 10:49:46 + +set w .plot +catch {destroy $w} +toplevel $w +wm title $w "Plot Demonstration" +wm iconname $w "Plot" +positionWindow $w +set c $w.c + +label $w.msg -font $font -wraplength 4i -justify left -text "This window displays a canvas widget containing a simple 2-dimensional plot. You can doctor the data by dragging any of the points with mouse button 1." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +canvas $c -relief raised -width 450 -height 300 +pack $w.c -side top -fill x + +set plotFont -*-Helvetica-Medium-R-Normal--*-180-*-*-*-*-*-* + +$c create line 100 250 400 250 -width 2 +$c create line 100 250 100 50 -width 2 +$c create text 225 20 -text "A Simple Plot" -font $plotFont -fill brown + +for {set i 0} {$i <= 10} {incr i} { + set x [expr {100 + ($i*30)}] + $c create line $x 250 $x 245 -width 2 + $c create text $x 254 -text [expr 10*$i] -anchor n -font $plotFont +} +for {set i 0} {$i <= 5} {incr i} { + set y [expr {250 - ($i*40)}] + $c create line 100 $y 105 $y -width 2 + $c create text 96 $y -text [expr $i*50].0 -anchor e -font $plotFont +} + +foreach point {{12 56} {20 94} {33 98} {32 120} {61 180} + {75 160} {98 223}} { + set x [expr {100 + (3*[lindex $point 0])}] + set y [expr {250 - (4*[lindex $point 1])/5}] + set item [$c create oval [expr $x-6] [expr $y-6] \ + [expr $x+6] [expr $y+6] -width 1 -outline black \ + -fill SkyBlue2] + $c addtag point withtag $item +} + +$c bind point "$c itemconfig current -fill red" +$c bind point "$c itemconfig current -fill SkyBlue2" +$c bind point <1> "plotDown $c %x %y" +$c bind point "$c dtag selected" +bind $c "plotMove $c %x %y" + +set plot(lastX) 0 +set plot(lastY) 0 + +# plotDown -- +# This procedure is invoked when the mouse is pressed over one of the +# data points. It sets up state to allow the point to be dragged. +# +# Arguments: +# w - The canvas window. +# x, y - The coordinates of the mouse press. + +proc plotDown {w x y} { + global plot + $w dtag selected + $w addtag selected withtag current + $w raise current + set plot(lastX) $x + set plot(lastY) $y +} + +# plotMove -- +# This procedure is invoked during mouse motion events. It drags the +# current item. +# +# Arguments: +# w - The canvas window. +# x, y - The coordinates of the mouse. + +proc plotMove {w x y} { + global plot + $w move selected [expr $x-$plot(lastX)] [expr $y-$plot(lastY)] + set plot(lastX) $x + set plot(lastY) $y +} diff --git a/tk4.2/library/demos/puzzle.tcl b/tk4.2/library/demos/puzzle.tcl new file mode 100644 index 0000000..39f40b3 --- /dev/null +++ b/tk4.2/library/demos/puzzle.tcl @@ -0,0 +1,69 @@ +# puzzle.tcl -- +# +# This demonstration script creates a 15-puzzle game using a collection +# of buttons. +# +# SCCS: @(#) puzzle.tcl 1.4 96/02/16 10:49:48 + +# puzzleSwitch -- +# This procedure is invoked when the user clicks on a particular button; +# if the button is next to the empty space, it moves the button into th +# empty space. + +proc puzzleSwitch {w num} { + global xpos ypos + if {(($ypos($num) >= ($ypos(space) - .01)) + && ($ypos($num) <= ($ypos(space) + .01)) + && ($xpos($num) >= ($xpos(space) - .26)) + && ($xpos($num) <= ($xpos(space) + .26))) + || (($xpos($num) >= ($xpos(space) - .01)) + && ($xpos($num) <= ($xpos(space) + .01)) + && ($ypos($num) >= ($ypos(space) - .26)) + && ($ypos($num) <= ($ypos(space) + .26)))} { + set tmp $xpos(space) + set xpos(space) $xpos($num) + set xpos($num) $tmp + set tmp $ypos(space) + set ypos(space) $ypos($num) + set ypos($num) $tmp + place $w.frame.$num -relx $xpos($num) -rely $ypos($num) + } +} + +set w .puzzle +catch {destroy $w} +toplevel $w +wm title $w "15-Puzzle Demonstration" +wm iconname $w "15-Puzzle" +positionWindow $w + +label $w.msg -font $font -wraplength 4i -justify left -text "A 15-puzzle appears below as a collection of buttons. Click on any of the pieces next to the space, and that piece will slide over the space. Continue this until the pieces are arranged in numerical order from upper-left to lower-right." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +# Special trick: select a darker color for the space by creating a +# scrollbar widget and using its trough color. + +scrollbar $w.s +frame $w.frame -width 120 -height 120 -borderwidth 2 -relief sunken \ + -bg [$w.s cget -troughcolor] +pack $w.frame -side top -pady 1c -padx 1c +destroy $w.s + +set order {3 1 6 2 5 7 15 13 4 11 8 9 14 10 12} +for {set i 0} {$i < 15} {set i [expr $i+1]} { + set num [lindex $order $i] + set xpos($num) [expr ($i%4)*.25] + set ypos($num) [expr ($i/4)*.25] + button $w.frame.$num -relief raised -text $num -highlightthickness 0 \ + -command "puzzleSwitch $w $num" + place $w.frame.$num -relx $xpos($num) -rely $ypos($num) \ + -relwidth .25 -relheight .25 +} +set xpos(space) .75 +set ypos(space) .75 diff --git a/tk4.2/library/demos/radio.tcl b/tk4.2/library/demos/radio.tcl new file mode 100644 index 0000000..c70aae7 --- /dev/null +++ b/tk4.2/library/demos/radio.tcl @@ -0,0 +1,40 @@ +# radio.tcl -- +# +# This demonstration script creates a toplevel window containing +# several radiobutton widgets. +# +# SCCS: @(#) radio.tcl 1.4 96/02/16 10:49:34 + +set w .radio +catch {destroy $w} +toplevel $w +wm title $w "Radiobutton Demonstration" +wm iconname $w "radio" +positionWindow $w +label $w.msg -font $font -wraplength 5i -justify left -text "Two groups of radiobuttons are displayed below. If you click on a button then the button will become selected exclusively among all the buttons in its group. A Tcl variable is associated with each group to indicate which of the group's buttons is selected. Click the \"See Variables\" button to see the current values of the variables." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +button $w.buttons.vars -text "See Variables" \ + -command "showVars $w.dialog size color" +pack $w.buttons.dismiss $w.buttons.code $w.buttons.vars -side left -expand 1 + +frame $w.left +frame $w.right +pack $w.left $w.right -side left -expand yes -pady .5c -padx .5c + +foreach i {10 12 18 24} { + radiobutton $w.left.b$i -text "Point Size $i" -variable size \ + -relief flat -value $i + pack $w.left.b$i -side top -pady 2 -anchor w +} + +foreach color {Red Green Blue Yellow Orange Purple} { + set lower [string tolower $color] + radiobutton $w.right.$lower -text $color -variable color \ + -relief flat -value $lower + pack $w.right.$lower -side top -pady 2 -anchor w +} diff --git a/tk3.6/library/demos/rmt b/tk4.2/library/demos/rmt similarity index 58% rename from tk3.6/library/demos/rmt rename to tk4.2/library/demos/rmt index 7e24dd9..4b2f5be 100644 --- a/tk3.6/library/demos/rmt +++ b/tk4.2/library/demos/rmt @@ -1,8 +1,13 @@ -#!/usr/local/bin/wish -f -# +#!/bin/sh +# the next line restarts using wish \ +exec wish "$0" "$@" + +# rmt -- # This script implements a simple remote-control mechanism for # Tk applications. It allows you to select an application and # then type commands to that application. +# +# SCCS: @(#) rmt 1.9 96/02/16 10:49:22 wm title . "Tk Remote Controller" wm iconname . "Tk Remote" @@ -31,51 +36,94 @@ frame .menu -relief raised -bd 2 pack .menu -side top -fill x menubutton .menu.file -text "File" -menu .menu.file.m -underline 0 menu .menu.file.m -.menu.file.m add cascade -label "Select Application" -command fillAppsMenu \ +.menu.file.m add cascade -label "Select Application" \ -menu .menu.file.m.apps -underline 0 .menu.file.m add command -label "Quit" -command "destroy ." -underline 0 -menu .menu.file.m.apps +menu .menu.file.m.apps -postcommand fillAppsMenu pack .menu.file -side left -tk_menuBar .menu .menu.file -# Create text window and scrollbar, and set up bindings for text -# window to foward commands to a remote application. +# Create text window and scrollbar. -text .t -relief raised -bd 2 -yscrollcommand ".s set" -setgrid true -scrollbar .s -relief flat -command ".t yview" +text .t -relief sunken -bd 2 -yscrollcommand ".s set" -setgrid true +scrollbar .s -command ".t yview" pack .s -side right -fill both pack .t -side left -bind .t <1> { - set tk_priv(selectMode) char - %W mark set anchor @%x,%y - if {[lindex [%W config -state] 4] == "normal"} {focus %W} +# Create a binding to forward commands to the target application, +# plus modify many of the built-in bindings so that only information +# in the current command can be deleted (can still set the cursor +# earlier in the text and select and insert; just can't delete). + +bindtags .t {.t Text . all} +bind .t { + .t mark set insert {end - 1c} + .t insert insert \n + invoke + break } -bind .t { - set tk_priv(selectMode) word - tk_textSelectTo %W @%x,%y -} -bind .t { - set tk_priv(selectMode) line - tk_textSelectTo %W @%x,%y -} -bind .t { - .t delete {promptEnd + 1 char} insert - .t yview -pickplace insert -} -bind .t {.t insert insert \n; invoke} -bind .t backspace -bind .t backspace -bind .t backspace -bind .t { - .t insert insert [selection get] - .t yview -pickplace insert - if [string match *.0 [.t index insert]] { - invoke +bind .t { + catch {.t tag remove sel sel.first promptEnd} + if {[.t tag nextrange sel 1.0 end] == ""} { + if [.t compare insert < promptEnd] { + break + } } } +bind .t { + catch {.t tag remove sel sel.first promptEnd} + if {[.t tag nextrange sel 1.0 end] == ""} { + if [.t compare insert <= promptEnd] { + break + } + } +} +bind .t { + if [.t compare insert < promptEnd] { + break + } +} +bind .t { + if [.t compare insert < promptEnd] { + .t mark set insert promptEnd + } +} +bind .t { + if [.t compare insert < promptEnd] { + break + } +} +bind .t { + if [.t compare insert < promptEnd] { + break + } +} +bind .t { + if [.t compare insert <= promptEnd] { + break + } +} +bind .t { + if [.t compare insert <= promptEnd] { + break + } +} +auto_load tkTextInsert +proc tkTextInsert {w s} { + if {$s == ""} { + return + } + catch { + if {[$w compare sel.first <= insert] + && [$w compare sel.last >= insert]} { + $w tag remove sel sel.first promptEnd + $w delete sel.first sel.last + } + } + $w insert insert $s + $w see insert +} -.t tag configure bold -font *-Courier-Bold-R-Normal-*-120-* +.t tag configure bold -font -*-Courier-Bold-R-Normal-*-120-*-*-*-*-*-* # The procedure below is used to print out a prompt at the # insertion point (which should be at the beginning of a line @@ -84,7 +132,8 @@ bind .t { proc prompt {} { global app .t insert insert "$app: " - .t mark set promptEnd {insert - 1 char} + .t mark set promptEnd {insert} + .t mark gravity promptEnd left .t tag add bold {promptEnd linestart} promptEnd } @@ -94,7 +143,7 @@ proc prompt {} { proc invoke {} { global app executing lastCommand - set cmd [.t get promptEnd+1c insert] + set cmd [.t get promptEnd insert] incr executing 1 if [info complete $cmd] { if {$cmd == "!!\n"} { @@ -115,7 +164,7 @@ proc invoke {} { } } prompt - .t mark set promptEnd insert-1c + .t mark set promptEnd insert } incr executing -1 .t yview -pickplace insert @@ -131,23 +180,15 @@ proc newApp appName { global app executing set app $appName if !$executing { + .t mark gravity promptEnd right .t delete "promptEnd linestart" promptEnd - .t insert promptEnd "$appName:" + .t insert promptEnd "$appName: " .t tag add bold "promptEnd linestart" promptEnd + .t mark gravity promptEnd left } return {} } -# The following procedure below handles backspaces, being careful not -# to backspace over the prompt. - -proc backspace {} { - if {[.t index promptEnd] != [.t index {insert - 1 char}]} { - .t delete insert-1c insert - .t yview -pickplace insert - } -} - # The procedure below will fill in the applications sub-menu with a list # of all the applications that currently exist. diff --git a/tk3.6/library/demos/rolodex b/tk4.2/library/demos/rolodex similarity index 66% rename from tk3.6/library/demos/rolodex rename to tk4.2/library/demos/rolodex index 9928de7..e3e0e5a 100644 --- a/tk3.6/library/demos/rolodex +++ b/tk4.2/library/demos/rolodex @@ -1,19 +1,19 @@ -#!/usr/local/bin/wish -f -# +#!/bin/sh +# the next line restarts using wish \ +exec wish "$0" "$@" + +# rolodex -- # This script was written as an entry in Tom LaStrange's rolodex # benchmark. It creates something that has some of the look and # feel of a rolodex program, although it's lifeless and doesn't # actually do the rolodex application. +# +# SCCS: @(#) rolodex 1.7 96/02/16 10:49:23 foreach i [winfo child .] { catch {destroy $i} } -proc tkerror err { - global errorInfo - puts stdout "$errorInfo" -} - #------------------------------------------ # Phase 0: create the front end. #------------------------------------------ @@ -57,85 +57,17 @@ menubutton .menu.help -text "Help" -menu .menu.help.m -underline 0 menu .menu.help.m pack .menu.help -side right -tk_menuBar .menu .menu.file .menu.help -tk_bindForTraversal . - -# The mkDialog procedure below was pirated from the widget demo. It -# was not written fresh for this benchmark. - -# Create a dialog box. Takes three or more arguments. The first is -# the name of the window to use for the dialog box. The second is a set -# of arguments for use in creating the message of the dialog box. The -# third and following arguments consist of two-element lists, each -# describing one button. The first element gives the text to be displayed -# in the button, the second gives the command to be invoked when the -# button is invoked. - -proc mkDialog {w msgArgs args} { - catch {destroy $w} - toplevel $w -class Dialog - set oldFocus [focus] - - # Create two frames in the main window. The top frame will hold the - # message and the bottom one will hold the buttons. Arrange them - # one above the other, with any extra vertical space split between - # them. - - frame $w.top -relief raised -border 1 - frame $w.bot -relief raised -border 1 - pack $w.top $w.bot -side top -fill both -expand yes - - # Create the message widget and arrange for it to be centered in the - # top frame. - - eval message $w.top.msg -justify center \ - -font -Adobe-times-medium-r-normal--*-180* $msgArgs - pack $w.top.msg -side top -expand yes -padx 2 -pady 2 - - # Create as many buttons as needed and arrange them from left to right - # in the bottom frame. Embed the left button in an additional sunken - # frame to indicate that it is the default button, and arrange for that - # button to be invoked as the default action for clicks and returns in - # the dialog. - - if {[llength $args] > 0} { - set arg [lindex $args 0] - frame $w.bot.0 -relief sunken -border 1 - pack $w.bot.0 -side left -expand yes -padx 10 -pady 10 - button $w.bot.0.button -text [lindex $arg 0] \ - -command "[lindex $arg 1]; destroy $w; focus $oldFocus" - pack $w.bot.0.button -expand yes -padx 6 -pady 6 - bind $w.top "$w.bot.0.button activate" - bind $w.top.msg "$w.bot.0.button activate" - bind $w.bot "$w.bot.0.button activate" - bind $w.top "$w.bot.0.button deactivate" - bind $w.top.msg "$w.bot.0.button deactivate" - bind $w.bot "$w.bot.0.button deactivate" - bind $w <1> "$w.bot.0.button config -relief sunken" - bind $w \ - "[lindex $arg 1]; $w.bot.0.button deactivate; destroy $w; focus $oldFocus" - bind $w "[lindex $arg 1]; destroy $w; focus $oldFocus" - focus $w - - set i 1 - foreach arg [lrange $args 1 end] { - button $w.bot.$i -text [lindex $arg 0] \ - -command "[lindex $arg 1]; destroy $w; focus $oldFocus" - pack $w.bot.$i -side left -expand yes -padx 10 - set i [expr $i+1] - } - } - wm geometry $w +300+350 -} - proc deleteAction {} { - mkDialog .delete {-text "Are you sure?" -aspect 10000} \ - "OK clearAction" "Cancel {}" + if {[tk_dialog .delete {Confirm Action} {Are you sure?} {} 0 Cancel] + == 0} { + clearAction + } } .buttons.delete config -command deleteAction proc fileAction {} { - mkDialog .fileSelection {-text "This is a dummy file selection dialog box, which is used because there isn't a good file selection dialog built into Tk yet." -aspect 400} "OK {puts stderr {dummy file name}}" + tk_dialog .fileSelection {File Selection} {This is a dummy file selection dialog box, which is used because there isn't a good file selection dialog built into Tk yet.} {} 0 OK + puts stderr {dummy file name} } #------------------------------------------ @@ -178,18 +110,18 @@ proc fillCard {} { #---------------------------------------------------- .buttons.clear config -text "Clear Ctrl+C" -bind Entry clearAction +bind . clearAction .buttons.add config -text "Add Ctrl+A" -bind Entry addAction +bind . addAction .buttons.search config -text "Search Ctrl+S" -bind Entry "addAction; fillCard" +bind . "addAction; fillCard" .buttons.delete config -text "Delete... Ctrl+D" -bind Entry deleteAction +bind . deleteAction -.menu.file.m entryconfig 0 -accel Ctrl+F -bind Entry fileAction -.menu.file.m entryconfig 1 -accel Ctrl+Q -bind Entry {destroy .} +.menu.file.m entryconfig 1 -accel Ctrl+F +bind . fileAction +.menu.file.m entryconfig 2 -accel Ctrl+Q +bind . {destroy .} focus .frame.1.entry @@ -208,15 +140,16 @@ proc Help {topic {x 0} {y 0}} { } else { set msg "Sorry, but no help is available for this topic" } - mkDialog .help "-text {Information on $topic:\n\n$msg} -justify left -aspect 300" "OK {}" + tk_dialog .help {Rolodex Help} "Information on $topic:\n\n$msg" \ + {} 0 OK } proc getMenuTopic {w x y} { return $w.[$w index @[expr $y-[winfo rooty $w]]] } -bind Entry {Help [winfo containing %X %Y] %X %Y} -bind Entry {Help [winfo containing %X %Y] %X %Y} +bind . {Help [winfo containing %X %Y] %X %Y} +bind . {Help [winfo containing %X %Y] %X %Y} # Help text and commands follow: diff --git a/tk4.2/library/demos/ruler.tcl b/tk4.2/library/demos/ruler.tcl new file mode 100644 index 0000000..3b3d76a --- /dev/null +++ b/tk4.2/library/demos/ruler.tcl @@ -0,0 +1,169 @@ +# ruler.tcl -- +# +# This demonstration script creates a canvas widget that displays a ruler +# with tab stops that can be set, moved, and deleted. +# +# SCCS: @(#) ruler.tcl 1.8 96/04/12 12:12:27 + +# rulerMkTab -- +# This procedure creates a new triangular polygon in a canvas to +# represent a tab stop. +# +# Arguments: +# c - The canvas window. +# x, y - Coordinates at which to create the tab stop. + +proc rulerMkTab {c x y} { + upvar #0 demo_rulerInfo v + $c create polygon $x $y [expr $x+$v(size)] [expr $y+$v(size)] \ + [expr $x-$v(size)] [expr $y+$v(size)] +} + +set w .ruler +global tk_library +catch {destroy $w} +toplevel $w +wm title $w "Ruler Demonstration" +wm iconname $w "ruler" +positionWindow $w +set c $w.c + +label $w.msg -font $font -wraplength 5i -justify left -text "This canvas widget shows a mock-up of a ruler. You can create tab stops by dragging them out of the well to the right of the ruler. You can also drag existing tab stops. If you drag a tab stop far enough up or down so that it turns dim, it will be deleted when you release the mouse button." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +canvas $c -width 14.8c -height 2.5c +pack $w.c -side top -fill x + +set demo_rulerInfo(grid) .25c +set demo_rulerInfo(left) [winfo fpixels $c 1c] +set demo_rulerInfo(right) [winfo fpixels $c 13c] +set demo_rulerInfo(top) [winfo fpixels $c 1c] +set demo_rulerInfo(bottom) [winfo fpixels $c 1.5c] +set demo_rulerInfo(size) [winfo fpixels $c .2c] +set demo_rulerInfo(normalStyle) "-fill black" +if {[winfo depth $c] > 1} { + set demo_rulerInfo(activeStyle) "-fill red -stipple {}" + set demo_rulerInfo(deleteStyle) [list -fill red \ + -stipple @[file join $tk_library demos images gray25.bmp]] +} else { + set demo_rulerInfo(activeStyle) "-fill black -stipple {}" + set demo_rulerInfo(deleteStyle) [list -fill black \ + -stipple @[file join $tk_library demos images gray25.bmp]] +} + +$c create line 1c 0.5c 1c 1c 13c 1c 13c 0.5c -width 1 +for {set i 0} {$i < 12} {incr i} { + set x [expr $i+1] + $c create line ${x}c 1c ${x}c 0.6c -width 1 + $c create line $x.25c 1c $x.25c 0.8c -width 1 + $c create line $x.5c 1c $x.5c 0.7c -width 1 + $c create line $x.75c 1c $x.75c 0.8c -width 1 + $c create text $x.15c .75c -text $i -anchor sw +} +$c addtag well withtag [$c create rect 13.2c 1c 13.8c 0.5c \ + -outline black -fill [lindex [$c config -bg] 4]] +$c addtag well withtag [rulerMkTab $c [winfo pixels $c 13.5c] \ + [winfo pixels $c .65c]] + +$c bind well <1> "rulerNewTab $c %x %y" +$c bind tab <1> "rulerSelectTab $c %x %y" +bind $c "rulerMoveTab $c %x %y" +bind $c "rulerReleaseTab $c" + +# rulerNewTab -- +# Does all the work of creating a tab stop, including creating the +# triangle object and adding tags to it to give it tab behavior. +# +# Arguments: +# c - The canvas window. +# x, y - The coordinates of the tab stop. + +proc rulerNewTab {c x y} { + upvar #0 demo_rulerInfo v + $c addtag active withtag [rulerMkTab $c $x $y] + $c addtag tab withtag active + set v(x) $x + set v(y) $y + rulerMoveTab $c $x $y +} + +# rulerSelectTab -- +# This procedure is invoked when mouse button 1 is pressed over +# a tab. It remembers information about the tab so that it can +# be dragged interactively. +# +# Arguments: +# c - The canvas widget. +# x, y - The coordinates of the mouse (identifies the point by +# which the tab was picked up for dragging). + +proc rulerSelectTab {c x y} { + upvar #0 demo_rulerInfo v + set v(x) [$c canvasx $x $v(grid)] + set v(y) [expr $v(top)+2] + $c addtag active withtag current + eval "$c itemconf active $v(activeStyle)" + $c raise active +} + +# rulerMoveTab -- +# This procedure is invoked during mouse motion events to drag a tab. +# It adjusts the position of the tab, and changes its appearance if +# it is about to be dragged out of the ruler. +# +# Arguments: +# c - The canvas widget. +# x, y - The coordinates of the mouse. + +proc rulerMoveTab {c x y} { + upvar #0 demo_rulerInfo v + if {[$c find withtag active] == ""} { + return + } + set cx [$c canvasx $x $v(grid)] + set cy [$c canvasy $y] + if {$cx < $v(left)} { + set cx $v(left) + } + if {$cx > $v(right)} { + set cx $v(right) + } + if {($cy >= $v(top)) && ($cy <= $v(bottom))} { + set cy [expr $v(top)+2] + eval "$c itemconf active $v(activeStyle)" + } else { + set cy [expr $cy-$v(size)-2] + eval "$c itemconf active $v(deleteStyle)" + } + $c move active [expr $cx-$v(x)] [expr $cy-$v(y)] + set v(x) $cx + set v(y) $cy +} + +# rulerReleaseTab -- +# This procedure is invoked during button release events that end +# a tab drag operation. It deselects the tab and deletes the tab if +# it was dragged out of the ruler. +# +# Arguments: +# c - The canvas widget. +# x, y - The coordinates of the mouse. + +proc rulerReleaseTab c { + upvar #0 demo_rulerInfo v + if {[$c find withtag active] == {}} { + return + } + if {$v(y) != [expr $v(top)+2]} { + $c delete active + } else { + eval "$c itemconf active $v(normalStyle)" + $c dtag active + } +} diff --git a/tk4.2/library/demos/sayings.tcl b/tk4.2/library/demos/sayings.tcl new file mode 100644 index 0000000..6edf854 --- /dev/null +++ b/tk4.2/library/demos/sayings.tcl @@ -0,0 +1,42 @@ +# sayings.tcl -- +# +# This demonstration script creates a listbox that can be scrolled +# both horizontally and vertically. It displays a collection of +# well-known sayings. +# +# SCCS: @(#) sayings.tcl 1.6 96/10/04 17:09:38 + +set w .sayings +catch {destroy $w} +toplevel $w +wm title $w "Listbox Demonstration (well-known sayings)" +wm iconname $w "sayings" +positionWindow $w + +label $w.msg -font $font -wraplength 4i -justify left -text "The listbox below contains a collection of well-known sayings. You can scan the list using either of the scrollbars or by dragging in the listbox window with button 2 pressed." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +frame $w.frame -borderwidth 10 +pack $w.frame -side top -expand yes -fill y + + +scrollbar $w.frame.yscroll -command "$w.frame.list yview" +scrollbar $w.frame.xscroll -orient horizontal \ + -command "$w.frame.list xview" +listbox $w.frame.list -width 20 -height 10 -setgrid 1 \ + -yscroll "$w.frame.yscroll set" -xscroll "$w.frame.xscroll set" + +grid $w.frame.list -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news +grid $w.frame.yscroll -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news +grid $w.frame.xscroll -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news +grid rowconfig $w.frame 0 -weight 1 -minsize 0 +grid columnconfig $w.frame 0 -weight 1 -minsize 0 + + +$w.frame.list insert 0 "Waste not, want not" "Early to bed and early to rise makes a man healthy, wealthy, and wise" "Ask not what your country can do for you, ask what you can do for your country" "I shall return" "NOT" "A picture is worth a thousand words" "User interfaces are hard to build" "Thou shalt not steal" "A penny for your thoughts" "Fool me once, shame on you; fool me twice, shame on me" "Every cloud has a silver lining" "Where there's smoke there's fire" "It takes one to know one" "Curiosity killed the cat" "Take this job and shove it" "Up a creek without a paddle" "I'm mad as hell and I'm not going to take it any more" "An apple a day keeps the doctor away" "Don't look a gift horse in the mouth" diff --git a/tk4.2/library/demos/search.tcl b/tk4.2/library/demos/search.tcl new file mode 100644 index 0000000..6b520c8 --- /dev/null +++ b/tk4.2/library/demos/search.tcl @@ -0,0 +1,137 @@ +# search.tcl -- +# +# This demonstration script creates a collection of widgets that +# allow you to load a file into a text widget, then perform searches +# on that file. +# +# SCCS: @(#) search.tcl 1.4 96/02/16 10:49:12 + +# textLoadFile -- +# This procedure below loads a file into a text widget, discarding +# the previous contents of the widget. Tags for the old widget are +# not affected, however. +# +# Arguments: +# w - The window into which to load the file. Must be a +# text widget. +# file - The name of the file to load. Must be readable. + +proc textLoadFile {w file} { + set f [open $file] + $w delete 1.0 end + while {![eof $f]} { + $w insert end [read $f 10000] + } + close $f +} + +# textSearch -- +# Search for all instances of a given string in a text widget and +# apply a given tag to each instance found. +# +# Arguments: +# w - The window in which to search. Must be a text widget. +# string - The string to search for. The search is done using +# exact matching only; no special characters. +# tag - Tag to apply to each instance of a matching string. + +proc textSearch {w string tag} { + $w tag remove search 0.0 end + if {$string == ""} { + return + } + set cur 1.0 + while 1 { + set cur [$w search -count length $string $cur end] + if {$cur == ""} { + break + } + $w tag add $tag $cur "$cur + $length char" + set cur [$w index "$cur + $length char"] + } +} + +# textToggle -- +# This procedure is invoked repeatedly to invoke two commands at +# periodic intervals. It normally reschedules itself after each +# execution but if an error occurs (e.g. because the window was +# deleted) then it doesn't reschedule itself. +# +# Arguments: +# cmd1 - Command to execute when procedure is called. +# sleep1 - Ms to sleep after executing cmd1 before executing cmd2. +# cmd2 - Command to execute in the *next* invocation of this +# procedure. +# sleep2 - Ms to sleep after executing cmd2 before executing cmd1 again. + +proc textToggle {cmd1 sleep1 cmd2 sleep2} { + catch { + eval $cmd1 + after $sleep1 [list textToggle $cmd2 $sleep2 $cmd1 $sleep1] + } +} + +set w .search +catch {destroy $w} +toplevel $w +wm title $w "Text Demonstration - Search and Highlight" +wm iconname $w "search" +positionWindow $w + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +frame $w.file +label $w.file.label -text "File name:" -width 13 -anchor w +entry $w.file.entry -width 40 -textvariable fileName +button $w.file.button -text "Load File" \ + -command "textLoadFile $w.text \$fileName" +pack $w.file.label $w.file.entry -side left +pack $w.file.button -side left -pady 5 -padx 10 +bind $w.file.entry " + textLoadFile $w.text \$fileName + focus $w.string.entry +" +focus $w.file.entry + +frame $w.string +label $w.string.label -text "Search string:" -width 13 -anchor w +entry $w.string.entry -width 40 -textvariable searchString +button $w.string.button -text "Highlight" \ + -command "textSearch $w.text \$searchString search" +pack $w.string.label $w.string.entry -side left +pack $w.string.button -side left -pady 5 -padx 10 +bind $w.string.entry "textSearch $w.text \$searchString search" + +text $w.text -yscrollcommand "$w.scroll set" -setgrid true +scrollbar $w.scroll -command "$w.text yview" +pack $w.file $w.string -side top -fill x +pack $w.scroll -side right -fill y +pack $w.text -expand yes -fill both + +# Set up display styles for text highlighting. + +if {[winfo depth $w] > 1} { + textToggle "$w.text tag configure search -background \ + #ce5555 -foreground white" 800 "$w.text tag configure \ + search -background {} -foreground {}" 200 +} else { + textToggle "$w.text tag configure search -background \ + black -foreground white" 800 "$w.text tag configure \ + search -background {} -foreground {}" 200 +} +$w.text insert 1.0 \ +{This window demonstrates how to use the tagging facilities in text +widgets to implement a searching mechanism. First, type a file name +in the top entry, then type or click on "Load File". Then +type a string in the lower entry and type or click on +"Load File". This will cause all of the instances of the string to +be tagged with the tag "search", and it will arrange for the tag's +display attributes to change to make all of the strings blink.} +$w.text mark set insert 0.0 + +set fileName "" +set searchString "" diff --git a/tk3.6/library/demos/square b/tk4.2/library/demos/square similarity index 89% rename from tk3.6/library/demos/square rename to tk4.2/library/demos/square index 8e4c0de..f0fdabf 100644 --- a/tk3.6/library/demos/square +++ b/tk4.2/library/demos/square @@ -1,5 +1,8 @@ -#!/usr/local/bin/wish -f -# +#!/bin/sh +# the next line restarts using wish \ +exec wish "$0" "$@" + +# square -- # This script generates a demo application containing only # a "square" widget. It's only usable if Tk has been compiled # with tkSquare.c and with the -DSQUARE_DEMO compiler switch. @@ -7,6 +10,8 @@ # # Button-1 press/drag: moves square to mouse # "a": toggle size animation on/off +# +# SCCS: @(#) square 1.6 96/02/16 10:49:21 square .s pack .s -expand yes -fill both diff --git a/tk4.2/library/demos/states.tcl b/tk4.2/library/demos/states.tcl new file mode 100644 index 0000000..21ffa15 --- /dev/null +++ b/tk4.2/library/demos/states.tcl @@ -0,0 +1,41 @@ +# states.tcl -- +# +# This demonstration script creates a listbox widget that displays +# the names of the 50 states in the United States of America. +# +# SCCS: @(#) states.tcl 1.3 96/02/16 10:49:50 + +set w .states +catch {destroy $w} +toplevel $w +wm title $w "Listbox Demonstration (50 states)" +wm iconname $w "states" +positionWindow $w + +label $w.msg -font $font -wraplength 4i -justify left -text "A listbox containing the 50 states is displayed below, along with a scrollbar. You can scan the list either using the scrollbar or by scanning. To scan, press button 2 in the widget and drag up or down." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +frame $w.frame -borderwidth .5c +pack $w.frame -side top -expand yes -fill y + +scrollbar $w.frame.scroll -command "$w.frame.list yview" +listbox $w.frame.list -yscroll "$w.frame.scroll set" -setgrid 1 -height 12 +pack $w.frame.scroll -side right -fill y +pack $w.frame.list -side left -expand 1 -fill both + +$w.frame.list insert 0 Alabama Alaska Arizona Arkansas California \ + Colorado Connecticut Delaware Florida Georgia Hawaii Idaho Illinois \ + Indiana Iowa Kansas Kentucky Louisiana Maine Maryland \ + Massachusetts Michigan Minnesota Mississippi Missouri \ + Montana Nebraska Nevada "New Hampshire" "New Jersey" "New Mexico" \ + "New York" "North Carolina" "North Dakota" \ + Ohio Oklahoma Oregon Pennsylvania "Rhode Island" \ + "South Carolina" "South Dakota" \ + Tennessee Texas Utah Vermont Virginia Washington \ + "West Virginia" Wisconsin Wyoming diff --git a/tk4.2/library/demos/style.tcl b/tk4.2/library/demos/style.tcl new file mode 100644 index 0000000..e2a26e2 --- /dev/null +++ b/tk4.2/library/demos/style.tcl @@ -0,0 +1,151 @@ +# style.tcl -- +# +# This demonstration script creates a text widget that illustrates the +# various display styles that may be set for tags. +# +# SCCS: @(#) style.tcl 1.5 96/02/16 10:49:24 + +set w .style +catch {destroy $w} +toplevel $w +wm title $w "Text Demonstration - Display Styles" +wm iconname $w "style" +positionWindow $w + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +text $w.text -yscrollcommand "$w.scroll set" -setgrid true \ + -width 70 -height 32 -wrap word +scrollbar $w.scroll -command "$w.text yview" +pack $w.scroll -side right -fill y +pack $w.text -expand yes -fill both + +# Set up display styles + +$w.text tag configure bold -font -*-Courier-Bold-O-Normal--*-120-*-*-*-*-*-* +$w.text tag configure big -font -*-Courier-Bold-R-Normal--*-140-*-*-*-*-*-* +$w.text tag configure verybig -font \ + -*-Helvetica-Bold-R-Normal--*-240-*-*-*-*-*-* +if {[winfo depth $w] > 1} { + $w.text tag configure color1 -background #a0b7ce + $w.text tag configure color2 -foreground red + $w.text tag configure raised -relief raised -borderwidth 1 + $w.text tag configure sunken -relief sunken -borderwidth 1 +} else { + $w.text tag configure color1 -background black -foreground white + $w.text tag configure color2 -background black -foreground white + $w.text tag configure raised -background white -relief raised \ + -borderwidth 1 + $w.text tag configure sunken -background white -relief sunken \ + -borderwidth 1 +} +$w.text tag configure bgstipple -background black -borderwidth 0 \ + -bgstipple gray12 +$w.text tag configure fgstipple -fgstipple gray50 +$w.text tag configure underline -underline on +$w.text tag configure overstrike -overstrike on +$w.text tag configure right -justify right +$w.text tag configure center -justify center +$w.text tag configure super -offset 4p \ + -font -Adobe-Courier-Medium-R-Normal--*-100-*-*-*-*-*-* +$w.text tag configure sub -offset -2p \ + -font -Adobe-Courier-Medium-R-Normal--*-100-*-*-*-*-*-* +$w.text tag configure margins -lmargin1 12m -lmargin2 6m -rmargin 10m +$w.text tag configure spacing -spacing1 10p -spacing2 2p \ + -lmargin1 12m -lmargin2 6m -rmargin 10m + +$w.text insert end {Text widgets like this one allow you to display information in a +variety of styles. Display styles are controlled using a mechanism +called } +$w.text insert end tags bold +$w.text insert end {. Tags are just textual names that you can apply to one +or more ranges of characters within a text widget. You can configure +tags with various display styles. If you do this, then the tagged +characters will be displayed with the styles you chose. The +available display styles are: +} +$w.text insert end "\n1. Font." big +$w.text insert end " You can choose any X font, " +$w.text insert end large verybig +$w.text insert end " or " +$w.text insert end "small.\n" +$w.text insert end "\n2. Color." big +$w.text insert end " You can change either the " +$w.text insert end background color1 +$w.text insert end " or " +$w.text insert end foreground color2 +$w.text insert end "\ncolor, or " +$w.text insert end both {color1 color2} +$w.text insert end ".\n" +$w.text insert end "\n3. Stippling." big +$w.text insert end " You can cause either the " +$w.text insert end background bgstipple +$w.text insert end " or " +$w.text insert end foreground fgstipple +$w.text insert end { +information to be drawn with a stipple fill instead of a solid fill. +} +$w.text insert end "\n4. Underlining." big +$w.text insert end " You can " +$w.text insert end underline underline +$w.text insert end " ranges of text.\n" +$w.text insert end "\n5. Overstrikes." big +$w.text insert end " You can " +$w.text insert end "draw lines through" overstrike +$w.text insert end " ranges of text.\n" +$w.text insert end "\n6. 3-D effects." big +$w.text insert end { You can arrange for the background to be drawn +with a border that makes characters appear either } +$w.text insert end raised raised +$w.text insert end " or " +$w.text insert end sunken sunken +$w.text insert end ".\n" +$w.text insert end "\n7. Justification." big +$w.text insert end " You can arrange for lines to be displayed\n" +$w.text insert end "left-justified,\n" +$w.text insert end "right-justified, or\n" right +$w.text insert end "centered.\n" center +$w.text insert end "\n8. Superscripts and subscripts." big +$w.text insert end " You can control the vertical\n" +$w.text insert end "position of text to generate superscript effects like 10" +$w.text insert end "n" super +$w.text insert end " or\nsubscript effects like X" +$w.text insert end "i" sub +$w.text insert end ".\n" +$w.text insert end "\n9. Margins." big +$w.text insert end " You can control the amount of extra space left" +$w.text insert end " on\neach side of the text:\n" +$w.text insert end "This paragraph is an example of the use of " margins +$w.text insert end "margins. It consists of a single line of text " margins +$w.text insert end "that wraps around on the screen. There are two " margins +$w.text insert end "separate left margin values, one for the first " margins +$w.text insert end "display line associated with the text line, " margins +$w.text insert end "and one for the subsequent display lines, which " margins +$w.text insert end "occur because of wrapping. There is also a " margins +$w.text insert end "separate specification for the right margin, " margins +$w.text insert end "which is used to choose wrap points for lines.\n" margins +$w.text insert end "\n10. Spacing." big +$w.text insert end " You can control the spacing of lines with three\n" +$w.text insert end "separate parameters. \"Spacing1\" tells how much " +$w.text insert end "extra space to leave\nabove a line, \"spacing3\" " +$w.text insert end "tells how much space to leave below a line,\nand " +$w.text insert end "if a text line wraps, \"spacing2\" tells how much " +$w.text insert end "space to leave\nbetween the display lines that " +$w.text insert end "make up the text line.\n" +$w.text insert end "These indented paragraphs illustrate how spacing " spacing +$w.text insert end "can be used. Each paragraph is actually a " spacing +$w.text insert end "single line in the text widget, which is " spacing +$w.text insert end "word-wrapped by the widget.\n" spacing +$w.text insert end "Spacing1 is set to 10 points for this text, " spacing +$w.text insert end "which results in relatively large gaps between " spacing +$w.text insert end "the paragraphs. Spacing2 is set to 2 points, " spacing +$w.text insert end "which results in just a bit of extra space " spacing +$w.text insert end "within a pararaph. Spacing3 isn't used " spacing +$w.text insert end "in this example.\n" spacing +$w.text insert end "To see where the space is, select ranges of " spacing +$w.text insert end "text within these paragraphs. The selection " spacing +$w.text insert end "highlight will cover the extra space." spacing diff --git a/tk4.2/library/demos/tclIndex b/tk4.2/library/demos/tclIndex new file mode 100644 index 0000000..86a72e2 --- /dev/null +++ b/tk4.2/library/demos/tclIndex @@ -0,0 +1,67 @@ +# 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(arrowSetup) [list source [file join $dir arrow.tcl]] +set auto_index(arrowMove1) [list source [file join $dir arrow.tcl]] +set auto_index(arrowMove2) [list source [file join $dir arrow.tcl]] +set auto_index(arrowMove3) [list source [file join $dir arrow.tcl]] +set auto_index(textLoadFile) [list source [file join $dir search.tcl]] +set auto_index(textSearch) [list source [file join $dir search.tcl]] +set auto_index(textToggle) [list source [file join $dir search.tcl]] +set auto_index(itemEnter) [list source [file join $dir items.tcl]] +set auto_index(itemLeave) [list source [file join $dir items.tcl]] +set auto_index(itemMark) [list source [file join $dir items.tcl]] +set auto_index(itemStroke) [list source [file join $dir items.tcl]] +set auto_index(itemsUnderArea) [list source [file join $dir items.tcl]] +set auto_index(itemStartDrag) [list source [file join $dir items.tcl]] +set auto_index(itemDrag) [list source [file join $dir items.tcl]] +set auto_index(butPress) [list source [file join $dir items.tcl]] +set auto_index(loadDir) [list source [file join $dir image2.tcl]] +set auto_index(loadImage) [list source [file join $dir image2.tcl]] +set auto_index(rulerMkTab) [list source [file join $dir ruler.tcl]] +set auto_index(rulerNewTab) [list source [file join $dir ruler.tcl]] +set auto_index(rulerSelectTab) [list source [file join $dir ruler.tcl]] +set auto_index(rulerMoveTab) [list source [file join $dir ruler.tcl]] +set auto_index(rulerReleaseTab) [list source [file join $dir ruler.tcl]] +set auto_index(mkTextConfig) [list source [file join $dir ctext.tcl]] +set auto_index(textEnter) [list source [file join $dir ctext.tcl]] +set auto_index(textInsert) [list source [file join $dir ctext.tcl]] +set auto_index(textPaste) [list source [file join $dir ctext.tcl]] +set auto_index(textB1Press) [list source [file join $dir ctext.tcl]] +set auto_index(textB1Move) [list source [file join $dir ctext.tcl]] +set auto_index(textBs) [list source [file join $dir ctext.tcl]] +set auto_index(textDel) [list source [file join $dir ctext.tcl]] +set auto_index(bitmapRow) [list source [file join $dir bitmap.tcl]] +set auto_index(scrollEnter) [list source [file join $dir cscroll.tcl]] +set auto_index(scrollLeave) [list source [file join $dir cscroll.tcl]] +set auto_index(scrollButton) [list source [file join $dir cscroll.tcl]] +set auto_index(textWindOn) [list source [file join $dir twind.tcl]] +set auto_index(textWindOff) [list source [file join $dir twind.tcl]] +set auto_index(textWindPlot) [list source [file join $dir twind.tcl]] +set auto_index(embPlotDown) [list source [file join $dir twind.tcl]] +set auto_index(embPlotMove) [list source [file join $dir twind.tcl]] +set auto_index(textWindDel) [list source [file join $dir twind.tcl]] +set auto_index(embDefBg) [list source [file join $dir twind.tcl]] +set auto_index(floorDisplay) [list source [file join $dir floor.tcl]] +set auto_index(newRoom) [list source [file join $dir floor.tcl]] +set auto_index(roomChanged) [list source [file join $dir floor.tcl]] +set auto_index(bg1) [list source [file join $dir floor.tcl]] +set auto_index(bg2) [list source [file join $dir floor.tcl]] +set auto_index(bg3) [list source [file join $dir floor.tcl]] +set auto_index(fg1) [list source [file join $dir floor.tcl]] +set auto_index(fg2) [list source [file join $dir floor.tcl]] +set auto_index(fg3) [list source [file join $dir floor.tcl]] +set auto_index(setWidth) [list source [file join $dir hscale.tcl]] +set auto_index(plotDown) [list source [file join $dir plot.tcl]] +set auto_index(plotMove) [list source [file join $dir plot.tcl]] +set auto_index(puzzleSwitch) [list source [file join $dir puzzle.tcl]] +set auto_index(setHeight) [list source [file join $dir vscale.tcl]] +set auto_index(showMessageBox) [list source [file join $dir msgbox.tcl]] +set auto_index(setColor) [list source [file join $dir clrpick.tcl]] +set auto_index(setColor_helper) [list source [file join $dir clrpick.tcl]] +set auto_index(fileDialog) [list source [file join $dir filebox.tcl]] diff --git a/tk3.6/library/demos/tcolor b/tk4.2/library/demos/tcolor similarity index 90% rename from tk3.6/library/demos/tcolor rename to tk4.2/library/demos/tcolor index 701e162..0bbf1a1 100644 --- a/tk3.6/library/demos/tcolor +++ b/tk4.2/library/demos/tcolor @@ -1,12 +1,15 @@ -#!/usr/local/bin/wish -f -# +#!/bin/sh +# the next line restarts using wish \ +exec wish "$0" "$@" + +# tcolor -- # This script implements a simple color editor, where you can # create colors using either the RGB, HSB, or CYM color spaces # and apply the color to existing applications. +# +# SCCS: @(#) tcolor 1.10 96/02/16 10:49:25 wm title . "Color Editor" -tk_bindForTraversal . -focus . # Global variables that control the program: # @@ -59,7 +62,6 @@ menu .menu.file.m .menu.file.m add command -label "Exit program" -underline 0 \ -command "destroy ." pack .menu.file -side left -tk_menuBar .menu .menu.file # Create the command entry window at the bottom of the window, along # with the update button. @@ -68,7 +70,7 @@ frame .bot -relief raised -borderwidth 2 pack .bot -side bottom -fill x label .commandLabel -text "Command:" entry .command -relief sunken -borderwidth 2 -textvariable command \ - -font -Adobe-Courier-Medium-R-Normal-*-120-* + -font -Adobe-Courier-Medium-R-Normal--*-120-*-*-*-*-*-* button .update -text Update -command doUpdate pack .commandLabel -in .bot -side left pack .update -in .bot -side right -pady .1c -padx .25c @@ -80,16 +82,16 @@ pack .command -in .bot -expand yes -fill x -ipadx 0.25c frame .middle -relief raised -borderwidth 2 pack .middle -side top -fill both foreach i {/usr/local/lib/X11/rgb.txt /usr/lib/X11/rgb.txt - /X11/R5/lib/X11/rgb.txt /X11/R4/lib/rgb/rgb.txt} { + /X11/R5/lib/X11/rgb.txt /X11/R4/lib/rgb/rgb.txt + /usr/openwin/lib/X11/rgb.txt} { if ![file readable $i] { continue; } set f [open $i] frame .middle.left pack .middle.left -side left -padx .25c -pady .25c - listbox .names -geometry 20x12 -yscrollcommand ".scroll set" \ + listbox .names -width 20 -height 12 -yscrollcommand ".scroll set" \ -relief sunken -borderwidth 2 -exportselection false - tk_listboxSingleSelect .names bind .names { tc_loadNamedColor [.names get [.names curselection]] } @@ -103,7 +105,7 @@ foreach i {/usr/local/lib/X11/rgb.txt /usr/lib/X11/rgb.txt } } close $f - break; + break } # Create the three scales for editing the color, and the entry for @@ -119,19 +121,15 @@ pack .middle.middle.1 .middle.middle.2 .middle.middle.3 -side top -expand yes pack .middle.middle.4 -side top -expand yes -fill x foreach i {1 2 3} { label .label$i -textvariable label$i - scale .scale$i -from 0 -to 1000 -length 10c -orient horizontal \ + scale .scale$i -from 0 -to 1000 -length 6c -orient horizontal \ -command tc_scaleChanged - button .up$i -width 2 -text + -command "tc_inc $i 1" - button .down$i -width 2 -text - -command "tc_inc $i -1" - pack .label$i -in .middle.middle.$i -side top -anchor w - pack .down$i -in .middle.middle.$i -side left -padx .25c - pack .scale$i -in .middle.middle.$i -side left - pack .up$i -in .middle.middle.$i -side left -padx .25c + pack .scale$i .label$i -in .middle.middle.$i -side top -anchor w } -label .nameLabel -text "Name of new color:" -entry .name -relief sunken -borderwidth 2 -textvariable name -width 30 \ - -font -Adobe-Courier-Medium-R-Normal-*-120-* -pack .nameLabel .name -in .middle.middle.4 -side left +label .nameLabel -text "Name:" +entry .name -relief sunken -borderwidth 2 -textvariable name -width 10 \ + -font -Adobe-Courier-Medium-R-Normal--*-120-*-*-*-*-*-* +pack .nameLabel -in .middle.middle.4 -side left +pack .name -in .middle.middle.4 -side right -expand 1 -fill x bind .name {tc_loadNamedColor $name} # Create the color display swatch on the right side of the window. @@ -140,18 +138,10 @@ frame .middle.right pack .middle.right -side left -pady .25c -padx .25c -anchor s frame .swatch -width 2c -height 5c -background $color label .value -textvariable color -width 13 \ - -font -Adobe-Courier-Medium-R-Normal-*-120-* + -font -Adobe-Courier-Medium-R-Normal--*-120-*-*-*-*-*-* pack .swatch -in .middle.right -side top -expand yes -fill both pack .value -in .middle.right -side bottom -pady .25c -# The procedure below handles the "+" and "-" buttons next to -# the adjustor scales. They just increment or decrement the -# appropriate scale value. - -proc tc_inc {scale inc} { - .scale$scale set [expr [.scale$scale get]+$inc] -} - # The procedure below is invoked when one of the scales is adjusted. # It propagates color information from the current scale readings # to everywhere else that it is used. @@ -316,6 +306,9 @@ proc rgbToHsv {red green blue} { set hue [expr {.166667*(4 + $gc - $rc)}] } } + if {$hue < 0.0} { + set hue [expr $hue + 1.0] + } } return [list $hue $sat [expr {$max/65535}]] } diff --git a/tk4.2/library/demos/text.tcl b/tk4.2/library/demos/text.tcl new file mode 100644 index 0000000..f9221b5 --- /dev/null +++ b/tk4.2/library/demos/text.tcl @@ -0,0 +1,72 @@ +# text.tcl -- +# +# This demonstration script creates a text widget that describes +# the basic editing functions. +# +# SCCS: @(#) text.tcl 1.5 96/02/16 10:49:07 + +set w .text +catch {destroy $w} +toplevel $w +wm title $w "Text Demonstration - Basic Facilities" +wm iconname $w "text" +positionWindow $w + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +text $w.text -relief sunken -bd 2 -yscrollcommand "$w.scroll set" -setgrid 1 \ + -height 30 +scrollbar $w.scroll -command "$w.text yview" +pack $w.scroll -side right -fill y +pack $w.text -expand yes -fill both +$w.text insert 0.0 \ +{This window is a text widget. It displays one or more lines of text +and allows you to edit the text. Here is a summary of the things you +can do to a text widget: + +1. Scrolling. Use the scrollbar to adjust the view in the text window. + +2. Scanning. Press mouse button 2 in the text window and drag up or down. +This will drag the text at high speed to allow you to scan its contents. + +3. Insert text. Press mouse button 1 to set the insertion cursor, then +type text. What you type will be added to the widget. + +4. Select. Press mouse button 1 and drag to select a range of characters. +Once you've released the button, you can adjust the selection by pressing +button 1 with the shift key down. This will reset the end of the +selection nearest the mouse cursor and you can drag that end of the +selection by dragging the mouse before releasing the mouse button. +You can double-click to select whole words or triple-click to select +whole lines. + +5. Delete and replace. To delete text, select the characters you'd like +to delete and type Backspace or Delete. Alternatively, you can type new +text, in which case it will replace the selected text. + +6. Copy the selection. To copy the selection into this window, select +what you want to copy (either here or in another application), then +click button 2 to copy the selection to the point of the mouse cursor. + +7. Edit. Text widgets support the standard Motif editing characters +plus many Emacs editing characters. Backspace and Control-h erase the +character to the left of the insertion cursor. Delete and Control-d +erase the character to the right of the insertion cursor. Meta-backspace +deletes the word to the left of the insertion cursor, and Meta-d deletes +the word to the right of the insertion cursor. Control-k deletes from +the insertion cursor to the end of the line, or it deletes the newline +character if that is the only thing left on the line. Control-o opens +a new line by inserting a newline character to the right of the insertion +cursor. Control-t transposes the two characters on either side of the +insertion cursor. + +7. Resize the window. This widget has been configured with the "setGrid" +option on, so that if you resize the window it will always resize to an +even number of characters high and wide. Also, if you make the window +narrow you can see that long lines automatically wrap around onto +additional lines so that all the information is always visible.} +$w.text mark set insert 0.0 diff --git a/tk3.6/library/demos/timer b/tk4.2/library/demos/timer similarity index 86% rename from tk3.6/library/demos/timer rename to tk4.2/library/demos/timer index 9102610..b2edd11 100644 --- a/tk3.6/library/demos/timer +++ b/tk4.2/library/demos/timer @@ -1,6 +1,11 @@ -#!/usr/local/bin/wish -f -# +#!/bin/sh +# the next line restarts using wish \ +exec wish "$0" "$@" + +# timer -- # This script generates a counter with start and stop buttons. +# +# SCCS: @(#) timer 1.6 96/02/16 10:49:20 label .counter -text 0.00 -relief raised -width 10 button .start -text Start -command { diff --git a/tk4.2/library/demos/twind.tcl b/tk4.2/library/demos/twind.tcl new file mode 100644 index 0000000..306b383 --- /dev/null +++ b/tk4.2/library/demos/twind.tcl @@ -0,0 +1,192 @@ +# twind.tcl -- +# +# This demonstration script creates a text widget with a bunch of +# embedded windows. +# +# SCCS: @(#) twind.tcl 1.5 96/08/20 16:04:04 + +set w .twind +catch {destroy $w} +toplevel $w +wm title $w "Text Demonstration - Embedded Windows" +wm iconname $w "Embedded Windows" +positionWindow $w + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +frame $w.f -highlightthickness 2 -borderwidth 2 -relief sunken +set t $w.f.text +text $t -yscrollcommand "$w.scroll set" -setgrid true -font $font -width 70 \ + -height 35 -wrap word -highlightthickness 0 -borderwidth 0 +pack $t -expand yes -fill both +scrollbar $w.scroll -command "$t yview" +pack $w.scroll -side right -fill y +pack $w.f -expand yes -fill both +$t tag configure center -justify center -spacing1 5m -spacing3 5m +$t tag configure buttons -lmargin1 1c -lmargin2 1c -rmargin 1c \ + -spacing1 3m -spacing2 0 -spacing3 0 + +button $t.on -text "Turn On" -command "textWindOn $w" \ + -cursor top_left_arrow +button $t.off -text "Turn Off" -command "textWindOff $w" \ + -cursor top_left_arrow +button $t.click -text "Click Here" -command "textWindPlot $t" \ + -cursor top_left_arrow +button $t.delete -text "Delete" -command "textWindDel $w" \ + -cursor top_left_arrow + +$t insert end "A text widget can contain other widgets embedded " +$t insert end "it. These are called \"embedded windows\", " +$t insert end "and they can consist of arbitrary widgets. " +$t insert end "For example, here are two embedded button " +$t insert end "widgets. You can click on the first button to " +$t window create end -window $t.on +$t insert end " horizontal scrolling, which also turns off " +$t insert end "word wrapping. Or, you can click on the second " +$t insert end "button to\n" +$t window create end -window $t.off +$t insert end " horizontal scrolling and turn back on word wrapping.\n\n" + +$t insert end "Or, here is another example. If you " +$t window create end -window $t.click +$t insert end " a canvas displaying an x-y plot will appear right here." +$t mark set plot insert +$t mark gravity plot left +$t insert end " You can drag the data points around with the mouse, " +$t insert end "or you can click here to " +$t window create end -window $t.delete +$t insert end " the plot again.\n\n" + +$t insert end "You may also find it useful to put embedded windows in " +$t insert end "a text without any actual text. In this case the " +$t insert end "text widget acts like a geometry manager. For " +$t insert end "example, here is a collection of buttons laid out " +$t insert end "neatly into rows by the text widget. These buttons " +$t insert end "can be used to change the background color of the " +$t insert end "text widget (\"Default\" restores the color to " +$t insert end "its default). If you click on the button labeled " +$t insert end "\"Short\", it changes to a longer string so that " +$t insert end "you can see how the text widget automatically " +$t insert end "changes the layout. Click on the button again " +$t insert end "to restore the short string.\n" + +button $t.default -text Default -command "embDefBg $t" \ + -cursor top_left_arrow +$t window create end -window $t.default -padx 3 +global embToggle +set embToggle Short +checkbutton $t.toggle -textvariable embToggle -indicatoron 0 \ + -variable embToggle -onvalue "A much longer string" \ + -offvalue "Short" -cursor top_left_arrow -pady 5 -padx 2 +$t window create end -window $t.toggle -padx 3 -pady 2 +set i 1 +foreach color {AntiqueWhite3 Bisque1 Bisque2 Bisque3 Bisque4 + SlateBlue3 RoyalBlue1 SteelBlue2 DeepSkyBlue3 LightBlue1 + DarkSlateGray1 Aquamarine2 DarkSeaGreen2 SeaGreen1 + Yellow1 IndianRed1 IndianRed2 Tan1 Tan4} { + button $t.color$i -text $color -cursor top_left_arrow -command \ + "$t configure -bg $color" + $t window create end -window $t.color$i -padx 3 -pady 2 + incr i +} +$t tag add buttons $t.default end + +proc textWindOn w { + catch {destroy $w.scroll2} + set t $w.f.text + scrollbar $w.scroll2 -orient horizontal -command "$t xview" + pack $w.scroll2 -after $w.buttons -side bottom -fill x + $t configure -xscrollcommand "$w.scroll2 set" -wrap none +} + +proc textWindOff w { + catch {destroy $w.scroll2} + set t $w.f.text + $t configure -xscrollcommand {} -wrap word +} + +proc textWindPlot t { + set c $t.c + if [winfo exists $c] { + return + } + canvas $c -relief sunken -width 450 -height 300 -cursor top_left_arrow + + set font -Adobe-Helvetica-Medium-R-Normal--*-180-*-*-*-*-*-* + + $c create line 100 250 400 250 -width 2 + $c create line 100 250 100 50 -width 2 + $c create text 225 20 -text "A Simple Plot" -font $font -fill brown + + for {set i 0} {$i <= 10} {incr i} { + set x [expr {100 + ($i*30)}] + $c create line $x 250 $x 245 -width 2 + $c create text $x 254 -text [expr 10*$i] -anchor n -font $font + } + for {set i 0} {$i <= 5} {incr i} { + set y [expr {250 - ($i*40)}] + $c create line 100 $y 105 $y -width 2 + $c create text 96 $y -text [expr $i*50].0 -anchor e -font $font + } + + foreach point {{12 56} {20 94} {33 98} {32 120} {61 180} + {75 160} {98 223}} { + set x [expr {100 + (3*[lindex $point 0])}] + set y [expr {250 - (4*[lindex $point 1])/5}] + set item [$c create oval [expr $x-6] [expr $y-6] \ + [expr $x+6] [expr $y+6] -width 1 -outline black \ + -fill SkyBlue2] + $c addtag point withtag $item + } + + $c bind point "$c itemconfig current -fill red" + $c bind point "$c itemconfig current -fill SkyBlue2" + $c bind point <1> "embPlotDown $c %x %y" + $c bind point "$c dtag selected" + bind $c "embPlotMove $c %x %y" + while {[string first [$t get plot] " \t\n"] >= 0} { + $t delete plot + } + $t insert plot "\n" + $t window create plot -window $c + $t tag add center plot + $t insert plot "\n" +} + +set embPlot(lastX) 0 +set embPlot(lastY) 0 + +proc embPlotDown {w x y} { + global embPlot + $w dtag selected + $w addtag selected withtag current + $w raise current + set embPlot(lastX) $x + set embPlot(lastY) $y +} + +proc embPlotMove {w x y} { + global embPlot + $w move selected [expr $x-$embPlot(lastX)] [expr $y-$embPlot(lastY)] + set embPlot(lastX) $x + set embPlot(lastY) $y +} + +proc textWindDel w { + set t $w.f.text + if [winfo exists $t.c] { + $t delete $t.c + while {[string first [$t get plot] " \t\n"] >= 0} { + $t delete plot + } + $t insert plot " " + } +} + +proc embDefBg t { + $t configure -background [lindex [$t configure -background] 3] +} diff --git a/tk4.2/library/demos/vscale.tcl b/tk4.2/library/demos/vscale.tcl new file mode 100644 index 0000000..40d598d --- /dev/null +++ b/tk4.2/library/demos/vscale.tcl @@ -0,0 +1,44 @@ +# vscale.tcl -- +# +# This demonstration script shows an example with a vertical scale. +# +# SCCS: @(#) vscale.tcl 1.3 96/02/16 10:49:51 + +set w .vscale +catch {destroy $w} +toplevel $w +wm title $w "Vertical Scale Demonstration" +wm iconname $w "vscale" +positionWindow $w + +label $w.msg -font $font -wraplength 3.5i -justify left -text "An arrow and a vertical scale are displayed below. If you click or drag mouse button 1 in the scale, you can change the size of the arrow." +pack $w.msg -side top -padx .5c + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +frame $w.frame -borderwidth 10 +pack $w.frame + +scale $w.frame.scale -orient vertical -length 284 -from 0 -to 250 \ + -command "setHeight $w.frame.canvas" -tickinterval 50 +canvas $w.frame.canvas -width 50 -height 50 -bd 0 -highlightthickness 0 +$w.frame.canvas create polygon 0 0 1 1 2 2 -fill SeaGreen3 -tags poly +$w.frame.canvas create line 0 0 1 1 2 2 0 0 -fill black -tags line +frame $w.frame.right -borderwidth 15 +pack $w.frame.scale -side left -anchor ne +pack $w.frame.canvas -side left -anchor nw -fill y +$w.frame.scale set 75 + +proc setHeight {w height} { + incr height 21 + set y2 [expr $height - 30] + if {$y2 < 21} { + set y2 21 + } + $w coords poly 15 20 35 20 35 $y2 45 $y2 25 $height 5 $y2 15 $y2 15 20 + $w coords line 15 20 35 20 35 $y2 45 $y2 25 $height 5 $y2 15 $y2 15 20 +} diff --git a/tk4.2/library/demos/widget b/tk4.2/library/demos/widget new file mode 100644 index 0000000..986479f --- /dev/null +++ b/tk4.2/library/demos/widget @@ -0,0 +1,376 @@ +#!/bin/sh +# the next line restarts using wish \ +exec wish "$0" "$@" + +# widget -- +# This script demonstrates the various widgets provided by Tk, +# along with many of the features of the Tk toolkit. This file +# only contains code to generate the main window for the +# application, which invokes individual demonstrations. The +# code for the actual demonstrations is contained in separate +# ".tcl" files is this directory, which are sourced by this script +# as needed. +# +# SCCS: @(#) widget 1.21 96/10/04 17:09:34 + +eval destroy [winfo child .] +wm title . "Widget Demonstration" + +#---------------------------------------------------------------- +# The code below create the main window, consisting of a menu bar +# and a text widget that explains how to use the program, plus lists +# all of the demos as hypertext items. +#---------------------------------------------------------------- + +set font -*-Helvetica-Medium-R-Normal--*-140-*-*-*-*-*-* +frame .menuBar +pack .menuBar -side top -fill x +menubutton .menuBar.file -text File -menu .menuBar.file.m -underline 0 +menu .menuBar.file.m +.menuBar.file.m add command -label "About ... " -command "aboutBox" \ + -underline 0 -accelerator "" +.menuBar.file.m add sep +.menuBar.file.m add command -label "Quit" -command "exit" -underline 0 +pack .menuBar.file -side left +bind . aboutBox + +frame .textFrame +scrollbar .s -orient vertical -command {.t yview} -highlightthickness 0 \ + -takefocus 1 +pack .s -in .textFrame -side right -fill y -padx 1 +text .t -yscrollcommand {.s set} -wrap word -width 60 -height 30 -font $font \ + -setgrid 1 -highlightthickness 0 -padx 4 -pady 2 -takefocus 0 +pack .t -in .textFrame -expand y -fill both -padx 1 +pack .textFrame -expand yes -fill both -padx 1 -pady 2 + +frame .statusBar +label .statusBar.lab -text " " -relief sunken -bd 1 \ + -font -*-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -anchor w +label .statusBar.foo -width 8 -relief sunken -bd 1 \ + -font -*-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -anchor w +pack .statusBar.lab -side left -padx 2 -expand yes -fill both +pack .statusBar.foo -side left -padx 2 +pack .statusBar -side top -fill x -pady 2 + +# Create a bunch of tags to use in the text widget, such as those for +# section titles and demo descriptions. Also define the bindings for +# tags. + +.t tag configure title -font -*-Helvetica-Bold-R-Normal--*-180-*-*-*-*-*-* + +# We put some "space" characters to the left and right of each demo description +# so that the descriptions are highlighted only when the mouse cursor +# is right over them (but not when the cursor is to their left or right) +# +.t tag configure demospace -lmargin1 1c -lmargin2 1c + + +if {[winfo depth .] == 1} { + .t tag configure demo -lmargin1 1c -lmargin2 1c \ + -underline 1 + .t tag configure visited -lmargin1 1c -lmargin2 1c \ + -underline 1 + .t tag configure hot -background black -foreground white +} else { + .t tag configure demo -lmargin1 1c -lmargin2 1c \ + -foreground blue -underline 1 + .t tag configure visited -lmargin1 1c -lmargin2 1c \ + -foreground #303080 -underline 1 + .t tag configure hot -foreground red -underline 1 +} +.t tag bind demo { + invoke [.t index {@%x,%y}] +} +set lastLine "" +.t tag bind demo { + set lastLine [.t index {@%x,%y linestart}] + .t tag add hot "$lastLine +1 chars" "$lastLine lineend -1 chars" + .t config -cursor hand2 + showStatus [.t index {@%x,%y}] +} +.t tag bind demo { + .t tag remove hot 1.0 end + .t config -cursor xterm + .statusBar.lab config -text "" +} +.t tag bind demo { + set newLine [.t index {@%x,%y linestart}] + if {[string compare $newLine $lastLine] != 0} { + .t tag remove hot 1.0 end + set lastLine $newLine + + set tags [.t tag names {@%x,%y}] + set i [lsearch -glob $tags demo-*] + if {$i >= 0} { + .t tag add hot "$lastLine +1 chars" "$lastLine lineend -1 chars" + } + } + showStatus [.t index {@%x,%y}] +} + +# Create the text for the text widget. + +.t insert end "Tk Widget Demonstrations\n" title +.t insert end { +This application provides a front end for several short scripts that demonstrate what you can do with Tk widgets. Each of the numbered lines below describes a demonstration; you can click on it to invoke the demonstration. Once the demonstration window appears, you can click the "See Code" button to see the Tcl/Tk code that created the demonstration. If you wish, you can edit the code and click the "Rerun Demo" button in the code window to reinvoke the demonstration with the modified code. + +} +.t insert end "Labels, buttons, checkbuttons, and radiobuttons" title +.t insert end " \n " {demospace} +.t insert end "1. Labels (text and bitmaps)." {demo demo-label} +.t insert end " \n " {demospace} +.t insert end "2. Buttons." {demo demo-button} +.t insert end " \n " {demospace} +.t insert end "3. Checkbuttons (select any of a group)." {demo demo-check} +.t insert end " \n " {demospace} +.t insert end "4. Radiobuttons (select one of a group)." {demo demo-radio} +.t insert end " \n " {demospace} +.t insert end "5. A 15-puzzle game made out of buttons." {demo demo-puzzle} +.t insert end " \n " {demospace} +.t insert end "6. Iconic buttons that use bitmaps." {demo demo-icon} +.t insert end " \n " {demospace} +.t insert end "7. Two labels displaying images." {demo demo-image1} +.t insert end " \n " {demospace} +.t insert end "8. A simple user interface for viewing images." \ + {demo demo-image2} +.t insert end " \n " {demospace} + +.t insert end \n {} "Listboxes" title +.t insert end " \n " {demospace} +.t insert end "1. 50 states." {demo demo-states} +.t insert end " \n " {demospace} +.t insert end "2. Colors: change the color scheme for the application." \ + {demo demo-colors} +.t insert end " \n " {demospace} +.t insert end "3. A collection of famous sayings." {demo demo-sayings} +.t insert end " \n " {demospace} + +.t insert end \n {} "Entries" title +.t insert end " \n " {demospace} +.t insert end "1. Without scrollbars." {demo demo-entry1} +.t insert end " \n " {demospace} +.t insert end "2. With scrollbars." {demo demo-entry2} +.t insert end " \n " {demospace} +.t insert end "3. Simple Rolodex-like form." {demo demo-form} +.t insert end " \n " {demospace} + +.t insert end \n {} "Text" title +.t insert end " \n " {demospace} +.t insert end "1. Basic editable text." {demo demo-text} +.t insert end " \n " {demospace} +.t insert end "2. Text display styles." {demo demo-style} +.t insert end " \n " {demospace} +.t insert end "3. Hypertext (tag bindings)." {demo demo-bind} +.t insert end " \n " {demospace} +.t insert end "4. A text widget with embedded windows." {demo demo-twind} +.t insert end " \n " {demospace} +.t insert end "5. A search tool built with a text widget." {demo demo-search} +.t insert end " \n " {demospace} + +.t insert end \n {} "Canvases" title +.t insert end " \n " {demospace} +.t insert end "1. The canvas item types." {demo demo-items} +.t insert end " \n " {demospace} +.t insert end "2. A simple 2-D plot." {demo demo-plot} +.t insert end " \n " {demospace} +.t insert end "3. Text items in canvases." {demo demo-ctext} +.t insert end " \n " {demospace} +.t insert end "4. An editor for arrowheads on canvas lines." {demo demo-arrow} +.t insert end " \n " {demospace} +.t insert end "5. A ruler with adjustable tab stops." {demo demo-ruler} +.t insert end " \n " {demospace} +.t insert end "6. A building floor plan." {demo demo-floor} +.t insert end " \n " {demospace} +.t insert end "7. A simple scrollable canvas." {demo demo-cscroll} +.t insert end " \n " {demospace} + +.t insert end \n {} "Scales" title +.t insert end " \n " {demospace} +.t insert end "1. Vertical scale." {demo demo-vscale} +.t insert end " \n " {demospace} +.t insert end "2. Horizontal scale." {demo demo-hscale} +.t insert end " \n " {demospace} + +.t insert end \n {} "Menus" title +.t insert end " \n " {demospace} +.t insert end "1. A window containing several menus and cascades." \ + {demo demo-menu} +.t insert end " \n " {demospace} + +.t insert end \n {} "Common Dialogs" title +.t insert end " \n " {demospace} +.t insert end "1. Message boxes." {demo demo-msgbox} +.t insert end " \n " {demospace} +.t insert end "2. File selection dialog." {demo demo-filebox} +.t insert end " \n " {demospace} +.t insert end "3. Color picker." {demo demo-clrpick} +.t insert end " \n " {demospace} + +.t insert end \n {} "Miscellaneous" title +.t insert end " \n " {demospace} +.t insert end "1. The built-in bitmaps." {demo demo-bitmap} +.t insert end " \n " {demospace} +.t insert end "2. A dialog box with a local grab." {demo demo-dialog1} +.t insert end " \n " {demospace} +.t insert end "3. A dialog box with a global grab." {demo demo-dialog2} +.t insert end " \n " {demospace} + +.t configure -state disabled +focus .s + +# positionWindow -- +# This procedure is invoked by most of the demos to position a +# new demo window. +# +# Arguments: +# w - The name of the window to position. + +proc positionWindow w { + wm geometry $w +300+300 +} + +# showVars -- +# Displays the values of one or more variables in a window, and +# updates the display whenever any of the variables changes. +# +# Arguments: +# w - Name of new window to create for display. +# args - Any number of names of variables. + +proc showVars {w args} { + catch {destroy $w} + toplevel $w + wm title $w "Variable values" + label $w.title -text "Variable values:" -width 20 -anchor center \ + -font -Adobe-helvetica-medium-r-normal--*-180-*-*-*-*-*-* + pack $w.title -side top -fill x + set len 1 + foreach i $args { + if {[string length $i] > $len} { + set len [string length $i] + } + } + foreach i $args { + frame $w.$i + label $w.$i.name -text "$i: " -width [expr $len + 2] -anchor w + label $w.$i.value -textvar $i -anchor w + pack $w.$i.name -side left + pack $w.$i.value -side left -expand 1 -fill x + pack $w.$i -side top -anchor w -fill x + } + button $w.ok -text OK -command "destroy $w" + pack $w.ok -side bottom -pady 2 +} + +# invoke -- +# This procedure is called when the user clicks on a demo description. +# It is responsible for invoking the demonstration. +# +# Arguments: +# index - The index of the character that the user clicked on. + +proc invoke index { + global tk_library + set tags [.t tag names $index] + set i [lsearch -glob $tags demo-*] + if {$i < 0} { + return + } + set cursor [.t cget -cursor] + .t configure -cursor watch + update + set demo [string range [lindex $tags $i] 5 end] + uplevel [list source [file join $tk_library demos $demo.tcl]] + update + .t configure -cursor $cursor + + .t tag add visited "$index linestart +1 chars" "$index lineend -1 chars" +} + +# showStatus -- +# +# Show the name of the demo program in the status bar. This procedure +# is called when the user moves the cursor over a demo description. +# +proc showStatus index { + global tk_library + set tags [.t tag names $index] + set i [lsearch -glob $tags demo-*] + set cursor [.t cget -cursor] + if {$i < 0} { + .statusBar.lab config -text " " + set newcursor xterm + } else { + set demo [string range [lindex $tags $i] 5 end] + .statusBar.lab config -text "Run the \"$demo\" sample program" + set newcursor hand2 + } + if [string compare $cursor $newcursor] { + .t config -cursor $newcursor + } +} + + +# showCode -- +# This procedure creates a toplevel window that displays the code for +# a demonstration and allows it to be edited and reinvoked. +# +# Arguments: +# w - The name of the demonstration's window, which can be +# used to derive the name of the file containing its code. + +proc showCode w { + global tk_library + set file [string range $w 1 end].tcl + if ![winfo exists .code] { + toplevel .code + frame .code.buttons + pack .code.buttons -side bottom -fill x + button .code.buttons.dismiss -text Dismiss -command "destroy .code" + button .code.buttons.rerun -text "Rerun Demo" -command { + eval [.code.text get 1.0 end] + } + pack .code.buttons.dismiss .code.buttons.rerun -side left \ + -expand 1 -pady 2 + frame .code.frame + pack .code.frame -expand yes -fill both -padx 1 -pady 1 + text .code.text -height 40 -wrap word\ + -xscrollcommand ".code.xscroll set" \ + -yscrollcommand ".code.yscroll set" \ + -setgrid 1 -highlightthickness 0 -pady 2 -padx 3 + scrollbar .code.xscroll -command ".code.text xview" \ + -highlightthickness 0 -orient horizontal + scrollbar .code.yscroll -command ".code.text yview" \ + -highlightthickness 0 -orient vertical + + grid .code.text -in .code.frame -padx 1 -pady 1 \ + -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news + grid .code.yscroll -in .code.frame -padx 1 -pady 1 \ + -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news +# grid .code.xscroll -in .code.frame -padx 1 -pady 1 \ +# -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news + grid rowconfig .code.frame 0 -weight 1 -minsize 0 + grid columnconfig .code.frame 0 -weight 1 -minsize 0 + } else { + wm deiconify .code + raise .code + } + wm title .code "Demo code: [file join $tk_library demos $file]" + wm iconname .code $file + set id [open [file join $tk_library demos $file]] + .code.text delete 1.0 end + .code.text insert 1.0 [read $id] + .code.text mark set insert 1.0 + close $id +} + +# aboutBox -- +# +# Pops up a message box with an "about" message +# +proc aboutBox {} { + tk_messageBox -icon info -type ok -title "About Widget Demo" -message \ +"Tk widget demonstration\n\n\ +Copyright (c) 1996 Sun Microsystems, Inc." +} + diff --git a/tk4.2/library/dialog.tcl b/tk4.2/library/dialog.tcl new file mode 100644 index 0000000..89f5c9c --- /dev/null +++ b/tk4.2/library/dialog.tcl @@ -0,0 +1,156 @@ +# dialog.tcl -- +# +# This file defines the procedure tk_dialog, which creates a dialog +# box containing a bitmap, a message, and one or more buttons. +# +# SCCS: @(#) dialog.tcl 1.26 96/05/07 09:30:31 +# +# Copyright (c) 1992-1993 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +# +# tk_dialog: +# +# This procedure displays a dialog box, waits for a button in the dialog +# to be invoked, then returns the index of the selected button. If the +# dialog somehow gets destroyed, -1 is returned. +# +# Arguments: +# w - Window to use for dialog top-level. +# title - Title to display in dialog's decorative frame. +# text - Message to display in dialog. +# bitmap - Bitmap to display in dialog (empty string means none). +# default - Index of button that is to display the default ring +# (-1 means none). +# args - One or more strings to display in buttons across the +# bottom of the dialog box. + +proc tk_dialog {w title text bitmap default args} { + global tkPriv + + # 1. Create the top-level window and divide it into top + # and bottom parts. + + catch {destroy $w} + toplevel $w -class Dialog + wm title $w $title + wm iconname $w Dialog + wm protocol $w WM_DELETE_WINDOW { } + + # The following command means that the dialog won't be posted if + # [winfo parent $w] is iconified, but it's really needed; otherwise + # the dialog can become obscured by other windows in the application, + # even though its grab keeps the rest of the application from being used. + + wm transient $w [winfo toplevel [winfo parent $w]] + frame $w.bot -relief raised -bd 1 + pack $w.bot -side bottom -fill both + frame $w.top -relief raised -bd 1 + pack $w.top -side top -fill both -expand 1 + + # 2. Fill the top part with bitmap and message (use the option + # database for -wraplength so that it can be overridden by + # the caller). + + option add *Dialog.msg.wrapLength 3i widgetDefault + label $w.msg -justify left -text $text + catch {$w.msg configure -font \ + -Adobe-Times-Medium-R-Normal--*-180-*-*-*-*-*-* + } + pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m + if {$bitmap != ""} { + label $w.bitmap -bitmap $bitmap + pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m + } + + # 3. Create a row of buttons at the bottom of the dialog. + + set i 0 + foreach but $args { + button $w.button$i -text $but -command "set tkPriv(button) $i" + if {$i == $default} { + frame $w.default -relief sunken -bd 1 + raise $w.button$i $w.default + pack $w.default -in $w.bot -side left -expand 1 -padx 3m -pady 2m + pack $w.button$i -in $w.default -padx 2m -pady 2m + } else { + pack $w.button$i -in $w.bot -side left -expand 1 \ + -padx 3m -pady 2m + } + incr i + } + + # 4. Create a binding for on the dialog if there is a + # default button. + + if {$default >= 0} { + bind $w " + $w.button$default configure -state active -relief sunken + update idletasks + after 100 + set tkPriv(button) $default + " + } + + # 5. Create a binding for the window that sets the + # button variable to -1; this is needed in case something happens + # that destroys the window, such as its parent window being destroyed. + + bind $w {set tkPriv(button) -1} + + # 6. Withdraw the window, then update all the geometry information + # so we know how big it wants to be, then center the window in the + # display and de-iconify it. + + wm withdraw $w + update idletasks + set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \ + - [winfo vrootx [winfo parent $w]]] + set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \ + - [winfo vrooty [winfo parent $w]]] + wm geom $w +$x+$y + wm deiconify $w + + # 7. Set a grab and claim the focus too. + + set oldFocus [focus] + set oldGrab [grab current $w] + if {$oldGrab != ""} { + set grabStatus [grab status $oldGrab] + } + grab $w + if {$default >= 0} { + focus $w.button$default + } else { + focus $w + } + + # 8. Wait for the user to respond, then restore the focus and + # return the index of the selected button. Restore the focus + # before deleting the window, since otherwise the window manager + # may take the focus away so we can't redirect it. Finally, + # restore any grab that was in effect. + + tkwait variable tkPriv(button) + catch {focus $oldFocus} + catch { + # It's possible that the window has already been destroyed, + # hence this "catch". Delete the Destroy handler so that + # tkPriv(button) doesn't get reset by it. + + bind $w {} + destroy $w + } + if {$oldGrab != ""} { + if {$grabStatus == "global"} { + grab -global $oldGrab + } else { + grab $oldGrab + } + } + return $tkPriv(button) +} diff --git a/tk4.2/library/entry.tcl b/tk4.2/library/entry.tcl new file mode 100644 index 0000000..2795112 --- /dev/null +++ b/tk4.2/library/entry.tcl @@ -0,0 +1,544 @@ +# entry.tcl -- +# +# This file defines the default bindings for Tk entry widgets and provides +# procedures that help in implementing those bindings. +# +# SCCS: @(#) entry.tcl 1.43 96/08/23 14:07:15 +# +# Copyright (c) 1992-1994 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +#------------------------------------------------------------------------- +# Elements of tkPriv that are used in this file: +# +# afterId - If non-null, it means that auto-scanning is underway +# and it gives the "after" id for the next auto-scan +# command to be executed. +# mouseMoved - Non-zero means the mouse has moved a significant +# amount since the button went down (so, for example, +# start dragging out a selection). +# pressX - X-coordinate at which the mouse button was pressed. +# selectMode - The style of selection currently underway: +# char, word, or line. +# x, y - Last known mouse coordinates for scanning +# and auto-scanning. +#------------------------------------------------------------------------- + +#------------------------------------------------------------------------- +# The code below creates the default class bindings for entries. +#------------------------------------------------------------------------- + +bind Entry <> { + if {[selection own -displayof %W] == "%W"} { + clipboard clear -displayof %W + catch { + clipboard append -displayof %W [selection get -displayof %W] + %W delete sel.first sel.last + } + } +} +bind Entry <> { + if {[selection own -displayof %W] == "%W"} { + clipboard clear -displayof %W + catch { + clipboard append -displayof %W [selection get -displayof %W] + } + } +} +bind Entry <> { + catch { + %W insert insert [selection get -displayof %W -selection CLIPBOARD] + tkEntrySeeInsert %W + } +} +bind Entry <> { + %W delete sel.first sel.last +} + +# Standard Motif bindings: + +bind Entry <1> { + tkEntryButton1 %W %x + %W selection clear +} +bind Entry { + set tkPriv(x) %x + tkEntryMouseSelect %W %x +} +bind Entry { + set tkPriv(selectMode) word + tkEntryMouseSelect %W %x + catch {%W icursor sel.first} +} +bind Entry { + set tkPriv(selectMode) line + tkEntryMouseSelect %W %x + %W icursor 0 +} +bind Entry { + set tkPriv(selectMode) char + %W selection adjust @%x +} +bind Entry { + set tkPriv(selectMode) word + tkEntryMouseSelect %W %x +} +bind Entry { + set tkPriv(selectMode) line + tkEntryMouseSelect %W %x +} +bind Entry { + set tkPriv(x) %x + tkEntryAutoScan %W +} +bind Entry { + tkCancelRepeat +} +bind Entry { + tkCancelRepeat +} +bind Entry { + %W icursor @%x +} +bind Entry { + if {!$tkPriv(mouseMoved) || $tk_strictMotif} { + tkEntryPaste %W %x + } +} + +bind Entry { + tkEntrySetCursor %W [expr [%W index insert] - 1] +} +bind Entry { + tkEntrySetCursor %W [expr [%W index insert] + 1] +} +bind Entry { + tkEntryKeySelect %W [expr [%W index insert] - 1] + tkEntrySeeInsert %W +} +bind Entry { + tkEntryKeySelect %W [expr [%W index insert] + 1] + tkEntrySeeInsert %W +} +bind Entry { + tkEntrySetCursor %W \ + [string wordstart [%W get] [expr [%W index insert] - 1]] +} +bind Entry { + tkEntrySetCursor %W [string wordend [%W get] [%W index insert]] +} +bind Entry { + tkEntryKeySelect %W \ + [string wordstart [%W get] [expr [%W index insert] - 1]] + tkEntrySeeInsert %W +} +bind Entry { + tkEntryKeySelect %W [string wordend [%W get] [%W index insert]] + tkEntrySeeInsert %W +} +bind Entry { + tkEntrySetCursor %W 0 +} +bind Entry { + tkEntryKeySelect %W 0 + tkEntrySeeInsert %W +} +bind Entry { + tkEntrySetCursor %W end +} +bind Entry { + tkEntryKeySelect %W end + tkEntrySeeInsert %W +} + +bind Entry { + if [%W selection present] { + %W delete sel.first sel.last + } else { + %W delete insert + } +} +bind Entry { + tkEntryBackspace %W +} + +bind Entry { + %W selection from insert +} +bind Entry { + tkListboxBeginSelect %W [%W index active] +} +bind Listbox { + tkListboxBeginExtend %W [%W index active] +} +bind Listbox { + tkListboxBeginExtend %W [%W index active] +} +bind Listbox { + tkListboxCancel %W +} +bind Listbox { + tkListboxSelectAll %W +} +bind Listbox { + if {[%W cget -selectmode] != "browse"} { + %W selection clear 0 end + } +} + +# Additional Tk bindings that aren't part of the Motif look and feel: + +bind Listbox <2> { + %W scan mark %x %y +} +bind Listbox { + %W scan dragto %x %y +} + +# tkListboxBeginSelect -- +# +# This procedure is typically invoked on button-1 presses. It begins +# the process of making a selection in the listbox. Its exact behavior +# depends on the selection mode currently in effect for the listbox; +# see the Motif documentation for details. +# +# Arguments: +# w - The listbox widget. +# el - The element for the selection operation (typically the +# one under the pointer). Must be in numerical form. + +proc tkListboxBeginSelect {w el} { + global tkPriv + if {[$w cget -selectmode] == "multiple"} { + if [$w selection includes $el] { + $w selection clear $el + } else { + $w selection set $el + } + } else { + $w selection clear 0 end + $w selection set $el + $w selection anchor $el + set tkPriv(listboxSelection) {} + set tkPriv(listboxPrev) $el + } +} + +# tkListboxMotion -- +# +# This procedure is called to process mouse motion events while +# button 1 is down. It may move or extend the selection, depending +# on the listbox's selection mode. +# +# Arguments: +# w - The listbox widget. +# el - The element under the pointer (must be a number). + +proc tkListboxMotion {w el} { + global tkPriv + if {$el == $tkPriv(listboxPrev)} { + return + } + set anchor [$w index anchor] + switch [$w cget -selectmode] { + browse { + $w selection clear 0 end + $w selection set $el + set tkPriv(listboxPrev) $el + } + extended { + set i $tkPriv(listboxPrev) + if [$w selection includes anchor] { + $w selection clear $i $el + $w selection set anchor $el + } else { + $w selection clear $i $el + $w selection clear anchor $el + } + while {($i < $el) && ($i < $anchor)} { + if {[lsearch $tkPriv(listboxSelection) $i] >= 0} { + $w selection set $i + } + incr i + } + while {($i > $el) && ($i > $anchor)} { + if {[lsearch $tkPriv(listboxSelection) $i] >= 0} { + $w selection set $i + } + incr i -1 + } + set tkPriv(listboxPrev) $el + } + } +} + +# tkListboxBeginExtend -- +# +# This procedure is typically invoked on shift-button-1 presses. It +# begins the process of extending a selection in the listbox. Its +# exact behavior depends on the selection mode currently in effect +# for the listbox; see the Motif documentation for details. +# +# Arguments: +# w - The listbox widget. +# el - The element for the selection operation (typically the +# one under the pointer). Must be in numerical form. + +proc tkListboxBeginExtend {w el} { + if {([$w cget -selectmode] == "extended") + && [$w selection includes anchor]} { + tkListboxMotion $w $el + } +} + +# tkListboxBeginToggle -- +# +# This procedure is typically invoked on control-button-1 presses. It +# begins the process of toggling a selection in the listbox. Its +# exact behavior depends on the selection mode currently in effect +# for the listbox; see the Motif documentation for details. +# +# Arguments: +# w - The listbox widget. +# el - The element for the selection operation (typically the +# one under the pointer). Must be in numerical form. + +proc tkListboxBeginToggle {w el} { + global tkPriv + if {[$w cget -selectmode] == "extended"} { + set tkPriv(listboxSelection) [$w curselection] + set tkPriv(listboxPrev) $el + $w selection anchor $el + if [$w selection includes $el] { + $w selection clear $el + } else { + $w selection set $el + } + } +} + +# tkListboxAutoScan -- +# This procedure is invoked when the mouse leaves an entry window +# with button 1 down. It scrolls the window up, down, left, or +# right, depending on where the mouse left the window, and reschedules +# itself as an "after" command so that the window continues to scroll until +# the mouse moves back into the window or the mouse button is released. +# +# Arguments: +# w - The entry window. + +proc tkListboxAutoScan {w} { + global tkPriv + if {![winfo exists $w]} return + set x $tkPriv(x) + set y $tkPriv(y) + if {$y >= [winfo height $w]} { + $w yview scroll 1 units + } elseif {$y < 0} { + $w yview scroll -1 units + } elseif {$x >= [winfo width $w]} { + $w xview scroll 2 units + } elseif {$x < 0} { + $w xview scroll -2 units + } else { + return + } + tkListboxMotion $w [$w index @$x,$y] + set tkPriv(afterId) [after 50 tkListboxAutoScan $w] +} + +# tkListboxUpDown -- +# +# Moves the location cursor (active element) up or down by one element, +# and changes the selection if we're in browse or extended selection +# mode. +# +# Arguments: +# w - The listbox widget. +# amount - +1 to move down one item, -1 to move back one item. + +proc tkListboxUpDown {w amount} { + global tkPriv + $w activate [expr [$w index active] + $amount] + $w see active + switch [$w cget -selectmode] { + browse { + $w selection clear 0 end + $w selection set active + } + extended { + $w selection clear 0 end + $w selection set active + $w selection anchor active + set tkPriv(listboxPrev) [$w index active] + set tkPriv(listboxSelection) {} + } + } +} + +# tkListboxExtendUpDown -- +# +# Does nothing unless we're in extended selection mode; in this +# case it moves the location cursor (active element) up or down by +# one element, and extends the selection to that point. +# +# Arguments: +# w - The listbox widget. +# amount - +1 to move down one item, -1 to move back one item. + +proc tkListboxExtendUpDown {w amount} { + if {[$w cget -selectmode] != "extended"} { + return + } + $w activate [expr [$w index active] + $amount] + $w see active + tkListboxMotion $w [$w index active] +} + +# tkListboxDataExtend +# +# This procedure is called for key-presses such as Shift-KEndData. +# If the selection mode isn't multiple or extend then it does nothing. +# Otherwise it moves the active element to el and, if we're in +# extended mode, extends the selection to that point. +# +# Arguments: +# w - The listbox widget. +# el - An integer element number. + +proc tkListboxDataExtend {w el} { + set mode [$w cget -selectmode] + if {$mode == "extended"} { + $w activate $el + $w see $el + if [$w selection includes anchor] { + tkListboxMotion $w $el + } + } elseif {$mode == "multiple"} { + $w activate $el + $w see $el + } +} + +# tkListboxCancel +# +# This procedure is invoked to cancel an extended selection in +# progress. If there is an extended selection in progress, it +# restores all of the items between the active one and the anchor +# to their previous selection state. +# +# Arguments: +# w - The listbox widget. + +proc tkListboxCancel w { + global tkPriv + if {[$w cget -selectmode] != "extended"} { + return + } + set first [$w index anchor] + set last $tkPriv(listboxPrev) + if {$first > $last} { + set tmp $first + set first $last + set last $tmp + } + $w selection clear $first $last + while {$first <= $last} { + if {[lsearch $tkPriv(listboxSelection) $first] >= 0} { + $w selection set $first + } + incr first + } +} + +# tkListboxSelectAll +# +# This procedure is invoked to handle the "select all" operation. +# For single and browse mode, it just selects the active element. +# Otherwise it selects everything in the widget. +# +# Arguments: +# w - The listbox widget. + +proc tkListboxSelectAll w { + set mode [$w cget -selectmode] + if {($mode == "single") || ($mode == "browse")} { + $w selection clear 0 end + $w selection set active + } else { + $w selection set 0 end + } +} diff --git a/tk4.2/library/menu.tcl b/tk4.2/library/menu.tcl new file mode 100644 index 0000000..104884f --- /dev/null +++ b/tk4.2/library/menu.tcl @@ -0,0 +1,935 @@ +# menu.tcl -- +# +# This file defines the default bindings for Tk menus and menubuttons. +# It also implements keyboard traversal of menus and implements a few +# other utility procedures related to menus. +# +# SCCS: @(#) menu.tcl 1.69 96/09/17 08:32:27 +# +# Copyright (c) 1992-1994 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +#------------------------------------------------------------------------- +# Elements of tkPriv that are used in this file: +# +# cursor - Saves the -cursor option for the posted menubutton. +# focus - Saves the focus during a menu selection operation. +# Focus gets restored here when the menu is unposted. +# grabGlobal - Used in conjunction with tkPriv(oldGrab): if +# tkPriv(oldGrab) is non-empty, then tkPriv(grabGlobal) +# contains either an empty string or "-global" to +# indicate whether the old grab was a local one or +# a global one. +# inMenubutton - The name of the menubutton widget containing +# the mouse, or an empty string if the mouse is +# not over any menubutton. +# oldGrab - Window that had the grab before a menu was posted. +# Used to restore the grab state after the menu +# is unposted. Empty string means there was no +# grab previously set. +# popup - If a menu has been popped up via tk_popup, this +# gives the name of the menu. Otherwise this +# value is empty. +# postedMb - Name of the menubutton whose menu is currently +# posted, or an empty string if nothing is posted +# A grab is set on this widget. +# relief - Used to save the original relief of the current +# menubutton. +# window - When the mouse is over a menu, this holds the +# name of the menu; it's cleared when the mouse +# leaves the menu. +#------------------------------------------------------------------------- + +#------------------------------------------------------------------------- +# Overall note: +# This file is tricky because there are four different ways that menus +# can be used: +# +# 1. As a pulldown from a menubutton. This is the most common usage. +# In this style, the variable tkPriv(postedMb) identifies the posted +# menubutton. +# 2. As a torn-off menu copied from some other menu. In this style +# tkPriv(postedMb) is empty, and the top-level menu is no +# override-redirect. +# 3. As an option menu, triggered from an option menubutton. In thi +# style tkPriv(postedMb) identifies the posted menubutton. +# 4. As a popup menu. In this style tkPriv(postedMb) is empty and +# the top-level menu is override-redirect. +# +# The various binding procedures use the state described above to +# distinguish the various cases and take different actions in each +# case. +#------------------------------------------------------------------------- + +#------------------------------------------------------------------------- +# The code below creates the default class bindings for menus +# and menubuttons. +#------------------------------------------------------------------------- + +bind Menubutton {} +bind Menubutton { + tkMbEnter %W +} +bind Menubutton { + tkMbLeave %W +} +bind Menubutton <1> { + if {$tkPriv(inMenubutton) != ""} { + tkMbPost $tkPriv(inMenubutton) %X %Y + } +} +bind Menubutton { + tkMbMotion %W up %X %Y +} +bind Menubutton { + tkMbMotion %W down %X %Y +} +bind Menubutton { + tkMbButtonUp %W +} +bind Menubutton { + tkMbPost %W + tkMenuFirstEntry [%W cget -menu] +} + +# Must set focus when mouse enters a menu, in order to allow +# mixed-mode processing using both the mouse and the keyboard. +# Don't set the focus if the event comes from a grab release, +# though: such an event can happen after as part of unposting +# a cascaded chain of menus, after the focus has already been +# restored to wherever it was before menu selection started. + +bind Menu {} +bind Menu { + set tkPriv(window) %W + if {"%m" != "NotifyUngrab"} { + focus %W + } +} +bind Menu { + tkMenuLeave %W %X %Y %s +} +bind Menu { + tkMenuMotion %W %y %s +} +bind Menu { + tkMenuButtonDown %W +} +bind Menu { + tkMenuInvoke %W 1 +} +bind Menu { + tkMenuInvoke %W 0 +} +bind Menu { + tkMenuInvoke %W 0 +} +bind Menu { + tkMenuEscape %W +} +bind Menu { + tkMenuLeftRight %W left +} +bind Menu { + tkMenuLeftRight %W right +} +bind Menu { + tkMenuNextEntry %W -1 +} +bind Menu { + tkMenuNextEntry %W +1 +} +bind Menu { + tkTraverseWithinMenu %W %A +} + +# The following bindings apply to all windows, and are used to +# implement keyboard menu traversal. + +bind all { + tkTraverseToMenu %W %A +} +bind all { + tkFirstMenu %W +} + +# tkMbEnter -- +# This procedure is invoked when the mouse enters a menubutton +# widget. It activates the widget unless it is disabled. Note: +# this procedure is only invoked when mouse button 1 is *not* down. +# The procedure tkMbB1Enter is invoked if the button is down. +# +# Arguments: +# w - The name of the widget. + +proc tkMbEnter w { + global tkPriv + + if {$tkPriv(inMenubutton) != ""} { + tkMbLeave $tkPriv(inMenubutton) + } + set tkPriv(inMenubutton) $w + if {[$w cget -state] != "disabled"} { + $w configure -state active + } +} + +# tkMbLeave -- +# This procedure is invoked when the mouse leaves a menubutton widget. +# It de-activates the widget, if the widget still exists. +# +# Arguments: +# w - The name of the widget. + +proc tkMbLeave w { + global tkPriv + + set tkPriv(inMenubutton) {} + if ![winfo exists $w] { + return + } + if {[$w cget -state] == "active"} { + $w configure -state normal + } +} + +# tkMbPost -- +# Given a menubutton, this procedure does all the work of posting +# its associated menu and unposting any other menu that is currently +# posted. +# +# Arguments: +# w - The name of the menubutton widget whose menu +# is to be posted. +# x, y - Root coordinates of cursor, used for positioning +# option menus. If not specified, then the center +# of the menubutton is used for an option menu. + +proc tkMbPost {w {x {}} {y {}}} { + global tkPriv errorInfo + if {([$w cget -state] == "disabled") || ($w == $tkPriv(postedMb))} { + return + } + set menu [$w cget -menu] + if {$menu == ""} { + return + } + if {[string first $w $menu] != 0} { + error "can't post $menu: it isn't a descendant of $w (this is a new requirement in Tk versions 3.0 and later)" + } + set cur $tkPriv(postedMb) + if {$cur != ""} { + tkMenuUnpost {} + } + set tkPriv(cursor) [$w cget -cursor] + set tkPriv(relief) [$w cget -relief] + $w configure -cursor arrow + $w configure -relief raised + set tkPriv(postedMb) $w + set tkPriv(focus) [focus] + $menu activate none + + # If this looks like an option menubutton then post the menu so + # that the current entry is on top of the mouse. Otherwise post + # the menu just below the menubutton, as for a pull-down. + + if [catch { + if [$w cget -indicatoron] { + if {$y == ""} { + set x [expr [winfo rootx $w] + [winfo width $w]/2] + set y [expr [winfo rooty $w] + [winfo height $w]/2] + } + tkPostOverPoint $menu $x $y [tkMenuFindName $menu [$w cget -text]] + } else { + $menu post [winfo rootx $w] [expr [winfo rooty $w] + \ + [winfo height $w]] + } + } msg] { + # Error posting menu (e.g. bogus -postcommand). Unpost it and + # reflect the error. + + tkMenuUnpost {} + error $msg $errorInfo + } + focus $menu + tkSaveGrabInfo $w + grab -global $w +} + +# tkMenuUnpost -- +# This procedure unposts a given menu, plus all of its ancestors up +# to (and including) a menubutton, if any. It also restores various +# values to what they were before the menu was posted, and releases +# a grab if there's a menubutton involved. Special notes: +# 1. It's important to unpost all menus before releasing the grab, so +# that any Enter-Leave events (e.g. from menu back to main +# application) have mode NotifyGrab. +# 2. Be sure to enclose various groups of commands in "catch" so that +# the procedure will complete even if the menubutton or the menu +# or the grab window has been deleted. +# +# Arguments: +# menu - Name of a menu to unpost. Ignored if there +# is a posted menubutton. + +proc tkMenuUnpost menu { + global tkPriv + set mb $tkPriv(postedMb) + + # Restore focus right away (otherwise X will take focus away when + # the menu is unmapped and under some window managers (e.g. olvwm) + # we'll lose the focus completely). + + catch {focus $tkPriv(focus)} + set tkPriv(focus) "" + + # Unpost menu(s) and restore some stuff that's dependent on + # what was posted. + + catch { + if {$mb != ""} { + set menu [$mb cget -menu] + $menu unpost + set tkPriv(postedMb) {} + $mb configure -cursor $tkPriv(cursor) + $mb configure -relief $tkPriv(relief) + } elseif {$tkPriv(popup) != ""} { + $tkPriv(popup) unpost + set tkPriv(popup) {} + } elseif {[wm overrideredirect $menu]} { + # We're in a cascaded sub-menu from a torn-off menu or popup. + # Unpost all the menus up to the toplevel one (but not + # including the top-level torn-off one) and deactivate the + # top-level torn off menu if there is one. + + while 1 { + set parent [winfo parent $menu] + if {([winfo class $parent] != "Menu") + || ![winfo ismapped $parent]} { + break + } + $parent activate none + $parent postcascade none + if {![wm overrideredirect $parent]} { + break + } + set menu $parent + } + $menu unpost + } + } + + # Release grab, if any, and restore the previous grab, if there + # was one. + + if {$menu != ""} { + set grab [grab current $menu] + if {$grab != ""} { + grab release $grab + } + } + if {$tkPriv(oldGrab) != ""} { + + # Be careful restoring the old grab, since it's window may not + # be visible anymore. + + catch { + if {$tkPriv(grabStatus) == "global"} { + grab set -global $tkPriv(oldGrab) + } else { + grab set $tkPriv(oldGrab) + } + } + set tkPriv(oldGrab) "" + } +} + +# tkMbMotion -- +# This procedure handles mouse motion events inside menubuttons, and +# also outside menubuttons when a menubutton has a grab (e.g. when a +# menu selection operation is in progress). +# +# Arguments: +# w - The name of the menubutton widget. +# upDown - "down" means button 1 is pressed, "up" means +# it isn't. +# rootx, rooty - Coordinates of mouse, in (virtual?) root window. + +proc tkMbMotion {w upDown rootx rooty} { + global tkPriv + + if {$tkPriv(inMenubutton) == $w} { + return + } + set new [winfo containing $rootx $rooty] + if {($new != $tkPriv(inMenubutton)) && (($new == "") + || ([winfo toplevel $new] == [winfo toplevel $w]))} { + if {$tkPriv(inMenubutton) != ""} { + tkMbLeave $tkPriv(inMenubutton) + } + if {($new != "") && ([winfo class $new] == "Menubutton") + && ([$new cget -indicatoron] == 0) + && ([$w cget -indicatoron] == 0)} { + if {$upDown == "down"} { + tkMbPost $new $rootx $rooty + } else { + tkMbEnter $new + } + } + } +} + +# tkMbButtonUp -- +# This procedure is invoked to handle button 1 releases for menubuttons. +# If the release happens inside the menubutton then leave its menu +# posted with element 0 activated. Otherwise, unpost the menu. +# +# Arguments: +# w - The name of the menubutton widget. + +proc tkMbButtonUp w { + global tkPriv + + if {($tkPriv(postedMb) == $w) && ($tkPriv(inMenubutton) == $w)} { + tkMenuFirstEntry [$tkPriv(postedMb) cget -menu] + } else { + tkMenuUnpost {} + } +} + +# tkMenuMotion -- +# This procedure is called to handle mouse motion events for menus. +# It does two things. First, it resets the active element in the +# menu, if the mouse is over the menu. Second, if a mouse button +# is down, it posts and unposts cascade entries to match the mouse +# position. +# +# Arguments: +# menu - The menu window. +# y - The y position of the mouse. +# state - Modifier state (tells whether buttons are down). + +proc tkMenuMotion {menu y state} { + global tkPriv + if {$menu == $tkPriv(window)} { + $menu activate @$y + } + if {($state & 0x1f00) != 0} { + $menu postcascade active + } +} + +# tkMenuButtonDown -- +# Handles button presses in menus. There are a couple of tricky things +# here: +# 1. Change the posted cascade entry (if any) to match the mouse position. +# 2. If there is a posted menubutton, must grab to the menubutton; this +# overrrides the implicit grab on button press, so that the menu +# button can track mouse motions over other menubuttons and change +# the posted menu. +# 3. If there's no posted menubutton (e.g. because we're a torn-off menu +# or one of its descendants) must grab to the top-level menu so that +# we can track mouse motions across the entire menu hierarchy. +# +# Arguments: +# menu - The menu window. + +proc tkMenuButtonDown menu { + global tkPriv + $menu postcascade active + if {$tkPriv(postedMb) != ""} { + grab -global $tkPriv(postedMb) + } else { + while {[wm overrideredirect $menu] + && ([winfo class [winfo parent $menu]] == "Menu") + && [winfo ismapped [winfo parent $menu]]} { + set menu [winfo parent $menu] + } + + # Don't update grab information if the grab window isn't changing. + # Otherwise, we'll get an error when we unpost the menus and + # restore the grab, since the old grab window will not be viewable + # anymore. + + if {$menu != [grab current $menu]} { + tkSaveGrabInfo $menu + } + + # Must re-grab even if the grab window hasn't changed, in order + # to release the implicit grab from the button press. + + grab -global $menu + } +} + +# tkMenuLeave -- +# This procedure is invoked to handle Leave events for a menu. It +# deactivates everything unless the active element is a cascade element +# and the mouse is now over the submenu. +# +# Arguments: +# menu - The menu window. +# rootx, rooty - Root coordinates of mouse. +# state - Modifier state. + +proc tkMenuLeave {menu rootx rooty state} { + global tkPriv + set tkPriv(window) {} + if {[$menu index active] == "none"} { + return + } + if {([$menu type active] == "cascade") + && ([winfo containing $rootx $rooty] + == [$menu entrycget active -menu])} { + return + } + $menu activate none +} + +# tkMenuInvoke -- +# This procedure is invoked when button 1 is released over a menu. +# It invokes the appropriate menu action and unposts the menu if +# it came from a menubutton. +# +# Arguments: +# w - Name of the menu widget. +# buttonRelease - 1 means this procedure is called because of +# a button release; 0 means because of keystroke. + +proc tkMenuInvoke {w buttonRelease} { + global tkPriv + + if {$buttonRelease && ($tkPriv(window) == "")} { + # Mouse was pressed over a menu without a menu button, then + # dragged off the menu (possibly with a cascade posted) and + # released. Unpost everything and quit. + + $w postcascade none + $w activate none + tkMenuUnpost $w + return + } + if {[$w type active] == "cascade"} { + $w postcascade active + set menu [$w entrycget active -menu] + tkMenuFirstEntry $menu + } elseif {[$w type active] == "tearoff"} { + tkMenuUnpost $w + tkTearOffMenu $w + } else { + tkMenuUnpost $w + uplevel #0 [list $w invoke active] + } +} + +# tkMenuEscape -- +# This procedure is invoked for the Cancel (or Escape) key. It unposts +# the given menu and, if it is the top-level menu for a menu button, +# unposts the menu button as well. +# +# Arguments: +# menu - Name of the menu window. + +proc tkMenuEscape menu { + if {[winfo class [winfo parent $menu]] != "Menu"} { + tkMenuUnpost $menu + } else { + tkMenuLeftRight $menu -1 + } +} + +# tkMenuLeftRight -- +# This procedure is invoked to handle "left" and "right" traversal +# motions in menus. It traverses to the next menu in a menu bar, +# or into or out of a cascaded menu. +# +# Arguments: +# menu - The menu that received the keyboard +# event. +# direction - Direction in which to move: "left" or "right" + +proc tkMenuLeftRight {menu direction} { + global tkPriv + + # First handle traversals into and out of cascaded menus. + + if {$direction == "right"} { + set count 1 + if {[$menu type active] == "cascade"} { + $menu postcascade active + set m2 [$menu entrycget active -menu] + if {$m2 != ""} { + tkMenuFirstEntry $m2 + } + return + } + } else { + set count -1 + set m2 [winfo parent $menu] + if {[winfo class $m2] == "Menu"} { + $menu activate none + focus $m2 + + # This code unposts any posted submenu in the parent. + + set tmp [$m2 index active] + $m2 activate none + $m2 activate $tmp + return + } + } + + # Can't traverse into or out of a cascaded menu. Go to the next + # or previous menubutton, if that makes sense. + + set w $tkPriv(postedMb) + if {$w == ""} { + return + } + set buttons [winfo children [winfo parent $w]] + set length [llength $buttons] + set i [expr [lsearch -exact $buttons $w] + $count] + while 1 { + while {$i < 0} { + incr i $length + } + while {$i >= $length} { + incr i -$length + } + set mb [lindex $buttons $i] + if {([winfo class $mb] == "Menubutton") + && ([$mb cget -state] != "disabled") + && ([$mb cget -menu] != "") + && ([[$mb cget -menu] index last] != "none")} { + break + } + if {$mb == $w} { + return + } + incr i $count + } + tkMbPost $mb + tkMenuFirstEntry [$mb cget -menu] +} + +# tkMenuNextEntry -- +# Activate the next higher or lower entry in the posted menu, +# wrapping around at the ends. Disabled entries are skipped. +# +# Arguments: +# menu - Menu window that received the keystroke. +# count - 1 means go to the next lower entry, +# -1 means go to the next higher entry. + +proc tkMenuNextEntry {menu count} { + global tkPriv + if {[$menu index last] == "none"} { + return + } + set length [expr [$menu index last]+1] + set quitAfter $length + set active [$menu index active] + if {$active == "none"} { + set i 0 + } else { + set i [expr $active + $count] + } + while 1 { + if {$quitAfter <= 0} { + # We've tried every entry in the menu. Either there are + # none, or they're all disabled. Just give up. + + return + } + while {$i < 0} { + incr i $length + } + while {$i >= $length} { + incr i -$length + } + if {[catch {$menu entrycget $i -state} state] == 0} { + if {$state != "disabled"} { + break + } + } + if {$i == $active} { + return + } + incr i $count + incr quitAfter -1 + } + $menu activate $i + $menu postcascade $i +} + +# tkMenuFind -- +# This procedure searches the entire window hierarchy under w for +# a menubutton that isn't disabled and whose underlined character +# is "char". It returns the name of that window, if found, or an +# empty string if no matching window was found. If "char" is an +# empty string then the procedure returns the name of the first +# menubutton found that isn't disabled. +# +# Arguments: +# w - Name of window where key was typed. +# char - Underlined character to search for; +# may be either upper or lower case, and +# will match either upper or lower case. + +proc tkMenuFind {w char} { + global tkPriv + set char [string tolower $char] + + foreach child [winfo child $w] { + switch [winfo class $child] { + Menubutton { + set char2 [string index [$child cget -text] \ + [$child cget -underline]] + if {([string compare $char [string tolower $char2]] == 0) + || ($char == "")} { + if {[$child cget -state] != "disabled"} { + return $child + } + } + } + + # The tag below used to be "Frame", but it was changed so + # that the code would work with Itcl 2.0, which apparently + # uses other classes of widgets to hold menubuttons. + + default { + set match [tkMenuFind $child $char] + if {$match != ""} { + return $match + } + } + } + } + return {} +} + +# tkTraverseToMenu -- +# This procedure implements keyboard traversal of menus. Given an +# ASCII character "char", it looks for a menubutton with that character +# underlined. If one is found, it posts the menubutton's menu +# +# Arguments: +# w - Window in which the key was typed (selects +# a toplevel window). +# char - Character that selects a menu. The case +# is ignored. If an empty string, nothing +# happens. + +proc tkTraverseToMenu {w char} { + global tkPriv + if {$char == ""} { + return + } + while {[winfo class $w] == "Menu"} { + if {$tkPriv(postedMb) == ""} { + return + } + set w [winfo parent $w] + } + set w [tkMenuFind [winfo toplevel $w] $char] + if {$w != ""} { + tkMbPost $w + tkMenuFirstEntry [$w cget -menu] + } +} + +# tkFirstMenu -- +# This procedure traverses to the first menubutton in the toplevel +# for a given window, and posts that menubutton's menu. +# +# Arguments: +# w - Name of a window. Selects which toplevel +# to search for menubuttons. + +proc tkFirstMenu w { + set w [tkMenuFind [winfo toplevel $w] ""] + if {$w != ""} { + tkMbPost $w + tkMenuFirstEntry [$w cget -menu] + } +} + +# tkTraverseWithinMenu +# This procedure implements keyboard traversal within a menu. It +# searches for an entry in the menu that has "char" underlined. If +# such an entry is found, it is invoked and the menu is unposted. +# +# Arguments: +# w - The name of the menu widget. +# char - The character to look for; case is +# ignored. If the string is empty then +# nothing happens. + +proc tkTraverseWithinMenu {w char} { + if {$char == ""} { + return + } + set char [string tolower $char] + set last [$w index last] + if {$last == "none"} { + return + } + for {set i 0} {$i <= $last} {incr i} { + if [catch {set char2 [string index \ + [$w entrycget $i -label] \ + [$w entrycget $i -underline]]}] { + continue + } + if {[string compare $char [string tolower $char2]] == 0} { + if {[$w type $i] == "cascade"} { + $w postcascade $i + $w activate $i + set m2 [$w entrycget $i -menu] + if {$m2 != ""} { + tkMenuFirstEntry $m2 + } + } else { + tkMenuUnpost $w + uplevel #0 [list $w invoke $i] + } + return + } + } +} + +# tkMenuFirstEntry -- +# Given a menu, this procedure finds the first entry that isn't +# disabled or a tear-off or separator, and activates that entry. +# However, if there is already an active entry in the menu (e.g., +# because of a previous call to tkPostOverPoint) then the active +# entry isn't changed. This procedure also sets the input focus +# to the menu. +# +# Arguments: +# menu - Name of the menu window (possibly empty). + +proc tkMenuFirstEntry menu { + if {$menu == ""} { + return + } + focus $menu + if {[$menu index active] != "none"} { + return + } + set last [$menu index last] + if {$last == "none"} { + return + } + for {set i 0} {$i <= $last} {incr i} { + if {([catch {set state [$menu entrycget $i -state]}] == 0) + && ($state != "disabled") && ([$menu type $i] != "tearoff")} { + $menu activate $i + return + } + } +} + +# tkMenuFindName -- +# Given a menu and a text string, return the index of the menu entry +# that displays the string as its label. If there is no such entry, +# return an empty string. This procedure is tricky because some names +# like "active" have a special meaning in menu commands, so we can't +# always use the "index" widget command. +# +# Arguments: +# menu - Name of the menu widget. +# s - String to look for. + +proc tkMenuFindName {menu s} { + set i "" + if {![regexp {^active$|^last$|^none$|^[0-9]|^@} $s]} { + catch {set i [$menu index $s]} + return $i + } + set last [$menu index last] + if {$last == "none"} { + return + } + for {set i 0} {$i <= $last} {incr i} { + if ![catch {$menu entrycget $i -label} label] { + if {$label == $s} { + return $i + } + } + } + return "" +} + +# tkPostOverPoint -- +# This procedure posts a given menu such that a given entry in the +# menu is centered over a given point in the root window. It also +# activates the given entry. +# +# Arguments: +# menu - Menu to post. +# x, y - Root coordinates of point. +# entry - Index of entry within menu to center over (x,y). +# If omitted or specified as {}, then the menu's +# upper-left corner goes at (x,y). + +proc tkPostOverPoint {menu x y {entry {}}} { + if {$entry != {}} { + if {$entry == [$menu index last]} { + incr y [expr -([$menu yposition $entry] \ + + [winfo reqheight $menu])/2] + } else { + incr y [expr -([$menu yposition $entry] \ + + [$menu yposition [expr $entry+1]])/2] + } + incr x [expr -[winfo reqwidth $menu]/2] + } + $menu post $x $y + if {($entry != {}) && ([$menu entrycget $entry -state] != "disabled")} { + $menu activate $entry + } +} + +# tkSaveGrabInfo -- +# Sets the variables tkPriv(oldGrab) and tkPriv(grabStatus) to record +# the state of any existing grab on the w's display. +# +# Arguments: +# w - Name of a window; used to select the display +# whose grab information is to be recorded. + +proc tkSaveGrabInfo w { + global tkPriv + set tkPriv(oldGrab) [grab current $w] + if {$tkPriv(oldGrab) != ""} { + set tkPriv(grabStatus) [grab status $tkPriv(oldGrab)] + } +} + +# tk_popup -- +# This procedure pops up a menu and sets things up for traversing +# the menu and its submenus. +# +# Arguments: +# menu - Name of the menu to be popped up. +# x, y - Root coordinates at which to pop up the +# menu. +# entry - Index of a menu entry to center over (x,y). +# If omitted or specified as {}, then menu's +# upper-left corner goes at (x,y). + +proc tk_popup {menu x y {entry {}}} { + global tkPriv + if {($tkPriv(popup) != "") || ($tkPriv(postedMb) != "")} { + tkMenuUnpost {} + } + tkPostOverPoint $menu $x $y $entry + tkSaveGrabInfo $menu + grab -global $menu + set tkPriv(popup) $menu + set tkPriv(focus) [focus] + focus $menu +} diff --git a/tk4.2/library/msgbox.tcl b/tk4.2/library/msgbox.tcl new file mode 100644 index 0000000..aa96df7 --- /dev/null +++ b/tk4.2/library/msgbox.tcl @@ -0,0 +1,245 @@ +# msgbox.tcl -- +# +# Implements messageboxes for platforms that do not have native +# messagebox support. +# +# SCCS: @(#) msgbox.tcl 1.4 96/09/05 11:30:30 +# +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + + +# tkMessageBox -- +# +# Pops up a messagebox with an application-supplied message with +# an icon and a list of buttons. This procedure will be called +# by tk_messageBox if the platform does not have native +# messagebox support, or if the particular type of messagebox is +# not supported natively. +# +# This procedure is a private procedure shouldn't be called +# directly. Call tk_messageBox instead. +# +# See the user documentation for details on what tk_messageBox does. +# +proc tkMessageBox {args} { + global tkPriv + + set w tkPrivMsgBox + upvar #0 $w data + + # + # The default value of the title is space (" ") not the empty string + # because for some window managers, a + # wm title .foo "" + # causes the window title to be "foo" instead of the empty string. + # + set specs { + {-default "" "" ""} + {-icon "" "" "info"} + {-message "" "" ""} + {-parent "" "" .} + {-title "" "" " "} + {-type "" "" "ok"} + } + + tclParseConfigSpec $w $specs "" $args + + if {[lsearch {info warning error question} $data(-icon)] == -1} { + error "invalid icon \"$data(-icon)\", must be error, info, question or warning" + } + + if ![winfo exists $data(-parent)] { + error "bad window path name \"$data(-parent)\"" + } + + case $data(-type) { + abortretryignore { + set buttons { + {abort -width 6 -text Abort -under 0} + {retry -width 6 -text Retry -under 0} + {ignore -width 6 -text Ignore -under 0} + } + } + ok { + set buttons { + {ok -width 6 -text OK -under 0} + } + if {$data(-default) == ""} { + set data(-default) "ok" + } + } + okcancel { + set buttons { + {ok -width 6 -text OK -under 0} + {cancel -width 6 -text Cancel -under 0} + } + } + retrycancel { + set buttons { + {retry -width 6 -text Retry -under 0} + {cancel -width 6 -text Cancel -under 0} + } + } + yesno { + set buttons { + {yes -width 6 -text Yes -under 0} + {no -width 6 -text No -under 0} + } + } + yesnocancel { + set buttons { + {yes -width 6 -text Yes -under 0} + {no -width 6 -text No -under 0} + {cancel -width 6 -text Cancel -under 0} + } + } + default { + error "invalid message box type \"$data(-type)\", must be abortretryignore, ok, okcancel, retrycancel, yesno or yesnocancel" + } + } + + if [string compare $data(-default) ""] { + set valid 0 + foreach btn $buttons { + if ![string compare [lindex $btn 0] $data(-default)] { + set valid 1 + break + } + } + if !$valid { + error "invalid default button \"$data(-default)\"" + } + } + + # 2. Set the dialog to be a child window of $parent + # + # + if [string compare $data(-parent) .] { + set w $data(-parent).__tk__messagebox + } else { + set w .__tk__messagebox + } + + # 3. Create the top-level window and divide it into top + # and bottom parts. + + catch {destroy $w} + toplevel $w -class Dialog + wm title $w $data(-title) + wm iconname $w Dialog + wm protocol $w WM_DELETE_WINDOW { } + wm transient $w $data(-parent) + + frame $w.bot -relief raised -bd 1 + pack $w.bot -side bottom -fill both + frame $w.top -relief raised -bd 1 + pack $w.top -side top -fill both -expand 1 + + # 4. Fill the top part with bitmap and message (use the option + # database for -wraplength so that it can be overridden by + # the caller). + + option add *Dialog.msg.wrapLength 3i widgetDefault + label $w.msg -justify left -text $data(-message) + catch {$w.msg configure -font \ + -Adobe-Times-Medium-R-Normal--*-180-*-*-*-*-*-* + } + pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m + if {$data(-icon) != ""} { + label $w.bitmap -bitmap $data(-icon) + pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m + } + + # 5. Create a row of buttons at the bottom of the dialog. + + set i 0 + foreach but $buttons { + set name [lindex $but 0] + set opts [lrange $but 1 end] + if ![string compare $opts {}] { + # Capitalize the first letter of $name + set capName \ + [string toupper \ + [string index $name 0]][string range $name 1 end] + set opts [list -text $capName] + } + + eval button $w.$name $opts -command [list "set tkPriv(button) $name"] + + if ![string compare $name $data(-default)] { + frame $w.default -relief sunken -bd 1 + raise $w.$name $w.default + pack $w.default -in $w.bot -side left -expand 1 -padx 3m -pady 2m + pack $w.$name -in $w.default -padx 2m -pady 2m + } else { + pack $w.$name -in $w.bot -side left -expand 1 \ + -padx 3m -pady 2m + } + + # create the binding for the key accelerator, based on the underline + # + set underIdx [$w.$name cget -under] + if {$underIdx >= 0} { + set key [string index [$w.$name cget -text] $underIdx] + bind $w "$w.$name invoke" + bind $w "$w.$name invoke" + } + incr i + } + + # 6. Create a binding for on the dialog if there is a + # default button. + + if [string compare $data(-default) ""] { + bind $w "tkButtonInvoke $w.$data(-default)" + } + + # 7. Withdraw the window, then update all the geometry information + # so we know how big it wants to be, then center the window in the + # display and de-iconify it. + + wm withdraw $w + update idletasks + set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \ + - [winfo vrootx [winfo parent $w]]] + set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \ + - [winfo vrooty [winfo parent $w]]] + wm geom $w +$x+$y + wm deiconify $w + + # 8. Set a grab and claim the focus too. + + set oldFocus [focus] + set oldGrab [grab current $w] + if {$oldGrab != ""} { + set grabStatus [grab status $oldGrab] + } + grab $w + if [string compare $data(-default) ""] { + focus $w.$data(-default) + } else { + focus $w + } + + # 9. Wait for the user to respond, then restore the focus and + # return the index of the selected button. Restore the focus + # before deleting the window, since otherwise the window manager + # may take the focus away so we can't redirect it. Finally, + # restore any grab that was in effect. + + tkwait variable tkPriv(button) + catch {focus $oldFocus} + destroy $w + if {$oldGrab != ""} { + if {$grabStatus == "global"} { + grab -global $oldGrab + } else { + grab $oldGrab + } + } + return $tkPriv(button) +} diff --git a/tk4.2/library/obsolete.tcl b/tk4.2/library/obsolete.tcl new file mode 100644 index 0000000..7fc1fb3 --- /dev/null +++ b/tk4.2/library/obsolete.tcl @@ -0,0 +1,21 @@ +# obsolete.tcl -- +# +# This file contains obsolete procedures that people really shouldn't +# be using anymore, but which are kept around for backward compatibility. +# +# SCCS: @(#) obsolete.tcl 1.3 96/02/16 10:48:19 +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +# The procedures below are here strictly for backward compatibility with +# Tk version 3.6 and earlier. The procedures are no longer needed, so +# they are no-ops. You should not use these procedures anymore, since +# they may be removed in some future release. + +proc tk_menuBar args {} +proc tk_bindForTraversal args {} diff --git a/tk4.2/library/optMenu.tcl b/tk4.2/library/optMenu.tcl new file mode 100644 index 0000000..871cabf --- /dev/null +++ b/tk4.2/library/optMenu.tcl @@ -0,0 +1,45 @@ +# optMenu.tcl -- +# +# This file defines the procedure tk_optionMenu, which creates +# an option button and its associated menu. +# +# SCCS: @(#) optMenu.tcl 1.9 96/02/16 10:48:26 +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +# tk_optionMenu -- +# This procedure creates an option button named $w and an associated +# menu. Together they provide the functionality of Motif option menus: +# they can be used to select one of many values, and the current value +# appears in the global variable varName, as well as in the text of +# the option menubutton. The name of the menu is returned as the +# procedure's result, so that the caller can use it to change configuration +# options on the menu or otherwise manipulate it. +# +# Arguments: +# w - The name to use for the menubutton. +# varName - Global variable to hold the currently selected value. +# firstValue - First of legal values for option (must be >= 1). +# args - Any number of additional values. + +proc tk_optionMenu {w varName firstValue args} { + upvar #0 $varName var + + if ![info exists var] { + set var $firstValue + } + menubutton $w -textvariable $varName -indicatoron 1 -menu $w.menu \ + -relief raised -bd 2 -highlightthickness 2 -anchor c + menu $w.menu -tearoff 0 + $w.menu add command -label $firstValue \ + -command [list set $varName $firstValue] + foreach i $args { + $w.menu add command -label $i -command [list set $varName $i] + } + return $w.menu +} diff --git a/tk4.2/library/palette.tcl b/tk4.2/library/palette.tcl new file mode 100644 index 0000000..4d8450f --- /dev/null +++ b/tk4.2/library/palette.tcl @@ -0,0 +1,220 @@ +# palette.tcl -- +# +# This file contains procedures that change the color palette used +# by Tk. +# +# SCCS: @(#) palette.tcl 1.2 96/02/16 10:48:25 +# +# Copyright (c) 1995 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +# tk_setPalette -- +# Changes the default color scheme for a Tk application by setting +# default colors in the option database and by modifying all of the +# color options for existing widgets that have the default value. +# +# Arguments: +# The arguments consist of either a single color name, which +# will be used as the new background color (all other colors will +# be computed from this) or an even number of values consisting of +# option names and values. The name for an option is the one used +# for the option database, such as activeForeground, not -activeforeground. + +proc tk_setPalette args { + global tkPalette + + # Create an array that has the complete new palette. If some colors + # aren't specified, compute them from other colors that are specified. + + if {[llength $args] == 1} { + set new(background) [lindex $args 0] + } else { + array set new $args + } + if ![info exists new(background)] { + error "must specify a background color" + } + if ![info exists new(foreground)] { + set new(foreground) black + } + set bg [winfo rgb . $new(background)] + set fg [winfo rgb . $new(foreground)] + set darkerBg [format #%02x%02x%02x [expr (9*[lindex $bg 0])/2560] \ + [expr (9*[lindex $bg 1])/2560] [expr (9*[lindex $bg 2])/2560]] + foreach i {activeForeground insertBackground selectForeground \ + highlightColor} { + if ![info exists new($i)] { + set new($i) $new(foreground) + } + } + if ![info exists new(disabledForeground)] { + set new(disabledForeground) [format #%02x%02x%02x \ + [expr (3*[lindex $bg 0] + [lindex $fg 0])/1024] \ + [expr (3*[lindex $bg 1] + [lindex $fg 1])/1024] \ + [expr (3*[lindex $bg 2] + [lindex $fg 2])/1024]] + } + if ![info exists new(highlightBackground)] { + set new(highlightBackground) $new(background) + } + if ![info exists new(activeBackground)] { + # Pick a default active background that islighter than the + # normal background. To do this, round each color component + # up by 15% or 1/3 of the way to full white, whichever is + # greater. + + foreach i {0 1 2} { + set light($i) [expr [lindex $bg $i]/256] + set inc1 [expr ($light($i)*15)/100] + set inc2 [expr (255-$light($i))/3] + if {$inc1 > $inc2} { + incr light($i) $inc1 + } else { + incr light($i) $inc2 + } + if {$light($i) > 255} { + set light($i) 255 + } + } + set new(activeBackground) [format #%02x%02x%02x $light(0) \ + $light(1) $light(2)] + } + if ![info exists new(selectBackground)] { + set new(selectBackground) $darkerBg + } + if ![info exists new(troughColor)] { + set new(troughColor) $darkerBg + } + if ![info exists new(selectColor)] { + set new(selectColor) #b03060 + } + + # Walk the widget hierarchy, recoloring all existing windows. + # Before doing this, make sure that the tkPalette variable holds + # the default values of all options, so that tkRecolorTree can + # be sure to only change options that have their default values. + # If the variable exists, then it is already correct (it was created + # the last time this procedure was invoked). If the variable + # doesn't exist, fill it in using the defaults from a few widgets. + + if ![info exists tkPalette] { + checkbutton .c14732 + entry .e14732 + scrollbar .s14732 + set tkPalette(activeBackground) \ + [lindex [.c14732 configure -activebackground] 3] + set tkPalette(activeForeground) \ + [lindex [.c14732 configure -activeforeground] 3] + set tkPalette(background) \ + [lindex [.c14732 configure -background] 3] + set tkPalette(disabledForeground) \ + [lindex [.c14732 configure -disabledforeground] 3] + set tkPalette(foreground) \ + [lindex [.c14732 configure -foreground] 3] + set tkPalette(highlightBackground) \ + [lindex [.c14732 configure -highlightbackground] 3] + set tkPalette(highlightColor) \ + [lindex [.c14732 configure -highlightcolor] 3] + set tkPalette(insertBackground) \ + [lindex [.e14732 configure -insertbackground] 3] + set tkPalette(selectColor) \ + [lindex [.c14732 configure -selectcolor] 3] + set tkPalette(selectBackground) \ + [lindex [.e14732 configure -selectbackground] 3] + set tkPalette(selectForeground) \ + [lindex [.e14732 configure -selectforeground] 3] + set tkPalette(troughColor) \ + [lindex [.s14732 configure -troughcolor] 3] + destroy .c14732 .e14732 .s14732 + } + tkRecolorTree . new + + # Change the option database so that future windows will get the + # same colors. + + foreach option [array names new] { + option add *$option $new($option) widgetDefault + } + + # Save the options in the global variable tkPalette, for use the + # next time we change the options. + + array set tkPalette [array get new] +} + +# tkRecolorTree -- +# This procedure changes the colors in a window and all of its +# descendants, according to information provided by the colors +# argument. It only modifies colors that have their default values +# as specified by the tkPalette variable. +# +# Arguments: +# w - The name of a window. This window and all its +# descendants are recolored. +# colors - The name of an array variable in the caller, +# which contains color information. Each element +# is named after a widget configuration option, and +# each value is the value for that option. + +proc tkRecolorTree {w colors} { + global tkPalette + upvar $colors c + foreach dbOption [array names c] { + set option -[string tolower $dbOption] + if ![catch {$w cget $option} value] { + if {$value == $tkPalette($dbOption)} { + $w configure $option $c($dbOption) + } + } + } + foreach child [winfo children $w] { + tkRecolorTree $child c + } +} + +# tkDarken -- +# Given a color name, computes a new color value that darkens (or +# brightens) the given color by a given percent. +# +# Arguments: +# color - Name of starting color. +# perecent - Integer telling how much to brighten or darken as a +# percent: 50 means darken by 50%, 110 means brighten +# by 10%. + +proc tkDarken {color percent} { + set l [winfo rgb . $color] + set red [expr [lindex $l 0]/256] + set green [expr [lindex $l 1]/256] + set blue [expr [lindex $l 2]/256] + set red [expr ($red*$percent)/100] + if {$red > 255} { + set red 255 + } + set green [expr ($green*$percent)/100] + if {$green > 255} { + set green 255 + } + set blue [expr ($blue*$percent)/100] + if {$blue > 255} { + set blue 255 + } + format #%02x%02x%02x $red $green $blue +} + +# tk_bisque -- +# Reset the Tk color palette to the old "bisque" colors. +# +# Arguments: +# None. + +proc tk_bisque {} { + tk_setPalette activeBackground #e6ceb1 activeForeground black \ + background #ffe4c4 disabledForeground #b0b0b0 foreground black \ + highlightBackground #ffe4c4 highlightColor black \ + insertBackground black selectColor #b03060 \ + selectBackground #e6ceb1 selectForeground black \ + troughColor #cdb79e +} diff --git a/tk4.2/library/prolog.ps b/tk4.2/library/prolog.ps new file mode 100644 index 0000000..409e06a --- /dev/null +++ b/tk4.2/library/prolog.ps @@ -0,0 +1,284 @@ +%%BeginProlog +50 dict begin + +% This is a standard prolog for Postscript generated by Tk's canvas +% widget. +% SCCS: @(#) prolog.ps 1.5 96/02/17 17:45:11 + +% The definitions below just define all of the variables used in +% any of the procedures here. This is needed for obscure reasons +% explained on p. 716 of the Postscript manual (Section H.2.7, +% "Initializing Variables," in the section on Encapsulated Postscript). + +/baseline 0 def +/stipimage 0 def +/height 0 def +/justify 0 def +/lineLength 0 def +/spacing 0 def +/stipple 0 def +/strings 0 def +/xoffset 0 def +/yoffset 0 def +/tmpstip null def + +% Define the array ISOLatin1Encoding (which specifies how characters are +% encoded for ISO-8859-1 fonts), if it isn't already present (Postscript +% level 2 is supposed to define it, but level 1 doesn't). + +systemdict /ISOLatin1Encoding known not { + /ISOLatin1Encoding [ + /space /space /space /space /space /space /space /space + /space /space /space /space /space /space /space /space + /space /space /space /space /space /space /space /space + /space /space /space /space /space /space /space /space + /space /exclam /quotedbl /numbersign /dollar /percent /ampersand + /quoteright + /parenleft /parenright /asterisk /plus /comma /minus /period /slash + /zero /one /two /three /four /five /six /seven + /eight /nine /colon /semicolon /less /equal /greater /question + /at /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 /bracketleft /backslash /bracketright /asciicircum /underscore + /quoteleft /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 /braceleft /bar /braceright /asciitilde /space + /space /space /space /space /space /space /space /space + /space /space /space /space /space /space /space /space + /dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent + /dieresis /space /ring /cedilla /space /hungarumlaut /ogonek /caron + /space /exclamdown /cent /sterling /currency /yen /brokenbar /section + /dieresis /copyright /ordfeminine /guillemotleft /logicalnot /hyphen + /registered /macron + /degree /plusminus /twosuperior /threesuperior /acute /mu /paragraph + /periodcentered + /cedillar /onesuperior /ordmasculine /guillemotright /onequarter + /onehalf /threequarters /questiondown + /Agrave /Aacute /Acircumflex /Atilde /Adieresis /Aring /AE /Ccedilla + /Egrave /Eacute /Ecircumflex /Edieresis /Igrave /Iacute /Icircumflex + /Idieresis + /Eth /Ntilde /Ograve /Oacute /Ocircumflex /Otilde /Odieresis /multiply + /Oslash /Ugrave /Uacute /Ucircumflex /Udieresis /Yacute /Thorn + /germandbls + /agrave /aacute /acircumflex /atilde /adieresis /aring /ae /ccedilla + /egrave /eacute /ecircumflex /edieresis /igrave /iacute /icircumflex + /idieresis + /eth /ntilde /ograve /oacute /ocircumflex /otilde /odieresis /divide + /oslash /ugrave /uacute /ucircumflex /udieresis /yacute /thorn + /ydieresis + ] def +} if + +% font ISOEncode font +% This procedure changes the encoding of a font from the default +% Postscript encoding to ISOLatin1. It's typically invoked just +% before invoking "setfont". The body of this procedure comes from +% Section 5.6.1 of the Postscript book. + +/ISOEncode { + dup length dict begin + {1 index /FID ne {def} {pop pop} ifelse} forall + /Encoding ISOLatin1Encoding def + currentdict + end + + % I'm not sure why it's necessary to use "definefont" on this new + % font, but it seems to be important; just use the name "Temporary" + % for the font. + + /Temporary exch definefont +} bind def + +% StrokeClip +% +% This procedure converts the current path into a clip area under +% the assumption of stroking. It's a bit tricky because some Postscript +% interpreters get errors during strokepath for dashed lines. If +% this happens then turn off dashes and try again. + +/StrokeClip { + {strokepath} stopped { + (This Postscript printer gets limitcheck overflows when) = + (stippling dashed lines; lines will be printed solid instead.) = + [] 0 setdash strokepath} if + clip +} bind def + +% desiredSize EvenPixels closestSize +% +% The procedure below is used for stippling. Given the optimal size +% of a dot in a stipple pattern in the current user coordinate system, +% compute the closest size that is an exact multiple of the device's +% pixel size. This allows stipple patterns to be displayed without +% aliasing effects. + +/EvenPixels { + % Compute exact number of device pixels per stipple dot. + dup 0 matrix currentmatrix dtransform + dup mul exch dup mul add sqrt + + % Round to an integer, make sure the number is at least 1, and compute + % user coord distance corresponding to this. + dup round dup 1 lt {pop 1} if + exch div mul +} bind def + +% width height string StippleFill -- +% +% Given a path already set up and a clipping region generated from +% it, this procedure will fill the clipping region with a stipple +% pattern. "String" contains a proper image description of the +% stipple pattern and "width" and "height" give its dimensions. Each +% stipple dot is assumed to be about one unit across in the current +% user coordinate system. This procedure trashes the graphics state. + +/StippleFill { + % The following code is needed to work around a NeWSprint bug. + + /tmpstip 1 index def + + % Change the scaling so that one user unit in user coordinates + % corresponds to the size of one stipple dot. + 1 EvenPixels dup scale + + % Compute the bounding box occupied by the path (which is now + % the clipping region), and round the lower coordinates down + % to the nearest starting point for the stipple pattern. Be + % careful about negative numbers, since the rounding works + % differently on them. + + pathbbox + 4 2 roll + 5 index div dup 0 lt {1 sub} if cvi 5 index mul 4 1 roll + 6 index div dup 0 lt {1 sub} if cvi 6 index mul 3 2 roll + + % Stack now: width height string y1 y2 x1 x2 + % Below is a doubly-nested for loop to iterate across this area + % in units of the stipple pattern size, going up columns then + % across rows, blasting out a stipple-pattern-sized rectangle at + % each position + + 6 index exch { + 2 index 5 index 3 index { + % Stack now: width height string y1 y2 x y + + gsave + 1 index exch translate + 5 index 5 index true matrix tmpstip imagemask + grestore + } for + pop + } for + pop pop pop pop pop +} bind def + +% -- AdjustColor -- +% Given a color value already set for output by the caller, adjusts +% that value to a grayscale or mono value if requested by the CL +% variable. + +/AdjustColor { + CL 2 lt { + currentgray + CL 0 eq { + .5 lt {0} {1} ifelse + } if + setgray + } if +} bind def + +% x y strings spacing xoffset yoffset justify stipple DrawText -- +% This procedure does all of the real work of drawing text. The +% color and font must already have been set by the caller, and the +% following arguments must be on the stack: +% +% x, y - Coordinates at which to draw text. +% strings - An array of strings, one for each line of the text item, +% in order from top to bottom. +% spacing - Spacing between lines. +% xoffset - Horizontal offset for text bbox relative to x and y: 0 for +% nw/w/sw anchor, -0.5 for n/center/s, and -1.0 for ne/e/se. +% yoffset - Vertical offset for text bbox relative to x and y: 0 for +% nw/n/ne anchor, +0.5 for w/center/e, and +1.0 for sw/s/se. +% justify - 0 for left justification, 0.5 for center, 1 for right justify. +% stipple - Boolean value indicating whether or not text is to be +% drawn in stippled fashion. If text is stippled, +% procedure StippleText must have been defined to call +% StippleFill in the right way. +% +% Also, when this procedure is invoked, the color and font must already +% have been set for the text. + +/DrawText { + /stipple exch def + /justify exch def + /yoffset exch def + /xoffset exch def + /spacing exch def + /strings exch def + + % First scan through all of the text to find the widest line. + + /lineLength 0 def + strings { + stringwidth pop + dup lineLength gt {/lineLength exch def} {pop} ifelse + newpath + } forall + + % Compute the baseline offset and the actual font height. + + 0 0 moveto (TXygqPZ) false charpath + pathbbox dup /baseline exch def + exch pop exch sub /height exch def pop + newpath + + % Translate coordinates first so that the origin is at the upper-left + % corner of the text's bounding box. Remember that x and y for + % positioning are still on the stack. + + translate + lineLength xoffset mul + strings length 1 sub spacing mul height add yoffset mul translate + + % Now use the baseline and justification information to translate so + % that the origin is at the baseline and positioning point for the + % first line of text. + + justify lineLength mul baseline neg translate + + % Iterate over each of the lines to output it. For each line, + % compute its width again so it can be properly justified, then + % display it. + + strings { + dup stringwidth pop + justify neg mul 0 moveto + stipple { + + % The text is stippled, so turn it into a path and print + % by calling StippledText, which in turn calls StippleFill. + % Unfortunately, many Postscript interpreters will get + % overflow errors if we try to do the whole string at + % once, so do it a character at a time. + + gsave + /char (X) def + { + char 0 3 -1 roll put + currentpoint + gsave + char true charpath clip StippleText + grestore + char stringwidth translate + moveto + } forall + grestore + } {show} ifelse + 0 spacing neg translate + } forall +} bind def + +%%EndProlog diff --git a/tk4.2/library/scale.tcl b/tk4.2/library/scale.tcl new file mode 100644 index 0000000..8e96176 --- /dev/null +++ b/tk4.2/library/scale.tcl @@ -0,0 +1,265 @@ +# scale.tcl -- +# +# This file defines the default bindings for Tk scale widgets and provides +# procedures that help in implementing the bindings. +# +# SCCS: @(#) scale.tcl 1.12 96/04/16 11:42:25 +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994-1995 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +#------------------------------------------------------------------------- +# The code below creates the default class bindings for entries. +#------------------------------------------------------------------------- + +# Standard Motif bindings: + +bind Scale { + if $tk_strictMotif { + set tkPriv(activeBg) [%W cget -activebackground] + %W config -activebackground [%W cget -background] + } + tkScaleActivate %W %x %y +} +bind Scale { + tkScaleActivate %W %x %y +} +bind Scale { + if $tk_strictMotif { + %W config -activebackground $tkPriv(activeBg) + } + if {[%W cget -state] == "active"} { + %W configure -state normal + } +} +bind Scale <1> { + tkScaleButtonDown %W %x %y +} +bind Scale { + tkScaleDrag %W %x %y +} +bind Scale { } +bind Scale { } +bind Scale { + tkCancelRepeat + tkScaleEndDrag %W + tkScaleActivate %W %x %y +} +bind Scale <2> { + tkScaleButton2Down %W %x %y +} +bind Scale { + tkScaleDrag %W %x %y +} +bind Scale { } +bind Scale { } +bind Scale { + tkCancelRepeat + tkScaleEndDrag %W + tkScaleActivate %W %x %y +} +bind Scale { + tkScaleControlPress %W %x %y +} +bind Scale { + tkScaleIncrement %W up little noRepeat +} +bind Scale { + tkScaleIncrement %W down little noRepeat +} +bind Scale { + tkScaleIncrement %W up little noRepeat +} +bind Scale { + tkScaleIncrement %W down little noRepeat +} +bind Scale { + tkScaleIncrement %W up big noRepeat +} +bind Scale { + tkScaleIncrement %W down big noRepeat +} +bind Scale { + tkScaleIncrement %W up big noRepeat +} +bind Scale { + tkScaleIncrement %W down big noRepeat +} +bind Scale { + %W set [%W cget -from] +} +bind Scale { + %W set [%W cget -to] +} + +# tkScaleActivate -- +# This procedure is invoked to check a given x-y position in the +# scale and activate the slider if the x-y position falls within +# the slider. +# +# Arguments: +# w - The scale widget. +# x, y - Mouse coordinates. + +proc tkScaleActivate {w x y} { + global tkPriv + if {[$w cget -state] == "disabled"} { + return; + } + if {[$w identify $x $y] == "slider"} { + $w configure -state active + } else { + $w configure -state normal + } +} + +# tkScaleButtonDown -- +# This procedure is invoked when a button is pressed in a scale. It +# takes different actions depending on where the button was pressed. +# +# Arguments: +# w - The scale widget. +# x, y - Mouse coordinates of button press. + +proc tkScaleButtonDown {w x y} { + global tkPriv + set tkPriv(dragging) 0 + set el [$w identify $x $y] + if {$el == "trough1"} { + tkScaleIncrement $w up little initial + } elseif {$el == "trough2"} { + tkScaleIncrement $w down little initial + } elseif {$el == "slider"} { + set tkPriv(dragging) 1 + set tkPriv(initValue) [$w get] + set coords [$w coords] + set tkPriv(deltaX) [expr $x - [lindex $coords 0]] + set tkPriv(deltaY) [expr $y - [lindex $coords 1]] + $w configure -sliderrelief sunken + } +} + +# tkScaleDrag -- +# This procedure is called when the mouse is dragged with +# mouse button 1 down. If the drag started inside the slider +# (i.e. the scale is active) then the scale's value is adjusted +# to reflect the mouse's position. +# +# Arguments: +# w - The scale widget. +# x, y - Mouse coordinates. + +proc tkScaleDrag {w x y} { + global tkPriv + if !$tkPriv(dragging) { + return + } + $w set [$w get [expr $x - $tkPriv(deltaX)] \ + [expr $y - $tkPriv(deltaY)]] +} + +# tkScaleEndDrag -- +# This procedure is called to end an interactive drag of the +# slider. It just marks the drag as over. +# +# Arguments: +# w - The scale widget. + +proc tkScaleEndDrag {w} { + global tkPriv + set tkPriv(dragging) 0 + $w configure -sliderrelief raised +} + +# tkScaleIncrement -- +# This procedure is invoked to increment the value of a scale and +# to set up auto-repeating of the action if that is desired. The +# way the value is incremented depends on the "dir" and "big" +# arguments. +# +# Arguments: +# w - The scale widget. +# dir - "up" means move value towards -from, "down" means +# move towards -to. +# big - Size of increments: "big" or "little". +# repeat - Whether and how to auto-repeat the action: "noRepeat" +# means don't auto-repeat, "initial" means this is the +# first action in an auto-repeat sequence, and "again" +# means this is the second repetition or later. + +proc tkScaleIncrement {w dir big repeat} { + global tkPriv + if {![winfo exists $w]} return + if {$big == "big"} { + set inc [$w cget -bigincrement] + if {$inc == 0} { + set inc [expr abs([$w cget -to] - [$w cget -from])/10.0] + } + if {$inc < [$w cget -resolution]} { + set inc [$w cget -resolution] + } + } else { + set inc [$w cget -resolution] + } + if {([$w cget -from] > [$w cget -to]) ^ ($dir == "up")} { + set inc [expr -$inc] + } + $w set [expr [$w get] + $inc] + + if {$repeat == "again"} { + set tkPriv(afterId) [after [$w cget -repeatinterval] \ + tkScaleIncrement $w $dir $big again] + } elseif {$repeat == "initial"} { + set delay [$w cget -repeatdelay] + if {$delay > 0} { + set tkPriv(afterId) [after $delay \ + tkScaleIncrement $w $dir $big again] + } + } +} + +# tkScaleControlPress -- +# This procedure handles button presses that are made with the Control +# key down. Depending on the mouse position, it adjusts the scale +# value to one end of the range or the other. +# +# Arguments: +# w - The scale widget. +# x, y - Mouse coordinates where the button was pressed. + +proc tkScaleControlPress {w x y} { + set el [$w identify $x $y] + if {$el == "trough1"} { + $w set [$w cget -from] + } elseif {$el == "trough2"} { + $w set [$w cget -to] + } +} + +# tkScaleButton2Down +# This procedure is invoked when button 2 is pressed over a scale. +# It sets the value to correspond to the mouse position and starts +# a slider drag. +# +# Arguments: +# w - The scrollbar widget. +# x, y - Mouse coordinates within the widget. + +proc tkScaleButton2Down {w x y} { + global tkPriv + + if {[$w cget -state] == "disabled"} { + return; + } + $w configure -state active + $w set [$w get $x $y] + set tkPriv(dragging) 1 + set tkPriv(initValue) [$w get] + set coords "$x $y" + set tkPriv(deltaX) 0 + set tkPriv(deltaY) 0 +} diff --git a/tk4.2/library/scrlbar.tcl b/tk4.2/library/scrlbar.tcl new file mode 100644 index 0000000..6c88c25 --- /dev/null +++ b/tk4.2/library/scrlbar.tcl @@ -0,0 +1,410 @@ +# scrlbar.tcl -- +# +# This file defines the default bindings for Tk scrollbar widgets. +# It also provides procedures that help in implementing the bindings. +# +# SCCS: @(#) scrlbar.tcl 1.23 96/04/16 11:42:23 +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +#------------------------------------------------------------------------- +# The code below creates the default class bindings for scrollbars. +#------------------------------------------------------------------------- + +# Standard Motif bindings: + +bind Scrollbar { + if $tk_strictMotif { + set tkPriv(activeBg) [%W cget -activebackground] + %W config -activebackground [%W cget -background] + } + %W activate [%W identify %x %y] +} +bind Scrollbar { + %W activate [%W identify %x %y] +} +bind Scrollbar { + if $tk_strictMotif { + %W config -activebackground $tkPriv(activeBg) + } + %W activate {} +} +bind Scrollbar <1> { + tkScrollButtonDown %W %x %y +} +bind Scrollbar { + tkScrollDrag %W %x %y +} +bind Scrollbar { + tkScrollDrag %W %x %y +} +bind Scrollbar { + tkScrollButtonUp %W %x %y +} +bind Scrollbar { + # Prevents binding from being invoked. +} +bind Scrollbar { + # Prevents binding from being invoked. +} +bind Scrollbar <2> { + tkScrollButton2Down %W %x %y +} +bind Scrollbar { + # Do nothing, since button 1 is already down. +} +bind Scrollbar { + # Do nothing, since button 2 is already down. +} +bind Scrollbar { + tkScrollDrag %W %x %y +} +bind Scrollbar { + tkScrollButtonUp %W %x %y +} +bind Scrollbar { + # Do nothing: B1 release will handle it. +} +bind Scrollbar { + # Do nothing: B2 release will handle it. +} +bind Scrollbar { + # Prevents binding from being invoked. +} +bind Scrollbar { + # Prevents binding from being invoked. +} +bind Scrollbar { + tkScrollTopBottom %W %x %y +} +bind Scrollbar { + tkScrollTopBottom %W %x %y +} + +bind Scrollbar { + tkScrollByUnits %W v -1 +} +bind Scrollbar { + tkScrollByUnits %W v 1 +} +bind Scrollbar { + tkScrollByPages %W v -1 +} +bind Scrollbar { + tkScrollByPages %W v 1 +} +bind Scrollbar { + tkScrollByUnits %W h -1 +} +bind Scrollbar { + tkScrollByUnits %W h 1 +} +bind Scrollbar { + tkScrollByPages %W h -1 +} +bind Scrollbar { + tkScrollByPages %W h 1 +} +bind Scrollbar { + tkScrollByPages %W hv -1 +} +bind Scrollbar { + tkScrollByPages %W hv 1 +} +bind Scrollbar { + tkScrollToPos %W 0 +} +bind Scrollbar { + tkScrollToPos %W 1 +} + +# tkScrollButtonDown -- +# This procedure is invoked when a button is pressed in a scrollbar. +# It changes the way the scrollbar is displayed and takes actions +# depending on where the mouse is. +# +# Arguments: +# w - The scrollbar widget. +# x, y - Mouse coordinates. + +proc tkScrollButtonDown {w x y} { + global tkPriv + set tkPriv(relief) [$w cget -activerelief] + $w configure -activerelief sunken + set element [$w identify $x $y] + if {$element == "slider"} { + tkScrollStartDrag $w $x $y + } else { + tkScrollSelect $w $element initial + } +} + +# tkScrollButtonUp -- +# This procedure is invoked when a button is released in a scrollbar. +# It cancels scans and auto-repeats that were in progress, and restores +# the way the active element is displayed. +# +# Arguments: +# w - The scrollbar widget. +# x, y - Mouse coordinates. + +proc tkScrollButtonUp {w x y} { + global tkPriv + tkCancelRepeat + $w configure -activerelief $tkPriv(relief) + tkScrollEndDrag $w $x $y + $w activate [$w identify $x $y] +} + +# tkScrollSelect -- +# This procedure is invoked when a button is pressed over the scrollbar. +# It invokes one of several scrolling actions depending on where in +# the scrollbar the button was pressed. +# +# Arguments: +# w - The scrollbar widget. +# element - The element of the scrollbar that was selected, such +# as "arrow1" or "trough2". Shouldn't be "slider". +# repeat - Whether and how to auto-repeat the action: "noRepeat" +# means don't auto-repeat, "initial" means this is the +# first action in an auto-repeat sequence, and "again" +# means this is the second repetition or later. + +proc tkScrollSelect {w element repeat} { + global tkPriv + if {![winfo exists $w]} return + if {$element == "arrow1"} { + tkScrollByUnits $w hv -1 + } elseif {$element == "trough1"} { + tkScrollByPages $w hv -1 + } elseif {$element == "trough2"} { + tkScrollByPages $w hv 1 + } elseif {$element == "arrow2"} { + tkScrollByUnits $w hv 1 + } else { + return + } + if {$repeat == "again"} { + set tkPriv(afterId) [after [$w cget -repeatinterval] \ + tkScrollSelect $w $element again] + } elseif {$repeat == "initial"} { + set delay [$w cget -repeatdelay] + if {$delay > 0} { + set tkPriv(afterId) [after $delay tkScrollSelect $w $element again] + } + } +} + +# tkScrollStartDrag -- +# This procedure is called to initiate a drag of the slider. It just +# remembers the starting position of the mouse and slider. +# +# Arguments: +# w - The scrollbar widget. +# x, y - The mouse position at the start of the drag operation. + +proc tkScrollStartDrag {w x y} { + global tkPriv + + if {[$w cget -command] == ""} { + return + } + set tkPriv(pressX) $x + set tkPriv(pressY) $y + set tkPriv(initValues) [$w get] + set iv0 [lindex $tkPriv(initValues) 0] + if {[llength $tkPriv(initValues)] == 2} { + set tkPriv(initPos) $iv0 + } else { + if {$iv0 == 0} { + set tkPriv(initPos) 0.0 + } else { + set tkPriv(initPos) [expr (double([lindex $tkPriv(initValues) 2])) \ + / [lindex $tkPriv(initValues) 0]] + } + } +} + +# tkScrollDrag -- +# This procedure is called for each mouse motion even when the slider +# is being dragged. It notifies the associated widget if we're not +# jump scrolling, and it just updates the scrollbar if we are jump +# scrolling. +# +# Arguments: +# w - The scrollbar widget. +# x, y - The current mouse position. + +proc tkScrollDrag {w x y} { + global tkPriv + + if {$tkPriv(initPos) == ""} { + return + } + set delta [$w delta [expr $x - $tkPriv(pressX)] [expr $y - $tkPriv(pressY)]] + if [$w cget -jump] { + if {[llength $tkPriv(initValues)] == 2} { + $w set [expr [lindex $tkPriv(initValues) 0] + $delta] \ + [expr [lindex $tkPriv(initValues) 1] + $delta] + } else { + set delta [expr round($delta * [lindex $tkPriv(initValues) 0])] + eval $w set [lreplace $tkPriv(initValues) 2 3 \ + [expr [lindex $tkPriv(initValues) 2] + $delta] \ + [expr [lindex $tkPriv(initValues) 3] + $delta]] + } + } else { + tkScrollToPos $w [expr $tkPriv(initPos) + $delta] + } +} + +# tkScrollEndDrag -- +# This procedure is called to end an interactive drag of the slider. +# It scrolls the window if we're in jump mode, otherwise it does nothing. +# +# Arguments: +# w - The scrollbar widget. +# x, y - The mouse position at the end of the drag operation. + +proc tkScrollEndDrag {w x y} { + global tkPriv + + if {$tkPriv(initPos) == ""} { + return + } + if [$w cget -jump] { + set delta [$w delta [expr $x - $tkPriv(pressX)] \ + [expr $y - $tkPriv(pressY)]] + tkScrollToPos $w [expr $tkPriv(initPos) + $delta] + } + set tkPriv(initPos) "" +} + +# tkScrollByUnits -- +# This procedure tells the scrollbar's associated widget to scroll up +# or down by a given number of units. It notifies the associated widget +# in different ways for old and new command syntaxes. +# +# Arguments: +# w - The scrollbar widget. +# orient - Which kinds of scrollbars this applies to: "h" for +# horizontal, "v" for vertical, "hv" for both. +# amount - How many units to scroll: typically 1 or -1. + +proc tkScrollByUnits {w orient amount} { + set cmd [$w cget -command] + if {($cmd == "") || ([string first \ + [string index [$w cget -orient] 0] $orient] < 0)} { + return + } + set info [$w get] + if {[llength $info] == 2} { + uplevel #0 $cmd scroll $amount units + } else { + uplevel #0 $cmd [expr [lindex $info 2] + $amount] + } +} + +# tkScrollByPages -- +# This procedure tells the scrollbar's associated widget to scroll up +# or down by a given number of screenfuls. It notifies the associated +# widget in different ways for old and new command syntaxes. +# +# Arguments: +# w - The scrollbar widget. +# orient - Which kinds of scrollbars this applies to: "h" for +# horizontal, "v" for vertical, "hv" for both. +# amount - How many screens to scroll: typically 1 or -1. + +proc tkScrollByPages {w orient amount} { + set cmd [$w cget -command] + if {($cmd == "") || ([string first \ + [string index [$w cget -orient] 0] $orient] < 0)} { + return + } + set info [$w get] + if {[llength $info] == 2} { + uplevel #0 $cmd scroll $amount pages + } else { + uplevel #0 $cmd [expr [lindex $info 2] + $amount*([lindex $info 1] - 1)] + } +} + +# tkScrollToPos -- +# This procedure tells the scrollbar's associated widget to scroll to +# a particular location, given by a fraction between 0 and 1. It notifies +# the associated widget in different ways for old and new command syntaxes. +# +# Arguments: +# w - The scrollbar widget. +# pos - A fraction between 0 and 1 indicating a desired position +# in the document. + +proc tkScrollToPos {w pos} { + set cmd [$w cget -command] + if {($cmd == "")} { + return + } + set info [$w get] + if {[llength $info] == 2} { + uplevel #0 $cmd moveto $pos + } else { + uplevel #0 $cmd [expr round([lindex $info 0]*$pos)] + } +} + +# tkScrollTopBottom +# Scroll to the top or bottom of the document, depending on the mouse +# position. +# +# Arguments: +# w - The scrollbar widget. +# x, y - Mouse coordinates within the widget. + +proc tkScrollTopBottom {w x y} { + global tkPriv + set element [$w identify $x $y] + if [string match *1 $element] { + tkScrollToPos $w 0 + } elseif [string match *2 $element] { + tkScrollToPos $w 1 + } + + # Set tkPriv(relief), since it's needed by tkScrollButtonUp. + + set tkPriv(relief) [$w cget -activerelief] +} + +# tkScrollButton2Down +# This procedure is invoked when button 2 is pressed over a scrollbar. +# If the button is over the trough or slider, it sets the scrollbar to +# the mouse position and starts a slider drag. Otherwise it just +# behaves the same as button 1. +# +# Arguments: +# w - The scrollbar widget. +# x, y - Mouse coordinates within the widget. + +proc tkScrollButton2Down {w x y} { + global tkPriv + set element [$w identify $x $y] + if {($element == "arrow1") || ($element == "arrow2")} { + tkScrollButtonDown $w $x $y + return + } + tkScrollToPos $w [$w fraction $x $y] + set tkPriv(relief) [$w cget -activerelief] + + # Need the "update idletasks" below so that the widget calls us + # back to reset the actual scrollbar position before we start the + # slider drag. + + update idletasks + $w configure -activerelief sunken + $w activate slider + tkScrollStartDrag $w $x $y +} diff --git a/tk4.2/library/tclIndex b/tk4.2/library/tclIndex new file mode 100644 index 0000000..c8c6b44 --- /dev/null +++ b/tk4.2/library/tclIndex @@ -0,0 +1,218 @@ +# 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(tk_dialog) [list source [file join $dir dialog.tcl]] +set auto_index(tkButtonEnter) [list source [file join $dir button.tcl]] +set auto_index(tkButtonLeave) [list source [file join $dir button.tcl]] +set auto_index(tkButtonDown) [list source [file join $dir button.tcl]] +set auto_index(tkButtonUp) [list source [file join $dir button.tcl]] +set auto_index(tkButtonInvoke) [list source [file join $dir button.tcl]] +set auto_index(tkCheckRadioInvoke) [list source [file join $dir button.tcl]] +set auto_index(tkEntryClosestGap) [list source [file join $dir entry.tcl]] +set auto_index(tkEntryButton1) [list source [file join $dir entry.tcl]] +set auto_index(tkEntryMouseSelect) [list source [file join $dir entry.tcl]] +set auto_index(tkEntryPaste) [list source [file join $dir entry.tcl]] +set auto_index(tkEntryAutoScan) [list source [file join $dir entry.tcl]] +set auto_index(tkEntryKeySelect) [list source [file join $dir entry.tcl]] +set auto_index(tkEntryInsert) [list source [file join $dir entry.tcl]] +set auto_index(tkEntryBackspace) [list source [file join $dir entry.tcl]] +set auto_index(tkEntrySeeInsert) [list source [file join $dir entry.tcl]] +set auto_index(tkEntrySetCursor) [list source [file join $dir entry.tcl]] +set auto_index(tkEntryTranspose) [list source [file join $dir entry.tcl]] +set auto_index(tkListboxBeginSelect) [list source [file join $dir listbox.tcl]] +set auto_index(tkListboxMotion) [list source [file join $dir listbox.tcl]] +set auto_index(tkListboxBeginExtend) [list source [file join $dir listbox.tcl]] +set auto_index(tkListboxBeginToggle) [list source [file join $dir listbox.tcl]] +set auto_index(tkListboxAutoScan) [list source [file join $dir listbox.tcl]] +set auto_index(tkListboxUpDown) [list source [file join $dir listbox.tcl]] +set auto_index(tkListboxExtendUpDown) [list source [file join $dir listbox.tcl]] +set auto_index(tkListboxDataExtend) [list source [file join $dir listbox.tcl]] +set auto_index(tkListboxCancel) [list source [file join $dir listbox.tcl]] +set auto_index(tkListboxSelectAll) [list source [file join $dir listbox.tcl]] +set auto_index(tkerror) [list source [file join $dir bgerror.tcl]] +set auto_index(bgerror) [list source [file join $dir bgerror.tcl]] +set auto_index(tkTextClosestGap) [list source [file join $dir text.tcl]] +set auto_index(tkTextButton1) [list source [file join $dir text.tcl]] +set auto_index(tkTextSelectTo) [list source [file join $dir text.tcl]] +set auto_index(tkTextKeyExtend) [list source [file join $dir text.tcl]] +set auto_index(tkTextPaste) [list source [file join $dir text.tcl]] +set auto_index(tkTextAutoScan) [list source [file join $dir text.tcl]] +set auto_index(tkTextSetCursor) [list source [file join $dir text.tcl]] +set auto_index(tkTextKeySelect) [list source [file join $dir text.tcl]] +set auto_index(tkTextResetAnchor) [list source [file join $dir text.tcl]] +set auto_index(tkTextInsert) [list source [file join $dir text.tcl]] +set auto_index(tkTextUpDownLine) [list source [file join $dir text.tcl]] +set auto_index(tkTextPrevPara) [list source [file join $dir text.tcl]] +set auto_index(tkTextNextPara) [list source [file join $dir text.tcl]] +set auto_index(tkTextScrollPages) [list source [file join $dir text.tcl]] +set auto_index(tkTextTranspose) [list source [file join $dir text.tcl]] +set auto_index(tk_textCopy) [list source [file join $dir text.tcl]] +set auto_index(tk_textCut) [list source [file join $dir text.tcl]] +set auto_index(tk_textPaste) [list source [file join $dir text.tcl]] +set auto_index(tkScrollButtonDown) [list source [file join $dir scrlbar.tcl]] +set auto_index(tkScrollButtonUp) [list source [file join $dir scrlbar.tcl]] +set auto_index(tkScrollSelect) [list source [file join $dir scrlbar.tcl]] +set auto_index(tkScrollStartDrag) [list source [file join $dir scrlbar.tcl]] +set auto_index(tkScrollDrag) [list source [file join $dir scrlbar.tcl]] +set auto_index(tkScrollEndDrag) [list source [file join $dir scrlbar.tcl]] +set auto_index(tkScrollByUnits) [list source [file join $dir scrlbar.tcl]] +set auto_index(tkScrollByPages) [list source [file join $dir scrlbar.tcl]] +set auto_index(tkScrollToPos) [list source [file join $dir scrlbar.tcl]] +set auto_index(tkScrollTopBottom) [list source [file join $dir scrlbar.tcl]] +set auto_index(tkScrollButton2Down) [list source [file join $dir scrlbar.tcl]] +set auto_index(tkMbEnter) [list source [file join $dir menu.tcl]] +set auto_index(tkMbLeave) [list source [file join $dir menu.tcl]] +set auto_index(tkMbPost) [list source [file join $dir menu.tcl]] +set auto_index(tkMenuUnpost) [list source [file join $dir menu.tcl]] +set auto_index(tkMbMotion) [list source [file join $dir menu.tcl]] +set auto_index(tkMbButtonUp) [list source [file join $dir menu.tcl]] +set auto_index(tkMenuMotion) [list source [file join $dir menu.tcl]] +set auto_index(tkMenuButtonDown) [list source [file join $dir menu.tcl]] +set auto_index(tkMenuLeave) [list source [file join $dir menu.tcl]] +set auto_index(tkMenuInvoke) [list source [file join $dir menu.tcl]] +set auto_index(tkMenuEscape) [list source [file join $dir menu.tcl]] +set auto_index(tkMenuLeftRight) [list source [file join $dir menu.tcl]] +set auto_index(tkMenuNextEntry) [list source [file join $dir menu.tcl]] +set auto_index(tkMenuFind) [list source [file join $dir menu.tcl]] +set auto_index(tkTraverseToMenu) [list source [file join $dir menu.tcl]] +set auto_index(tkFirstMenu) [list source [file join $dir menu.tcl]] +set auto_index(tkTraverseWithinMenu) [list source [file join $dir menu.tcl]] +set auto_index(tkMenuFirstEntry) [list source [file join $dir menu.tcl]] +set auto_index(tkMenuFindName) [list source [file join $dir menu.tcl]] +set auto_index(tkPostOverPoint) [list source [file join $dir menu.tcl]] +set auto_index(tkSaveGrabInfo) [list source [file join $dir menu.tcl]] +set auto_index(tk_popup) [list source [file join $dir menu.tcl]] +set auto_index(tkScreenChanged) [list source [file join $dir tk.tcl]] +set auto_index(tkEventMotifBindings) [list source [file join $dir tk.tcl]] +set auto_index(tkCancelRepeat) [list source [file join $dir tk.tcl]] +set auto_index(tkScaleActivate) [list source [file join $dir scale.tcl]] +set auto_index(tkScaleButtonDown) [list source [file join $dir scale.tcl]] +set auto_index(tkScaleDrag) [list source [file join $dir scale.tcl]] +set auto_index(tkScaleEndDrag) [list source [file join $dir scale.tcl]] +set auto_index(tkScaleIncrement) [list source [file join $dir scale.tcl]] +set auto_index(tkScaleControlPress) [list source [file join $dir scale.tcl]] +set auto_index(tkScaleButton2Down) [list source [file join $dir scale.tcl]] +set auto_index(tk_optionMenu) [list source [file join $dir optMenu.tcl]] +set auto_index(tkTearOffMenu) [list source [file join $dir tearoff.tcl]] +set auto_index(tkMenuDup) [list source [file join $dir tearoff.tcl]] +set auto_index(tk_menuBar) [list source [file join $dir obsolete.tcl]] +set auto_index(tk_bindForTraversal) [list source [file join $dir obsolete.tcl]] +set auto_index(tk_focusNext) [list source [file join $dir focus.tcl]] +set auto_index(tk_focusPrev) [list source [file join $dir focus.tcl]] +set auto_index(tkFocusOK) [list source [file join $dir focus.tcl]] +set auto_index(tk_focusFollowsMouse) [list source [file join $dir focus.tcl]] +set auto_index(tkConsoleInit) [list source [file join $dir console.tcl]] +set auto_index(tkConsoleInvoke) [list source [file join $dir console.tcl]] +set auto_index(tkConsoleHistory) [list source [file join $dir console.tcl]] +set auto_index(tkConsolePrompt) [list source [file join $dir console.tcl]] +set auto_index(tkConsoleBind) [list source [file join $dir console.tcl]] +set auto_index(tkConsoleInsert) [list source [file join $dir console.tcl]] +set auto_index(tkConsoleOutput) [list source [file join $dir console.tcl]] +set auto_index(tkConsoleExit) [list source [file join $dir console.tcl]] +set auto_index(tk_setPalette) [list source [file join $dir palette.tcl]] +set auto_index(tkRecolorTree) [list source [file join $dir palette.tcl]] +set auto_index(tkDarken) [list source [file join $dir palette.tcl]] +set auto_index(tk_bisque) [list source [file join $dir palette.tcl]] +set auto_index(tkColorDialog) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_InitValues) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_Config) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_BuildDialog) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_SetRGBValue) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_XToRgb) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_RgbToX) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_DrawColorScale) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_CreateSelector) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_RedrawFinalColor) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_RedrawColorBars) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_StartMove) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_MoveSelector) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_ReleaseMouse) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_ResizeColorBars) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_HandleSelEntry) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_HandleRGBEntry) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_EnterColorBar) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_LeaveColorBar) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_OkCmd) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_CancelCmd) [list source [file join $dir clrpick.tcl]] +set auto_index(tclParseConfigSpec) [list source [file join $dir comdlg.tcl]] +set auto_index(tclListValidFlags) [list source [file join $dir comdlg.tcl]] +set auto_index(tclSortNoCase) [list source [file join $dir comdlg.tcl]] +set auto_index(tclVerifyInteger) [list source [file join $dir comdlg.tcl]] +set auto_index(tkFocusGroup_Create) [list source [file join $dir comdlg.tcl]] +set auto_index(tkFocusGroup_BindIn) [list source [file join $dir comdlg.tcl]] +set auto_index(tkFocusGroup_BindOut) [list source [file join $dir comdlg.tcl]] +set auto_index(tkFocusGroup_Destroy) [list source [file join $dir comdlg.tcl]] +set auto_index(tkFocusGroup_In) [list source [file join $dir comdlg.tcl]] +set auto_index(tkFocusGroup_Out) [list source [file join $dir comdlg.tcl]] +set auto_index(tkFDGetFileTypes) [list source [file join $dir comdlg.tcl]] +set auto_index(tkMotifFDialog) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkMotifFDialog_Config) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkMotifFDialog_Create) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkMotifFDialog_MakeSList) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkMotifFDialog_BrowseDList) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkMotifFDialog_ActivateDList) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkMotifFDialog_BrowseFList) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkMotifFDialog_ActivateFList) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkMotifFDialog_ActivateFEnt) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkMotifFDialog_InterpFilter) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkMotifFDialog_ActivateSEnt) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkMotifFDialog_OkCmd) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkMotifFDialog_FilterCmd) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkMotifFDialog_CancelCmd) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkMotifFDialog_Update) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkMotifFDialog_LoadFiles) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkListBoxKeyAccel_Set) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkListBoxKeyAccel_Unset) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkListBoxKeyAccel_Key) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkListBoxKeyAccel_Goto) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkListBoxKeyAccel_Reset) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkIconList) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_Config) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_Create) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_AutoScan) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_DeleteAll) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_Add) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_Arrange) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_Invoke) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_See) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_SelectAtXY) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_Select) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_Unselect) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_Get) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_Btn1) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_Motion1) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_Double1) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_ReturnKey) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_Leave1) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_FocusIn) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_UpDown) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_LeftRight) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_KeyPress) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_Goto) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_Reset) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog_Config) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog_GetImgFile) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog_Create) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog_UpdateWhenIdle) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog_Update) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog_SetPathSilently) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog_SetPath) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog_SetFilter) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialogResolveFile) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog_EntFocusIn) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog_EntFocusOut) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog_ActivateEnt) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog_InvokeBtn) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog_UpDirCmd) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog_OkCmd) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog_CancelCmd) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog_ListBrowse) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog_ListInvoke) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog_Done) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkMessageBox) [list source [file join $dir msgbox.tcl]] diff --git a/tk4.2/library/tearoff.tcl b/tk4.2/library/tearoff.tcl new file mode 100644 index 0000000..2e00fc5 --- /dev/null +++ b/tk4.2/library/tearoff.tcl @@ -0,0 +1,129 @@ +# tearoff.tcl -- +# +# This file contains procedures that implement tear-off menus. +# +# SCCS: @(#) tearoff.tcl 1.10 96/08/09 16:55:07 +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994-1995 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +# tkTearoffMenu -- +# Given the name of a menu, this procedure creates a torn-off menu +# that is identical to the given menu (including nested submenus). +# The new torn-off menu exists as a toplevel window managed by the +# window manager. The return value is the name of the new menu. +# +# Arguments: +# w - The menu to be torn-off (duplicated). + +proc tkTearOffMenu w { + # Find a unique name to use for the torn-off menu. Find the first + # ancestor of w that is a toplevel but not a menu, and use this as + # the parent of the new menu. This guarantees that the torn off + # menu will be on the same screen as the original menu. By making + # it a child of the ancestor, rather than a child of the menu, it + # can continue to live even if the menu is deleted; it will go + # away when the toplevel goes away. + + set parent [winfo parent $w] + while {([winfo toplevel $parent] != $parent) + || ([winfo class $parent] == "Menu")} { + set parent [winfo parent $parent] + } + if {$parent == "."} { + set parent "" + } + for {set i 1} 1 {incr i} { + set menu $parent.tearoff$i + if ![winfo exists $menu] { + break + } + } + + tkMenuDup $w $menu + $menu configure -transient 0 + + # Pick a title for the new menu by looking at the parent of the + # original: if the parent is a menu, then use the text of the active + # entry. If it's a menubutton then use its text. + + set parent [winfo parent $w] + switch [winfo class $parent] { + Menubutton { + wm title $menu [$parent cget -text] + } + Menu { + wm title $menu [$parent entrycget active -label] + } + } + + $menu configure -tearoff 0 + $menu post [winfo x $w] [winfo y $w] + + # Set tkPriv(focus) on entry: otherwise the focus will get lost + # after keyboard invocation of a sub-menu (it will stay on the + # submenu). + + bind $menu { + set tkPriv(focus) %W + } + + # If there is a -tearoffcommand option for the menu, invoke it + # now. + + set cmd [$w cget -tearoffcommand] + if {$cmd != ""} { + uplevel #0 $cmd $w $menu + } +} + +# tkMenuDup -- +# Given a menu (hierarchy), create a duplicate menu (hierarchy) +# in a given window. +# +# Arguments: +# src - Source window. Must be a menu. It and its +# menu descendants will be duplicated at dst. +# dst - Name to use for topmost menu in duplicate +# hierarchy. + +proc tkMenuDup {src dst} { + set cmd [list menu $dst] + foreach option [$src configure] { + if {[llength $option] == 2} { + continue + } + lappend cmd [lindex $option 0] [lindex $option 4] + } + eval $cmd + set last [$src index last] + if {$last == "none"} { + return + } + for {set i [$src cget -tearoff]} {$i <= $last} {incr i} { + set cmd [list $dst add [$src type $i]] + foreach option [$src entryconfigure $i] { + lappend cmd [lindex $option 0] [lindex $option 4] + } + eval $cmd + if {[$src type $i] == "cascade"} { + tkMenuDup [$src entrycget $i -menu] $dst.m$i + $dst entryconfigure $i -menu $dst.m$i + } + } + + # Duplicate the binding tags and bindings from the source menu. + + regsub -all . $src {\\&} quotedSrc + regsub -all . $dst {\\&} quotedDst + regsub -all $quotedSrc [bindtags $src] $dst x + bindtags $dst $x + foreach event [bind $src] { + regsub -all $quotedSrc [bind $src $event] $dst x + bind $dst $event $x + } +} diff --git a/tk4.2/library/text.tcl b/tk4.2/library/text.tcl new file mode 100644 index 0000000..c6e2300 --- /dev/null +++ b/tk4.2/library/text.tcl @@ -0,0 +1,888 @@ +# text.tcl -- +# +# This file defines the default bindings for Tk text widgets and provides +# procedures that help in implementing the bindings. +# +# SCCS: @(#) text.tcl 1.46 96/08/23 14:07:32 +# +# Copyright (c) 1992-1994 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +#------------------------------------------------------------------------- +# Elements of tkPriv that are used in this file: +# +# afterId - If non-null, it means that auto-scanning is underway +# and it gives the "after" id for the next auto-scan +# command to be executed. +# char - Character position on the line; kept in order +# to allow moving up or down past short lines while +# still remembering the desired position. +# mouseMoved - Non-zero means the mouse has moved a significant +# amount since the button went down (so, for example, +# start dragging out a selection). +# prevPos - Used when moving up or down lines via the keyboard. +# Keeps track of the previous insert position, so +# we can distinguish a series of ups and downs, all +# in a row, from a new up or down. +# selectMode - The style of selection currently underway: +# char, word, or line. +# x, y - Last known mouse coordinates for scanning +# and auto-scanning. +#------------------------------------------------------------------------- + +#------------------------------------------------------------------------- +# The code below creates the default class bindings for entries. +#------------------------------------------------------------------------- + +# Standard Motif bindings: + +bind Text <1> { + tkTextButton1 %W %x %y + %W tag remove sel 0.0 end +} +bind Text { + set tkPriv(x) %x + set tkPriv(y) %y + tkTextSelectTo %W %x %y +} +bind Text { + set tkPriv(selectMode) word + tkTextSelectTo %W %x %y + catch {%W mark set insert sel.first} +} +bind Text { + set tkPriv(selectMode) line + tkTextSelectTo %W %x %y + catch {%W mark set insert sel.first} +} +bind Text { + tkTextResetAnchor %W @%x,%y + set tkPriv(selectMode) char + tkTextSelectTo %W %x %y +} +bind Text { + set tkPriv(selectMode) word + tkTextSelectTo %W %x %y +} +bind Text { + set tkPriv(selectMode) line + tkTextSelectTo %W %x %y +} +bind Text { + set tkPriv(x) %x + set tkPriv(y) %y + tkTextAutoScan %W +} +bind Text { + tkCancelRepeat +} +bind Text { + tkCancelRepeat +} +bind Text { + %W mark set insert @%x,%y +} +bind Text { + if {!$tkPriv(mouseMoved) || $tk_strictMotif} { + tkTextPaste %W %x %y + } +} +bind Text { + tkTextSetCursor %W insert-1c +} +bind Text { + tkTextSetCursor %W insert+1c +} +bind Text { + tkTextSetCursor %W [tkTextUpDownLine %W -1] +} +bind Text { + tkTextSetCursor %W [tkTextUpDownLine %W 1] +} +bind Text { + tkTextKeySelect %W [%W index {insert - 1c}] +} +bind Text { + tkTextKeySelect %W [%W index {insert + 1c}] +} +bind Text { + tkTextKeySelect %W [tkTextUpDownLine %W -1] +} +bind Text { + tkTextKeySelect %W [tkTextUpDownLine %W 1] +} +bind Text { + tkTextSetCursor %W [%W index {insert - 1c wordstart}] +} +bind Text { + tkTextSetCursor %W [%W index {insert wordend}] +} +bind Text { + tkTextSetCursor %W [tkTextPrevPara %W insert] +} +bind Text { + tkTextSetCursor %W [tkTextNextPara %W insert] +} +bind Text { + tkTextKeySelect %W [%W index {insert - 1c wordstart}] +} +bind Text { + tkTextKeySelect %W [%W index {insert wordend}] +} +bind Text { + tkTextKeySelect %W [tkTextPrevPara %W insert] +} +bind Text { + tkTextKeySelect %W [tkTextNextPara %W insert] +} +bind Text { + tkTextSetCursor %W [tkTextScrollPages %W -1] +} +bind Text { + tkTextKeySelect %W [tkTextScrollPages %W -1] +} +bind Text { + tkTextSetCursor %W [tkTextScrollPages %W 1] +} +bind Text { + tkTextKeySelect %W [tkTextScrollPages %W 1] +} +bind Text { + %W xview scroll -1 page +} +bind Text { + %W xview scroll 1 page +} + +bind Text { + tkTextSetCursor %W {insert linestart} +} +bind Text { + tkTextKeySelect %W {insert linestart} +} +bind Text { + tkTextSetCursor %W {insert lineend} +} +bind Text { + tkTextKeySelect %W {insert lineend} +} +bind Text { + tkTextSetCursor %W 1.0 +} +bind Text { + tkTextKeySelect %W 1.0 +} +bind Text { + tkTextSetCursor %W {end - 1 char} +} +bind Text { + tkTextKeySelect %W {end - 1 char} +} + +bind Text { + tkTextInsert %W \t + focus %W + break +} +bind Text { + # Needed only to keep binding from triggering; doesn't + # have to actually do anything. +} +bind Text { + focus [tk_focusNext %W] +} +bind Text { + focus [tk_focusPrev %W] +} +bind Text { + tkTextInsert %W \t +} +bind Text { + tkTextInsert %W \n +} +bind Text { + if {[%W tag nextrange sel 1.0 end] != ""} { + %W delete sel.first sel.last + } else { + %W delete insert + %W see insert + } +} +bind Text { + if {[%W tag nextrange sel 1.0 end] != ""} { + %W delete sel.first sel.last + } elseif [%W compare insert != 1.0] { + %W delete insert-1c + %W see insert + } +} + +bind Text { + %W mark set anchor insert +} +bind Text